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