caTools/0000755000176000001440000000000012404057275011714 5ustar ripleyuserscaTools/src/0000755000176000001440000000000012403665602012501 5ustar ripleyuserscaTools/src/runfunc.c0000644000176000001440000015024512403665602014334 0ustar ripleyusers/*===========================================================================*/ /* runfunc - running window functions */ /* Copyright (C) 2005 Jarek Tuszynski */ /* Distributed under GNU General Public License version 3 */ /*===========================================================================*/ /*==================================================*/ /* Index: */ /* |------------------+------+------+----------| */ /* | function | NaN | Edge | Underflow| */ /* |------------------+------+------+----------| */ /* | sum_exact | NA | NA | 1024 | */ /* | cumsum_exact | NA | NA | 1024 | */ /* | runmean_exact | yes | yes | 1024 | */ /* | runmean | yes | yes | 2 | */ /* | runmean_lite | no | no | 1 | */ /* | runmin | yes | yes | NA | */ /* | runmax | yes | yes | NA | */ /* | runquantile_lite | no | no | NA | */ /* | runquantile | yes | yes | NA | */ /* | runmad_lite | no | no | NA | */ /* | runmad | yes | yes | NA | */ /* | runsd_lite | no | no | 1 | */ /* | runsd | yes | yes | 2 | */ /* |------------------+------+------+----------| */ /* NaN - means support for NaN and possibly Inf */ /* edge - means calculations are done all the way */ /* to the edges */ /* underflow - means at maximum how many numbers */ /* are used to store results of addition in case */ /* of underflow */ /*==================================================*/ #include #include #include #include #include /* #define DEBBUG */ #ifdef DEBBUG int R_finite(double x) { return ( (x)==(x) ); } #define Calloc(b, t) (t*) calloc(b,sizeof(t)) #define Free free #define PRINT(x) { if ((x)==(x)) printf("%04.1f ",x); else printf("NaN "); } #else #include #include #endif #define notNaN(x) ((x)==(x)) #define isNaN(x) (!((x)==(x))) #define MIN(y,x) ((x)<(y) && (x)==(x) ? (x) : (y)) #define MAX(y,x) ((x)>(y) && (x)==(x) ? (x) : (y)) #define SQR(x) ((x)*(x)) /*============================================================================*/ /* The following macros were inspired by msum from */ /* http://aspn.activestate.com/ASPN/Cookbook/Python/Recipe/393090 */ /* Quote from it: */ /* "Full precision summation using multiple doubles for intermediate values */ /* Rounded x+y stored in hi with the round-off stored in lo. Together */ /* hi+lo are exactly equal to x+y. The loop applies hi/lo summation */ /* to each partial so that the list of partial sums remains exact. */ /* Depends on IEEE-754 arithmetic guarantees. See proof of correctness at: */ /* www-2.cs.cmu.edu/afs/cs/project/quake/public/papers/robust-arithmetic.ps" */ /*============================================================================*/ /* SumErr - macro calculating error of the summing operation */ #define SumErr(a,b,ab) ((((a)>(b)) == ((a)>-(b))) ? (b) - ((ab)-(a)) : (a) - ((ab)-(b)) ) /* SUM_1 - macro for calculating Sum+=x; Num+=n; Which is NaN aware and have minimal (single number) overflow error correction */ #define SUM_1(x,n, Sum, Err, Num) if (R_finite(x)){ y=Sum; Err+=x; Sum+=Err; Num+=n; Err=SumErr(y,Err,Sum); } #define mpartial 1024 void SUM_N(double x, int n, double *partial, int *npartial, int *Num) { if (R_finite(x)){ int j, i; double hi, lo, y; for (i=j=0; j<*npartial; j++) { y = partial[j]; hi = y + x; lo = SumErr(x,y,hi); if (lo && i0; j--) { if (V[idx[j-1]]>1; /* half of moving window */ // for(i=0; i<=k; i++) { // Out [i]=Out [n-i-1]=0; // Size[i]=Size[n-i-1]=0; // } // if (m>=n) return; // // /* step 1: sum of the first window *out = sum(x[0:(m-1)]) + err1 */ // in=In; out=Out+k; size=Size+k; // for(i=0; i>1; /* right half of window size */ d = 1.0/m; in=In; out=Out; Sum = 0; /* we need to calculate initial 'Sum' */ /* step 1 - find mean of elements 0:(k2-1) */ for(i=0; i>1; /* right half of window size */ in=In; out=Out; Sum = 0; /* we need to calculate initial 'Sum' */ Err = 0; Num = 0; /* step 1 - find mean of elements 0:(k2-1) */ for(i=0; i>1; /* right half of window size */ in=In; out=Out; /* step 1 - find mean of elements 0:(k2-1) */ for(i=0; i>1; /* right half of window size */ in = In; out = Out; /* --- step 1 - find min of elements 0:(k2-1) */ Min=CST; /* we need to calculate initial 'Min' */ for(i=0; i>1; /* right half of window size */ in = In; out = Out; /* step 1 - find max of elements 0:(k2-1) */ Max= CST; /* we need to calculate initial 'Max' */ for(i=0; i j ? 1 : 0); break; // type 1 case 2: h = (nppm > j ? 1 : 0.5); break; // type 2 case 3: h = ((nppm==j) && ((j>>1) == 0) ? 0 : 1); break; // type 3 default: h=1; break; } } else { // Types 4 through 9 are continuous sample qs. switch(type) { case 4: a=0; b=1; break; case 5: a=b=0.5; break; case 6: a=b=0; break; case 7: a=b=1; break; case 8: a=b=1.0/3.0; break; case 9: a=b=3.0/8.0; break; default: a=b=1; break; } nppm = a + prob * (nWin + 1 - a - b); // n*probs + m fuzz = 4 * DBL_EPSILON; j = (int) floor(nppm + fuzz); h = nppm - j; h = (fabs(h) < fuzz ? 0 : h); } nppm = j+h; nppm = (nppm<1 ? 1 : nppm); nppm = (nppm>nWin ? nWin : nppm); return nppm - 1; // C arrays are zero based } /*==================================================================*/ /* quantile function applied to (running) window */ /* Input : */ /* In - array to run moving window over will remain umchanged */ /* Out - empty space for array to store the results. Out is */ /* assumed to have reserved memory for nIn*nProbs elements */ /* nIn - size of arrays In and Out */ /* nWin - size of the moving window */ /* Prob - Array of probabilities from 0 to 1 */ /* nProb - How many elements in Probs array? */ /* type - integer between 1 and 9 indicating type of quantile */ /* See http://mathworld.wolfram.com/Quantile.html */ /* Output : */ /* Out - results of runing moving window over array In and */ /* colecting window mean */ /*==================================================================*/ void runquantile_lite(double *In, double *Out, const int *nIn, const int *nWin, const double *Prob, const int *nProb, const int *Type) { /* internal region only is calculated. Edges, NaN's are not handled */ int i, j, k, *idx, d, n=*nIn, m=*nWin, nPrb=*nProb; double *Win, *in, *out, r, ip, *prob, pointOut, ext; k = m>>1; /* half of window size */ in = In; out = Out+k; if (nPrb==1 && (*Prob==1 || *Prob==0)) { /* trivial case shortcut - if prob is 0 or 1 than wind windows min or max */ d = (*Prob==0 ? -1 : 1); /* runmin d=-1; runmax d=1*/ pointOut=ext=0; for(i=m-1; iin[j]) ext=in[j]; /* find minimum over a window of length m */ } } else /* if point comining out of the window was NOT window extreme than we know ... */ if (ext*d>1; /* right half of window size */ k1 = m-k2-1; /* left half of window size */ in = In; out = Out; if (nPrb==1 && *Prob==0) { /* trivial case shortcut - if prob is 0 or 1 than find windows min */ runmin(In, Out, nIn, nWin); } else if (nPrb==1 && *Prob==1) {/* trivial case shortcut - if prob is 0 or 1 than find windows max */ runmax(In, Out, nIn, nWin); } else { /* non-trivial case */ idx = Calloc(m,int ); /* index will hold partially sorted index numbers of Save array */ Win = Calloc(m,double); /* stores all points of the current running window */ prob = Calloc(nPrb,double); /* stores all points of the current running window */ for(i=0; i0) { /* not all points in the window are NaN*/ p = QuantilePosition(Prob[d], count, type); r = modf( p, &ip ); /* Divide p into its fractional and integer parts */ k = (int) ip; /* k-1 instead of k because in C arrays are 0 based and in R they are 1 based */ if (r) r = Win[idx[k]]*(1-r) + Win[idx[k+1]]*r; /* interpolate */ else r = Win[idx[k]]; } else r = NaN; /* all points in the window are NaN*/ out[d*n] = r; } out++; j = (j+1)%m; /* index goes from 0 to m-1, and back to 0 again */ //printf("1-------- %3.0f %3.0f %3.0f %3.0f %3.0f - %i\n", Win[idx[0]],Win[idx[1]],Win[idx[2]],Win[idx[3]],Win[idx[4]], count); } /* --- step 2: inner section ----------------------------------------------------------------*/ for(d=0; d0) { /* not all points in the window are NaN*/ p = (count==m ? prob[d] : QuantilePosition(Prob[d], count, type)); r = modf( p, &ip ); /* Divide p into its fractional and integer parts */ k = (int) ip; /* k-1 instead of k because in C arrays are 0 based and in R they are 1 based */ if (r) r = Win[idx[k]]*(1-r) + Win[idx[k+1]]*r; /* interpolate */ else r = Win[idx[k]]; } else r = NaN; /* all points in the window are NaN*/ out[d*n] = r; } out++; j = (j+1)%m; /* index goes from 0 to m-1, and back to 0 again */ //printf("2-------- %3.0f %3.0f %3.0f %3.0f %3.0f - %i\n", Win[idx[0]],Win[idx[1]],Win[idx[2]],Win[idx[3]],Win[idx[4]], count); } /* --- step 3 : right edge ----------------------------------------------------------*/ Max = Win[idx[m-1]]; /* store window maximum */ for(i=0; i0) { /* not all points in the window are NaN*/ p = QuantilePosition(Prob[d], count, type); r = modf( p, &ip ); /* Divide p into its fractional and integer parts */ k = (int) ip; /* k-1 instead of k because in C arrays are 0 based and in R they are 1 based */ if (r) r = Win[idx[k]]*(1-r) + Win[idx[k+1]]*r; /* interpolate */ else r = Win[idx[k]]; } else r = NaN; /* all points in the window are NaN*/ out[d*n] = r; } out++; j = (j+1)%m; /* index goes from 0 to m-1, and back to 0 again */ //printf("3-------- %3.0f %3.0f %3.0f %3.0f %3.0f - %i\n", Win[idx[0]],Win[idx[1]],Win[idx[2]],Win[idx[3]],Win[idx[4]], count); } Free(Win); Free(idx); Free(prob); } } /*==================================================================================*/ /* MAD function applied to moving (running) window */ /* No edge calculations and no NAN support */ /* Input : */ /* In - array to run moving window over will remain umchanged */ /* Ctr - array storing results of runmed or other running average function */ /* Out - empty space for array to store the results */ /* nIn - size of arrays In and Out */ /* nWin - size of the moving window */ /* Output : */ /* Out - results of runing moving window over array In and colecting window mean */ /*==================================================================================*/ void runmad_lite(double *In, double *Ctr, double *Out, const int *nIn, const int *nWin) { int i, k2, k1, j, l, *idx, n=*nIn, m=*nWin; double *Win1, *Win2, *in, *out, *ctr, med0, med; idx = Calloc(m,int ); /* index will hold partially sorted index numbers of Save array */ Win1 = Calloc(m,double); /* stores all "In" points of the current running window */ Win2 = Calloc(m,double); /* stores all "abs(In-Crt) values of the current running window */ k2 = m>>1; /* right half of window size */ k1 = m-k2-1; /* left half of window size */ in = In; /* initialize pointer to input In vector */ out = Out+k1; /* initialize pointer to output Mad vector */ ctr = Ctr+k1; /* initialize pointer to input Ctr vector */ med0 = 0; /* med0 - will save previous center (median) so we know it changed */ for(i=0; i>1; /* right half of window size */ k1 = m-k2-1; /* left half of window size */ in = In; /* initialize pointer to input In vector */ out = Out; /* initialize pointer to output Mad vector */ ctr = Ctr; /* initialize pointer to output Mad vector */ /* --- step 1 : left edge -----------------------------------------------------------------*/ for(i=0; i>1; /* right half of window size */ kk1 = Num-kk2-1; /* left half of window size. if nWin is odd than kk1==kk2 */ *(out++) = (Win2[idx[kk1]]+Win2[idx[kk2]])*0.5; /* find mad of current Win1 and store it */ // med0 = med; /* save previous median */ // printf("1-------- "); for(l=0; l>1; /* right half of window size */ kk1 = Num-kk2-1; /* left half of window size. if nWin is odd than kk1==kk2 */ *(out++) = (Win2[idx[kk1]]+Win2[idx[kk2]])*0.5; /* find mad of current Win1 and store it */ med0 = med; /* save previous median */ j = (j+1)%m; /* index goes from 0 to m-1, and back to 0 again */ // printf("2-------- "); for(l=0; l>1; /* right half of window size */ kk1 = Num-kk2-1; /* left half of window size. if nWin is odd than kk1==kk2 */ Out[n-i] = (Win2[idx[kk1]]+Win2[idx[kk2]])*0.5; /* find mad of current Win1 and store it */ // med0 = med; /* save previous median */ // printf("3-------- "); for(l=0; l>1; /* right half of window size */ k1 = m-k2-1; /* left half of window size */ in = In; /* initialize pointer to input In vector */ out = Out+k1; /* initialize pointer to output Mad vector */ ctr = Ctr+k1; /* initialize pointer to output Mad vector */ med0 = *ctr+1; /* med0 - will save previous center (median) sowe know it changed */ for(i=0; i>1; /* right half of window size */ k1 = m-k2-1; /* left half of window size */ in = In; /* initialize pointer to input In vector */ out = Out; /* initialize pointer to output Mad vector */ ctr = Ctr; /* initialize pointer to output Mad vector */ /* --- step 1 : left edge -----------------------------------------------------------------*/ for(i=0; i1 ? sqrt((Sum+Err)/(Num-1)) : NaN); /* save std and move window */ med0 = med; /* save previous median */ /*printf("1-------- "); for(l=0; l1 ? sqrt((Sum+Err)/(Num-1)) : NaN); /* save std and move window */ med0 = med; /* save previous median */ j = (j+1)%m; /* index goes from 0 to m-1, and back to 0 again */ /*printf("2-------- "); for(l=0; l1 ? sqrt((Sum+Err)/(Num-1)) : NaN); /* save std and move window */ med0 = med; /* save previous median */ /*printf("3-------- "); for(l=0; l #include extern "C" { #define print Rprintf #define Error error typedef unsigned char uchar; int imreadGif(const char* filename, int nImage, bool verbose, uchar** data, int &nRow, int &nCol, int &nBand, int ColorMap[255], int &Transparent, char** Comment); int imwriteGif(const char* filename, const uchar* data, int nRow, int nCol, int nBand, int nColor, const int *ColorMap, bool interlace, int transparent, int DalayTime, char* comment); } #endif caTools/src/GifTools.cpp0000644000176000001440000010417012403665602014736 0ustar ripleyusers/*===========================================================================*/ /* GifTools - GIF encoder / decoder */ /* Copyright (C) 2005 Jarek Tuszynski */ /* Distributed under GNU General Public License version 3 */ /*===========================================================================*/ #include #include #include // memset, memcpy #include "GifTools.h" typedef unsigned char uchar; #ifndef USING_R // if not using R language than define following calls: #define print printf #define Calloc(n, T) new T[n]; inline void Free(void* p) { delete []p; } #endif //#define STANDALONE_TEST #ifdef STANDALONE_TEST inline void Error(char *message) { fprintf(stderr, "\nError: %s.\n", message); exit(1); } #endif //STANDALONE_TEST //======================================================================= // Encoding Algorithm adapted from code by Christoph Hohmann // found at http://members.aol.com/rf21exe/gif.htm. // Which was adapted from code by Michael A, Mayer // found at http://www.danbbs.dk/%7Edino/whirlgif/gifcode.html // Parts of Decoding Algorithm were adapted from code by David Koblas. // It had the following notice: // "Copyright 1990 - 1994, David Koblas. (koblas@netcom.com) // Permission to use, copy, modify, and distribute this software and its // documentation for any purpose and without fee is hereby granted, provided // that the above copyright notice appear in all copies and that both that // copyright notice and this permission notice appear in supporting // documentation. This software is provided "as is" without express or // implied warranty." //======================================================================= inline int bitGet (int num, int bit) { return ((num & (1<12) Error("BitPacker::SubmitCode"); short mask; while (nBits >= need) { mask = (1<((mask&code) << (8-need)); // the 'need' lowest bits of 'code' fill the current byte at its upper end nBits -= need; // update the length of 'code' code >>= need; // remove the written bits from code *(++pos)=0; // byte is now full, goto next byte & init it need=8; // current byte can take 8 bits } // Now we have nBits < need. // (remainder of) code is written to the nBits rightmost free bits of // the current byte. The current byte can still take 'need' bits, and // we have 'need'>0. The bits will be filled upon future calls. if(nBits>0) { mask = (1<((mask&code)<<(8-need)); need -= nBits; } // As soon as 255 bytes are full, they are written to 'binfile' as a // data block and removed from 'buffer'. if(pos-buffer >= 255) { // pos pointing to buffer[255] or beyond fputc(255,binfile); // write the "bytecount-byte" fwrite(buffer,255,1,binfile); // write buffer[0..254] to file buffer[0] = buffer[255]; // rotate the following bytes, which may still buffer[1] = buffer[256]; // contain data, to the beginning of buffer, pos -= 255; // point pos to the position for new input bytesdone += 256; } } // BitPacker::SubmitCode //------------------------------------------------------------------------- void WriteFlush() // Writes any data contained in 'buffer' to the file as one data block of // 1<= length<=255. { // if the current byte is partially filled, leave it alone if(need<8) pos++; // close any partially filled terminal byte int BlockSize = static_cast(pos-buffer); // # remaining bytes if(BlockSize>0) { // buffer is empty fputc(BlockSize, binfile); fwrite(buffer, BlockSize, 1, binfile); bytesdone += BlockSize+1; } } // BitPacker::WriteFlush //------------------------------------------------------------------------- short GetCode(short nBits) // Extract nBits [1:32] integer from the buffer. // Read next data block if needed. { short i, j, code, lastbit; // if more bits is needed than we have stored in the buffer lastbit = (2+BlockSize)<<3; // (BlockSize<<3 == BlockSize*8) - byte to bit conversion while ( (curbit+nBits) >= lastbit ) { // If () should have been enough but used while() just in case buffer[0] = buffer[BlockSize ]; buffer[1] = buffer[BlockSize+1]; curbit -= BlockSize<<3; BlockSize = GetDataBlock(binfile, &buffer[2]); lastbit = (2+BlockSize)<<3; // (BlockSize<<3 == BlockSize*8) - byte to bit conversion bytesdone += BlockSize+1; // keep track of number of bytes read } // read next set of nBits from the buffer and store it into ret code = 0; i = curbit; for (j=0; j>3] , i&7) << j; curbit += nBits; // we read nBits of data from buffer return code; } //------------------------------------------------------------------------- int ReadFlush() { short count; while ((count = GetDataBlock(binfile, buffer)) > 0); return count; } private: FILE *binfile; uchar buffer[260]; // holds the total buffer of 256 + some extra uchar *pos; // sliding pointer into buffer uchar need; // [1..8] tells how many bits will still fit in current byte int bytesdone; // total number of bytes processed during the object's lifetime int curbit, BlockSize; }; // class bitpacker //============================================================== // Gif-compression de compression functions //============================================================== //=========================================================================== // Contains the string-table, generates compression codes and writes them to a // binary file, formatted in data blocks of maximum length 255 with // additional bytecount header. // Encodes the pixel data and writes the "raster data"-section of the GIF // file, consisting of the "code size" byte followed by the counter-headed // data blocks, including the terminating zero block. // bf must be an opened binary file to which the preceding parts // of the GIF format have been written // data is an array of bytes containing one pixel each and sorted // left to right, top to bottom. The first pixel is in data[0] // nPixel Number of pixels in the image // nBit Number of bits per pixel, where 2^nBit is the size of the GIF's // color tables. Allowed are 1..8. Used to determine 'nbits' and // the number of root codes. Max(data) HAS to be < 2^nBits // returns: The total number of bytes that have been written. //------------------------------------------------------------------------- int EncodeLZW(FILE *bf, const uchar *data, int nPixel, short nBits) { BitPacker bp; // object that does the packing and writing of the compression codes int iPixel; // pixel counter uchar pixel; // next pixel value to be encoded short axon[4096], next[4096]; // arrays making up the string-table uchar pix[4096]; // dito short freecode; // next code to be added to the string-table short i, depth, cc, eoi, up, down, outlet; if (nPixel<0) Error("EncodeLZW: nPixel can not be negative"); if (nBits<1 || nBits>8) Error(" EncodeLZW: nBit has to be between 1 and 8"); // The following parameters will remain unchanged through the run depth = (nBits<2 ? 2 : nBits); // number of bits per data item (=pixel). Remains unchanged. cc = 1<(i); // Initialize the string-table's root nodes // Write what the GIF specification calls the "code size". Allowed are [2..8]. // This is the number of bits required to represent the pixel values. fputc(depth,bf); // provide data-depth to the decoder freecode = 4096; // this will cause string-table flush first time around while(iPixel=4096) { // free code is 2^12 the largest allowed // Flush the string-table by removing the outlets of all root nodes. Everything is set to initial state. memset(axon, 0, 4096*sizeof(short)); // avoid string-table overflow bp.SubmitCode(cc,nBits); // tell the decoding software to flush its string-table nBits = depth+1; // reset nBits freecode = cc+2; // reset freecode } // Writes the next code to the codestream and adds one entry to the string-table. outlet=pixel; // start with the root node for 'pixel' // Follow the string-table and the data stream to the end of the // longest string that has a code do { up = outlet; iPixel++; // advance pixel counter (the only place it is advanced) if(iPixel >= nPixel) break; // end of data stream ? Terminate pixel = data[iPixel]; // get the value of the next pixel // Checks if the chain starting from headnode's axon (axon[up]) contains a node for // 'pixel'. Returns that node's address (=outlet), or 0 if there is no such node. // 0 cannot be the root node 0, since root nodes occur in no chain. outlet = axon[up]; while(outlet && pix[outlet]!=pixel) outlet=next[outlet]; } while(outlet); // Submit 'up' which is the code of the longest string bp.SubmitCode(up,nBits); if(iPixel >= nPixel) break; // end of data stream ? Terminate // Extend the string by appending 'pixel': // Create a successor node for 'pixel' whose code is 'freecode' pix [freecode]=pixel; axon[freecode]=next[freecode]=0; // Link it to the end of the chain emanating from axon[up]. // Don't link it to the start: it would slow down performance. down=axon[up]; if(!down) axon[up]=freecode; else { while(next[down]) down=next[down]; next[down]=freecode; } } // while() // Wrap up the file bp.SubmitCode(eoi,nBits); // submit 'eoi' as the last item of the code stream bp.WriteFlush(); // write remaining codes including this 'eoi' to the binary file fputc(0,bf); // write an empty data block to signal the end of "raster data" section in the file return 2 + bp.BytesDone(); } // EncodeLZW //------------------------------------------------------------------------- // Reads the "raster data"-section of the GIF file and decodes the pixel // data. Most work is done by GifDecomposer class and this function mostly // handles interlace row irdering // bf must be an opened binary file to which the preceding parts // of the GIF format have been written // data is an array of bytes containing one pixel each and sorted // left to right, top to bottom. // nPixels Number of pixels in the image // returns: The total number of bytes that have been written. //------------------------------------------------------------------------- int DecodeLZW(FILE *fp, uchar *data, int nPixel) { BitPacker bp; // object that does the packing and writing of the short cc, eoi, freecode, nBits, depth, nStack, code, incode, firstcode, oldcode; short pix[4096], next[4096]; uchar stack[4096]; int iPixel, ret; freecode=nBits=firstcode=oldcode=0; // unnecesary line used to prevent warnings in gcc depth = fgetc(fp); // number of bits per data item (=pixel). Remains unchanged. if (depth==EOF) return -1; bp.GetFile(fp); // object packs the code and renders it to the binary file 'bf' cc = 1<(firstcode); } else { // the regular case nStack = 0; // (re)initialize the stack incode = code; // store a copy of the code - it will be needed if (code >= freecode) { stack[nStack++] = static_cast(firstcode); code = oldcode; } while (code >= cc) { // read string for code from string-table if (nStack>=4096) return 0; // error stack[nStack++] = static_cast(pix[code]); code = next[code]; } firstcode = pix[code]; data[iPixel++] = static_cast(pix[code]); while (nStack && iPixel>8) & 0xff, fp ); } //------------------------------------------ int imwriteGif(const char* filename, const uchar* data, int nRow, int nCol, int nBand, int nColor, const int *ColorMap, bool interlace, int transparent, int DalayTime, char* comment) { int B, i, rgb, imMax, filesize=0, Bands, band, n, m; int BitsPerPixel=0, ColorMapSize, Width, Height, nPixel; char fname[256], sig[16], *q; const uchar *p=data; strcpy(fname,filename); i = static_cast(strlen(fname)); if (fname[i-4]=='.') strcpy(strrchr(fname,'.'),".gif"); Width = nCol; Height = nRow; Bands = nBand; nPixel = Width*Height; imMax = data[0]; n = nPixel*nBand; for(i=0; i256 ? 256 : nColor); // is a power of two between 2 and 256 compute its exponent BitsPerPixel (between 1 and 8) if (!nColor) nColor = imMax+1; if (imMax>nColor) Error("ImWriteGif: Higher pixel values than size of color table"); for(i=1; i=0 || comment || Bands>1) strcpy(sig,"GIF89a"); else strcpy(sig,"GIF87a"); fwrite( sig, 1, 6, fp ); // Write the Magic header fputw( Width , fp ); // Bit 1&2 : Logical Screen Width fputw( Height, fp ); // Bit 3&4 : Logical Screen Height B = 0xf0 | (0x7&(BitsPerPixel-1)); // write BitsPerPixel-1 to the three least significant bits of byte 5 fputc( B, fp ); // Bit 5: global color table (yes), color resolution, sort flag (no) size of global color table fputc( 0, fp ); // Bit 6: Write out the Background color index fputc( 0, fp ); // Bit 7: Byte of 0's (no aspect ratio info) //==================================== // Global Color Map //==================================== ColorMapSize = 1 << BitsPerPixel; if (ColorMap) { for( i=0; i> 16) & 0xff, fp ); fputc( (rgb >> 8) & 0xff, fp ); fputc( rgb & 0xff, fp ); } } else { // default gray-scale ramp for( i=0; i(strlen(comment)) : 0); if (n>0) { fputc( 0x21, fp ); // GIF Extention Block introducer fputc( 0xfe, fp ); // "Comment Extension" for (q=comment; n>0; n-=255) { m = n<255 ? n : 255; fputc(m, fp ); fwrite(q, 1, m, fp ); q += m; filesize += m+1; } fputc( 0, fp ); // extention Block Terminator filesize += 3; } if (Bands>1) { fputc( 0x21, fp ); // GIF Extention Block introducer fputc( 0xff, fp ); // byte 2: 255 (hex 0xFF) Application Extension Label fputc( 11, fp ); // byte 3: 11 (hex (0x0B) Length of Application Block fwrite("NETSCAPE2.0", 1, 11, fp ); // bytes 4 to 14: 11 bis of first sub-block fputc( 3, fp ); // byte 15: 3 (hex 0x03) Length of Data Sub-Block (three bytes of data to follow) fputc( 1, fp ); // byte 16: 1-means next number 2 bytes have iteration counter; 2-means next 4 bytes haveamount of memory needed fputw( 0, fp ); // byte 17&18: 0 to 65535, an unsigned integer. # of iterations the loop should be executed. fputc( 0, fp ); // extention Block Terminator filesize += 19; } filesize += 6 + 7 + 3*ColorMapSize; for (band=0; band= 0 || Bands>1 ) { fputc( 0x21, fp ); // GIF Extention Block introducer "!" fputc( 0xf9, fp ); // "Graphic Control Extension" fputc( 4, fp ); // block is of size 4 B = (Bands>1 ? 2 : 0) << 2; // Disposal Method B |= (0) << 1; // User Input flag: is user input needed? B |= (transparent >= 0 ? 1 : 0); // Transparency flag fputc( B, fp ); // "transparency color follows" flag fputw( DalayTime, fp ); // delay time in # of hundredths (1/100) of a second delay between frames fputc( static_cast(transparent), fp ); fputc( 0, fp ); // extention Block Terminator filesize += 8; } //==================================== // Image Descriptor //==================================== fputc( 0x2c , fp ); // Byte 1 : Write an Image Separator "," fputw( 0 , fp ); // Byte 2&3: Write the Image left offset fputw( 0 , fp ); // Byte 4&5: Write the Image top offset fputw( Width , fp ); // Byte 6&7: Write the Image width fputw( Height, fp ); // Byte 8&9: Write the Image height fputc( interlace ? 0x40 : 0x00,fp); // Byte 10 : contains the interlaced flag filesize += 10; //==================================== // Raster Data (LZW encrypted) //==================================== p = data+band*nPixel; if(interlace) { // rearrange rows to do interlace int i, row=0; uchar* tmp = new uchar[Width*Height]; for (i=0; i( strlen(fname)); if (fname[i-4]=='.') strcpy(strrchr(fname,'.'),".gif"); FILE *fp = fopen(fname,"rb"); if (fp==0) return -1; //==================================================== // GIF Signature, Screen Descriptor & Global Color Map //==================================================== if (!fread(version, 6, 1, fp)) return -2; // Read Header version[6] = '\0'; if ((strcmp(version, "GIF87a") != 0) && (strcmp(version, "GIF89a") != 0)) return -2; if (!fread(buffer, 7, 1, fp)) return -3; // Read Screen Descriptor if(verbose) print("GIF image header\n"); i = ReadColorMap(fp, buffer[4], ColorMap); // Read Global Colormap if (i==0) return -3; if (i==2) nColMap++; if(verbose) { if(i==2) print("Global colormap with %i colors \n", 2<<(buffer[4]&0x07)); else print("No global colormap provided\n"); } filesize += 6 + 7 + 3*256; //==================================================== // Raster Data of encoded images and Extention Blocks //==================================================== iImage = stats = done = 0; while(!stats && !done) { c = fgetc(fp); switch(c) { case EOF: stats=3; break; // unexpected EOF case 0x3b: // GIF terminator ";" done =1; if(verbose) print("GIF Terminator\n"); break; case 0x21: // GIF Extention Block introducer c = fgetc(fp); switch (c) { case EOF : stats=3; break; // unexpected EOF case 0xf9: // "Graphic Control Extension" n = GetDataBlock(fp, buffer); // block is of size 4 if (n==4) { // block has to be of size 4 DelayTime = getint(buffer+1); if ((buffer[0] & 0x1) != 0) Transparent = buffer[3]; if(verbose) print("Graphic Control Extension (delay=%i transparent=%i)\n", DelayTime, Transparent); } while (GetDataBlock(fp, buffer) != 0); // look for block terminator break; case 0xfe: // "Comment Extension" m = (comment ? static_cast(strlen(comment)) : 0); while ((n=GetDataBlock(fp, buffer)) != 0) { // look for block terminator p = Calloc(m+n+1,char); if(m>0) { // if there was a previous comment than whey will be concatinated memcpy(p,comment,m); free(comment); } comment = p; strncpy(comment+m, (char*) buffer, n); m+=n; comment[m]=0; } if(verbose) print("Comment Extension\n"); break; case 0xff: // "Software Specific Extension" most likelly NETSCAPE2.0 while (GetDataBlock(fp, buffer) != 0); // look for block terminator if(verbose) print("Animation Extension\n"); break; case 0x01: // "Plain Text Extension" while (GetDataBlock(fp, buffer) != 0); // look for block terminator if(verbose) print("Plain Text Extension (ignored)\n"); break; default: // Any other type of Extension while (GetDataBlock(fp, buffer) != 0); // look for block terminator if(verbose) print("Unknown Extension %i\n", c); break; } break; case 0x2c: // Image separator found //==================================== // Image Descriptor //==================================== if (!fread(buffer, 9, 1, fp)) {stats=3; break;} // unexpected EOF Width = getint(buffer+4); // Byte 6&7: Read the Image width Height = getint(buffer+6); // Byte 8&9: Read the Image height interlace = ((buffer[8]&0x40)==0x40); if(verbose) print("Image [%i x %i]: ", Height, Width); if (!nImage && nBand>0 && (nRow!=Height || nCol!=Width)) {stats=5; break;} //============================================= // Local Color Map & Raster Data (LZW encrypted) //============================================= i = ReadColorMap(fp, buffer[8], ColorMap, nColMap*nImage); // Read local Colormap if (i==0) {stats=3; break;} // EOF found during reading local colormap if (i==2) nColMap++; if(image) Free(image); image = Calloc(Height*Width, uchar); ret = DecodeLZW(fp, image, Height*Width); // if (ret==0) {stats=4; break;} // syntax error if(interlace) { int i, row=0; uchar* to = image; uchar* from = new uchar[Width*Height]; memcpy(from, to, Width*Height); for (i=0; i1) stats += 6; if (stats) filesize = -stats; // if no image than save error # return filesize; } //============================================================== // Section below is used in interface with Matrix Library //============================================================== #ifdef MATRIX_INTERFACE template <> int imwriteGif(const bMatrix &im, const char* filename, const iMatrix ColorMap, bool interlace, int transparent, int delayTime, char* comment) { int ret = imwriteGif(filename, im->d(), im->rows(), im->cols(), im->bands(), ColorMap->len(), ColorMap->d(), interlace, transparent, delayTime, comment); if (ret<0) Error("write.gif: cannot open the output GIF file"); return ret; } int imreadGif(bMatrix &im, const char* filename, iMatrix &ColorMap, int imageNumber) { int nRow, nCol, nBand, transparent, stats, success, nPixel; char *comment=0; uchar* data=0; ColorMap->init(256); // initialize data nRow=nCol=nBand=transparent=0; comment = NULL; success = imreadGif(filename, imageNumber, false, &data, nRow, nCol, nBand, ColorMap->d(), transparent, &comment); nPixel = nRow*nCol*nBand; if(comment) Free(comment); stats = -success; if (stats>=6) { print("write.gif: file '", filename, "' contains multiple color-maps. Use 'frame' > 0."); stats = stats-6; } if (nPixel==0) { switch (stats) { case 1: Error("write.gif: cannot open the input GIF file"); case 2: Error("write.gif: input file is not a GIF file"); case 3: Error("write.gif: unexpected end of input GIF file"); case 4: Error("write.gif: syntax error in input GIF file"); } } else { switch (stats) { // warnings case 3: print("write.gif: unexpected end of input GIF file: ", filename); case 4: print("write.gif: syntax error in input GIF file: ", filename); case 5: print("write.gif: file '", filename, "' contains multiple images (frames) of uneven length. Use 'imageNumber' > 0." ); } } im->moveto(data, nRow*nCol*nBand); im->resize(nBand, nRow, nCol); return success; } #endif //============================================================== // Section below is used in standalone test application //============================================================== #ifdef STANDALONE_TEST int main() { bool interlace; int nRow, nCol, nBand, ColorMap[256], transparent, *Data=0, DelayTime, nImage, succes, n; char *Comment=0, str[256]; uchar *data=0; interlace = 0; DelayTime = 0; nImage = 0; succes = imreadGif ("bats.gif", nImage, (bool) 1, &data, nRow, nCol, nBand, ColorMap, transparent, &Comment); printf("Image read = [%i x %i x %i]: %i\n",nRow, nCol, nBand, succes); if (1) { n = nRow*nCol; strcpy(str, "hello world"); succes = imwriteGif("tmp.gif", data, nRow, nCol, nBand, 256, ColorMap, interlace, transparent, DelayTime, str); printf("Image written = [%i x %i x %i]: %i\n",nRow, nCol, nBand, succes); } printf("Press any key\n"); getchar(); return 0; } #endif caTools/NAMESPACE0000644000176000001440000000011512325152723013124 0ustar ripleyusersuseDynLib("caTools") # Export all names exportPattern(".") import(bitops) caTools/R/0000755000176000001440000000000012403665602012113 5ustar ripleyuserscaTools/R/GIF.R0000644000176000001440000001563012325152723012646 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# write.gif = function(image, filename, col="gray", scale=c("smart", "never", "always"), transparent=NULL, comment=NULL, delay=0, flip=FALSE, interlace=FALSE) { if (!is.character(filename)) stop("write.gif: 'filename' has to be a string") if (length(filename)>1) filename = paste(filename, collapse = "") # combine characters into a string #====================================== # cast 'image' into a proper dimentions #====================================== dm = dim(image) if (is.null(dm)) stop("write.gif: input 'x' has to be an matrix or 3D array") if (length(dm)<=2) { # this is a 2D matrix or smaller image = as.matrix(image) # cast to 2D matrix if (flip) x = image[,dm[2]:1] else x = t(image) } else { # 3D data cube or bigger dim(image) = c(dm[1], dm[2], prod(dm)/(dm[1]*dm[2])) # cast to 3D if (flip) x = image[,dm[2]:1,] else x = aperm(image, c(2,1,3)) } image = 0 # release memory dm = dim(x) # save dimentions and ... x = as.vector(x) # convert to 1D vector #================================= # scale x into a proper range #================================= scale = match.arg(scale) if (!is.null(transparent)) if ((transparent<0) || (transparent>255)) stop("write.gif:'transparent' has to be an integer between 0 and 255") mask = !is.finite(x) xx = 0 mColor = 255 if (any(mask)) { # some non-finite numbers were found if (is.null(transparent)) mColor = 254 xx = x # save original x x = x[!mask] # remove non-finite numbers } minx = min(x) maxx = max(x) d = mColor/(maxx-minx) if (scale=="never") { if ((minx<0) || (maxx>mColor)) warning("write.gif: 'x' is not in proper range and 'scale' is set to 'never',", " clipping 'x' to proper range ") if (minx<0 ) x[x<0 ] = 0 if (maxx>mColor) x[x>mColor] = mColor } else if (scale=="always") { if ((minx>=0) && (maxx<=1)) x = mColor*x # doubles between [0 and 1] -> scale them else x = (x-minx)*d # numbers outside allowed range -> scale them } else if (scale=="smart") { if ((minx<0) || (maxx>mColor)) { x = (x-minx)*d # numbers outside allowed range -> scale them } else if ((minx>=0) && (maxx<=1)) { if (any(x!=as.integer(x))) x = mColor*x # doubles between [0 and 1] -> scale them } } maxx = max(x) if (length(xx)>1) { # some non-finite numbers were found if (is.null(transparent)) transparent = maxx+1 xx[ mask] = transparent xx[!mask] = x x = xx } if (is.null(transparent)) transparent = -1 x = as.integer(round(x)) #================================= # format color palette #================================= n = maxx+1 if (is.character(col) && length(col)==1) { if (col %in% c("grey", "gray")) col = gray(0:n/n) if (col=="jet") col = colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # define "jet" palette } if (length(col)==1) { # if not a vector than maybe it is a palette function FUN = match.fun(col) # make sure it is a function not a string with function name col = FUN(n) } crgb = col2rgb(col) Palette = as.integer(c(256^(2:0) %*% crgb)) # convert to internal int format nColor = length(Palette) if (nColor1) filename = paste(filename, collapse = "") # combine characters into a string isURL = length(grep("^http://", filename)) | length(grep("^ftp://", filename)) | length(grep("^file://", filename)) if(isURL) { tf <- tempfile() download.file(filename, tf, mode='wb', quiet=TRUE) filename = tf } x = .Call("imreadgif", filename, as.integer(frame), as.integer(verbose), PACKAGE="caTools") comt = as.character(attr(x, 'comm')) if (isURL) file.remove(filename) nRow = x[1] nCol = x[2] nBand = x[3] tran = x[4] success = x[5] nPixel = nRow*nCol*nBand stats = -success if (stats>=6) { warning("write.gif: file '", filename, "' contains multiple color-maps. Use 'frame' > 0.") stats = stats-6 } if (nPixel==0) { switch (stats, stop("write.gif: cannot open the input file: ", filename, call.=FALSE), stop("write.gif: input file '", filename, "' is not a GIF file", call.=FALSE), stop("write.gif: unexpected end of file: ", filename, call.=FALSE), stop("write.gif: syntax error in file: ", filename, call.=FALSE) ) } else { switch (stats, , , warning("write.gif: unexpected end of file: ", filename, call.=FALSE), warning("write.gif: syntax error in file: ", filename, call.=FALSE), warning("write.gif: file '", filename, "' contains multiple images (frames) of uneven length. Use 'frame' > 0." , call.=FALSE)) } Palette = x[ 10:265 ] x = x[-(1:265)] # delete non image data if (nBand>1) { # 3D data cubes dim(x) = c(nCol, nRow, nBand) if (flip) x = x[,ncol(x):1,] else x = aperm(x, c(2,1,3)) } else { # this is a matrix dim(x) = c(nCol, nRow) if (flip) x = x[,ncol(x):1] else x = t(x) } Palette = Palette[Palette>=0] red = bitAnd(bitShiftR(Palette,16), 255) green = bitAnd(bitShiftR(Palette, 8), 255) blue = bitAnd( Palette , 255) Palette = rgb (red, green, blue, 255, maxColorValue = 255) if (tran==-1) tran = NULL return (list(image=x, col=Palette, transparent=tran, comment=comt)) } # source("c:/programs/R/rw2011/src/library/caTools/R/GIF.R") caTools/R/runfunc.R0000644000176000001440000002407312403664755013734 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# #source('C:/Projects/R Packages/caTools/R/runfunc.R') runmean = function(x, k, alg=c("C", "R", "fast", "exact"), endrule=c("mean", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { alg = match.arg(alg) endrule = match.arg(endrule) align = match.arg(align) dimx = dim(x) # Capture dimension of input array - to be used for formating y x = as.vector(x) n = length(x) if (k<=1) return (x) if (k >n) k = n k2 = k%/%2 if (alg=="exact") { y <- .C("runmean_exact", x, y = double(n) , as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y } else if (alg=="C") { y <- .C("runmean", as.double(x), y = double(n), as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y } else if (alg=="fast") { y <- .C("runmean_lite", as.double(x), y = double(n), as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y } else { # the similar algorithm implemented in R language y = double(n) k1 = k-k2-1 y = c( sum(x[1:k]), diff(x,k) ); # find the first sum and the differences from it y = cumsum(y)/k # apply precomputed differences y = c(rep(0,k1), y, rep(0,k2)) # make y the same length as x if (endrule=="mean") endrule="func" } y = EndRule(x, y, k, dimx, endrule, align, mean, na.rm=TRUE) return(y) } #============================================================================== runmin = function(x, k, alg=c("C", "R"), endrule=c("min", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { alg = match.arg(alg) align = match.arg(align) endrule = match.arg(endrule) dimx = dim(x) # Capture dimension of input array - to be used for formating y x = as.vector(x) n = length(x) if (k<=1) return (x) if (k >n) k = n if (alg=="C") { y <- .C("runmin", as.double(x), y = double(n), as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y } else { # the similar algorithm implemented in R language y = double(n) k2 = k%/%2 k1 = k-k2-1 a <- y[k1+1] <- min(x[1:k], na.rm=TRUE) if (k!=n) for (i in (2+k1):(n-k2)) { if (a==y[i-1]) # point leaving the window was the min, so ... y[i] = min(x[(i-k1):(i+k2)], na.rm=TRUE) # recalculate min of the window else # min=y[i-1] is still inside the window y[i] = min(y[i-1], x[i+k2 ], na.rm=TRUE) # compare it with the new point a = x[i-k1] # point that will be removed from the window next if (!is.finite(a)) a=y[i-1]+1 # this will force the 'else' option } if (endrule=="min") endrule="func" } y = EndRule(x, y, k, dimx, endrule, align, min, na.rm=TRUE) return(y) } #============================================================================== runmax = function(x, k, alg=c("C", "R"), endrule=c("max", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { alg = match.arg(alg) endrule = match.arg(endrule) align = match.arg(align) dimx = dim(x) # Capture dimension of input array - to be used for formating y x = as.vector(x) n = length(x) k = as.integer(k) if (k<=1) return (x) if (k >n) k = n y = double(n) if (alg=="C") { y <- .C("runmax", as.double(x), y = double(n) , as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y } else { # the same algorithm implemented in R language y = double(n) k2 = k%/%2 k1 = k-k2-1 a <- y[k1+1] <- max(x[1:k], na.rm=TRUE) if (k!=n) for (i in (2+k1):(n-k2)) { if (a==y[i-1]) # point leaving the window was the max, so ... y[i] = max(x[(i-k1):(i+k2)], na.rm=TRUE) # recalculate max of the window else # max=y[i-1] is still inside the window y[i] = max(y[i-1], x[i+k2 ], na.rm=TRUE) # compare it with the new point a = x[i-k1] # point that will be removed from the window next if (!is.finite(a)) a=y[i-1]+1 # this will force the 'else' option } if (endrule=="max") endrule="func" } y = EndRule(x, y, k, dimx, endrule, align, max, na.rm=TRUE) return(y) } #============================================================================== runquantile = function(x, k, probs, type=7, endrule=c("quantile", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { ## see http://mathworld.wolfram.com/Quantile.html for very clear definition ## of different quantile types endrule = match.arg(endrule) align = match.arg(align) dimx = dim(x) # Capture dimension of input array - to be used for formating y yIsVec = is.null(dimx) # original x was a vector x = as.vector(x) n = length(x) np = length(probs) k = as.integer(k) type = as.integer(type) if (k<=1) return (rep(x,n,np)) if (k >n) k = n if (is.na(type) || (type < 1 | type > 9)) warning("'type' outside allowed range [1,9]; changing 'type' to ", type<-7) y = double(n*np) y <- .C("runquantile", as.double(x), y = y , as.integer(n), as.integer(k), as.double(probs), as.integer(np),as.integer(type), NAOK=TRUE, PACKAGE="caTools")$y dim(y) = c(n,np) for (i in 1:np) { # for each percentile yTmp = EndRule(x, y[,i], k, dimx, endrule, align, quantile, probs=probs[i], type=type, na.rm=TRUE) if (i==1) { if (is.null(dimx)) dimy = length(yTmp) else dimy = dim(yTmp) yy = matrix(0,length(yTmp),np) # initialize output array } yy[,i] = as.vector(yTmp) } if (np>1) dim(yy) = c(dimy,np) else dim(yy) = dimy return(yy) } #============================================================================== runmad = function(x, k, center = runmed(x,k), constant = 1.4826, endrule=c("mad", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { endrule = match.arg(endrule) align = match.arg(align) dimx = dim(x) # Capture dimension of input array - to be used for formating y x = as.vector(x) n = length(x) if (k<3) stop("'k' must be larger than 2") if (k>n) k = n y <- .C("runmad", as.double(x), as.double(center), y = double(n), as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y y = EndRule(x, y, k, dimx, endrule, align, mad, constant=1, na.rm=TRUE) return(constant*y) } #============================================================================== runsd = function(x, k, center = runmean(x,k), endrule=c("sd", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) { endrule = match.arg(endrule) align = match.arg(align) dimx = dim(x) # Capture dimension of input array - to be used for formating y x = as.vector(x) n = length(x) if (k<3) stop("'k' must be larger than 2") if (k>n) k = n y <- .C("runsd", as.double(x), as.double(center), y = double(n), as.integer(n), as.integer(k), NAOK=TRUE, PACKAGE="caTools")$y y = EndRule(x, y, k, dimx, endrule, align, sd, na.rm=TRUE) return(y) } #============================================================================== EndRule = function(x, y, k, dimx, endrule=c("NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right"), Func, ...) { # Function which postprocess results of running windows functions and cast # them in to specified format. On input y is equivalent to # y = runFUNC(as.vector(x), k, endrule="func", align="center") # === Step 1: inspects inputs and unify format === align = match.arg(align) k = as.integer(k) k2 = k%/%2 if (k2<1) k2 = 1 yIsVec = is.null(dimx) # original x was a vector -> returned y will be a vector if (yIsVec) dimx=c(length(y),1) # x & y will become 2D arrays dim(x) <- dimx dim(y) <- dimx n = nrow(x) m = ncol(x) if (k>n) k2 = (n-1)%/%2 k1 = k-k2-1 if (align=="center" && k==2) align='right' # === Step 2: Apply different endrules === if (endrule=="trim") { y = y[(k1+1):(n-k2),] # change y dimensions } else if (align=="center") { idx1 = 1:k1 idx2 = (n-k2+1):n # endrule calculation in R will be skipped for most common case when endrule # is default and array was a vector not a matrix if (endrule=="NA") { y[idx1,] = NA y[idx2,] = NA } else if (endrule=="keep") { y[idx1,] = x[idx1,] y[idx2,] = x[idx2,] } else if (endrule=="constant") { y[idx1,] = y[k1+1+integer(m),] y[idx2,] = y[n-k2+integer(m),] } else if (endrule=="func" || !yIsVec) { for (j in 1:m) { for (i in idx1) y[i,j] = Func(x[1:(i+k2),j], ...) for (i in idx2) y[i,j] = Func(x[(i-k1):n,j], ...) } } } else if (align=="left") { y[1:(n-k1),] = y[(k1+1):n,] idx = (n-k+2):n if (endrule=="NA") { y[idx,] = NA } else if (endrule=="keep") { y[idx,] = x[idx,] } else if (endrule=="constant") { y[idx,] = y[n-k+integer(m)+1,] } else { for (j in 1:m) for (i in idx) y[i,j] = Func(x[i:n,j], ...) } } else if (align=="right") { y[(k2+1):n,] = y[1:(n-k2),] idx = 1:(k-1) if (endrule=="NA") { y[idx,] = NA } else if (endrule=="keep") { y[idx,] = x[idx,] } else if (endrule=="constant") { y[idx,] = y[k+integer(m),] } else { for (j in 1:m) for (i in idx) y[i,j] = Func(x[1:i,j], ...) } } # === Step 4: final casting and return results === if (yIsVec) y = as.vector(y); return(y) } caTools/R/sumexact.R0000644000176000001440000000164212403660602014065 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# sumexact = function(..., na.rm = FALSE) { x = c(..., recursive=TRUE) if (na.rm) x = x[!is.na(x)] else if (any(is.na(x))) return(NA) n = length(x) .C("sum_exact", as.double(x), y = as.double(0), as.integer(n), NAOK=TRUE, DUP=TRUE, PACKAGE="caTools")$y } #============================================================================== cumsumexact = function(x) { n = length(x) .C("cumsum_exact", as.double(x), y = double(n), as.integer(n), NAOK=TRUE, DUP=TRUE, PACKAGE="caTools")$y } caTools/R/colAUC.R0000644000176000001440000001364212325152723013350 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# colAUC = function (X, y, plotROC=FALSE, alg=c("Wilcoxon","ROC")) { # input: # X - 2D matrix (of feature columns and samples rows) # y - 1D array identifying which class each sample belongs to (csource(lass numbers start from 1) #======================================= # make sure inputs are in correct format #======================================= y = as.factor(y) X = as.matrix(X) # make sure inputs are in correct format alg = match.arg(alg) if (nrow(X)==1) X = t(X) if (plotROC) alg = "ROC" #======================================= # Prepare for calculations & error-check #======================================= nR = nrow(X) # number of samples nC = ncol(X) # get dimentions of the data set nY = table(y) # number of elements per label uL = as.factor(rownames(nY)) # find all the classes among the labels nL = length(nY) # number of unique classes if (nL<=1) stop("colAUC: List of labels 'y' have to contain at least 2 class labels.") if (!is.numeric(X)) stop("colAUC: 'X' must be numeric") if (nR!=length(y)) stop("colAUC: length(y) and nrow(X) must be the same") L = matrix(rep(uL,each=nR),nR,nL) # store vector L as row vector and copy it into nR rows per = combs(1:nL,2) # find all possible pairs of L columns nP = nrow(per) # how many possible pairs were found? Auc = matrix(0.5,nP,nC) # initialize array to store results rownames(Auc) = paste(uL[per[,1]]," vs. ",uL[per[,2]], sep="") colnames(Auc) = colnames(X) #======================================= # prepare the plot, if needed #======================================= if (plotROC) { # initialize the plot plot(c(0,1), c(0,1), type='n', xaxs="i", yaxs="i", xlab="probability of false alarm", sub="(1-Specificity)", ylab="probability of detection\n(Sensitivity)") title("ROC Curves") abline(h=0:10/10, v=0:10/10, col = "lightgray") # grid on if (nC*nP<20) { # if too many curves than skip the labels S = colnames(Auc) if (is.null(S)) S=paste('col',1:nC); if (nP>1) S = paste(rep(S,each=nP), "[", rownames(Auc), "]") legend("bottomright", S, col=1:(nC*nP), lty=1, lwd=1, pch=20, merge=TRUE, inset=0.01, bg="white") } nClr = 1 } #============================================= # Calculate AUC by using Wilcox test algorithm #============================================= if(alg=='Wilcoxon') { idxL = vector(mode="list", length=nL) for (i in 1:nL) idxL[[i]] = which(y==uL[i]) for (j in 1:nC) { # for each column representing a feature for (i in 1:nP) { # go through all permutations of columns in d c1 = per[i,1] # and identify 2 classes to be compared c2 = per[i,2] n1 = as.numeric(nY[c1]) n2 = as.numeric(nY[c2]) if (n1>0 & n2>0) { r = rank(c(X[idxL[[c1]],j], X[idxL[[c2]],j])) Auc[i,j] = (sum(r[1:n1]) - n1*(n1+1)/2) / (n1*n2) } } # end of 'for i' loop } # end of 'for j' loop } #============================================== # Calculate AUC by using integrating ROC curves #============================================== if(alg=='ROC') { # use 'ROC' algorithm for (j in 1:nC) { # for each column representing a feature x = sort(X[, j], index=TRUE) # sort all columns and store each one in x[[1]]. x[[2]] stores original positions nunq = which(diff(x$x)==0) # find non-unique A's in column j (if vector is [1 1] nunq=1 nTies = length(nunq) # number of non-unique values if (nTies0) Auc[i,j] = trapz(d[,c1], d[,c2])/n # Trapezoidal numerical integration if (plotROC) { # plot the results xx = if(n>0) d[,c1]/d[nD,c1] else c(0,1) yy = if(n>0) d[,c2]/d[nD,c2] else c(0,1) if (2*Auc[i,j]<1) { xx=1-xx; yy=1-yy; } # if auc<0.5 than mirror it to the other side of 0.5 lines(xx, yy, col=nClr, type='o', pch=20) nClr = nClr+1 # next color } } # end of 'for i' loop } } # end of 'for j' loop } Auc = pmax(Auc, 1-Auc) # if any auc<0.5 than mirror it to the other side of 0.5 return (Auc) } caTools/R/sample.split.R0000644000176000001440000000574712325152723014664 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# sample.split = function( Y, SplitRatio = 2/3, group = NULL ) { # Split data from vector Y into 2 bins in predefined ratio while preserving relative retios of # different labels in Y. # if (0<=SplitRatio<1) then "SplitRatio" fraction of points from Y will go to bin 1 # if (1<=SplitRatio) then "SplitRatio" number of points from Y will go to bin 1 # Returns logical vector of the same length as Y marking points to be added to bin 1 nSamp = length(Y) # number of sample labels nGroup = length(group) if (nGroup>0 && nGroup!=nSamp) stop("Error in sample.split: Vectors 'Y' and 'group' have to have the same length") BinOne = logical(nSamp) # boolean mask of samples in bin #1 set to false SplitRatio = abs(SplitRatio) # make sure split ratio is positive if (SplitRatio>=nSamp) stop("Error in sample.split: 'SplitRatio' parameter has to be i [0, 1] range or [1, length(Y)] range") U = unique(Y) # unique labels nU = length(U) # how many different labels? if (2*nU>nSamp | nU==1) { # single label or most are different n = if(SplitRatio>=1) SplitRatio else SplitRatio*nSamp # how many samples will be in the first bin? rnd = runif(nSamp) # get "nSamp" random numbers if (nGroup) split(rnd, group) <- lapply(split(rnd, group), mean) ord = order(rnd) # order them BinOne[ord[1:n]] = TRUE # and n idx samples will be remarked as true (bin 1) } else { # few different labels rat = if(SplitRatio>=1) SplitRatio/nSamp else SplitRatio for( iU in 1:nU) { # for each label... idx = which(Y==U[iU]) # find samples that have it n = round(length(idx)*rat) # how many samples will be in the first bin? rnd = runif(length(idx)) # get random numbers if (nGroup) { grp = group[idx] # get group labels of current subset of labels split(rnd, grp) <- lapply(split(rnd, grp), mean) } ord = order(rnd) # order them BinOne[idx[ord[1:n]]] = TRUE # and n idx samples will be remarked as true (bin 1) } } if (SplitRatio>=1) { # if user selected actual number not ratio n = sum(BinOne)-SplitRatio # how many extra points do we have in bin 1? if (n>0) BinOne[sample(which( BinOne), n)] = FALSE # move n points from bin 1 to 2 else if (n<0) BinOne[sample(which(!BinOne),-n)] = TRUE # move -n points from bin 2 to 1 } return( BinOne ) } caTools/R/ENVI.R0000644000176000001440000001276612325152723013011 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# write.ENVI = function(X, filename, interleave=c("bsq", "bil", "bip") ) { # write matrix or data cube to binary ENVI file if (is.vector(X)) { nCol = length(X) nRow <- nBand <- 1 } else { d = dim(X) nRow = d[1] nCol = d[2] nBand = prod(d)/(nRow*nCol) } dim(X) = c(nRow, nCol, nBand) # make it into 3D array in case it was not # check data type data.type = 0 if (is.double (X)) data.type = 5 # 64-bit double if (is.integer(X)) data.type = 3 # 32-bit int if (is.complex(X)) data.type = 9 # 2x64-bit complex if (data.type == 0) { # do not know what is it -> make it a double X = as.double(X) data.type = 5 } # change interleave and store tha data interleave = match.arg(interleave) if (interleave=="bil") X=aperm(X, c(2,3,1)) # R's [row,col,band] -> bil [col,band,row] else if (interleave=="bip") X=aperm(X, c(3,2,1)) # R's [row,col,band] -> bip [band,col,row] else if (interleave=="bsq") X=aperm(X, c(2,1,3)) # R's [row,col,band] -> bsq [col,row,band] writeBin(as.vector(X), filename) # write Envi file # write header file out = "ENVI\ndescription = { R-language data }\n" out = paste(out, "samples = ", nCol, "\n", sep="") out = paste(out, "lines = ", nRow, "\n", sep="") out = paste(out, "bands = ", nBand, "\n", sep="") out = paste(out, "data type = ",data.type,"\n", sep="") out = paste(out, "header offset = 0\n", sep="") out = paste(out, "interleave = ",interleave,"\n", sep="") # interleave is assumed to be bsq - in case of 1 band images all 3 formats are the same ieee = if(.Platform$endian=="big") 1 else 0 # does this machine uses ieee (UNIX) format? or is it intel format? out = paste(out, "byte order = ", ieee, "\n", sep="") cat(out, file=paste(filename, ".hdr", sep="")) invisible(NULL) } # ======================================================================================= read.ENVI = function(filename, headerfile=paste(filename, ".hdr", sep="")) { # read matrix or data cube from binary ENVI file # parse header file nCol <- nRow <- nBand <- data.type <- header.offset <- byte.order <- (-1) interleave = "bsq" if (!file.exists(headerfile)) stop("read.ENVI: Could not open input header file: ", headerfile) Lines = read.table(headerfile, sep="=", strip.white=TRUE, row.names = NULL, as.is=TRUE, fill=TRUE) Fields = c("samples", "lines", "bands", "data type", "header offset", "interleave", "byte order") for (i in 1:nrow(Lines)) { Lab = tolower(Lines[i,1]) Lab = gsub("[ ]+", " ", Lab) # Replace all multiple spaces with a single space j = match(Lab, Fields) Val = Lines[i,2] if (length(j) == 1) switch( j, nCol <- as.integer(Val), nRow <- as.integer(Val), nBand <- as.integer(Val), data.type <- as.integer(Val), header.offset <- as.integer(Val), interleave <- gsub(" ", "", Val), byte.order <- as.integer(Val) ) } if (nCol <= 0 | nRow <= 0 | nBand <= 0) stop("read.ENVI: Error in input header file ", headerfile, " data sizes missing or incorrect", nRow, nCol, nBand) if (! ( data.type %in% c(1,2,3,4,5,9,12) ) ) stop("read.ENVI: Error in input header file ", headerfile, " data type is missing, incorrect or unsupported ") # read the data binary file ieee = if(.Platform$endian=="big") 1 else 0 # does this machine uses ieee (UNIX) format? or is it intel format? endian = if(ieee==byte.order | byte.order<0) .Platform$endian else "swap" size = nRow*nCol*nBand if (!file.exists(filename)) stop("read.ENVI: Could not open input file: ", filename) f = file(filename, "rb") if (header.offset>0) readBin(f, raw(), n=header.offset) switch( data.type, X <- readBin(f, integer(), n=size, size=1, signed=FALSE), # data.type==1 -> 1-byte unsigned integer (char) X <- readBin(f, integer(), n=size, size=2, endian=endian), # data.type==2 -> 2-byte short X <- readBin(f, integer(), n=size, endian=endian), # data.type==3 -> 4-byte int X <- readBin(f, double() , n=size, size=4, endian=endian), # data.type==4 -> 4-byte float X <- readBin(f, double() , n=size, endian=endian), , , , # data.type==5 -> 8-byte double X <- readBin(f, complex(), n=size, endian=endian), , , # data.type==9 -> 2x8-byte complex X <- readBin(f, integer(), n=size, size=2, endian=endian, signed=FALSE) # data.type==12 -> 2-byte unsigned short integer ) close(f) Fields = c("bil", "bip", "bsq") j = match(interleave, Fields) if (length(j)==0) stop("read.ENVI: Error in input header file ", headerfile, " incorrect interleave type") switch(j, { dim(X)<-c(nCol,nBand,nRow); X<-aperm(X, c(3,1,2)); }, # bil [col,band,row] -> R's [row,col,band] { dim(X)<-c(nBand,nCol,nRow); X<-aperm(X, c(3,2,1)); }, # bip [band,col,row] -> R's [row,col,band] { dim(X)<-c(nCol,nRow,nBand); X<-aperm(X, c(2,1,3)); } # bsq [col,row,band] -> R's [row,col,band] ) if (nBand==1) dim(X)=c(nRow, nCol) return(X) } caTools/R/base64.R0000644000176000001440000001434712325152723013331 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# #=============================================================================== # The Base64 encoding is designed to encode arbitrary binary information for # transmission by electronic mail. It is defined by MIME (Multipurpose Internet # Mail Extensions) specification RFC 1341, RFC 1421, RFC 2045 and others. # Triplets of 8-bit octets are encoded as groups of four characters, each # representing 6 bits of the source 24 bits. Only a 65-character subset # ([A-Z,a-z,0-9,+,/,=]) present in all variants of ASCII and EBCDIC is used, # enabling 6 bits to be represented per printable character #=============================================================================== base64encode = function(x, size=NA, endian=.Platform$endian) { if ((typeof(x)!="character")&(typeof(x)!="raw")) x = writeBin(x, raw(), size=size, endian=endian) if ((typeof(x)=="character")&(typeof(x)!="raw")) {nlen<- nchar(x);x = writeBin(x, raw(), size=size, endian=endian);length(x)<- nlen} x = as.integer(x) ndByte = length(x) # number of decoded bytes nBlock = ceiling(ndByte / 3) # number of blocks/groups neByte = 4 * nBlock # number of encoded bytes # add padding if necessary, to make the length of x a multiple of 3 if (ndByte < 3*nBlock) x[(ndByte+1) : (3*nBlock)] = 0; dim(x) = c(3, nBlock) # reshape the data y = matrix(as.integer(0), 4, nBlock) # for the encoded data #------------------------------------------- # Split up every 3 bytes into 4 pieces # x = aaaaaabb bbbbcccc ccdddddd # to form # y = 00aaaaaa 00bbbbbb 00cccccc 00dddddd # than convert y to integers in 0-63 range # This section is based on Matlab code by Peter Acklam # http://home.online.no/~pjacklam/matlab/software/util/datautil/ #------------------------------------------- y[1,] = bitShiftR(x[1,], 2) # 6 highest bits of x(1,:) y[2,] = bitOr(bitShiftL(x[1,], 4), bitShiftR(x[2,], 4)) y[3,] = bitOr(bitShiftL(x[2,], 2), bitShiftR(x[3,], 6)) y[4,] = x[3,] y = bitAnd(y, 63) # trim numbers to lower 6-bits #---------------------------------- # Perform the following mapping # 0 - 25 -> A-Z # 26 - 51 -> a-z # 52 - 61 -> 0-9 # 62 -> + # 63 -> / #---------------------------------- alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" alpha = strsplit(alpha, NULL)[[1]] # convert string to array of characters z = alpha[y+1] # rearrange characters #------------------------- # Add padding if necessary. #------------------------- npbytes = 3 * nBlock - ndByte # number of padding bytes needed if (npbytes>0) z[(neByte-npbytes+1) : neByte] = '=' # '=' is used for padding z = paste(z, collapse = "") # combine characters into a string return (z) } #==================================================================== base64decode = function(z, what, size=NA, signed = TRUE, endian=.Platform$endian) { if (!is.character(z)) stop("base64decode: Input argument 'z' is suppose to be a string") if (length(z)==1) z = strsplit(z, NULL)[[1]] # convert string to array of characters if (length(z)%%4!=0) warning("In base64decode: Length of base64 data (z) not a multiple of 4.") #----------------------------------- # Now perform the following mapping # A-Z -> 0 - 25 # a-z -> 26 - 51 # 0-9 -> 52 - 61 # + -> 62 # / -> 63 # = -> 64 - special padding character # otherwise -1 #----------------------------------- alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" alpha = strsplit(alpha, NULL)[[1]] # convert string to array of characters y = match(z, alpha, nomatch=-1)-1 # lookup number of each character if (any(y == -1)) stop("base64decode: Input string is not in Base64 format") if (any(y == 64)) y = y[y != 64] # remove padding neByte = length(y); # number of encoded bytes nBlock = ceiling(neByte/4); # number of blocks/groups ndByte = 3 * nBlock # number of decoded bytes # add padding if necessary if (neByte < 4*nBlock) y[(neByte+1) : (4*nBlock)] = 0; dim(y) = c(4, nBlock); # shape into a matrix x = matrix(as.integer(0), 3, nBlock); # for the decoded data #--------------------------------------------- # Rearrange every 4 bytes into 3 bytes # y = 00aaaaaa 00bbbbbb 00cccccc 00dddddd # to form # x = aaaaaabb bbbbcccc ccdddddd # This section is based on Matlab code by Peter Acklam # http://home.online.no/~pjacklam/matlab/software/util/datautil/ #--------------------------------------------- x[1,] = bitOr(bitShiftL(y[1,], 2), bitShiftR(y[2,], 4)) x[2,] = bitOr(bitShiftL(y[2,], 4), bitShiftR(y[3,], 2)) x[3,] = bitOr(bitShiftL(y[3,], 6), y[4,]) x = bitAnd(x, 255) # trim numbers to lower 8-bits # remove padding if (neByte %% 4 == 2) x = x[1:(ndByte-2)] if (neByte %% 4 == 3) x = x[1:(ndByte-1)] # perform final conversion from 'raw' to type given by 'what' r = as.raw(x) TypeList = c("logical", "integer", "double", "complex", "character", "raw", "numeric", "int") if (!is.character(what) || length(what) != 1 || !(what %in% TypeList)) what <- typeof(what) if (what=="raw") return(r) if (is.na(size)) size = switch(match(what, TypeList), 4, 4, 8, 16, 2, 1, 8, 4) if (what=="character") {rlen<- size*ceiling(length(r)/size);length(r)<- rlen} n = length(r) if (n%%size) stop("raw2bin: number of elements in 'r' is not multiple of 'size'") x = readBin(r, what, n = n%/%size, size=size, signed=signed, endian=endian) if (what=="character") x = paste(x, collapse = "") # convert arrays of characters to strings return (x) } caTools/R/trapz.R0000644000176000001440000000113212325152723013371 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# trapz = function(x, y) { # computes the integral of y with respect to x using trapezoidal integration. idx = 2:length(x) return (as.double( (x[idx] - x[idx-1]) %*% (y[idx] + y[idx-1])) / 2) } caTools/R/combs.R0000644000176000001440000000233712325152723013344 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# combs = function(v,k) { # combs(V,K) - finds all unordered combinations of K elements from vector V # V is a vector of length N # K is a integer # combs(V,K) creates a matrix with N!/((N-K)! K!) rows # and K columns containing all possible combinations of N elements taken K at a time. # example: combs(1:3,2) returns matrix with following rows (1 2), (1 3), (2 3) n = length(v) if (n==k ) P = matrix(v,1,n) else if (k==1 ) P = matrix(v,n,1) else if (k==n-1) P = matrix( rep(v, each=n-1), n, n-1) else if (k< n) { P = matrix(0,0,k) if (k < n & k > 1) { for (i in 1:(n-k+1)) { Q = combs(v[(i+1):n],k-1) j = nrow(Q) P = rbind(P, cbind(rep(v[i],j), Q)) } } } else stop("combs: number m has to be smaller or equal to length of vector v") return(P) } caTools/R/LogitBoost.R0000644000176000001440000002443012325152723014324 0ustar ripleyusers#===========================================================================# # caTools - R library # # Copyright (C) 2005 Jarek Tuszynski # # Distributed under GNU General Public License version 3 # #===========================================================================# LogitBoost = function(xlearn, ylearn, nIter=ncol(xlearn)) # An implementation of the LogitBoost classification algorithm with # decision stumps as weak learners. # # Input: # xlearn - A dataset, whose n rows contain the training instances. # ylearn - Class labels of dataset # nIter - An integer, describing the number of iterations for # which boosting should be run. # # Output: # Stump - list of decision stumps used: # column 1: contains feature numbers or each stump # column 2: contains threshold # column 3: contains bigger/smaller info: 1 means (col>thresh ? class_1 : class_2); -1 means (col>thresh ? class_2 : class_1) # # Writen by Jarek Tuszynski - SAIC (jaroslaw.w.tuszynski@saic.com) # This code was addapted from logitboost.R function written by Marcel Dettling # See "Boosting for Tumor Classification of Gene Expression Data", Dettling and Buhlmann (2002), # available on the web page http://stat.ethz.ch/~dettling/boosting.html { lablist = sort(unique(ylearn)) # different classes in label array nClass = length(lablist) # number of different classes in label array if (nClass>2) { # Multi class version uses 2-class code ... Stump = NULL # ... recursivly for (jClass in 1:nClass) { y = as.numeric(ylearn!=lablist[jClass]) # lablist[jClass]->1; rest->0 Stump = cbind(Stump, LogitBoost(xlearn, y, nIter)$Stump) } object = list(Stump=Stump, lablist=lablist) # create LogitBoost object class(object) <- "LogitBoost" return(object) } Mask = is.na(xlearn) # any NA in test data will ... if (any(Mask)) xlearn[Mask] = Inf # ... be changed to +Inf ylearn = as.numeric(ylearn!=lablist[1]) # change class labels to boolean nLearn = nrow(xlearn) # Length of training data nFeat = ncol(xlearn) # number of features to choose from # Array Initialization f = 0 # range -1 or 1 p = numeric(nLearn)+1/2 # range [0,1] Stump = matrix(0, nIter,3) # will hold the results colnames(Stump) = c("feature", "threshhold", "sign") Thresh = matrix(0, nLearn, nFeat) # sorted xlearn each fearure at a time Index = matrix(as.integer(0), nLearn, nFeat) # order of samples in Thresh Mask = matrix(as.logical(0), nLearn, nFeat) # mask of unique samples in Thresh repts = as.logical(numeric(nFeat)) # for each feature: are all samples unique # sort all columns and store them in Thresh; Index stores original positions for (iFeat in 1:nFeat) { x = sort(xlearn[,iFeat], index=TRUE) Thresh[,iFeat] = x[[1]] Index [,iFeat] = x[[2]] Mask [,iFeat] = c((diff(Thresh[,iFeat])!=0), TRUE) repts [ iFeat] = !all(Mask[,iFeat]) } # Boosting Iterations jFeat = 0 for (m in 1:nIter) { # Computation of working response and weights w = pmax(p*(1-p), 1e-24) # weight for each sample z = (ylearn-p)/w w = w/sum(w) # normalize to 1 # older version similar to rpart (more readable but slower) left as documentation # MinLS = 1000 # initialize search for minimum Least-Square # for (iFeat in 1:nFeat) { # for each feature do: for each spliting point calculate least square regresion of z to xlearn with weights w. # Col = xlearn[,iFeat] # sort all columns and store each one in thr # thr = Thresh[,iFeat] # sort all columns and store each one in thr # for (j in 1:nLearn) { # for every possible threshold # ff = 2*(Col<=thr[j])-1 # for every point in the column if (col<=Thresh) then f=1 else f=-1 # LS1[j] = sum(w*(z-ff)^2) # Least Square array for every possible theshold ( f = (col<=Thresh ? 1 : -1) ) # LS2[j] = sum(w*(z+ff)^2) # Least Square array for every possible theshold after swaping output classes ( f = (colvLS1) { stump=c(iFeat, thr[iLS1], 1); MinLS=vLS1; } # if (MinLS>vLS2) { stump=c(iFeat, thr[iLS2], -1); MinLS=vLS2; } # } # Same as code above but faster: # for each feature do: for each spliting point calculate least square regresion of z to xlearn with weights w. # This part of the code is my version of rpart object. # LS1 is least square array LS1 = sum((w.*(z-f)).^2) where f = (col<=sp ? 1 : -1) LS1 is calculated for all spliting points # LS2 is least square array LS2 = sum((w.*(z-f)).^2) where f = (col<=sp ? -1 : 1) LS2 is calculated for all spliting points # for each spliting point col(idx) we will take one sample and change its sign, that will change current least square: # LS(i) = LS(i) - ( w(idx(i)) .* ( z(idx(i)) - (-1) ) ).^2 + ( w(idx(i)) .* ( z(idx(i)) - 1 ) ).^2 what can be simplified to: # LS(i) = LS(i) - 4*(w(idx(i)).^2) .* z(idx(i)) ls1 = sum(w*(z+1)^2) # Least Square value for left-most theshold ( f = -1 ) ls2 = sum(w*(z-1)^2) # Least Square value for left-most theshold after swaping output classes ( f = 1 ) MinLS = max(ls1,ls2) # initialize search for minimum Least-Square wz = 4 * w * z # precompute vector to be used later for (iFeat in 1:nFeat) { # for each feature do: for each spliting point calculate least square regresion of z to xlearn with weights w. if (iFeat==jFeat) next # Prevent the simplest cycle Col = Thresh[,iFeat] # get one column of sorted data LS = cumsum(wz[Index[,iFeat]]) # find offset to Least Square value for every possible theshold if (repts[iFeat]) { # if any repeating thresholds than delete all but last LS value mask = Mask[,iFeat] # use mask of unique samples Col = Col[mask] # delete non-unique thresholds since they can cause errors LS = LS [mask] # delete coressponding Least Square values } iLS1 = which.max(LS) # min of LS1=ls1-LS - Least Square value for every possible theshold ( f = (col<=Thresh ? 1 : -1) ) iLS2 = which.min(LS) # min of LS2=ls2+LS - Least Square value for every possible theshold after swaping output classes ( f = (colvLS1) { stump=c(iFeat, Col[iLS1], 1); MinLS=vLS1; } if (MinLS>vLS2) { stump=c(iFeat, Col[iLS2], -1); MinLS=vLS2; } } # ================= # Fitting the tree # ================= Stump[m,] = stump # if stump[3]>0 f(i) += (xlearn(i,stump[1])<=stump[2] ? 1 : -1) jFeat = stump[1] f = f + stump[3] * (2*( xlearn[,jFeat]<=stump[2] )-1) # if stump[3]<0 f(i) += (xlearn(i,stump[1])> stump[2] ? 1 : -1) p = 1/(1+exp(-f)) # Updating and probabilities - range (0, 1] y = (f>0) y[f==0] = 0.5 Conv = sum(abs(ylearn-y)) # keep track of error rate } object = list(Stump=Stump, lablist=lablist) # create LogitBoost object class(object) <- "LogitBoost" return(object) } predict.LogitBoost = function(object, xtest, type = c("class", "raw"), nIter=NA, ...) # An implementation of the LogitBoost classification algorithm with # decision stumps as weak learners. # # Input: # xtest - A dataset, whose n rows contain samples to be classified. # ytest - Class labels of dataset (if given than Conv will return error rates as function of iterations) # # input: # Stump - list of decision stumps used: # column 1: contains feature numbers or each stump # column 2: contains threshold # column 3: contains bigger/smaller info: 1 means (col>Thresh ? class_1 : class_2); -1 means (col>Thresh ? class_2 : class_1) # # Writen by Jarek Tuszynski - SAIC (jaroslaw.w.tuszynski@saic.com) # This code was addapted from logitboost.R function written by Marcel Dettling # See "Boosting for Tumor Classification of Gene Expression Data", Dettling and Buhlmann (2002), # available on the web page http://stat.ethz.ch/~dettling/boosting.html { type = match.arg(type) Stump = object$Stump lablist = object$lablist if (is.na(nIter)) nIter = nrow(Stump) else nIter = min(nIter, nrow(Stump)) nTest = nrow(xtest) nClass = ncol(Stump)/3 if (nClass==1) nClass=2 Prob = matrix(0,nTest, nClass) colnames(Prob) = lablist if (nClass>2) { # multi class problem object$lablist = c(1,2) # generic labels for(iClass in 1:nClass) { object$Stump = Stump[,3*iClass + (-2:0)] prob = predict.LogitBoost(object, xtest, type="raw", nIter=nIter) Prob[,iClass] = prob[,1] # probability that "sample belongs to iClass" is true } } else { # two class problem Mask = is.na(xtest) # any NA in test data will... be changed if (any(Mask)) xtest[Mask] = Inf # be changed to +Inf f = numeric(nTest) for (iter in 1:nIter) { iFeat = Stump[iter,1] thresh = Stump[iter,2] Sign = Stump[iter,3] f = f + Sign*(2*(xtest[,iFeat]<=thresh)-1) } Ytest = (f>0) Ytest[f==0] = 0.5 prob = 1/(1+exp(-f)) Prob[,1] = 1-prob # probability that "sample belongs to 1" Prob[,2] = prob # probability that "sample belongs to 2" } if (type=="raw") RET=Prob # request to return raw probabilities else { # otherwise assign labels ord = t(apply(-Prob, 1, order))# find order of sorted Probs RET = lablist[ord[,1]] # find label with highest Prob Prob = -t(apply(-Prob,1,sort)) # sort Probs RET[Prob[,1]==Prob[,2]] = NA # in case of ties return NA's } return (RET) } caTools/MD50000644000176000001440000000315412404057275012227 0ustar ripleyusers65b515a4a199efcdabe15885509654c2 *CHANGES 1ecb5acf61565fcaaf7dca1dceaf48c6 *DESCRIPTION 1059827c58c5e99ae6fb17253aa83f46 *NAMESPACE 25ab51c53deac92f3418ee4dbc4b53f9 *R/ENVI.R d7405289169b72bc40abb8cb30c1c544 *R/GIF.R b421780331c21cad3c597f0083aa35b5 *R/LogitBoost.R 270c5669456a380a7b1b747d5da88ee4 *R/base64.R 7295f946de3992f6af97d5b4c40ee777 *R/colAUC.R d50a683b98ecf388ba04286b2726e19c *R/combs.R 8ae2b3444938f1810c247a892d8e0b86 *R/runfunc.R b6ae0856ac8c13e72afef79d355fe27a *R/sample.split.R 6d80d29c1b5de79fa12fcfa5b60bc499 *R/sumexact.R daca10395e4d0b5f3552e0cd5a7c8ccd *R/trapz.R 5a5add1eb6b515c2a0d4d706c3a316e3 *man/ENVI.Rd 00ae1547dae05cafde61dc3cc77cc399 *man/GIF.Rd 7c4eb89b423d4f4b95bc10173d334254 *man/LogitBoost.Rd fa909fafbcac3de4a64e6a335e7ab152 *man/base64.Rd 3b88b66e21161b3930902ded9d1756ce *man/caTools-internal.Rd 911fd7a8e53ffac39f8009dafa869786 *man/caTools-package.Rd a26264a3475717dc7b4c78ff5ed2a656 *man/colAUC.Rd c38d433dce051860d1f82c0af2a2aeb6 *man/combs.Rd bcc9159d41ef60898ea71d53d82ae5c6 *man/predict.LogitBoost.Rd a869f7e2824fd7c91a1a14a296a0e89f *man/runmad.Rd 475a2f2c0e88aa0293509f7e02cf9bcd *man/runmean.Rd 92e126095f6119b3dd7985e029a3ba09 *man/runminmax.Rd 230b2f39ecf94184cf0c6c58937b30e9 *man/runquantile.Rd f6fbf3e4095dd169a8e8b693a5d5b877 *man/runsd.Rd 2839390531b48ef53cb20a5ccba15701 *man/sample.split.Rd 97987d93c865d8f4d2e437560a0e41da *man/sumexact.Rd ec975d24a2d995bbd14bc1444ac40b91 *man/trapz.Rd 5e425ab1545bc5693a721fc172d93770 *src/Gif2R.cpp dbf744035d4b5db78d69a2a669d6abeb *src/GifTools.cpp 58be7971430689ab43fb66678093362e *src/GifTools.h b81d2ad5847f9ff48f2559901e0b3886 *src/runfunc.c caTools/DESCRIPTION0000644000176000001440000000134612404057275013426 0ustar ripleyusersPackage: caTools Type: Package Title: Tools: moving window statistics, GIF, Base64, ROC AUC, etc. Version: 1.17.1 Date: 2014-04-21 Author: Jarek Tuszynski Maintainer: Harutyun Khachatryan Depends: R (>= 2.2.0) Imports: bitops Suggests: MASS, rpart Description: Contains several basic utility functions including: moving (rolling, running) window statistic functions, read/write for GIF and ENVI binary files, fast calculation of AUC, LogitBoost classifier, base64 encoder/decoder, round-off-error-free sum and cumsum, etc. License: GPL-3 Packaged: 2014-09-09 21:05:06 UTC; ripley NeedsCompilation: yes Repository: CRAN Date/Publication: 2014-09-10 16:22:53 caTools/man/0000755000176000001440000000000012325152723012463 5ustar ripleyuserscaTools/man/GIF.Rd0000644000176000001440000002764212325152723013372 0ustar ripleyusers\name{read.gif & write.gif} \alias{read.gif} \alias{write.gif} \title{Read and Write Images in GIF format} \description{Read and write files in GIF format. Files can contain single images or multiple frames. Multi-frame images are saved as animated GIF's. } \usage{ read.gif(filename, frame=0, flip=FALSE, verbose=FALSE) write.gif(image, filename, col="gray", scale=c("smart", "never", "always"), transparent=NULL, comment=NULL, delay=0, flip=FALSE, interlace=FALSE) } \arguments{ \item{filename}{Character string with name of the file. In case of \code{read.gif} URL's are also allowed.} \item{image}{Data to be saved as GIF file. Can be a 2D matrix or 3D array. Allowed formats in order of preference: \itemize{ \item array of integers in [0:255] range - this is format required by GIF file, and unless \code{scale='always'}, numbers will not be rescaled. Each pixel \code{i} will have associated color \code{col[image[i]+1]}. This is the only format that can be safely used with non-continuous color maps. \item array of doubles in [0:1] range - Unless \code{scale='never'} the array will be multiplied by 255 and rounded. \item array of numbers in any range - will be scaled or clipped depending on \code{scale} option. } } \item{frame}{Request specific frame from multiframe (i.e., animated) GIF file. By default all frames are read from the file (\code{frame=0}). Setting \code{frame=1} will ensure that output is always a 2D matrix containing the first frame. Some files have to be read frame by frame, for example: files with subimages of different sizes and files with both global and local color-maps (palettes).} \item{col}{Color palette definition. Several formats are allowed: \itemize{ \item array (list) of colors in the same format as output of palette functions. Preferred format for precise color control. \item palette function itself (ex. '\code{col=rainbow}'). Preferred format if not sure how many colors are needed. \item character string with name of internally defined palette. At the moment only "gray" and "jet" (Matlab's jet palette) are defined. \item character string with name of palette function (ex. '\code{col="rainbow"}') } Usually palette will consist of 256 colors, which is the maximum allowed by GIF format. By default, grayscale will be used.} \item{scale}{There are three approaches to rescaling the data to required [0, 255] integer range: \itemize{ \item "smart" - Data is fitted to [0:255] range, only if it falls outside of it. Also, if \code{image} is an array of doubles in range [0, 1] than data is multiplied by 255. \item "never" - Pixels with intensities outside of the allowed range are clipped to either 0 or 255. Warning is given. \item "always" - Data is always rescaled. If \code{image} is a array of doubles in range [0, 1] than data is multiplied by 255; otherwise it is scaled to fit to [0:255] range. } } \item{delay}{In case of 3D arrays the data will be stored as animated GIF, and \code{delay} controls speed of the animation. It is number of hundredths (1/100) of a second of delay between frames. } \item{comment}{Comments in text format are allowed in GIF files. Few file viewers can access them.} \item{flip}{By default data is stored in the same orientation as data displayed by \code{\link{print}} function: row 1 is on top, image x-axis corresponds to columns and y-axis corresponds to rows. However function \code{\link{image}} adopted different standard: column 1 is on the bottom, image x-axis corresponds to rows and y-axis corresponds to columns. Set \code{flip} to \code{TRUE} to get the orientation used by \code{\link{image}}. } \item{transparent}{Optional color number to be shown as transparent. Has to be an integer in [0:255] range. NA's in the \code{image} will be set to transparent.} \item{interlace}{GIF files allow image rows to be \code{interlace}d, or reordered in such a way as to allow viewer to display image using 4 passes, making image sharper with each pass. Irrelevant feature on fast computers.} \item{verbose}{Display details sections encountered while reading GIF file.} } \details{ Palettes often contain continuous colors, such that swapping palettes or rescaling of the image date does not affect image apperance in a drastic way. However, when working with non-continuous color-maps one should always provide image in [0:255] integer range (and set \code{scale="never"}), in order to prevent scaling. If \code{NA} or other infinite numbers are found in the \code{image} by \code{write.gif}, they will be converted to numbers given by \code{transparent}. If \code{transparent} color is not provided than it will be created, possibly after reshretching. There are some GIF files not fully supported by \code{read.gif} function: \itemize{ \item "Plain Text Extension" is not supported, and will be ignored. \item Multi-frame files with unique settings for each frame have to be read frame by frame. Possible settings include: frames with different sizes, frames using local color maps and frames using individual transparency colors. } } \value{ Function \code{write.gif} does not return anything. Function \code{read.gif} returns a list with following fields: \item{image}{matrix or 3D array of integers in [0:255] range.} \item{col}{color palette definitions with number of colors ranging from 1 to 256. In case when \code{frame=0} only the first (usually global) color-map (palette) is returned.} \item{comment}{Comments imbedded in GIF File} \item{transparent}{color number corresponding to transparent color. If none was stated than NULL, otherwise an integer in [0:255] range. In order for \code{\link[graphics]{image}} to display transparent colors correctly one should use \code{y$col[y$transparent+1] = NA}. } } \author{ Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}. Encoding Algorithm adapted from code by Christoph Hohmann, which was adapted from code by Michael Mayer. Parts of decoding algorithm adapted from code by David Koblas. } \seealso{ Displaying of images can be done through functions: \code{\link[graphics]{image}} (part of R), \code{\link[fields]{image.plot}} and \code{\link[fields]{add.image}} from \pkg{fields} or \code{\link[spatstat]{plot.im}} from \pkg{spatstat} package, and possibly many other functions. Displayed image can be saved in GIF, JPEG or PNG format using several different functions, like \code{\link[R2HTML]{HTMLplot}} from package \pkg{R2HTML}. Functions for directly reading and writing image files: \itemize{ \item \code{\link[pixmap]{read.pnm}} and \code{\link[pixmap]{write.pnm}} from \pkg{pixmap} package can process PBM, PGM and PPM images (file types supported by ImageMagic software) \item \code{\link{read.ENVI}} and \code{\link{write.ENVI}} from this package can process files in ENVI format. ENVI files can store 2D images and 3D data (multi-frame images), and are supported by most GIS (Geographic Information System) software including free "freelook". } There are many functions for creating and managing color palettes: \itemize{ \item \code{\link[fields]{tim.colors}} in package \pkg{fields} contains palette similar to Matlab's jet palette (see examples for simpler implementation) \item \code{\link[gplots]{rich.colors}} in package \pkg{gplots} contains two palettes of continuous colors. \item Functions \code{\link[RColorBrewer]{brewer.pal}} from \pkg{RColorBrewer} package and \code{\link[epitools]{colorbrewer.palette}} from \pkg{epitools} package contain tools for generating palettes \item \code{\link[grDevices]{rgb}} and \code{\link[grDevices]{hsv}} creates palette from RGB or HSV 3-vectors. \item \code{\link[grDevices]{col2rgb}} translates palette colors to RGB 3-vectors. } } \references{ Ziv, J., Lempel, A. (1977) \emph{An Universal Algorithm for Sequential Data Compression}, IEEE Transactions on Information Theory, May 1977. Copy of official file format description \url{http://www.danbbs.dk/\%7Edino/whirlgif/gif89.html} Nicely explained file format description \url{http://semmix.pl/color/exgraf/eeg11.htm} Christoph Hohmann code and documentation of encoding algorithm \url{http://members.aol.com/rf21exe/gif.htm} Michael A, Mayer code \url{http://www.danbbs.dk/\%7Edino/whirlgif/gifcode.html} Discussion of GIF file legal status can be found in \url{http://www.cloanto.com/users/mcb/19950127giflzw.html}. Interesting page on one way of doing animations in R (with help of outside calls) can be found at \url{http://pinard.progiciels-bpi.ca/plaisirs/animations/index.html}. } \examples{ # visual comparison between image and plot write.gif( volcano, "volcano.gif", col=terrain.colors, flip=TRUE, scale="always", comment="Maunga Whau Volcano") y = read.gif("volcano.gif", verbose=TRUE, flip=TRUE) image(y$image, col=y$col, main=y$comment, asp=1) # browseURL("file://volcano.gif") # inspect GIF file on your hard disk # test reading & writing col = heat.colors(256) # choose colormap trn = 222 # set transparent color com = "Hello World" # imbed comment in the file write.gif( volcano, "volcano.gif", col=col, transparent=trn, comment=com) y = read.gif("volcano.gif") stopifnot(volcano==y$image, col==y$col, trn==y$transparent, com==y$comment) # browseURL("file://volcano.gif") # inspect GIF file on your hard disk # create simple animated GIF (using image function in a loop is very rough, # but only way I know of displaying 'animation" in R) x <- y <- seq(-4*pi, 4*pi, len=200) r <- sqrt(outer(x^2, y^2, "+")) image = array(0, c(200, 200, 10)) for(i in 1:10) image[,,i] = cos(r-(2*pi*i/10))/(r^.25) write.gif(image, "wave.gif", col="rainbow") y = read.gif("wave.gif") for(i in 1:10) image(y$image[,,i], col=y$col, breaks=(0:256)-0.5, asp=1) # browseURL("file://wave.gif") # inspect GIF file on your hard disk # Another neat animation of Mandelbrot Set jet.colors = colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # define "jet" palette m = 400 C = complex( real=rep(seq(-1.8,0.6, length.out=m), each=m ), imag=rep(seq(-1.2,1.2, length.out=m), m ) ) C = matrix(C,m,m) Z = 0 X = array(0, c(m,m,20)) for (k in 1:20) { Z = Z^2+C X[,,k] = exp(-abs(Z)) } image(X[,,k], col=jet.colors(256)) write.gif(X, "Mandelbrot.gif", col=jet.colors, delay=100) # browseURL("file://Mandelbrot.gif") # inspect GIF file on your hard disk file.remove("wave.gif", "volcano.gif", "Mandelbrot.gif") # Display interesting images from the web \dontrun{ url = "http://www.ngdc.noaa.gov/seg/cdroms/ged_iib/datasets/b12/gifs/eccnv.gif" y = read.gif(url, verbose=TRUE, flip=TRUE) image(y$image, col=y$col, breaks=(0:length(y$col))-0.5, asp=1, main="January Potential Evapotranspiration mm/mo") url = "http://www.ngdc.noaa.gov/seg/cdroms/ged_iib/datasets/b01/gifs/fvvcode.gif" y = read.gif(url, flip=TRUE) y$col[y$transparent+1] = NA # mark transparent color in R way image(y$image, col=y$col[1:87], breaks=(0:87)-0.5, asp=1, main="Vegetation Types") url = "http://talc.geo.umn.edu/people/grads/hasba002/erosion_vids/run2/r2_dems_5fps(8color).gif" y = read.gif(url, verbose=TRUE, flip=TRUE) for(i in 2:dim(y$image)[3]) image(y$image[,,i], col=y$col, breaks=(0:length(y$col))-0.5, asp=1, main="Erosion in Drainage Basins") } } \keyword{file} \concept{GIF} \concept{image file} \concept{animation} caTools/man/runmad.Rd0000644000176000001440000002065212325152723014245 0ustar ripleyusers\name{runmad} \alias{runmad} \title{Median Absolute Deviation of Moving Windows} \description{ Moving (aka running, rolling) Window MAD (Median Absolute Deviation) calculated over a vector} \usage{ runmad(x, k, center = runmed(x,k), constant = 1.4826, endrule=c("mad", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) } \arguments{ \item{x}{numeric vector of length n or matrix with n rows. If \code{x} is a matrix than each column will be processed separately.} \item{k}{width of moving window; must be an integer between one and n. In case of even k's one will have to provide different \code{center} function, since \code{\link{runmed}} does not take even k's.} \item{endrule}{character string indicating how the values at the beginning and the end, of the data, should be treated. Only first and last \code{k2} values at both ends are affected, where \code{k2} is the half-bandwidth \code{k2 = k \%/\% 2}. \itemize{ \item \code{"mad"} - applies the mad function to smaller and smaller sections of the array. Equivalent to: \code{for(i in 1:k2) out[i]=mad(x[1:(i+k2)])}. \item \code{"trim"} - trim the ends; output array length is equal to \code{length(x)-2*k2 (out = out[(k2+1):(n-k2)])}. This option mimics output of \code{\link{apply}} \code{(\link{embed}(x,k),1,FUN)} and other related functions. \item \code{"keep"} - fill the ends with numbers from \code{x} vector \code{(out[1:k2] = x[1:k2])}. This option makes more sense in case of smoothing functions, kept here for consistency. \item \code{"constant"} - fill the ends with first and last calculated value in output array \code{(out[1:k2] = out[k2+1])} \item \code{"NA"} - fill the ends with NA's \code{(out[1:k2] = NA)} \item \code{"func"} - same as \code{"mad"} option except that implemented in R for testing purposes. Avoid since it can be very slow for large windows. } Similar to \code{endrule} in \code{\link{runmed}} function which has the following options: \dQuote{\code{c("median", "keep", "constant")}} . } \item{center}{moving window center. Defaults to running median (\code{\link{runmed}} function). Similar to \code{center} in \code{\link{mad}} function. For best acuracy at the edges use \code{\link{runquantile}(x,k,0.5,type=2)}, which is slower than default \code{\link{runmed}(x,k,endrule="med")}. If \code{x} is a 2D array (and \code{endrule="mad"}) or if \code{endrule="func"} than array edges are filled by repeated calls to \dQuote{\code{\link{mad}(x, center=\link{median}(x), na.rm=TRUE)}} function. Runmad's \code{center} parameter will be ignored for the beggining and the end of output \code{y}. Please use \code{center=\link{runquantile}(x,k,0.5,type=2)} for those cases. } \item{constant}{scale factor such that for Gaussian distribution X, \code{\link{mad}}(X) is the same as \code{\link{sd}}(X). Same as \code{constant} in \code{\link{mad}} function.} \item{align}{specifies whether result should be centered (default), left-aligned or right-aligned. If \code{endrule}="mad" then setting \code{align} to "left" or "right" will fall back on slower implementation equivalent to \code{endrule}="func". } } \details{ Apart from the end values, the result of y = runmad(x, k) is the same as \dQuote{\code{for(j=(1+k2):(n-k2)) y[j]=mad(x[(j-k2):(j+k2)], na.rm = TRUE)}}. It can handle non-finite numbers like NaN's and Inf's (like \dQuote{\code{\link{mad}(x, na.rm = TRUE)}}). The main incentive to write this set of functions was relative slowness of majority of moving window functions available in R and its packages. With the exception of \code{\link{runmed}}, a running window median function, all functions listed in "see also" section are slower than very inefficient \dQuote{\code{\link{apply}(\link{embed}(x,k),1,FUN)}} approach. Functions \code{runquantile} and \code{runmad} are using insertion sort to sort the moving window, but gain speed by remembering results of the previous sort. Since each time the window is moved, only one point changes, all but one points in the window are already sorted. Insertion sort can fix that in O(k) time. } \value{ Returns a numeric vector or matrix of the same size as \code{x}. Only in case of \code{endrule="trim"} the output vectors will be shorter and output matrices will have fewer rows. } \references{ About insertion sort used in \code{runmad} function see: R. Sedgewick (1988): \emph{Algorithms}. Addison-Wesley (page 99) } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ Links related to: \itemize{ \item \code{runmad} - \code{\link{mad}} \item Other moving window functions from this package: \code{\link{runmin}}, \code{\link{runmax}}, \code{\link{runquantile}}, \code{\link{runmean}} and \code{\link{runsd}} \item generic running window functions: \code{\link{apply}}\code{ (\link{embed}(x,k), 1, FUN)} (fastest), \code{\link[gtools]{running}} from \pkg{gtools} package (extremely slow for this purpose), \code{\link[magic]{subsums}} from \pkg{magic} library can perform running window operations on data with any dimensions. } } \examples{ # show runmed function k=25; n=200; x = rnorm(n,sd=30) + abs(seq(n)-n/4) col = c("black", "red", "green") m=runmed(x, k) y=runmad(x, k, center=m) plot(x, col=col[1], main = "Moving Window Analysis Functions") lines(m , col=col[2]) lines(m-y/2, col=col[3]) lines(m+y/2, col=col[3]) lab = c("data", "runmed", "runmed-runmad/2", "runmed+runmad/2") legend(0,0.9*n, lab, col=col, lty=1 ) # basic tests against apply/embed eps = .Machine$double.eps ^ 0.5 k=25 # odd size window a = runmad(x,k, center=runmed(x,k), endrule="trim") b = apply(embed(x,k), 1, mad) stopifnot(all(abs(a-b)5) # logical for (i in c(NA, 1, 2, 4)) { y = base64encode(x, size=i) z = base64decode(y, typeof(x), size=i) stopifnot(x==z) } print("Checked base64 for encode/decode logical type") x = as.integer(1:10) # integer for (i in c(NA, 1, 2, 4)) { y = base64encode(x, size=i) z = base64decode(y, typeof(x), size=i) stopifnot(x==z) } print("Checked base64 encode/decode for integer type") x = (1:10)*pi # double for (i in c(NA, 4, 8)) { y = base64encode(x, size=i) z = base64decode(y, typeof(x), size=i) stopifnot(mean(abs(x-z))<1e-5) } print("Checked base64 for encode/decode double type") x = log(as.complex(-(1:10)*pi)) # complex y = base64encode(x) z = base64decode(y, typeof(x)) stopifnot(x==z) print("Checked base64 for encode/decode complex type") x = "Chance favors the prepared mind" # character y = base64encode(x) z = base64decode(y, typeof(x)) stopifnot(x==z) print("Checked base64 for encode/decode character type") } \keyword{file} \concept{XML} caTools/man/trapz.Rd0000644000176000001440000000260512325152723014115 0ustar ripleyusers\name{trapz} \alias{trapz} \title{Trapezoid Rule Numerical Integration} \description{Computes the integral of Y with respect to X using trapezoid rule integration.} \usage{trapz(x, y)} \arguments{ \item{x}{ Sorted vector of x-axis values. } \item{y}{ Vector of y-axis values. } } \details{ The function has only two lines: \preformatted{ idx = 2:length(x) return (as.double( (x[idx] - x[idx-1]) \%*\% (y[idx] + y[idx-1])) / 2) } } \value{Integral of Y with respect to X or area under the Y curve.} \note{ Trapezoid rule is not the most accurate way of calculating integrals (it is exact for linear functions), for example Simpson's rule (exact for linear and quadratic functions) is more accurate. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \references{ D. Kincaid & W. Chaney (1991), \emph{Numerical Analysis}, p.445 } \seealso{ \itemize{ \item \code{\link{integrate}} \item Matlab's \code{trapz} function (\url{ http://www.mathworks.com/access/helpdesk/help/techdoc/ref/trapz.html}) } } \examples{ # integral of sine function in [0, pi] range suppose to be exactly 2. # lets calculate it using 10 samples: x = (1:10)*pi/10 trapz(x, sin(x)) # now lets calculate it using 1000 samples: x = (1:1000)*pi/1000 trapz(x, sin(x)) } \keyword{math} \concept{integration} caTools/man/sumexact.Rd0000644000176000001440000000544612325152723014614 0ustar ripleyusers\name{sumexact, cumsumexact} \alias{sumexact} \alias{cumsumexact} \title{Basic Sum Operations without Round-off Errors} \description{ Functions for performing basic sum operations without round-off errors } \usage{ sumexact(..., na.rm = FALSE) cumsumexact(x) } \arguments{ \item{x}{numeric vector} \item{...}{numeric vector(s), numbers or other objects to be summed} \item{na.rm}{logical. Should missing values be removed?} } \details{ All three functions use full precision summation using multiple doubles for intermediate values. The sum of numbers x & y is a=x+y with error term b=error(a+b). That way a+b is equal exactly x+y, so sum of 2 numbers is stored as 2 or fewer values, which when added would under-flow. By extension sum of n numbers is calculated with intermediate results stored as array of numbers that can not be added without introducing an error. Only final result is converted to a single number } \value{ Function \code{sumexact} returns single number. Function \code{cumsumexact} returns vector of the same length as \code{x}. } \references{ Round-off error correction is based on: Shewchuk, Jonathan, \emph{Adaptive Precision Floating-Point Arithmetic and Fast Robust Geometric Predicates}, \url{http://www-2.cs.cmu.edu/afs/cs/project/quake/public/papers/robust-arithmetic.ps} and its implementation found at: \url{http://aspn.activestate.com/ASPN/Cookbook/Python/Recipe/393090} McCullough, D.B., (1998) \emph{Assessing the Reliability of Statistical Software, Part I}, The American Statistician, Vol. 52 No 4, \url{http://www.amstat.org/publications/tas/mccull-1.pdf} McCullough, D.B., (1999) \emph{Assessing the Reliability of Statistical Software, Part II}, The American Statistician, Vol. 53 No 2 \url{http://www.amstat.org/publications/tas/mccull.pdf} NIST Statistical Reference Datasets (StRD) website \url{http://www.nist.gov/itl/div898/strd} } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com} based on code by Vadim Ogranovich, which is based on algorithms described in references, pointed out by Gabor Grothendieck. } \seealso{ \itemize{ \item \code{\link[base]{sum}} is faster but not error-save version of \code{sumexact} \item \code{\link[base]{cumsum}} is equivalent to \code{cumsumexact} } } \examples{ x = c(1, 1e20, 1e40, -1e40, -1e20, -1) a = sum(x); print(a) b = sumexact(x); print(b) stopifnot(b==0) a = cumsum(x); print(a) b = cumsumexact(x); print(b) stopifnot(b[6]==0) } \keyword{ts} \keyword{smooth} \keyword{array} \keyword{utilities} \concept{sum with no round-off errors} \concept{cumulative sum with no round-off errors} caTools/man/runsd.Rd0000644000176000001440000001502512325152723014110 0ustar ripleyusers\name{runsd} \alias{runsd} \title{Standard Deviation of Moving Windows} \description{ Moving (aka running, rolling) Window's Standard Deviation calculated over a vector} \usage{ runsd(x, k, center = runmean(x,k), endrule=c("sd", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) } \arguments{ \item{x}{numeric vector of length n or matrix with n rows. If \code{x} is a matrix than each column will be processed separately.} \item{k}{width of moving window; must be an integer between one and n. In case of even k's one will have to provide different \code{center} function, since \code{\link{runmed}} does not take even k's.} \item{endrule}{character string indicating how the values at the beginning and the end, of the data, should be treated. Only first and last \code{k2} values at both ends are affected, where \code{k2} is the half-bandwidth \code{k2 = k \%/\% 2}. \itemize{ \item \code{"sd"} - applies the \code{sd} function to smaller and smaller sections of the array. Equivalent to: \code{for(i in 1:k2) out[i]=mad(x[1:(i+k2)])}. \item \code{"trim"} - trim the ends; output array length is equal to \code{length(x)-2*k2 (out = out[(k2+1):(n-k2)])}. This option mimics output of \code{\link{apply}} \code{(\link{embed}(x,k),1,FUN)} and other related functions. \item \code{"keep"} - fill the ends with numbers from \code{x} vector \code{(out[1:k2] = x[1:k2])}. This option makes more sense in case of smoothing functions, kept here for consistency. \item \code{"constant"} - fill the ends with first and last calculated value in output array \code{(out[1:k2] = out[k2+1])} \item \code{"NA"} - fill the ends with NA's \code{(out[1:k2] = NA)} \item \code{"func"} - same as \code{"mad"} option except that implemented in R for testing purposes. Avoid since it can be very slow for large windows. } Similar to \code{endrule} in \code{\link{runmed}} function which has the following options: \dQuote{\code{c("median", "keep", "constant")}} . } \item{center}{moving window center. Defaults to running mean (\code{\link{runmean}} function). Similar to \code{center} in \code{\link{mad}} function. } \item{align}{specifies whether result should be centered (default), left-aligned or right-aligned. If \code{endrule}="sd" then setting \code{align} to "left" or "right" will fall back on slower implementation equivalent to \code{endrule}="func". } } \details{ Apart from the end values, the result of y = runmad(x, k) is the same as \dQuote{\code{for(j=(1+k2):(n-k2)) y[j]=sd(x[(j-k2):(j+k2)], na.rm = TRUE)}}. It can handle non-finite numbers like NaN's and Inf's (like \code{\link{mean}(x, na.rm = TRUE)}). The main incentive to write this set of functions was relative slowness of majority of moving window functions available in R and its packages. With the exception of \code{\link{runmed}}, a running window median function, all functions listed in "see also" section are slower than very inefficient \dQuote{\code{\link{apply}(\link{embed}(x,k),1,FUN)}} approach. } \value{ Returns a numeric vector or matrix of the same size as \code{x}. Only in case of \code{endrule="trim"} the output vectors will be shorter and output matrices will have fewer rows. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ Links related to: \itemize{ \item \code{runsd} - \code{\link{sd}} \item Other moving window functions from this package: \code{\link{runmin}}, \code{\link{runmax}}, \code{\link{runquantile}}, \code{\link{runmad}} and \code{\link{runmean}} \item generic running window functions: \code{\link{apply}}\code{ (\link{embed}(x,k), 1, FUN)} (fastest), \code{\link[gtools]{running}} from \pkg{gtools} package (extremely slow for this purpose), \code{\link[magic]{subsums}} from \pkg{magic} library can perform running window operations on data with any dimensions. } } \examples{ # show runmed function k=25; n=200; x = rnorm(n,sd=30) + abs(seq(n)-n/4) col = c("black", "red", "green") m=runmean(x, k) y=runsd(x, k, center=m) plot(x, col=col[1], main = "Moving Window Analysis Functions") lines(m , col=col[2]) lines(m-y/2, col=col[3]) lines(m+y/2, col=col[3]) lab = c("data", "runmean", "runmean-runsd/2", "runmean+runsd/2") legend(0,0.9*n, lab, col=col, lty=1 ) # basic tests against apply/embed eps = .Machine$double.eps ^ 0.5 k=25 # odd size window a = runsd(x,k, endrule="trim") b = apply(embed(x,k), 1, sd) stopifnot(all(abs(a-b)= 2.2.0), bitops\cr Suggests: \tab MASS, rpart\cr License: \tab GPL=3\cr } Index: \preformatted{ LogitBoost LogitBoost Classification Algorithm predict.LogitBoost Prediction Based on LogitBoost Algorithm base64encode Convert R vectors to/from the Base64 format colAUC Column-wise Area Under ROC Curve (AUC) combs All Combinations of k Elements from Vector v read.ENVI Read and Write Binary Data in ENVI Format read.gif Read and Write Images in GIF format runmean Mean of a Moving Window runmin Minimum and Maximum of Moving Windows runquantile Quantile of Moving Window runmad Median Absolute Deviation of Moving Windows runsd Standard Deviation of Moving Windows sample.split Split Data into Test and Train Set sumexact Basic Sum Operations without Round-off Errors trapz Trapezoid Rule Numerical Integration } } \author{Jarek Tuszynski } \keyword{ package } \examples{ # GIF image read & write write.gif( volcano, "volcano.gif", col=terrain.colors, flip=TRUE, scale="always", comment="Maunga Whau Volcano") y = read.gif("volcano.gif", verbose=TRUE, flip=TRUE) image(y$image, col=y$col, main=y$comment, asp=1) # test runmin, runmax and runmed k=25; n=200; x = rnorm(n,sd=30) + abs(seq(n)-n/4) col = c("black", "red", "green", "brown", "blue", "magenta", "cyan") plot(x, col=col[1], main = "Moving Window Analysis Functions (window size=25)") lines(runmin (x,k), col=col[2]) lines(runmed (x,k), col=col[3]) lines(runmean(x,k), col=col[4]) lines(runmax (x,k), col=col[5]) legend(0,.9*n, c("data", "runmin", "runmed", "runmean", "runmax"), col=col, lty=1 ) # sum vs. sumexact x = c(1, 1e20, 1e40, -1e40, -1e20, -1) a = sum(x); print(a) b = sumexact(x); print(b) } caTools/man/predict.LogitBoost.Rd0000644000176000001440000000354512325152723016477 0ustar ripleyusers\name{predict.LogitBoost} \alias{predict.LogitBoost} \title{Prediction Based on LogitBoost Classification Algorithm} \description{Prediction or Testing using logitboost classification algorithm} \usage{\method{predict}{LogitBoost}(object, xtest, type = c("class", "raw"), nIter=NA, \dots)} \arguments{ \item{object}{An object of class "LogitBoost" see "Value" section of \code{\link{LogitBoost}} for details} \item{xtest}{A matrix or data frame with test data. Rows contain samples and columns contain features} \item{type}{See "Value" section} \item{nIter}{An optional integer, used to lower number of iterations (decision stumps) used in the decision making. If not provided than the number will be the same as the one provided in \code{\link{LogitBoost}}. If provided than the results will be the same as running \code{\link{LogitBoost}} with fewer iterations. } \item{\dots}{not used but needed for compatibility with generic predict method} } \details{ Logitboost algorithm relies on a voting scheme to make classifications. Many (\code{nIter} of them) week classifiers are applied to each sample and their findings are used as votes to make the final classification. The class with the most votes "wins". However, with this scheme it is common for two cases have a tie (the same number of votes), especially if number of iterations is even. In that case NA is returned, instead of a label. } \value{ If type = "class" (default) label of the class with maximal probability is returned for each sample. If type = "raw", the a-posterior probabilities for each class are returned. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{\code{\link{LogitBoost}} has training half of LogitBoost code} \examples{# See LogitBoost example} \keyword{classif} caTools/man/LogitBoost.Rd0000644000176000001440000000722212325152723015042 0ustar ripleyusers\name{LogitBoost} \alias{LogitBoost} \title{LogitBoost Classification Algorithm} \description{Train logitboost classification algorithm using decision stumps (one node decision trees) as weak learners. } \usage{LogitBoost(xlearn, ylearn, nIter=ncol(xlearn))} \arguments{ \item{xlearn}{A matrix or data frame with training data. Rows contain samples and columns contain features} \item{ylearn}{Class labels for the training data samples. A response vector with one label for each row/component of \code{xlearn}. Can be either a factor, string or a numeric vector.} \item{nIter}{An integer, describing the number of iterations for which boosting should be run, or number of decision stumps that will be used.} } \details{ The function was adapted from logitboost.R function written by Marcel Dettling. See references and "See Also" section. The code was modified in order to make it much faster for very large data sets. The speed-up was achieved by implementing a internal version of decision stump classifier instead of using calls to \code{\link[rpart]{rpart}}. That way, some of the most time consuming operations were precomputed once, instead of performing them at each iteration. Another difference is that training and testing phases of the classification process were split into separate functions. } \value{ An object of class "LogitBoost" including components: \item{Stump}{List of decision stumps (one node decision trees) used: \itemize{ \item column 1: feature numbers or each stump, or which column each stump operates on \item column 2: threshold to be used for that column \item column 3: bigger/smaller info: 1 means that if values in the column are above threshold than corresponding samples will be labeled as \code{lablist[1]}. Value "-1" means the opposite. } If there are more than two classes, than several "Stumps" will be \code{cbind}'ed } \item{lablist}{names of each class} } \references{ Dettling and Buhlmann (2002), \emph{Boosting for Tumor Classification of Gene Expression Data}, available on the web page \url{http://stat.ethz.ch/~dettling/boosting.html}. \url{http://www.cs.princeton.edu/~schapire/boost.html} } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ \itemize{ \item \code{\link{predict.LogitBoost}} has prediction half of LogitBoost code \item \code{logitboost} function from \pkg{logitboost} library (not in CRAN or BioConductor but can be found at \url{http://stat.ethz.ch/~dettling/boosting.html}) is very similar but much slower on very large datasets. It also perform optional cross-validation. } } \examples{ data(iris) Data = iris[,-5] Label = iris[, 5] # basic interface model = LogitBoost(Data, Label, nIter=20) Lab = predict(model, Data) Prob = predict(model, Data, type="raw") t = cbind(Lab, Prob) t[1:10, ] # two alternative call syntax p=predict(model,Data) q=predict.LogitBoost(model,Data) pp=p[!is.na(p)]; qq=q[!is.na(q)] stopifnot(pp == qq) # accuracy increases with nIter (at least for train set) table(predict(model, Data, nIter= 2), Label) table(predict(model, Data, nIter=10), Label) table(predict(model, Data), Label) # example of spliting the data into train and test set mask = sample.split(Label) model = LogitBoost(Data[mask,], Label[mask], nIter=10) table(predict(model, Data[!mask,], nIter=2), Label[!mask]) table(predict(model, Data[!mask,]), Label[!mask]) } \keyword{classif} caTools/man/sample.split.Rd0000644000176000001440000000644612325152723015377 0ustar ripleyusers\name{sample.split} \alias{sample.split} \title{Split Data into Test and Train Set} \description{Split data from vector Y into two sets in predefined ratio while preserving relative ratios of different labels in Y. Used to split the data used during classification into train and test subsets. } \usage{ sample.split( Y, SplitRatio = 2/3, group = NULL ) } \arguments{ \item{Y}{Vector of data labels. If there are only a few labels (as is expected) than relative ratio of data in both subsets will be the same.} \item{SplitRatio}{ Splitting ratio: \itemize{ \item if \code{(0<=SplitRatio<1)} then \code{SplitRatio} fraction of points from Y will be set toTRUE \item if \code{(SplitRatio==1)} then one random point from Y will be set to TRUE \item if \code{(SplitRatio>1)} then \code{SplitRatio} number of points from Y will be set to TRUE } } \item{group}{Optional vector/list used when multiple copies of each sample are present. In such a case \code{group} contains unique sample labels, marking all copies of the same sample with the same label, and the function tries to place all copies in either train or test subset. If provided than has to have the same length as \code{Y}.} } \details{ Function \code{msc.sample.split} is the old name of the \code{sample.split} function. To be retired soon. } \value{Returns logical vector of the same length as Y with random \code{SplitRatio*length(Y)} elements set to TRUE. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ \itemize{ \item Similar to \code{\link{sample}} function. \item Variable \code{group} is used in the same way as \code{f} argument in \code{\link{split}} and \code{INDEX} argument in \code{\link{tapply}} } } \examples{ library(MASS) data(cats) # load cats data Y = cats[,1] # extract labels from the data msk = sample.split(Y, SplitRatio=3/4) table(Y,msk) t=sum( msk) # number of elements in one class f=sum(!msk) # number of elements in the other class stopifnot( round((t+f)*3/4) == t ) # test ratios # example of using group variable g = rep(seq(length(Y)/4), each=4); g[48]=12; msk = sample.split(Y, SplitRatio=1/2, group=g) table(Y,msk) # try to get correct split ratios ... split(msk,g) # ... while keeping samples with the same group label together # test results print(paste( "All Labels numbers: total=",t+f,", train=",t,", test=",f, ", ratio=", t/(t+f) ) ) U = unique(Y) # extract all unique labels for( i in 1:length(U)) { # check for all labels lab = (Y==U[i]) # mask elements that have label U[i] t=sum( msk[lab]) # number of elements with label U[i] in one class f=sum(!msk[lab]) # number of elements with label U[i] in the other class print(paste( "Label",U[i],"numbers: total=",t+f,", train=",t,", test=",f, ", ratio=", t/(t+f) ) ) } # use results train = cats[ msk,2:3] # use output of sample.split to ... test = cats[!msk,2:3] # create train and test subsets z = lda(train, Y[msk]) # perform classification table(predict(z, test)$class, Y[!msk]) # predicted & true labels # see also LogitBoost example } \keyword{classif} caTools/man/colAUC.Rd0000644000176000001440000002031012325152723014054 0ustar ripleyusers\name{colAUC} \alias{colAUC} \title{Column-wise Area Under ROC Curve (AUC)} \description{Calculate Area Under the ROC Curve (AUC) for every column of a matrix. Also, can be used to plot the ROC curves.} \usage{ colAUC(X, y, plotROC=FALSE, alg=c("Wilcoxon","ROC")) } \arguments{ \item{X}{A matrix or data frame. Rows contain samples and columns contain features/variables.} \item{y}{Class labels for the \code{X} data samples. A response vector with one label for each row/component of \code{X}. Can be either a factor, string or a numeric vector.} \item{plotROC}{Plot ROC curves. Use only for small number of features. If \code{TRUE}, will set \code{alg} to "ROC".} \item{alg}{Algorithm to use: "ROC" integrates ROC curves, while "Wilcoxon" uses Wilcoxon Rank Sum Test to get the same results. Default "Wilcoxon" is faster. This argument is mostly provided for verification.} } \details{ AUC is a very useful measure of similarity between two classes measuring area under "Receiver Operating Characteristic" or ROC curve. In case of data with no ties all sections of ROC curve are either horizontal or vertical, in case of data with ties diagonal sections can also occur. Area under the ROC curve is calculated using \code{\link{trapz}} function. AUC is always in between 0.5 (two classes are statistically identical) and 1.0 (there is a threshold value that can achieve a perfect separation between the classes). Area under ROC Curve (AUC) measure is very similar to Wilcoxon Rank Sum Test (see \code{\link{wilcox.test}}) and Mann-Whitney U Test. There are numerous other functions for calculating AUC in other packages. Unfortunately none of them had all the properties that were needed for classification preprocessing, to lower the dimensionality of the data (from tens of thousands to hundreds) before applying standard classification algorithms. The main properties of this code are: \itemize{ \item Ability to work with multi-dimensional data (\code{X} can have many columns). \item Ability to work with multi-class datasets (\code{y} can have more than 2 different values). \item Speed - this code was written to calculate AUC's of large number of features, fast. \item Returned AUC is always bigger than 0.5, which is equivalent of testing for each feature \code{colAUC(x,y)} and \code{colAUC(-x,y)} and returning the value of the bigger one. } If those properties do not fit your problem, see "See Also" and "Examples" sections for AUC functions in other packages that might be a better fit for your needs. } \value{ An output is a single matrix with the same number of columns as \code{X} and "n choose 2" ( \eqn{\frac{n!}{(n-2)! 2!} = n(n-1)/2}{n!/((n-2)! 2!) = n(n-1)/2} ) number of rows, where n is number of unique labels in \code{y} list. For example, if \code{y} contains only two unique class labels ( \code{length(unique(lab))==2} ) than output matrix will have a single row containing AUC of each column. If more than two unique labels are present than AUC is calculated for every possible pairing of classes ("n choose 2" of them). For multi-class AUC "Total AUC" as defined by Hand & Till (2001) can be calculated by \code{\link{colMeans}(auc)}. } \references{ \itemize{ \item Mason, S.J. and Graham, N.E. (1982) \emph{Areas beneath the relative operating characteristics (ROC) and relative operating levels (ROL) curves: Statistical significance and interpretation}, Q. J. R. Meteorol. Soc. textbf{30} 291-303. \item Fawcett, Tom (2004) \emph{ROC Graphs: Notes and Practical Considerations for Researchers}, \url{http://home.comcast.net/~tom.fawcett/public_html/papers/ROC101.pdf} and \url{http://home.comcast.net/~tom.fawcett/public_html/ROCCH/} \item Hand, David and Till, Robert (2001) \emph{A Simple Generalization of the Area Under the ROC Curve for Multiple Class Classification Problems}; Machine Learning 45(2): 171-186 \item See \url{http://www.medicine.mcgill.ca/epidemiology/hanley/software/} to find articles below: \itemize{ \item Hanley and McNeil (1982), \emph{The Meaning and Use of the Area under a Receiver Operating Characteristic (ROC) Curve}, Radiology 143: 29-36. \item Hanley and McNeil (1983), \emph{A Method of Comparing the Areas under ROC curves derived from same cases}, Radiology 148: 839-843. \item McNeil and Hanley (1984), \emph{Statistical Approaches to the Analysis of ROC curves}, Medical Decision Making 4(2): 136-149. } \item See \url{http://rocr.bioinf.mpi-sb.mpg.de/evaluation_literature.html} for bibliography of \pkg{ROCR} package. } } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ \itemize{ \item \code{\link{wilcox.test}} and \code{\link{pwilcox}} \item \code{\link[exactRankTests]{wilcox.exact}} from \pkg{exactRankTests} package \item \code{\link[coin]{wilcox_test}} from \pkg{coin} package \item \code{\link[ROCR]{performance}} from \pkg{ROCR} package \item \code{\link[Epi]{ROC}} from \pkg{Epi} package \item \code{\link[verification]{roc.area}} from \pkg{verification} package \item \code{\link[Hmisc]{rcorr.cens}} from \pkg{Hmisc} package } } \examples{ # Load MASS library with "cats" data set that have following columns: sex, body # weight, hart weight. Calculate how good weights are in predicting sex of cats. # 2 classes; 2 features; 144 samples library(MASS); data(cats); colAUC(cats[,2:3], cats[,1], plotROC=TRUE) # Load rpart library with "kyphosis" data set that records if kyphosis # deformation was present after corrective surgery. Calculate how good age, # number and position of vertebrae are in predicting successful operation. # 2 classes; 3 features; 81 samples library(rpart); data(kyphosis); colAUC(kyphosis[,2:4], kyphosis[,1], plotROC=TRUE) # Example of 3-class 4-feature 150-sample iris data data(iris) colAUC(iris[,-5], iris[,5], plotROC=TRUE) cat("Total AUC: \n"); colMeans(colAUC(iris[,-5], iris[,5])) # Test plots in case of data without column names Iris = as.matrix(iris[,-5]) dim(Iris) = c(600,1) dim(Iris) = c(150,4) colAUC(Iris, iris[,5], plotROC=TRUE) # Compare calAUC with other functions designed for similar purpose auc = matrix(NA,12,3) rownames(auc) = c("colAUC(alg='ROC')", "colAUC(alg='Wilcox')", "sum(rank)", "wilcox.test", "wilcox_test", "wilcox.exact", "roc.area", "AUC", "performance", "ROC", "auROC", "rcorr.cens") colnames(auc) = c("AUC(x)", "AUC(-x)", "AUC(x+noise)") X = cbind(cats[,2], -cats[,2], cats[,2]+rnorm(nrow(cats)) ) y = ifelse(cats[,1]=='F',0,1) for (i in 1:3) { x = X[,i] x1 = x[y==1]; n1 = length(x1); # prepare input data ... x2 = x[y==0]; n2 = length(x2); # ... into required format data = data.frame(x=x,y=factor(y)) auc[1,i] = colAUC(x, y, alg="ROC") auc[2,i] = colAUC(x, y, alg="Wilcox") r = rank(c(x1,x2)) auc[3,i] = (sum(r[1:n1]) - n1*(n1+1)/2) / (n1*n2) auc[4,i] = wilcox.test(x1, x2, exact=0)$statistic / (n1*n2) \dontrun{ if (require("coin")) auc[5,i] = statistic(wilcox_test(x~y, data=data)) / (n1*n2) if (require("exactRankTests")) auc[6,i] = wilcox.exact(x, y, exact=0)$statistic / (n1*n2) if (require("verification")) auc[7,i] = roc.area(y, x)$A.tilda if (require("ROC")) auc[8,i] = AUC(rocdemo.sca(y, x, dxrule.sca)) if (require("ROCR")) auc[9,i] = performance(prediction( x, y),"auc")@y.values[[1]] if (require("Epi")) auc[10,i] = ROC(x,y,grid=0)$AUC if (require("limma")) auc[11,i] = auROC(y, x) if (require("Hmisc")) auc[12,i] = rcorr.cens(x, y)[1] } } print(auc) stopifnot(auc[1, ]==auc[2, ]) # results of 2 alg's in colAUC must be the same stopifnot(auc[1,1]==auc[3,1]) # compare with wilcox.test results # time trials x = matrix(runif(100*1000),100,1000) y = (runif(100)>0.5) system.time(colAUC(x,y,alg="ROC" )) system.time(colAUC(x,y,alg="Wilcox")) } \keyword{univar} caTools/man/combs.Rd0000644000176000001440000000235212325152723014057 0ustar ripleyusers\name{combs} \alias{combs} \title{All Combinations of k Elements from Vector v} \description{Finds all unordered combinations of \code{k} elements from vector \code{v}.} \usage{combs(v,k)} \arguments{ \item{v}{Any numeric vector} \item{k}{Number of elements to choose from vector \code{v}. Integer smaller or equal than length of \code{v}. } } \value{ \code{combs(v,k)} (where \code{v} has length \code{n}) creates a matrix with \eqn{\frac{n!}{(n-k)! k!}}{n!/((n-k)! k!)} (\code{n} choose \code{k}) rows and \code{k} columns containing all possible combinations of \code{n} elements taken \code{k} at a time. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ I discovered recently that R packages already have two functions with similar capabilities: \code{\link[gtools]{combinations}} from \pkg{gTools} package and Also similar to Matlab's \code{nchoosek} function (\url{ http://www.mathworks.com/access/helpdesk/help/techdoc/ref/nchoosek.html}) } \examples{ combs(2:5, 3) # display examples combs(c("cats", "dogs", "mice"), 2) a = combs(1:4, 2) b = matrix( c(1,1,1,2,2,3,2,3,4,3,4,4), 6, 2) stopifnot(a==b) } \keyword{models} caTools/man/runminmax.Rd0000644000176000001440000002340112325152723014770 0ustar ripleyusers\name{runmin & runmax} \alias{runmin} \alias{runmax} \title{Minimum and Maximum of Moving Windows} \description{Moving (aka running, rolling) Window Minimum and Maximum calculated over a vector } \usage{ runmin(x, k, alg=c("C", "R"), endrule=c("min", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) runmax(x, k, alg=c("C", "R"), endrule=c("max", "NA", "trim", "keep", "constant", "func"), align = c("center", "left", "right")) } \arguments{ \item{x}{numeric vector of length n or matrix with n rows. If \code{x} is a matrix than each column will be processed separately.} \item{k}{width of moving window; must be an integer between one and n } \item{endrule}{character string indicating how the values at the beginning and the end, of the array, should be treated. Only first and last \code{k2} values at both ends are affected, where \code{k2} is the half-bandwidth \code{k2 = k \%/\% 2}. \itemize{ \item \code{"min"} & \code{"max"} - applies the underlying function to smaller and smaller sections of the array. In case of min equivalent to: \code{for(i in 1:k2) out[i]=min(x[1:(i+k2)])}. Default. \item \code{"trim"} - trim the ends; output array length is equal to \code{length(x)-2*k2 (out = out[(k2+1):(n-k2)])}. This option mimics output of \code{\link{apply}} \code{(\link{embed}(x,k),1,FUN)} and other related functions. \item \code{"keep"} - fill the ends with numbers from \code{x} vector \code{(out[1:k2] = x[1:k2])} \item \code{"constant"} - fill the ends with first and last calculated value in output array \code{(out[1:k2] = out[k2+1])} \item \code{"NA"} - fill the ends with NA's \code{(out[1:k2] = NA)} \item \code{"func"} - same as \code{"min"} & \code{"max"} but implimented in R. This option could be very slow, and is included mostly for testing } Similar to \code{endrule} in \code{\link{runmed}} function which has the following options: \dQuote{\code{c("median", "keep", "constant")}} . } \item{alg}{an option allowing to choose different algorithms or implementations. Default is to use of code written in C (option \code{alg="C"}). Option \code{alg="R"} will use slower code written in R. Useful for debugging and studying the algorithm.} \item{align}{specifies whether result should be centered (default), left-aligned or right-aligned. If \code{endrule}="min" or "max" then setting \code{align} to "left" or "right" will fall back on slower implementation equivalent to \code{endrule}="func". } } \details{ Apart from the end values, the result of y = runFUN(x, k) is the same as \dQuote{\code{for(j=(1+k2):(n-k2)) y[j]=FUN(x[(j-k2):(j+k2)], na.rm = TRUE)}}, where FUN stands for min or max functions. Both functions can handle non-finite numbers like NaN's and Inf's the same way as \code{\link{min}(x, na.rm = TRUE)}). The main incentive to write this set of functions was relative slowness of majority of moving window functions available in R and its packages. With the exception of \code{\link{runmed}}, a running window median function, all functions listed in "see also" section are slower than very inefficient \dQuote{\code{\link{apply}(\link{embed}(x,k),1,FUN)}} approach. Relative speeds \code{runmin} and \code{runmax} functions is O(n) in best and average case and O(n*k) in worst case. Both functions work with infinite numbers (\code{NA},\code{NaN},\code{Inf}, \code{-Inf}). Also default \code{endrule} is hardwired in C for speed. } \value{ Returns a numeric vector or matrix of the same size as \code{x}. Only in case of \code{endrule="trim"} the output vectors will be shorter and output matrices will have fewer rows. } \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ Links related to: \itemize{ \item Other moving window functions from this package: \code{\link{runmean}}, \code{\link{runquantile}}, \code{\link{runmad}} and \code{\link{runsd}} \item R functions: \code{\link{runmed}}, \code{\link{min}}, \code{\link{max}} \item Similar functions in other packages: \code{\link[zoo]{rollmax}} from \pkg{zoo} library \item generic running window functions: \code{\link{apply}}\code{ (\link{embed}(x,k), 1, FUN)} (fastest), \code{\link[gtools]{running}} from \pkg{gtools} package (extremely slow for this purpose), \code{\link[magic]{subsums}} from \pkg{magic} library can perform running window operations on data with any dimensions. } } \examples{ # show plot using runmin, runmax and runmed k=25; n=200; x = rnorm(n,sd=30) + abs(seq(n)-n/4) col = c("black", "red", "green", "blue", "magenta", "cyan") plot(x, col=col[1], main = "Moving Window Analysis Functions") lines(runmin(x,k), col=col[2]) lines(runmean(x,k), col=col[3]) lines(runmax(x,k), col=col[4]) legend(0,.9*n, c("data", "runmin", "runmean", "runmax"), col=col, lty=1 ) # basic tests against standard R approach a = runmin(x,k, endrule="trim") # test only the inner part b = apply(embed(x,k), 1, min) # Standard R running min stopifnot(all(a==b)); a = runmax(x,k, endrule="trim") # test only the inner part b = apply(embed(x,k), 1, max) # Standard R running min stopifnot(all(a==b)); # test against loop approach k=25; data(iris) x = iris[,1] n = length(x) x[seq(1,n,11)] = NaN; # add NANs k2 = k%/%2 k1 = k-k2-1 a1 = runmin(x, k) a2 = runmax(x, k) b1 = array(0,n) b2 = array(0,n) for(j in 1:n) { lo = max(1, j-k1) hi = min(n, j+k2) b1[j] = min(x[lo:hi], na.rm = TRUE) b2[j] = max(x[lo:hi], na.rm = TRUE) } # this test works fine at the R prompt but fails during package check - need to investigate \dontrun{ stopifnot(all(a1==b1, na.rm=TRUE)); stopifnot(all(a2==b2, na.rm=TRUE)); } # Test if moving windows forward and backward gives the same results # Two data sets also corespond to best and worst-case scenatio data-sets k=51; n=200; a = runmin(n:1, k) b = runmin(1:n, k) stopifnot(all(a[n:1]==b, na.rm=TRUE)); a = runmax(n:1, k) b = runmax(1:n, k) stopifnot(all(a[n:1]==b, na.rm=TRUE)); # test vector vs. matrix inputs, especially for the edge handling nRow=200; k=25; nCol=10 x = rnorm(nRow,sd=30) + abs(seq(nRow)-n/4) x[seq(1,nRow,10)] = NaN; # add NANs X = matrix(rep(x, nCol ), nRow, nCol) # replicate x in columns of X a = runmax(x, k) b = runmax(X, k) stopifnot(all(a==b[,1], na.rm=TRUE)); # vector vs. 2D array stopifnot(all(b[,1]==b[,nCol], na.rm=TRUE)); # compare rows within 2D array a = runmin(x, k) b = runmin(X, k) stopifnot(all(a==b[,1], na.rm=TRUE)); # vector vs. 2D array stopifnot(all(b[,1]==b[,nCol], na.rm=TRUE)); # compare rows within 2D array # Compare C and R algorithms to each other for extreme window sizes numeric.test = function (x, k) { a = runmin( x, k, alg="C") b = runmin( x, k, alg="R") c =-runmax(-x, k, alg="C") d =-runmax(-x, k, alg="R") stopifnot(all(a==b, na.rm=TRUE)); #stopifnot(all(c==d, na.rm=TRUE)); #stopifnot(all(a==c, na.rm=TRUE)); stopifnot(all(b==d, na.rm=TRUE)); } n=200; # n is an even number x = rnorm(n,sd=30) + abs(seq(n)-n/4) # random data for(i in 1:5) numeric.test(x, i) # test for small window size for(i in 1:5) numeric.test(x, n-i+1) # test for large window size n=201; # n is an odd number x = rnorm(n,sd=30) + abs(seq(n)-n/4) # random data for(i in 1:5) numeric.test(x, i) # test for small window size for(i in 1:5) numeric.test(x, n-i+1) # test for large window size n=200; # n is an even number x = rnorm(n,sd=30) + abs(seq(n)-n/4) # random data x[seq(1,200,10)] = NaN; # with some NaNs for(i in 1:5) numeric.test(x, i) # test for small window size for(i in 1:5) numeric.test(x, n-i+1) # test for large window size n=201; # n is an odd number x = rnorm(n,sd=30) + abs(seq(n)-n/4) # random data x[seq(1,200,2)] = NaN; # with some NaNs for(i in 1:5) numeric.test(x, i) # test for small window size for(i in 1:5) numeric.test(x, n-i+1) # test for large window size # speed comparison \dontrun{ n = 1e7; k=991; x1 = runif(n); # random data - average case scenario x2 = 1:n; # best-case scenario data for runmax x3 = n:1; # worst-case scenario data for runmax system.time( runmax( x1,k,alg="C")) # C alg on average data O(n) system.time( runmax( x2,k,alg="C")) # C alg on best-case data O(n) system.time( runmax( x3,k,alg="C")) # C alg on worst-case data O(n*k) system.time(-runmin(-x1,k,alg="C")) # use runmin to do runmax work system.time( runmax( x1,k,alg="R")) # R version of the function x=runif(1e5); k=1e2; # reduce vector and window sizes system.time(runmax(x,k,alg="R")) # R version of the function system.time(apply(embed(x,k), 1, max)) # standard R approach } } \keyword{ts} \keyword{smooth} \keyword{array} \keyword{utilities} \concept{moving min} \concept{rolling min} \concept{running min} \concept{moving max} \concept{rolling max} \concept{running max} \concept{moving minimum} \concept{rolling minimum} \concept{running minimum} \concept{moving maximum} \concept{rolling maximum} \concept{running maximum} \concept{running window} \concept{moving window} \concept{rolling window} caTools/man/ENVI.Rd0000644000176000001440000001074212325152723013517 0ustar ripleyusers\name{read.ENVI & write.ENVI} \alias{read.ENVI} \alias{write.ENVI} \title{Read and Write Binary Data in ENVI Format} \description{Read and write binary data in ENVI format, which is supported by most GIS software.} \usage{ read.ENVI(filename, headerfile=paste(filename, ".hdr", sep="")) write.ENVI (X, filename, interleave = c("bsq", "bil", "bip")) } \arguments{ \item{X}{data to be saved in ENVI file. Can be a matrix or 3D array.} \item{filename}{character string with name of the file (connection)} \item{headerfile}{optional character string with name of the header file} \item{interleave}{optional character string specifying interleave to be used} } \details{ ENVI binary files use a generalized raster data format that consists of two parts: \itemize{ \item binary file - flat binary file equivalent to memory dump, as produced by \code{\link{writeBin}} in R or \code{fwrite} in C/C++. \item header file - small text (ASCII) file containing the metadata associated with the binary file. This file can contain the following fields, followed by equal sign and a variable: \itemize{ \item \code{samples} - number of columns \cr \item \code{lines} - number of rows \cr \item \code{bands} - number of bands (channels, planes) \cr \item \code{data type} - following types are supported: \itemize{ \item 1 - 1-byte unsigned integer \item 2 - 2-byte signed integer \item 3 - 4-byte signed integer \item 4 - 4-byte float \item 5 - 8-byte double \item 9 - 2x8-byte complex number made up from 2 doubles \item 12 - 2-byte unsigned integer } \item \code{header offset} - number of bytes to skip before raster data starts in binary file. \item \code{interleave} - Permutations of dimensions in binary data: \itemize{ \item \code{BSQ} - Band Sequential (X[col,row,band]) \item \code{BIL} - Band Interleave by Line (X[col,band,row]) \item \code{BIP} - Band Interleave by Pixel (X[band,col,row]) } \item \code{byte order} - the endian-ness of the saved data: \itemize{ \item 0 - means little-endian byte order, format used on PC/Intel machines \item 1 - means big-endian (aka IEEE, aka "network") byte order, format used on UNIX and Macintosh machines } } } Fields \code{samples}, \code{lines}, \code{bands}, \code{data type} are required, while \code{header offset}, \code{interleave}, \code{byte order} are optional. All of them are in form of integers except \code{interleave} which is a string. This generic format allows reading of many raw file formats, including those with embedded header information. Also it is a handy binary format to exchange data between PC and UNIX/Mac machines, as well as different languages like: C, Fortran, Matlab, etc. Especially since header files are simple enough to edit by hand. File type supported by most of GIS (geographic information system) software including: ENVI software, Freelook (free file viewer by ENVI), ArcGIS, etc. } \value{ Function \code{read.ENVI} returns either a matrix or 3D array. Function \code{write.ENVI} does not return anything.} \author{Jarek Tuszynski (SAIC) \email{jaroslaw.w.tuszynski@saic.com}} \seealso{ Displaying of images can be done through functions: \code{\link[graphics]{image}}, \code{\link[fields]{image.plot}} and \code{\link[fields]{add.image}} from \pkg{fields} or \code{\link[spatstat]{plot.im}} from \pkg{spatstat}. ENVI files are practically C-style memory-dumps as performed by \code{\link{readBin}} and \code{\link{writeBin}} functions plus separate meta-data header file. GIF file formats can also store 3D data (see \code{\link{read.gif}} and \code{\link{write.gif}} functions). Packages related to GIS data: \pkg{shapefiles}, \pkg{maptools}, \pkg{sp}, \pkg{spdep}, \pkg{adehabitat}, \pkg{GRASS}, \pkg{PBSmapping}. } \examples{ X = array(1:60, 3:5) write.ENVI(X, "temp.nvi") Y = read.ENVI("temp.nvi") stopifnot(X == Y) readLines("temp.nvi.hdr") d = c(20,30,40) X = array(runif(prod(d)), d) write.ENVI(X, "temp.nvi", interleave="bil") Y = read.ENVI("temp.nvi") stopifnot(X == Y) readLines("temp.nvi.hdr") file.remove("temp.nvi") file.remove("temp.nvi.hdr") } \keyword{file} \concept{GIS data I/O} caTools/CHANGES0000644000176000001440000001167412325152723012714 0ustar ripleyusersChanges: 1) caMassClass-1.0 to caTools-1.0 - caTools created after splitting caMassClass package: - bin2raw and raw2bin files: endian variable was added - raw2bin: additional error checking - runmean, runmax, runmin, runquantile, runmad: additional error checking and corrected error checking - EndRule: added error checking - runmean, runmax, runmin: additional parameter "alg" was added - runmean - new C code can survive round-off errors 2) caTools-1.1 (7/15/2005) - read.GIF and write.GIF files were added. - bin2raw and raw2bin files: much faster raw to numeric conversion - sum.exact, cumsum.exact and runsum.exact functions were added for under-flow safe addition. 3) caTools-1.2 (8/8/2005) - minor changes to .Rd files to fix problems found by new 'checkDocFiles' function. 4) caTools-1.3 (9/23/2005) - changes to colAUC function. Parameters: plotROC and alg were added. Parameter 'p.val' was removed, since it gave wrong results in case of data with ties. And it was too complicated to fix. - added much better testing of "colAUC" in Example section. 4) caTools-1.4 (9/28/2005) - a small change in 1.3 that used call to 'max' instead of 'pmax' made 'colAUC' return wrong numbers in case of multi-feature data. 5) caTools-1.5 (11/10/2005) - several new examples - functions raw2bin and bin2raw still work but return warnings. They will be retired in the next version, since they parallel new capabilities of readBin and writeBin. - Argument 'col' of function 'write.gif' was changed to allow several other ways to define a color palette. - base64encode and base64decode now use readBin and writeBin instead raw2bin and bin2raw. 6) caTools-1.6 (04/11/2006) - functions raw2bin and bin2raw were retired, since they parallel new (as of R-2.2.0) capabilities of readBin and writeBin. - Bug in plotting in colAUC function was fixed, after it was reported by Tom Wright. - Documentation of colAUC was updated and some examples modified in order to reduce dependency on external libraries. - GifTools.cc was split into GifTools.cpp and GifTools.cc. The first file contains GIF encoding/decoding algorithm and second is a shell that comunicates with R. 7) caTools-1.7 (Jan 31 2007) - Added 4th variable in 'rgb' function (line 174). 8) caTools-1.8 (Oct. 9 2007) - Major changes to moving window statistics functions: * use fast C code to process array edges * added suport for NaN's * added suport for even size windows * split help file into 5 new help files * added much more examples and self-tests - Followed Prof. Brian Ripley request to move R header files out of extern "C" blocks in C++ files. - Changed licence to GPL 9) caTools-1.9 (July 7 2008) - No code changes - Corrected inconsistent licence information 10) caTools-1.10 (Oct 08 2009) - Fixed runmax to handle correctly negative numbers - Added align argument to moving window statistics functions: runmean, runmax, runmin, runsd, runmad and runquintile functions. It allows left and right alligned window in addition to centered window. - Added support for 2D arrays to be passed to moving window statistics functions: runmean, runmax, runmin, runsd, runmad and runquintile functions. If input array is a 2D matrix than the operations are performed for each column separately. This change was mostly handled by EndRule function. Speed for 2D array input is expected to be slower than for vectors since calculations for beggining and end of arrays if handled in R instead of C. is expected to be - Changed "if(!require(LIB)) warning(..." to ""library(LIB)" to get rid or warnings by RCMD CHECK 11) caTools-1.11 (Dec 2010) - Changed EndRule function used by all run... functions to fix handling of different endrules when for non-central aligments and for k=2. - Fully retired runsum.exact, which was not working for a while, use runmean with "exact" option instead. - Removed references to several no-longer-existing packages and functions from Rd files. - changed documentation of predict.LogitBoost to follow S3 mathod syntax. - renamed sum.exact and cumsum.exact to sumexact and cumsumexact to avoid package build errors. those functions were confused with S3 mathods. 12) caTools-1.12 (April 2011) - small correction to GifTools.cpp sent by Murray Stokely to allow compilation with clang rather than gcc compiler. - corrections to runmean documentation sent by Jon Wade - fixed bug in LogitBoost.R which was causing crashes when all values of a column were identical - added comments to runfunc.c 13) caTools-1.13 (May 2012) - removed Rd cross-references that are no longer available on CRAN - updated caTools-package.rD with correct licensing information - updated DESCRIPTION file to reflect new maintainer