-
Notifications
You must be signed in to change notification settings - Fork 90
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
4 changed files
with
117 additions
and
1 deletion.
There are no files selected for viewing
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
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
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,68 @@ | ||
|
|
||
| setMethod("xapp", signature(x="SpatRaster", y="SpatRaster"), | ||
| function(x, y, fun, ..., filename="", overwrite=FALSE, wopt=list()) { | ||
|
|
||
| fun <- match.fun(fun) | ||
| out <- rast(x) | ||
| nc <- ncol(x) | ||
| readStart(x) | ||
| readStart(y) | ||
| on.exit(readStop(x)) | ||
| on.exit(readStop(y), add=TRUE) | ||
|
|
||
| dots <- list(...) | ||
| if (length(dots) > 0) { | ||
| test <- any(sapply(dots, function(i) inherits(i, "SpatRaster"))) | ||
| if (test) { | ||
| error("app", "additional arguments cannot be a SpatRaster") | ||
| } | ||
| } | ||
| teststart <- max(1, 0.5 * nc - 6) | ||
| testend <- min(teststart + 12, nc) | ||
| ntest <- 1 + testend - teststart | ||
| vx <- readValues(x, round(0.51*nrow(x)), 1, teststart, ntest, mat=TRUE) | ||
| vy <- readValues(y, round(0.51*nrow(y)), 1, teststart, ntest, mat=TRUE) | ||
| test <- sapply(1:nrow(vx), function(i) fun(vx[i, ], vy[i, ], ...)) | ||
| if (is.list(test)) { | ||
| error("xapp", "'fun' returns a list (should be numeric or matrix)") | ||
| } | ||
| trans <- FALSE | ||
| if (NCOL(test) > 1) { | ||
| if (ncol(test) == ntest) { | ||
| nlyr(out) <- nrow(test) | ||
| trans <- TRUE | ||
| nms <- rownames(test) | ||
| } else if (nrow(test) == ntest) { | ||
| nlyr(out) <- ncol(test) | ||
| nms <- colnames(test) | ||
| } else { | ||
| error("xapp", "the number of values returned by 'fun' is not appropriate\n(it should be the product of the number of cells and and a positive integer)") | ||
| } | ||
| if (is.null(wopt$names)) { | ||
| wopt$names <- nms | ||
| } | ||
| } else { | ||
| if ((length(test) %% ntest) != 0) { | ||
| error("xapp", "the number of values returned by 'fun' is not appropriate") | ||
| } else { | ||
| nlyr(out) <- length(test) / ntest | ||
| } | ||
| } | ||
|
|
||
| ncops <- (nlyr(x)+nlyr(y)) / nlyr(out) | ||
| ncops <- ifelse(ncops > 1, ceiling(ncops), 1) * 4 | ||
| b <- writeStart(out, filename, overwrite, wopt=wopt, n=ncops, sources=sources(x)) | ||
| for (i in 1:b$n) { | ||
| vx <- readValues(x, b$row[i], b$nrows[i], 1, nc, TRUE) | ||
| vy <- readValues(y, b$row[i], b$nrows[i], 1, nc, TRUE) | ||
| r <- sapply(1:nrow(vx), function(i) fun(vx[i, ], vy[i, ], ...)) | ||
| if (trans) { | ||
| r <- t(r) | ||
| } | ||
| writeValues(out, r, b$row[i], b$nrows[i]) | ||
| } | ||
| writeStop(out) | ||
| } | ||
| ) | ||
|
|
||
|
|
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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,46 @@ | ||
| \name{xapp} | ||
|
|
||
| \docType{methods} | ||
|
|
||
| \alias{xapp} | ||
| \alias{xapp,SpatRaster-method} | ||
|
|
||
| \title{Apply a function to the cells of a two SpatRasters} | ||
|
|
||
| \description{ | ||
| Apply a function to the values of each cell of two (multilayer) SpatRasters. | ||
| } | ||
|
|
||
| \usage{ | ||
| \S4method{xapp}{SpatRaster}(x, y, fun, ..., filename="", overwrite=FALSE, wopt=list()) | ||
| } | ||
|
|
||
| \arguments{ | ||
| \item{x}{SpatRaster} | ||
| \item{y}{SpatRaster with the same geometry as \code{x}} | ||
| \item{fun}{a function that operates on two vectors} | ||
| \item{...}{additional arguments for \code{fun}. These are typically numerical constants. They should *never* be another SpatRaster} | ||
| \item{filename}{character. Output filename} | ||
| \item{overwrite}{logical. If \code{TRUE}, \code{filename} is overwritten} | ||
| \item{wopt}{list with named options for writing files as in \code{\link{writeRaster}}} | ||
| } | ||
|
|
||
| \value{ | ||
| SpatRaster | ||
| } | ||
|
|
||
|
|
||
| \seealso{\code{\link{app}}, \code{\link{lapp}}, \code{\link{tapp}}, \code{\link[terra]{Math-methods}}, \code{\link{roll}} } | ||
|
|
||
|
|
||
| \examples{ | ||
| r <- rast(ncols=10, nrows=10, nlyr=5) | ||
| set.seed(1) | ||
| r <- init(r, runif) | ||
| s <- init(r, runif) | ||
| x <- xapp(r, s, fun=cor) | ||
| } | ||
|
|
||
|
|
||
| \keyword{methods} | ||
| \keyword{spatial} |