# File src/library/stats/R/aggregate.R # Part of the R package, https://www.R-project.org # # Copyright (C) 1995-2022 The R Core Team # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # https://www.R-project.org/Licenses/ aggregate <- function(x, ...) UseMethod("aggregate") aggregate.default <- function(x, ...) { if(is.ts(x)) aggregate.ts(as.ts(x), ...) else aggregate.data.frame(as.data.frame(x), ...) } aggregate.data.frame <- function(x, by, FUN, ..., simplify = TRUE, drop = TRUE) { if(!is.data.frame(x)) x <- as.data.frame(x) ## Do this here to avoid masking by non-function (could happen) FUN <- match.fun(FUN) ## manually dispatch to formula method if 'by' is a formula and not a list if (inherits(by, "formula")) { return(aggregate.formula(x = by, data = x, FUN = FUN, ...)) } if(NROW(x) == 0L) stop("no rows to aggregate") if(NCOL(x) == 0L) { ## fake it x <- data.frame(x = rep(1, NROW(x))) return(aggregate.data.frame(x, by, function(x) 0L)[seq_along(by)]) } if(!is.list(by)) stop("'by' must be a list") if(is.null(names(by)) && length(by)) names(by) <- paste0("Group.", seq_along(by)) else { nam <- names(by) ind <- which(!nzchar(nam)) names(by)[ind] <- paste0("Group.", ind) } if(any(lengths(by) != NROW(x))) stop("arguments must have same length") y <- as.data.frame(by, stringsAsFactors = FALSE) keep <- complete.cases(by) y <- y[keep, , drop = FALSE] x <- x[keep, , drop = FALSE] nrx <- NROW(x) ## Generate a group identifier vector with integers and dots. ident <- function(x) { y <- as.factor(x) l <- length(levels(y)) s <- as.character(seq_len(l)) n <- nchar(s) levels(y) <- paste0(strrep("0", n[l] - n), s) y # levels used for drop = FALSE } grp <- lapply(y, ident) multi.y <- !drop && ncol(y) if(multi.y) { lev <- lapply(grp, levels) y <- as.list(y) for (i in seq_along(y)) { z <- y[[i]][match(lev[[i]], grp[[i]])] if(is.factor(z) && any(keep <- is.na(z))) z[keep] <- levels(z)[keep] y[[i]] <- z } eGrid <- function(L) expand.grid(L, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) y <- eGrid(y) } grp <- if(ncol(y)) { names(grp) <- NULL do.call(paste, c(rev(grp), list(sep = "."))) } else integer(nrx) if(multi.y) { lev <- as.list(eGrid(lev)) names(lev) <- NULL lev <- do.call(paste, c(rev(lev), list(sep = "."))) } else y <- y[match(sort(unique(grp)), grp, 0L), , drop = FALSE] z <- lapply(x, function(e) { ## In case of a common length > 1, sapply() gives ## the transpose of what we need ... ans <- lapply(X = unname(split(e, grp)), FUN = FUN, ...) if(simplify && length(len <- unique(lengths(ans))) == 1L) { if(len == 1L) { cl <- lapply(ans, oldClass) cl1 <- cl[[1L]] ans <- if(!is.null(cl1) && all(vapply(cl, identical, NA, y = cl1))) do.call(c, ans) else unlist(ans, recursive = FALSE, use.names = FALSE) } else if(len > 1L) ans <- matrix(unlist(ans, recursive = FALSE, use.names = FALSE), ncol = len, byrow = TRUE, dimnames = if(!is.null(nms <- names(ans[[1L]]))) list(NULL, nms) ## else NULL ) } ans }) len <- length(y) if(multi.y) { keep <- match(lev, sort(unique(grp))) for(i in seq_along(z)) y[[len + i]] <- if(is.matrix(z[[i]])) z[[i]][keep, , drop = FALSE] else z[[i]][keep] } else for(i in seq_along(z)) y[[len + i]] <- z[[i]] names(y) <- c(names(by), names(x)) row.names(y) <- NULL y } aggregate.formula <- function(x, data, FUN, ..., subset, na.action = na.omit) { if(missing(x)) stop("argument 'x' is missing -- it has been renamed from 'formula'") if(!inherits(x, "formula")) stop("argument 'x' must be a formula") if(length(x) != 3L) stop("formula 'x' must have both left and right hand sides") m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) m$... <- m$FUN <- NULL names(m)[match("x", names(m))] <- "formula" ## need stats:: for non-standard evaluation m[[1L]] <- quote(stats::model.frame) if (x[[2L]] == quote(`.`)) { ## LHS is a dot, expand it ... ##rhs <- unlist(strsplit(deparse(x[[3L]]), " *[:+] *")) ## ## Note that this will not do quite the right thing in case the ## RHS contains transformed variables, such that ## setdiff(rhs, names(data)) ## is non-empty ... ##lhs <- sprintf("cbind(%s)", ## paste(setdiff(names(data), rhs), collapse = ",")) ## x[[2L]] <- parse(text = lhs)[[1L]] ## ## New logic May 2012 --pd ## Dot expansion: ## lhs ends up as quote(cbind(v1, v2, ....)) using all variables in ## data, except those that are used on the RHS. ## This version uses terms() to get the rhs variables, which means ## that it will NOT remove a variable from the expansion if a ## transformation of it is on the RHS of the formula. rhs <- as.list(attr(terms(x[-2L]),"variables")[-1]) lhs <- as.call(c(quote(cbind), setdiff(lapply(names(data), as.name), rhs) ) ) x[[2L]] <- lhs m[[2L]] <- x } mf <- eval(m, parent.frame()) lhs <- if(is.matrix(mf[[1L]])) { ## LHS is a cbind() combo, convert to data frame and fix names. ## Commented out May 2012 (seems to work without it) -- pd ##lhs <- setNames(as.data.frame(mf[[1L]]), ## as.character(m[[2L]][[2L]])[-1L]) as.data.frame(mf[[1L]]) } else mf[1L] aggregate.data.frame(lhs, mf[-1L], FUN = FUN, ...) } aggregate.ts <- function(x, nfrequency = 1, FUN = sum, ndeltat = 1, ts.eps = getOption("ts.eps"), ...) { x <- as.ts(x) ofrequency <- tsp(x)[3L] ## do this here to avoid masking by non-function (could happen) FUN <- match.fun(FUN) ## Set up the new frequency, and make sure it is an integer. if(missing(nfrequency)) nfrequency <- 1 / ndeltat if((nfrequency > 1) && (abs(nfrequency - round(nfrequency)) < ts.eps)) nfrequency <- round(nfrequency) if(nfrequency == ofrequency) return(x) ratio <- ofrequency /nfrequency if(abs(ratio - round(ratio)) > ts.eps) stop(gettextf("cannot change frequency from %g to %g", ofrequency, nfrequency), domain = NA) ## The desired result is obtained by applying FUN to blocks of ## length ofrequency/nfrequency, for each of the variables in x. ## We first get the new start and end right, and then break x into ## such blocks by reshaping it into an array and setting dim. ## avoid e.g. 1.0 %/% 0.2 ## https://stat.ethz.ch/pipermail/r-devel/2010-April/057225.html len <- trunc((ofrequency / nfrequency) + ts.eps) mat <- is.matrix(x) if(mat) cn <- colnames(x) ## nstart <- ceiling(tsp(x)[1L] * nfrequency) / nfrequency ## x <- as.matrix(window(x, start = nstart)) nstart <- tsp(x)[1L] ## Can't use nstart <- start(x) as this causes problems if ## you get a vector of length 2. x <- as.matrix(x) nend <- floor(nrow(x) / len) * len x <- apply(array(c(x[1 : nend, ]), dim = c(len, nend / len, ncol(x))), MARGIN = c(2L, 3L), FUN = FUN, ...) if(!mat) x <- as.vector(x) else colnames(x) <- cn ts(x, start = nstart, frequency = nfrequency) }