From d76eb3efdb52cb0505f4e3a53c32716a2625caa2 Mon Sep 17 00:00:00 2001 From: rhijmans Date: Sun, 14 Jan 2024 15:17:39 -0800 Subject: [PATCH] xapp --- NAMESPACE | 2 +- R/Agenerics.R | 2 ++ R/xapp.R | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++ man/xapp.Rd | 46 ++++++++++++++++++++++++++++++++++ 4 files changed, 117 insertions(+), 1 deletion(-) create mode 100644 R/xapp.R create mode 100644 man/xapp.Rd diff --git a/NAMESPACE b/NAMESPACE index 2e736cc01..6aeeeca34 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,7 @@ useDynLib(terra, .registration=TRUE) import(methods, Rcpp) exportClasses(SpatExtent, SpatRaster, SpatRasterDataset, SpatRasterCollection, SpatVector, SpatVectorProxy, SpatVectorCollection) -exportMethods("[", "[[", "!", "%in%", activeCat, "activeCat<-", "add<-", addCats, adjacent, all.equal, aggregate, allNA, align, animate, anyNA, app, area, Arith, approximate, as.bool, as.int, as.contour, as.lines, as.points, as.polygons, as.raster, as.array, as.data.frame, as.factor, as.list, as.logical, as.matrix, as.numeric, atan2, atan_2, autocor, barplot, blocks, boundaries, boxplot, buffer, cartogram, categories, cats, catalyze, clamp, clamp_ts, classify, clearance, cellSize, cells, cellFromXY, cellFromRowCol, cellFromRowColCombine, centroids, click, colFromX, colFromCell, colorize, coltab, "coltab<-", combineGeoms, compare, concats, Compare, compareGeom, contour, convHull, countNA, costDist, crds, cover, crop, crosstab, crs, "crs<-", datatype, deepcopy, delaunay, densify, density, depth, "depth<-", describe, diff, disagg, direction, distance, dots, draw, droplevels, elongate, emptyGeoms, erase, extend, ext, "ext<-", extract, extractRange, expanse, fillHoles, fillTime, flip, focal, focal3D, focalCor, focalPairs, focalReg, focalCpp, focalValues, forceCCW, freq, gaps, geom, geomtype, global, gridDist, gridDistance, has.colors, has.RGB, has.time, hasMinMax, hasValues, hist, head, identical, ifel, impose, init, image, inext, interpIDW, interpNear, inMemory, inset, interpolate, intersect, is.bool, is.int, is.lonlat, is.rotated, isTRUE, isFALSE, is.empty, is.factor, is.lines, is.points, is.polygons, is.related, is.valid, k_means, lapp, layerCor, levels, linearUnits, lines, Logic, varnames, "varnames<-", logic, longnames, "longnames<-", makeValid, mask, match, math, Math, Math2, mean, median, meta, merge, mergeLines, mergeTime, minCircle, minmax, minRect, modal, mosaic, na.omit, not.na, NAflag, "NAflag<-", nearby, nearest, ncell, ncol, "ncol<-", nlyr, "nlyr<-", noNA, normalize.longitude, nrow, "nrow<-", nsrc, origin, "origin<-", pairs, panel, patches, perim, persp, plot, plotRGB, plet, prcomp, princomp, RGB, "RGB<-", polys, points, predict, project, quantile, query, rangeFill, rapp, rast, rasterize, rasterizeGeom, rasterizeWin,readStart, readStop, readValues, rectify, regress, relate, removeDupNodes, res, "res<-", resample, rescale, rev, rcl, roll, rotate, rowFromY, rowColCombine, rowColFromCell, rowFromCell, sapp, scale, scoff, "scoff<-", sds, sort, sprc, sel, selectRange, setMinMax, setValues, segregate, selectHighest, set.cats, set.crs, set.ext, set.names, set.RGB, set.values, size, sharedPaths, shift, sieve, simplifyGeom, snap, sources, spatSample, split, spin, stdev, stretch, subset, subst, summary, Summary, svc, symdif, t, metags, "metags<-", tail, tapp, terrain, tighten, makeNodes, makeTiles, time, timeInfo, "time<-", text, trans, trim, units, union, "units<-", unique, unwrap, update, vect, values, "values<-", viewshed, voronoi, vrt, weighted.mean, where.min, where.max, which.lyr, which.min, which.max, which.lyr, width, window, "window<-", writeCDF, writeRaster, wrap, wrapCache, writeStart, writeStop, writeVector, writeValues, xmin, xmax, "xmin<-", "xmax<-", xres, xFromCol, xyFromCell, xFromCell, ymin, ymax, "ymin<-", "ymax<-", yres, yFromCell, yFromRow, zonal, zoom, cbind2, readRDS, saveRDS, unserialize, serialize) +exportMethods("[", "[[", "!", "%in%", activeCat, "activeCat<-", "add<-", addCats, adjacent, all.equal, aggregate, allNA, align, animate, anyNA, app, area, Arith, approximate, as.bool, as.int, as.contour, as.lines, as.points, as.polygons, as.raster, as.array, as.data.frame, as.factor, as.list, as.logical, as.matrix, as.numeric, atan2, atan_2, autocor, barplot, blocks, boundaries, boxplot, buffer, cartogram, categories, cats, catalyze, clamp, clamp_ts, classify, clearance, cellSize, cells, cellFromXY, cellFromRowCol, cellFromRowColCombine, centroids, click, colFromX, colFromCell, colorize, coltab, "coltab<-", combineGeoms, compare, concats, Compare, compareGeom, contour, convHull, countNA, costDist, crds, cover, crop, crosstab, crs, "crs<-", datatype, deepcopy, delaunay, densify, density, depth, "depth<-", describe, diff, disagg, direction, distance, dots, draw, droplevels, elongate, emptyGeoms, erase, extend, ext, "ext<-", extract, extractRange, expanse, fillHoles, fillTime, flip, focal, focal3D, focalCor, focalPairs, focalReg, focalCpp, focalValues, forceCCW, freq, gaps, geom, geomtype, global, gridDist, gridDistance, has.colors, has.RGB, has.time, hasMinMax, hasValues, hist, head, identical, ifel, impose, init, image, inext, interpIDW, interpNear, inMemory, inset, interpolate, intersect, is.bool, is.int, is.lonlat, is.rotated, isTRUE, isFALSE, is.empty, is.factor, is.lines, is.points, is.polygons, is.related, is.valid, k_means, lapp, layerCor, levels, linearUnits, lines, Logic, varnames, "varnames<-", logic, longnames, "longnames<-", makeValid, mask, match, math, Math, Math2, mean, median, meta, merge, mergeLines, mergeTime, minCircle, minmax, minRect, modal, mosaic, na.omit, not.na, NAflag, "NAflag<-", nearby, nearest, ncell, ncol, "ncol<-", nlyr, "nlyr<-", noNA, normalize.longitude, nrow, "nrow<-", nsrc, origin, "origin<-", pairs, panel, patches, perim, persp, plot, plotRGB, plet, prcomp, princomp, RGB, "RGB<-", polys, points, predict, project, quantile, query, rangeFill, rapp, rast, rasterize, rasterizeGeom, rasterizeWin,readStart, readStop, readValues, rectify, regress, relate, removeDupNodes, res, "res<-", resample, rescale, rev, rcl, roll, rotate, rowFromY, rowColCombine, rowColFromCell, rowFromCell, sapp, scale, scoff, "scoff<-", sds, sort, sprc, sel, selectRange, setMinMax, setValues, segregate, selectHighest, set.cats, set.crs, set.ext, set.names, set.RGB, set.values, size, sharedPaths, shift, sieve, simplifyGeom, snap, sources, spatSample, split, spin, stdev, stretch, subset, subst, summary, Summary, svc, symdif, t, metags, "metags<-", tail, tapp, terrain, tighten, makeNodes, makeTiles, time, timeInfo, "time<-", text, trans, trim, units, union, "units<-", unique, unwrap, update, vect, values, "values<-", viewshed, voronoi, vrt, weighted.mean, where.min, where.max, which.lyr, which.min, which.max, which.lyr, width, window, "window<-", writeCDF, writeRaster, wrap, wrapCache, writeStart, writeStop, writeVector, writeValues, xmin, xmax, "xmin<-", "xmax<-", xres, xFromCol, xyFromCell, xFromCell, ymin, ymax, "ymin<-", "ymax<-", yres, yFromCell, yFromRow, zonal, zoom, cbind2, readRDS, saveRDS, unserialize, serialize, xapp) S3method(cbind, SpatVector) S3method(rbind, SpatVector) diff --git a/R/Agenerics.R b/R/Agenerics.R index fbf649ec5..dd22328c8 100644 --- a/R/Agenerics.R +++ b/R/Agenerics.R @@ -163,6 +163,8 @@ if (!isGeneric("lapp")) { setGeneric("lapp", function(x, ...) standardGeneric("l if (!isGeneric("rapp")) { setGeneric("rapp", function(x, ...) standardGeneric("rapp"))} if (!isGeneric("tapp")) { setGeneric("tapp", function(x, ...) standardGeneric("tapp"))} if (!isGeneric("sapp")) { setGeneric("sapp", function(x, ...) standardGeneric("sapp"))} +if (!isGeneric("xpp")) { setGeneric("xapp", function(x, y, ...) standardGeneric("xapp"))} + if (!isGeneric("add<-")) {setGeneric("add<-", function(x, value) standardGeneric("add<-"))} if (!isGeneric("align")) { setGeneric("align", function(x, y, ...) standardGeneric("align"))} if (!isGeneric("as.contour")) {setGeneric("as.contour", function(x,...) standardGeneric("as.contour"))} diff --git a/R/xapp.R b/R/xapp.R new file mode 100644 index 000000000..b906a2680 --- /dev/null +++ b/R/xapp.R @@ -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) +} +) + + diff --git a/man/xapp.Rd b/man/xapp.Rd new file mode 100644 index 000000000..7ebe3fe20 --- /dev/null +++ b/man/xapp.Rd @@ -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}