1 2setMethod("rapp", signature(x="SpatRaster"), 3function(x, first, last, fun, ..., allyrs=FALSE, fill=NA, clamp=FALSE, filename="", overwrite=FALSE, wopt=list()) { 4 5 stopifnot(hasValues(x)) 6 firstval <- lastval <- NA 7 if (inherits(first, "SpatRaster")) { 8 first <- first[[1]] 9 stopifnot(hasValues(first)) 10 } else { 11 if (!is.numeric(first)) { 12 error("rapp", "argument `first` should be numeric or SpatRaster") 13 } 14 firstval <- first 15 stopifnot(first %in% 1:nlyr(x)) 16 } 17 if (inherits(last, "SpatRaster")) { 18 last <- last[[1]] 19 stopifnot(hasValues(last)) 20 } else { 21 if (!is.numeric(last)) { 22 error("rapp", "argument `last` should be numeric or SpatRaster") 23 } 24 lastval <- last 25 stopifnot(last %in% 1:nlyr(x)) 26 } 27 if (!(is.na(firstval)) && (!(is.na(lastval)))) { 28 error("rapp", "argument `first` or `last` must be a SpatRaster. Or use `app`") 29 } 30 if (!is.na(firstval)) { 31 index <- last; 32 } else if (!is.na(lastval)) { 33 index <- first 34 } else { 35 index <- c(first, last) 36 } 37 compareGeom(x, index, lyrs=FALSE, crs=FALSE, warncrs=FALSE, ext=TRUE, rowcol=TRUE, res=FALSE) 38 39 if (!allyrs) { 40 txtfun <- .makeTextFun(match.fun(fun)) 41 if (inherits(txtfun, "character")) { 42 if (txtfun %in% .cpp_funs) { 43 opt <- spatOptions(filename, overwrite, wopt=wopt) 44 na.rm <- isTRUE(list(...)$na.rm) 45 x@ptr <- x@ptr$rapply(index@ptr, firstval, lastval, txtfun, clamp, na.rm, opt) 46 return(messages(x, "rapp")) 47 } 48 } 49 } 50 out <- rast(x) 51 v <- x@ptr$rappvals(index@ptr, firstval, lastval, clamp, allyrs, fill, 0, 1) 52 v <- sapply(v, fun, ...) 53 if (is.list(v)) { error("rapp", "values returned by 'fun' do not have the same length for each cell") } 54 nc <- ncol(out) 55 trans = FALSE 56 if (NCOL(v) == nc) { 57 trans = TRUE 58 nlyr(out) <- nrow(v) 59 } else if (NROW(v) == nc) { 60 nlyr(out) <- NCOL(v) 61 } else if (length(v) == nc) { 62 nlyr(out) <- 1 63 } 64 b <- writeStart(out, filename, overwrite, wopt=wopt, n=nlyr(x)*3) 65 for (i in 1:b$n) { 66 v <- x@ptr$rappvals(index@ptr, firstval, lastval, clamp, allyrs, fill, b$row[i]-1, b$nrows[i]) 67 v <- sapply(v, fun, ...) 68 if (trans) v = t(v) 69 writeValues(out, as.vector(v), b$row[i], b$nrows[i]) 70 } 71 out <- writeStop(out) 72 return(out) 73} 74) 75 76 77