R/aggregate2.R

In groupedHyperframe: Grouped Hyper Data Frame

#' @title Aggregate, an Alternative \link[stats]{formula}-Interface
#' 
#' @description
#' An alternative aggregation function with a \link[stats]{formula}-interface, 
#' to avoid the \link[base]{cbind}-operation in the function \link[stats]{aggregate.formula}.
#' 
#' @param data a \link[base]{data.frame}
#' 
#' @param by a two-sided \link[stats]{formula}
#' 
#' @param ... additional parameters of the function \link[stats]{aggregate.data.frame},
#' *except for* `simplify`
#' 
#' @details
#' The \link[base]{cbind}-operation in the function \link[stats]{aggregate.formula} 
#' messes up with column(s) that are 
#' \describe{
#' \item{\link[base]{factor}}{and treat them as \link[base]{integer}}
#' \item{\link[survival]{Surv}}{and treat them as \link[base]{matrix}}
#' }
#' 
#' The function \link[stats]{aggregate.data.frame} only accepts 
#' a \link[base]{list} of \link[base]{factor}s for the parameter `by`.
#' 
#' Therefore, the function [aggregate2()] is created to take care of 
#' the \link[base]{factor} and \link[survival]{Surv} columns of the input,
#' with a \link[stats]{formula}-interface.
#' 
#' @returns 
#' The function [aggregate2()] returns a \link[base]{data.frame}.
#' 
#' @note
#' The function \link[stats]{aggregate.data.frame} is the workhorse of 
#' the function \link[stats]{aggregate.formula}.
#' 
#' The function \link[spatstat.geom]{as.hyperframe.data.frame}
#' is **designed** to handle the \link[base]{list}-columns 
#' returned by the function \link[stats]{aggregate}.
#' 
#' @importFrom stats aggregate.data.frame model.frame.default update.formula
#' @export
aggregate2 <- function(data, by, ...) {
  
  # drop unused factor levels in all columns of `data`
  data[] <- data |>
    lapply(FUN = \(i) {
      if (!is.factor(i)) return(i)
      factor(i) # drop empty levels!!
    })
  
  if (!is.call(by) || (by[[1L]] != '~') || (length(by) != 3L)) stop('`by` must be two-sided formula')
  
  if (is.symbol(by[[2L]]) && (by[[2L]] == '.')) {
    vars <- names(data)
  } else if (is.call(by[[2L]]) && (by[[2L]][[1L]] == '-')) {
    # e.g. `by = . - x1 - x2 ~ subj_id/image_id`
    vars <- names(data) |>
      lapply(FUN = as.symbol) |>
      Reduce(f = \(e1, e2) call(name = '+', e1, e2)) |>
      call(name = '~', . = _) |>
      eval() |>
      update.formula(new = call(name = '~', by[[2L]])) |>
      all.vars()
  } else {
    vars <- all.vars(by)
    if (!all(vars %in% names(data))) stop()
  }
  
  out <- data[unique(c(all.vars(by[[3L]]), vars))]
  
  f <- by[[3L]] |>
    call(name = '~', . = _) |>
    model.frame.default(formula = _, data = data) |>
    as.list.data.frame() |>
    interaction(drop = TRUE, lex.order = TRUE)
  if (all(table(f) == 1L)) return(out) # exception handling, no aggregation needed!!
  
  z <- out |>
    aggregate.data.frame(
      x = _, 
      by = list(.f = f), ...,
      simplify = TRUE # must!! for `Surv`-column!!
    )
  z[] <- z |> 
    lapply(FUN = unsimplify)
  z <- z[-1L] # grouping structure on the 1st column removed
  return(z)
  
}