1# Authors: Robert J. Hijmans
2# Date :  January 2009
3# Version 0.9
4# Licence GPL v3
5
6.addArgs <- function(...) {
7	lst <- list(...)
8	if (length(lst) > 0 ) {
9		i <- sapply(lst, function(x) class(x) %in% c('logical', 'integer', 'numeric'))
10		add <- unlist(lst[i], use.names = FALSE)
11	} else {
12		add <- NULL
13	}
14	return(add)
15}
16
17
18
19setMethod("Summary", signature(x='Raster'),
20	function(x, ..., na.rm=FALSE){
21
22		fun <- as.character(sys.call()[[1L]])
23
24		dots <- list(...)
25		if (length(dots) > 0) {
26			d <- sapply(dots, function(i) inherits(i, 'Raster'))
27			if (any(d)) {
28				x <- .makeRasterList(x, dots[d])
29				if (length(x) > 1) {
30					x <- stack(x)
31				} else {
32					x <- x[[1]]
33				}
34			}
35			add <- .addArgs(unlist(dots[!d]))
36		} else {
37			add <- NULL
38		}
39
40		if (nlayers(x)==1 & length(add)==0) {
41			warning('Nothing to summarize if you provide a single RasterLayer; see cellStats')
42			return(x)
43		}
44
45		if (fun[1] == 'sum') {
46			return(.sum( x, add, na.rm=na.rm))
47		} else if (fun[1] == 'min') {
48			return(.min( x, add, na.rm=na.rm ))
49		} else if (fun[1] == 'max') {
50			return(.max( x, add, na.rm=na.rm))
51		} else if (fun[1] == 'range') {
52			return(.range( x, add, na.rm=na.rm))
53		}
54
55
56		out <- raster(x)
57
58		if (canProcessInMemory(x)) {
59
60			if (!is.null(add)) {
61				add <- fun(add, na.rm=na.rm)
62				x <- cbind(getValues(x), add)
63			} else {
64				x <- getValues(x)
65			}
66			x <- apply(x, 1, FUN=fun, na.rm=na.rm)
67			out <- setValues(out, x)
68			return(out)
69		}
70
71		tr <- blockSize(x)
72		out <- writeStart(out, filename="")
73		x <- readStart(x)
74
75		pb <- pbCreate(tr$n)
76		if (!is.null(add)) {
77			add <- fun(add, na.rm=na.rm)
78			for (i in 1:tr$n) {
79				v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
80				v <- apply(cbind(v, add), 1, FUN=fun, na.rm=na.rm)
81				out <- writeValues(out, v, tr$row[i])
82				pbStep(pb, i)
83			}
84		} else {
85			for (i in 1:tr$n) {
86				v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
87				v <- apply(v, 1, FUN=fun, na.rm=na.rm)
88				out <- writeValues(out, v, tr$row[i])
89				pbStep(pb, i)
90			}
91		}
92		pbClose(pb)
93		x <- readStop(x)
94		writeStop(out)
95	}
96)
97
98
99