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