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