Permalink
Cannot retrieve contributors at this time
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
277 lines (241 sloc)
6.07 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# Author: Robert J. Hijmans & Matteo Mattiuzzi | |
# Date : June 2008 | |
# Version 0.9 | |
# Licence GPL v3 | |
.makeTextFun <- function(fun) { | |
if (!inherits(fun, 'character')) { | |
if (is.primitive(fun)) { | |
test <- try(deparse(fun)[[1]], silent=TRUE) | |
if (test == '.Primitive(\"sum\")') { fun <- 'sum' | |
} else if (test == '.Primitive(\"min\")') { fun <- 'min' | |
} else if (test == '.Primitive(\"max\")') { fun <- 'max' | |
} | |
} else { | |
test1 <- isTRUE(try( deparse(fun)[2] == 'UseMethod(\"mean\")', silent=TRUE)) | |
test2 <- isTRUE(try( fun@generic == 'mean', silent=TRUE)) | |
if (test1 | test2) { | |
fun <- 'mean' | |
} | |
} | |
} | |
return(fun) | |
} | |
.getRowFun <- function(fun) { | |
if (fun == 'mean') { return(rowMeans) | |
} else if (fun == 'sum') { return(rowSums) | |
} else if (fun == 'min') { return(.rowMin) | |
} else if (fun == 'max') { return(.rowMax) | |
} else { stop('unknown fun') } | |
} | |
.getColFun <- function(fun) { | |
if (fun == 'mean') { return(colMeans) | |
} else if (fun == 'sum') { return(colSums) | |
} else if (fun == 'min') { return(.colMin) | |
} else if (fun == 'max') { return(.colMax) | |
} else { stop('unknown fun') } | |
} | |
.calcTest <- function(tstdat, fun, na.rm, forcefun=FALSE, forceapply=FALSE) { | |
if (forcefun & forceapply) { | |
forcefun <- FALSE | |
forceapply <- FALSE | |
} | |
trans <- FALSE | |
doapply <- FALSE | |
makemat <- FALSE | |
nl <- NCOL(tstdat) | |
if (nl == 1) { | |
# the main difference with nl > 1 is that | |
# it is important to avoid using apply when a normal fun( ) call will do. | |
# that is a MAJOR time saver. But in the case of a RasterStackBrick it is more | |
# natural to try apply first. | |
if (forceapply) { | |
doapply <- TRUE | |
makemat <- TRUE | |
tstdat <- matrix(tstdat, ncol=1) | |
if (missing(na.rm)) { | |
test <- try( apply(tstdat, 1, fun), silent=TRUE) | |
} else { | |
test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) | |
} | |
if (length(test) < length(tstdat) | inherits(test, "try-error")) { | |
stop('cannot forceapply this function') | |
} | |
if (is.matrix(test)) { | |
if (ncol(test) > 1) { | |
trans <- TRUE | |
} | |
} | |
} else { | |
if (! missing(na.rm)) { | |
test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) | |
doapply <- TRUE | |
if (inherits(test, "try-error")) { | |
stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") | |
} | |
if (is.matrix(test)) { | |
if (ncol(test) > 1) { | |
trans <- TRUE | |
} | |
} | |
} | |
} else { | |
test <- try(fun(tstdat), silent=TRUE) | |
if (length(test) < length(tstdat) | inherits(test, "try-error")) { | |
doapply <- TRUE | |
makemat <- TRUE | |
tstdat <- matrix(tstdat, ncol=1) | |
test <- try( apply(tstdat, 1, fun), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
stop("cannot use this function") | |
} | |
if (is.matrix(test)) { | |
if (ncol(test) > 1) { | |
trans <- TRUE | |
} | |
} | |
} | |
} | |
} | |
} else { | |
if (forcefun) { | |
doapply <- FALSE | |
test <- fun(tstdat) | |
} else { | |
doapply <- TRUE | |
if (! missing(na.rm)) { | |
test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
doapply <- FALSE | |
test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") | |
} | |
} else if (is.matrix(test)) { | |
trans <- TRUE | |
} | |
} else { | |
test <- try( apply(tstdat, 1, fun), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
doapply <- FALSE | |
test <- try(fun(tstdat), silent=TRUE) | |
if (inherits(test, "try-error")) { | |
stop("cannot use this function") | |
} | |
} else if (is.matrix(test)) { | |
trans <- TRUE | |
} | |
} | |
} | |
} | |
if (trans) { | |
test <- t(test) | |
test <- ncol(test) | |
} else { | |
test <- length(test) / 5 | |
} | |
nlout <- as.integer(test) | |
list(doapply=doapply, makemat=makemat, trans=trans, nlout=nlout) | |
} | |
#.calcTest(test[1:5], fun, forceapply=T) | |
setMethod('calc', signature(x='Raster', fun='function'), | |
function(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) { | |
nl <- nlayers(x) | |
test <- .calcTest(x[1:5], fun, na.rm, forcefun, forceapply) | |
doapply <- test$doapply | |
makemat <- test$makemat | |
trans <- test$trans | |
nlout <- test$nlout | |
if (nlout == 1) { | |
out <- raster(x) | |
} else { | |
out <- brick(x, values=FALSE) | |
out@data@nlayers <- nlout | |
} | |
fun <- .makeTextFun(fun) | |
if (inherits(fun, 'character')) { | |
doapply <- FALSE | |
fun <- .getRowFun(fun) | |
} | |
filename <- trim(filename) | |
estnl <- (nlayers(x) + nlayers(out)) * 2 | |
if (canProcessInMemory(x, estnl)) { | |
x <- getValues(x) | |
if (makemat) { | |
x <- matrix(x, ncol=1) | |
} | |
if (missing(na.rm)) { | |
if (! doapply ) { | |
x <- fun(x ) | |
} else { | |
x <- apply(x, 1, fun ) | |
} | |
} else { | |
if ( ! doapply ) { | |
x <- fun(x, na.rm=na.rm ) | |
} else { | |
x <- apply(x, 1, fun, na.rm=na.rm) | |
} | |
} | |
if (trans) { | |
x <- t(x) | |
} | |
x <- setValues(out, x) | |
if (filename != '') { | |
x <- writeRaster(x, filename, ...) | |
} | |
return(x) | |
} | |
# else | |
x <- readStart(x) | |
out <- writeStart(out, filename=filename, ...) | |
tr <- blockSize(out, n=estnl) | |
pb <- pbCreate(tr$n, label='calc', ...) | |
if (missing(na.rm)) { | |
for (i in 1:tr$n) { | |
v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) | |
if ( ! doapply ) { | |
v <- fun(v) | |
if (nlout > 1 && !is.matrix(v)) { | |
v <- matrix(v, ncol=nlout) | |
} | |
} else { | |
if (makemat) { | |
v <- matrix(v, ncol=1) | |
} | |
v <- apply(v, 1, fun) | |
if (trans) { | |
v <- t(v) | |
} | |
} | |
out <- writeValues(out, v, tr$row[i]) | |
pbStep(pb) | |
} | |
} else { | |
for (i in 1:tr$n) { | |
v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) | |
if ( ! doapply ) { | |
v <- fun(v, na.rm=na.rm) | |
if (nlout > 1 && !is.matrix(v)) { | |
v <- matrix(v, ncol=nlout) | |
} | |
} else { | |
if (makemat) { | |
v <- matrix(v, ncol=1) | |
} | |
v <- apply(v, 1, fun, na.rm=na.rm) | |
if (trans) { | |
v <- t(v) | |
} | |
} | |
out <- writeValues(out, v, tr$row[i]) | |
pbStep(pb) | |
} | |
} | |
out <- writeStop(out) | |
x <- readStop(x) | |
pbClose(pb) | |
return(out) | |
} | |
) | |