R/dcast.R

In dataprep: Fast, Efficient, and Versatile Data Preprocessing and Reshaping with 'C++', 'OpenMP' & 'SIMD'

#' Cast a long-format data.frame into wide format
#'
#' Structural inverse of \code{\link{melt}}. The C++ backend
#' (\code{dcast_cpp}) builds compact integer lookup tables for both
#' the row keys (id columns) and the column keys (variable column),
#' then writes values by output column in strictly sequential order.
#'
#' Backend pipeline:
#'   Phase 0  encode every id column into int32
#'   Phase 0a detect whether the input is a canonical melt block
#'   Phase 0b verify block alignment of id columns
#'   Phase 0c build compact column descriptors
#'   Phase 0d build column keys (block path) or col_of[] (general path)
#'   Phase 1  Robin Hood hash for row keys (64-bit packed) or
#'            FNV-1a 96-bit fingerprint with SIMD acceleration
#'   Phase 2  allocate output
#'   Phase 3  SIMD-fill missing cells
#'   Phase 4  scatter (block path: tile-based transpose with
#'            multi-threading; general path: parallel per-element write)
#'   Phase 5  attach data.frame attributes
#'
#' @details
#' \code{dcast()} is the structural inverse of \code{\link{melt}}. The
#' C++ backend detects canonical \code{melt()} output automatically
#' (variable column is periodic, every id column is constant within
#' one period) and switches to a \emph{block-path tile transpose}:
#' each tile of \code{TILE x period} doubles is read contiguously
#' into an L1 buffer, transposed in place, and written contiguously
#' to the output columns. This keeps both reads and writes sequential
#' and enables OpenMP parallelisation.
#'
#' When the input is not block-aligned, \code{dcast()} builds an
#' open-addressing hash of 64-bit packed row keys. If the combined
#' bit budget of the id columns exceeds 64, it falls back to an
#' FNV-1a 96-bit fingerprint (`uint64_t + uint32_t`) with
#' AVX2-accelerated hash computation and a 16-byte slot table with
#' linear probing for fast negative lookups.
#'
#' The output is identical to \code{reshape2::dcast},
#' \code{data.table::dcast}, \code{tidyr::pivot_wider},
#' \code{pandas.pivot}, \code{polars.pivot}, \code{duckdb PIVOT}, and
#' \code{dask} on every tested shape, within \code{tol = 1e-12}.
#'
#' @section Where the gap is narrowest:
#' Measured against 7 other engines (R: \code{reshape2},
#' \code{data.table}, \code{tidyr}; Python: \code{pandas},
#' \code{polars}, \code{dask}, \code{duckdb}), every cell has
#' \code{dcast()} ahead of every other engine. The narrowest cell
#' in the entire benchmark suite is \code{1e6 rows x 100 id
#' columns}, where \code{polars} reaches 7.4x on Ubuntu and 3.5x on
#' Windows but still remains behind \code{dcast()}.
#'
#' @param data           data.frame in long format.
#' @param id             id columns (character names, integer indices,
#'                       logical mask, or \code{NULL} to infer).
#' @param formula        optional formula of the form
#'                       \code{id1 + id2 ~ variable}.
#' @param variable       name of the "variable" column.
#' @param value          name of the "value" column.
#' @param value.var      alias of \code{value}.
#' @param fill           value used to fill missing cells.
#' @param fun.aggregate  optional aggregation function for duplicate
#'                       \code{(id, variable)} pairs.
#' @param na.rm          if \code{TRUE}, skip NA/NaN values when
#'                       scattering.
#' @param cores          number of OpenMP threads; \code{0} = auto.
#' @param verbose        print progress info.
#'
#' @return data.frame in wide format.
#'
#' @seealso \code{\link{melt}} for the inverse operation.
#'
#' @examples
#' long <- data.frame(
#'   id       = rep(1:3, each = 2),
#'   variable = rep(c("x", "y"), 3),
#'   value    = c(1, 2, 3, 4, 5, 6)
#' )
#' dcast(long, id = "id", variable = "variable", value = "value")
#' dcast(long, formula = id ~ variable)
#' dcast(long, id = 1, fill = 0)
#'
#' # fun.aggregate: aggregate duplicate (id, variable) pairs in R
#' long_dup <- data.frame(
#'   id       = c(1, 1, 2),
#'   variable = "x",
#'   value    = c(1, 2, 3)
#' )
#' dcast(long_dup, id = "id", variable = "variable",
#'       value = "value", fun.aggregate = mean)
#'
#' # na.rm = TRUE: skip NA cells when scattering
#' long_na <- data.frame(
#'   id       = c(1, 1, 2, 2),
#'   variable = c("x", "y", "x", "y"),
#'   value    = c(1, NA, 3, 4)
#' )
#' dcast(long_na, id = "id", variable = "variable",
#'       value = "value", na.rm = TRUE)
#' @export
dcast <- function(data,
                  id             = NULL,
                  formula        = NULL,
                  variable       = NULL,
                  value          = NULL,
                  value.var      = NULL,
                  fill           = NA_real_,
                  fun.aggregate  = NULL,
                  na.rm          = FALSE,
                  cores          = 0L,
                  verbose        = FALSE) {

  if (!is.data.frame(data)) stop("dcast is only supported for data frames")
  if (nrow(data) == 0L)     stop("data has no rows")
  if (ncol(data) < 2L)      stop("data must have at least 2 columns")

  ncols  <- ncol(data)
  cnames <- names(data)

  # Helpers ---------------------------------------------------------
  find_col_match <- function(cnames, base_name) {
    upper_first <- paste0(toupper(substr(base_name, 1L, 1L)),
                          substring(base_name, 2L))
    candidates <- c(base_name, paste0(base_name, "s"),
                    upper_first, paste0(upper_first, "s"),
                    toupper(base_name), toupper(paste0(base_name, "s")))
    for (cand in candidates) {
      hit <- which(cnames == cand)
      if (length(hit) == 1L) return(hit)
    }
    integer(0)
  }

  resolve_single <- function(spec, arg_name) {
    if (is.character(spec)) {
      if (length(spec) != 1L)
        stop(sprintf("%s must be a single column name", arg_name))
      idx <- match(spec, cnames)
      if (is.na(idx)) stop(sprintf("%s column '%s' not found", arg_name, spec))
      return(as.integer(idx))
    }
    if (is.numeric(spec)) {
      idx <- as.integer(spec)[1]
      if (idx < 1L || idx > ncols)
        stop(sprintf("%s column index out of range", arg_name))
      return(idx)
    }
    stop(sprintf("%s must be character or numeric", arg_name))
  }

  # Aliases ---------------------------------------------------------
  if (!is.null(value.var) && is.null(value)) value <- value.var

  # Formula ---------------------------------------------------------
  if (!is.null(formula)) {
    if (!inherits(formula, "formula"))
      stop("formula must be a formula object")
    if (length(formula) != 3L)
      stop("formula must have the form 'lhs ~ rhs'")
    lhs <- all.vars(formula[[2]])
    rhs <- all.vars(formula[[3]])
    if (is.null(id))       id <- lhs
    if (is.null(variable)) {
      if (length(rhs) != 1L)
        stop("formula RHS must specify exactly one variable column")
      variable <- rhs
    }
  }

  # Inference -------------------------------------------------------
  if (is.null(variable)) {
    hit <- find_col_match(cnames, "variable")
    if (length(hit) == 1L) variable <- hit
  }
  if (is.null(value)) {
    hit <- find_col_match(cnames, "value")
    if (length(hit) == 1L) value <- hit
  }
  if (is.null(variable))
    stop("cannot infer 'variable' column; specify it explicitly")
  if (is.null(value))
    stop("cannot infer 'value' column; specify it explicitly")

  var_idx <- resolve_single(variable, "variable")
  val_idx <- resolve_single(value,    "value")
  if (var_idx == val_idx)
    stop("variable and value must be distinct columns")

  # id --------------------------------------------------------------
  id_arg <- NULL
  if (!is.null(id)) {
    if (is.character(id)) {
      bad <- !(id %in% cnames)
      if (any(bad))
        stop(sprintf("id column(s) not found: %s",
                     paste(id[bad], collapse = ", ")))
      id_arg <- as.integer(match(id, cnames))
    } else if (is.numeric(id)) {
      id_arg <- as.integer(id)
      if (any(id_arg < 1L | id_arg > ncols))
        stop("id contains invalid column indices")
    } else if (is.logical(id)) {
      if (length(id) != ncols)
        stop("logical id must have length ncol(data)")
      id_arg <- which(id)
    } else stop("id must be character, numeric, or logical")
    id_arg <- setdiff(id_arg, c(var_idx, val_idx))
    if (length(id_arg) == 0L) id_arg <- NULL
  }

  # fun.aggregate: pre-aggregate in R (arbitrary user function) -----
  if (!is.null(fun.aggregate)) {
    if (!is.function(fun.aggregate))
      stop("fun.aggregate must be a function")

    agg_id <- if (!is.null(id_arg)) cnames[id_arg] else
      setdiff(cnames, c(cnames[var_idx], cnames[val_idx]))

    key_cols <- c(agg_id, cnames[var_idx])
    by_list  <- data[, key_cols, drop = FALSE]

    agg <- stats::aggregate(
      data[[val_idx]],
      by = by_list,
      FUN = function(v) fun.aggregate(v, na.rm = TRUE)
    )
    data <- agg
    names(data)[ncol(data)] <- cnames[val_idx]

    var_idx <- which(names(data) == cnames[var_idx])
    val_idx <- ncol(data)
    id_arg  <- setdiff(seq_len(ncol(data)), c(var_idx, val_idx))
    if (length(id_arg) == 0L) id_arg <- NULL
  }

  # Cores -----------------------------------------------------------
  MAX_THREADS_CAP <- 64L
  cores <- as.integer(cores)[1]
  if (is.na(cores) || cores < 0L) cores <- 0L
  if (cores > MAX_THREADS_CAP)    cores <- MAX_THREADS_CAP

  if (verbose) {
    n_id_show <- if (!is.null(id_arg)) length(id_arg) else NA_integer_
    cat(sprintf(
      "[dcast] rows=%d  id_cols=%s  variable=%s  value=%s  cores=%d  na_rm=%s\n",
      nrow(data), ifelse(is.na(n_id_show), "auto", n_id_show),
      cnames[var_idx], cnames[val_idx], cores, na.rm))
  }

  t0 <- proc.time()[["elapsed"]]
  result <- dcast_cpp(
    data          = data,
    id            = id_arg,
    variable      = as.integer(var_idx),
    value         = as.integer(val_idx),
    variable_name = NULL,
    cores         = cores,
    fill          = fill,
    na_rm         = isTRUE(na.rm)
  )
  if (verbose)
    cat(sprintf("[dcast] done in %.3fs\n",
                proc.time()[["elapsed"]] - t0))

  result
}