1#===========================================================================# 2# caTools - R library # 3# Copyright (C) 2005 Jarek Tuszynski # 4# Distributed under GNU General Public License version 3 # 5#===========================================================================# 6 7write.gif = function(image, filename, col="gray", 8 scale=c("smart", "never", "always"), transparent=NULL, 9 comment=NULL, delay=0, flip=FALSE, interlace=FALSE) 10{ 11 if (!is.character(filename)) stop("write.gif: 'filename' has to be a string") 12 if (length(filename)>1) filename = paste(filename, collapse = "") # combine characters into a string 13 14 #====================================== 15 # cast 'image' into a proper dimentions 16 #====================================== 17 dm = dim(image) 18 if (is.null(dm)) stop("write.gif: input 'x' has to be an matrix or 3D array") 19 if (length(dm)<=2) { # this is a 2D matrix or smaller 20 image = as.matrix(image) # cast to 2D matrix 21 if (flip) x = image[,dm[2]:1] 22 else x = t(image) 23 } else { # 3D data cube or bigger 24 dim(image) = c(dm[1], dm[2], prod(dm)/(dm[1]*dm[2])) # cast to 3D 25 if (flip) x = image[,dm[2]:1,] 26 else x = aperm(image, c(2,1,3)) 27 } 28 image = 0 # release memory 29 dm = dim(x) # save dimentions and ... 30 x = as.vector(x) # convert to 1D vector 31 32 #================================= 33 # scale x into a proper range 34 #================================= 35 scale = match.arg(scale) 36 if (!is.null(transparent)) 37 if ((transparent<0) || (transparent>255)) 38 stop("write.gif:'transparent' has to be an integer between 0 and 255") 39 mask = !is.finite(x) 40 xx = 0 41 mColor = 255 42 if (any(mask)) { # some non-finite numbers were found 43 if (is.null(transparent)) mColor = 254 44 xx = x # save original x 45 x = x[!mask] # remove non-finite numbers 46 } 47 minx = min(x) 48 maxx = max(x) 49 d = mColor/(maxx-minx) 50 if (scale=="never") { 51 if ((minx<0) || (maxx>mColor)) 52 warning("write.gif: 'x' is not in proper range and 'scale' is set to 'never',", 53 " clipping 'x' to proper range ") 54 if (minx<0 ) x[x<0 ] = 0 55 if (maxx>mColor) x[x>mColor] = mColor 56 } else 57 if (scale=="always") { 58 if ((minx>=0) && (maxx<=1)) 59 x = mColor*x # doubles between [0 and 1] -> scale them 60 else 61 x = (x-minx)*d # numbers outside allowed range -> scale them 62 } else 63 if (scale=="smart") { 64 if ((minx<0) || (maxx>mColor)) { 65 x = (x-minx)*d # numbers outside allowed range -> scale them 66 } else if ((minx>=0) && (maxx<=1)) { 67 if (any(x!=as.integer(x))) x = mColor*x # doubles between [0 and 1] -> scale them 68 } 69 } 70 maxx = max(x) 71 72 if (length(xx)>1) { # some non-finite numbers were found 73 if (is.null(transparent)) transparent = maxx+1 74 xx[ mask] = transparent 75 xx[!mask] = x 76 x = xx 77 } 78 if (is.null(transparent)) transparent = -1 79 x = as.integer(round(x)) 80 81 #================================= 82 # format color palette 83 #================================= 84 n = maxx+1 85 if (is.character(col) && length(col)==1) { 86 if (col %in% c("grey", "gray")) col = gray(0:n/n) 87 if (col=="jet") 88 col = colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", 89 "yellow", "#FF7F00", "red", "#7F0000")) # define "jet" palette 90 } 91 if (length(col)==1) { # if not a vector than maybe it is a palette function 92 FUN = match.fun(col) # make sure it is a function not a string with function name 93 col = FUN(n) 94 } 95 crgb = col2rgb(col) 96 Palette = as.integer(c(256^(2:0) %*% crgb)) # convert to internal int format 97 nColor = length(Palette) 98 if (nColor<maxx) 99 stop("write.gif: not enough colors in color palette 'col'. Has ",nColor, 100 " need at least ", maxx) 101 if (nColor<256) Palette = c(Palette, rep(0,256-nColor)) # pad it 102 103 # format and cast other input variables into proper format 104 param = as.integer(c( dm[2], dm[1], prod(dm)/(dm[1]*dm[2]), nColor, transparent, delay, interlace, 0 )) 105 if (is.null(comment)) comment = as.character("") 106 else comment = as.character(comment) 107 # call C++ function 108 .C("imwritegif", filename, x, Palette, param, comment, 109 NAOK=FALSE, PACKAGE="caTools") 110 if (param[7]<0) stop("write.gif: cannot open the output file (connection)") 111 invisible(NULL) 112} 113 114#============================================================================== 115 116read.gif = function(filename, frame=0, flip=FALSE, verbose=FALSE) 117{ 118 if (!is.character(filename)) stop("write.gif: 'filename' has to be a string") 119 if (length(filename)>1) filename = paste(filename, collapse = "") # combine characters into a string 120 isURL = length(grep("^http://", filename)) | 121 length(grep("^ftp://", filename)) | 122 length(grep("^file://", filename)) 123 if(isURL) { 124 tf <- tempfile() 125 download.file(filename, tf, mode='wb', quiet=TRUE) 126 filename = tf 127 } 128 129 x = .Call("imreadgif", filename, as.integer(frame), as.integer(verbose), 130 PACKAGE="caTools") 131 comt = as.character(attr(x, 'comm')) 132 if (isURL) file.remove(filename) 133 134 nRow = x[1] 135 nCol = x[2] 136 nBand = x[3] 137 tran = x[4] 138 success = x[5] 139 nPixel = nRow*nCol*nBand 140 stats = -success 141 if (stats>=6) { 142 warning("write.gif: file '", filename, 143 "' contains multiple color-maps. Use 'frame' > 0.") 144 stats = stats-6 145 } 146 if (nPixel==0) { 147 switch (stats, 148 stop("write.gif: cannot open the input file: ", filename, call.=FALSE), 149 stop("write.gif: input file '", filename, "' is not a GIF file", call.=FALSE), 150 stop("write.gif: unexpected end of file: ", filename, call.=FALSE), 151 stop("write.gif: syntax error in file: ", filename, call.=FALSE) ) 152 } else { 153 switch (stats, , , 154 warning("write.gif: unexpected end of file: ", filename, call.=FALSE), 155 warning("write.gif: syntax error in file: ", filename, call.=FALSE), 156 warning("write.gif: file '", filename, 157 "' contains multiple images (frames) of uneven length. Use 'frame' > 0." , call.=FALSE)) 158 } 159 Palette = x[ 10:265 ] 160 x = x[-(1:265)] # delete non image data 161 if (nBand>1) { # 3D data cubes 162 dim(x) = c(nCol, nRow, nBand) 163 if (flip) x = x[,ncol(x):1,] 164 else x = aperm(x, c(2,1,3)) 165 } else { # this is a matrix 166 dim(x) = c(nCol, nRow) 167 if (flip) x = x[,ncol(x):1] 168 else x = t(x) 169 } 170 Palette = Palette[Palette>=0] 171 red = bitAnd(bitShiftR(Palette,16), 255) 172 green = bitAnd(bitShiftR(Palette, 8), 255) 173 blue = bitAnd( Palette , 255) 174 Palette = rgb (red, green, blue, 255, maxColorValue = 255) 175 if (tran==-1) tran = NULL 176 return (list(image=x, col=Palette, transparent=tran, comment=comt)) 177} 178 179# source("c:/programs/R/rw2011/src/library/caTools/R/GIF.R") 180