1# Author: Robert J. Hijmans
2# Date : December 2017
3# Version 1.0
4# License GPL v3
5
6
7.makeTextFun <- function(fun) {
8	if (!inherits(fun, "character")) {
9		fun <- match.fun(fun)
10		if (is.primitive(fun)) {
11			test <- try(deparse(fun)[[1]], silent=TRUE)
12			if (test == '.Primitive(\"sum\")') { fun <- 'sum'
13			} else if (test == '.Primitive(\"min\")') { fun <- 'min'
14			} else if (test == '.Primitive(\"max\")') { fun <- 'max'
15			}
16		} else {
17			depf <- deparse(fun)
18			test1 <- isTRUE(try( depf[2] == 'UseMethod(\"mean\")', silent=TRUE))
19			test2 <- isTRUE(try( fun@generic == "mean", silent=TRUE))
20			if (test1 | test2) {
21				fun <- "mean"
22			}
23			test1 <- isTRUE(try( depf[2] == 'UseMethod(\"median\")', silent=TRUE))
24			test2 <- isTRUE(try( fun@generic == "median", silent=TRUE))
25			if (test1 | test2) {
26				fun <- "median"
27			}
28			test1 <- isTRUE(try( depf[1] == "function (x, na.rm = FALSE) ", silent=TRUE))
29			test2 <- isTRUE(try( depf[2] == "sqrt(var(if (is.vector(x) || is.factor(x)) x else as.double(x), ", silent=TRUE))
30			test3 <- isTRUE(try( depf[3] == "    na.rm = na.rm))", silent=TRUE))
31			if (test1 && test2 && test3) {
32				fun <- "sd"
33			}
34		}
35	}
36	return(fun)
37}
38
39
40setMethod("aggregate", signature(x="SpatRaster"),
41function(x, fact=2, fun="mean", ..., cores=1, filename="", overwrite=FALSE, wopt=list())  {
42
43	fun <- .makeTextFun(fun)
44	toc <- FALSE
45	if (class(fun) == "character") {
46		if (fun %in% c("sum", "mean", "min", "max", "median", "modal", "sd", "sdpop")) {
47			toc <- TRUE
48		} else {
49			fun <- match.fun(fun)
50		}
51	} else {
52		fun <- match.fun(fun)
53	}
54	if (!hasValues(x)) { toc = TRUE }
55	if (toc) {
56		#	fun="mean", expand=TRUE, na.rm=TRUE, filename=""
57		narm <- isTRUE(list(...)$na.rm)
58		opt <- spatOptions(filename, overwrite, wopt=wopt)
59		x@ptr <- x@ptr$aggregate(fact, fun, narm, opt)
60		return (messages(x, "aggregate"))
61	} else {
62		out <- rast(x)
63		nl <- nlyr(out)
64		opt <- spatOptions()
65		out@ptr <- out@ptr$aggregate(fact, "sum", TRUE, opt)
66		out <- messages(out, "aggregate")
67
68		dims <- x@ptr$get_aggregate_dims(fact)
69		b <- x@ptr$getBlockSize(4, opt$memfrac)
70
71		nr <- max(1, floor(b$nrows[1] / fact[1])) * fact[1]
72		nrs <- rep(nr, floor(nrow(x)/nr))
73		d <- nrow(x) - sum(nrs)
74		if (d > 0) nrs <- c(nrs, d)
75		b$row <- c(0, cumsum(nrs))[1:length(nrs)] + 1
76		b$nrows <- nrs
77		b$n <- length(nrs)
78		outnr <- ceiling(b$nrows / fact[1])
79		outrows  <- c(0, cumsum(outnr))[1:length(outnr)] + 1
80		nc <- ncol(x)
81
82		if (cores > 1) {
83			doPar <- TRUE
84			cls <- parallel::makeCluster(cores)
85			on.exit(parallel::stopCluster(cls))
86			#f <- function(v, ...) parallel::parSapply(cls, v, fun, ...)
87		} else {
88			doPar <- FALSE
89			#f <- function(v, ...) sapply(v, fun, ...)
90		}
91
92		readStart(x)
93		on.exit(readStop(x))
94		ignore <- writeStart(out, filename, overwrite, wopt=wopt)
95		if (doPar) {
96			for (i in 1:b$n) {
97				v <- readValues(x, b$row[i], b$nrows[i], 1, nc)
98				v <- x@ptr$get_aggregates(v, b$nrows[i], dims)
99				v <- parallel::parSapply(cls, v, fun, ...)
100				if (length(v) != outnr[i] * prod(dims[5:6])) {
101					error("aggregate", "this function does not return the correct number of values")
102				}
103				writeValues(out, v, outrows[i], outnr[i])
104			}
105		} else {
106			for (i in 1:b$n) {
107				v <- readValues(x, b$row[i], b$nrows[i], 1, nc)
108				v <- x@ptr$get_aggregates(v, b$nrows[i], dims)
109				v <- sapply(v, fun, ...)
110				if (length(v) != outnr[i] * prod(dims[5:6])) {
111					error("aggregate", "this function does not return the correct number of values")
112				}
113				writeValues(out, v, outrows[i], outnr[i])
114			}
115		}
116		out <- writeStop(out)
117		messages(out, "aggregate")
118	}
119}
120)
121
122
123.agg_uf <- function(i) {
124	u <- unique(i)
125	if (length(u) == 1) { u } else { NA	}
126}
127
128
129aggregate_attributes <- function(d, by, fun=NULL, ...) {
130	i <- sapply(d, is.numeric)
131	i[colnames(d) %in% by] <- FALSE
132	j <- 1:length(by)
133	da <- db <- NULL
134	if (!is.null(fun)) {
135		if (any(i)) {
136			if (is.character(fun)) {
137				f <- match.fun(fun)
138				da <- aggregate(d[, i,drop=FALSE], d[, by, drop=FALSE], f)
139				names(da)[-j] <- paste0(fun, "_", names(da)[-j])
140			} else {
141				da <- aggregate(d[, i,drop=FALSE], d[, by, drop=FALSE], fun)
142				names(da)[-j] <- paste0("agg_", names(da)[-j])
143			}
144		}
145	} else {
146		i[] <- FALSE
147	}
148	i[colnames(d) %in% by] <- TRUE
149	if (any(!i)) {
150		db <- aggregate(d[, !i,drop=FALSE], d[, by, drop=FALSE], .agg_uf)
151		db <- db[, colSums(is.na(db)) < nrow(db), drop=FALSE]
152		if (NCOL(da)>1) {
153			da <- merge(da, db, by=by)
154		} else {
155			da <- db
156		}
157	}
158
159	dn <- aggregate(d[, by,drop=FALSE], d[, by, drop=FALSE], length)
160	colnames(dn)[2] = "agg_n"
161	if (NCOL(da)>1) {
162		dn <- merge(da, dn, by=by)
163	}
164	dn
165}
166
167
168setMethod("aggregate", signature(x="SpatVector"),
169	function(x, by=NULL, dissolve=TRUE, fun="mean", ...) {
170		 if (length(by) > 1) {
171			# to be fixed
172			error("aggregate", "this method can only aggregate by one variable")
173		}
174		if (is.numeric(by[1])) {
175			 i <- round(by)
176			 if ((i > 0) & (i <= ncol(x))) {
177				 by <- names(x)[i]
178			 } else {
179				 error("aggregate", "invalid column number supplied: ", by)
180			 }
181		}
182
183		if (is.null(by)) {
184			x$aggregate_by_variable = 1;
185			x@ptr <- x@ptr$aggregate("aggregate_by_variable", dissolve)
186			x$aggregate_by_variable = NULL;
187		} else {
188			d <- as.data.frame(x)
189			x@ptr <- x@ptr$aggregate(by, dissolve)
190			a <- aggregate_attributes(d, by, fun)
191			i <- match(a[[by]], x[[by,drop=TRUE]])
192			values(x) <- a[i,]
193		}
194		x
195	}
196)
197
198# setMethod("aggregate", signature(x="SpatVector"),
199	# function(x, by=NULL, dissolve=TRUE, fun="mean", ...) {
200		# gt <- geomtype(x)
201		# if (length(by) > 1) {
202			# error("aggregate", "this method can only aggregate by one variable")
203		# }
204		# x <- methods::as(x, "Spatial")
205		# if (is.numeric(by[1])) {
206			# i <- round(by)
207			# if ((i > 0) & (i <= ncol(x))) {
208				# by <- names(x)[i]
209			# } else {
210				# error("aggregate", "invalid column number supplied: ", by)
211			# }
212		# }
213		# r <- aggregate(x, by=by, dissolve=dissolve, ...)
214		# if (!missing(fun) && !missing(by)) {
215			# if (.hasSlot(x, "data")) {
216				# d <- x@data
217				# i <- sapply(d, is.numeric)
218				# i[colnames(d) %in% by] <- FALSE
219				# j <- 1:length(by)
220				# if (any(i)) {
221					# if (is.character(fun)) {
222						# f <- match.fun(fun)
223						# da <- aggregate(d[, i,drop=FALSE], d[, by, drop=FALSE], f)
224						# names(da)[-j] <- paste0(fun, "_", names(da)[-j])
225					# } else {
226						# da <- aggregate(d[, i,drop=FALSE], d[, by, drop=FALSE], fun)
227						# names(da)[-j] <- paste0("agg_", names(da)[-j])
228					# }
229					# r <- merge(r, da, by)
230				# }
231				# i[colnames(d) %in% by] <- TRUE
232				# if (any(!i)) {
233					# db <- aggregate(d[, !i,drop=FALSE], d[, by, drop=FALSE], .agg_uf)
234					# db <- db[, colSums(is.na(db)) < nrow(db), drop=FALSE]
235					# if (ncol(db) > 1) {
236						# r <- merge(r, db, by)
237					# }
238				# }
239				# dn <- aggregate(d[, by,drop=FALSE], d[, by, drop=FALSE], length)
240				# colnames(dn)[2] = "agg_n"
241				# r <- merge(r, dn, by)
242			# }
243		# }
244		# vect(r)
245	# }
246# )
247
248