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