aggregate.R

#  File src/library/stats/R/aggregate.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 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)
    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) {
                        ## this used to lose classes
                        if(len == 1L) {
                            cl <- lapply(ans, oldClass)
                            cl1 <- cl[[1L]]
			    ans <- unlist(ans, recursive = FALSE, use.names = FALSE)
                            if (!is.null(cl1) &&
                                all(vapply(cl, identical, NA, y = cl1)))
                                class(ans) <- cl1
                        } 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(formula, data, FUN, ..., subset, na.action = na.omit)
{
    if(missing(formula) || !inherits(formula, "formula"))
        stop("'formula' missing or incorrect")
    if(length(formula) != 3L)
        stop("'formula' 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
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame)

    if (formula[[2L]] == ".") {
        ## LHS is a dot, expand it ...
        ##rhs <- unlist(strsplit(deparse(formula[[3L]]), " *[:+] *"))
        ## <NOTE>
        ## 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 = ","))
        ## formula[[2L]] <- parse(text = lhs)[[1L]]
        ## </NOTE>

        ## 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(formula[-2L]),"variables")[-1])
        lhs <- as.call(c(quote(cbind),
                         setdiff(lapply(names(data), as.name),
                                 rhs)
                         )
                       )
        formula[[2L]] <- lhs
        m[[2L]] <- formula
    }
    mf <- eval(m, parent.frame())

    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])
        lhs <- as.data.frame(mf[[1L]])
        aggregate.data.frame(lhs, mf[-1L], FUN = FUN, ...)
    }
    else
        aggregate.data.frame(mf[1L], 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)
}