R/r2p_nest.R

In mintyr: Grouped and Nested Data Pipelines Built on 'data.table'

# WARNING - Generated by {fusen} from dev/flat_reshape.Rmd: do not edit by hand # nolint: line_length_linter.

#' Row to Pair Nested Transformation
#'
#' @description
#' Pivots the levels of one column (`names_from`, e.g. environment, farm or
#' test station) into separate columns for every trait in `cols`, aligning
#' records by the identifier columns `id` (e.g. the animal ID). The result is
#' nested by trait, ready for iterative analyses such as genetic correlations
#' of the same trait across environments.
#'
#' @param data Input `data.frame` or `data.table`. It is never modified.
#' @param names_from A single column name or index whose levels become columns.
#' @param cols A character vector of column names or numeric indices: the
#'   trait columns to pivot.
#' @param id Identifier column(s) used to align rows across levels of
#'   `names_from`. Default `NULL` uses all columns that are neither in `cols`
#'   nor `names_from` (a message lists them); supplying `id` explicitly is
#'   strongly recommended.
#' @param out_type Output nesting format (`"dt"` or `"df"`). Default `"dt"`.
#'
#' @details
#' The combination of `id` and `names_from` must identify every row uniquely.
#' Otherwise `dcast()` would aggregate duplicated records with `length()` and
#' silently replace trait values by counts; the function stops instead.
#'
#' Other trait columns in `cols` are never used as identifiers: their values
#' differ between environments and would prevent any pairing.
#'
#' @return A nested `data.table` with columns `name` (trait) and `data`.
#'   Each nested table holds the `id` columns plus one column per level of
#'   `names_from`.
#'
#' @import data.table
#' @importFrom stats as.formula
#' @export
#' @examples
#' # Example: the same traits recorded on the same animals in two farms
#' set.seed(1)
#' growth <- data.frame(
#'   animal = rep(sprintf("A%02d", 1:6), each = 2),
#'   farm   = rep(c("farm1", "farm2"), times = 6),
#'   adg    = round(rnorm(12, 900, 50)),     # average daily gain
#'   bf     = round(rnorm(12, 11, 1.5), 1)   # backfat
#' )
#'
#' # Example 1: column names
#' r2p_nest(
#'   growth,
#'   names_from = "farm",           # levels become columns: farm1, farm2
#'   cols      = c("adg", "bf"),    # traits to pivot
#'   id        = "animal"           # aligns records of the same animal
#' )
#' # Returns a nested data.table where:
#' # - name: trait names (adg, bf)
#' # - data: one row per animal with columns animal, farm1, farm2
#'
#' # Example 2: numeric indices
#' r2p_nest(growth, names_from = 2, cols = 3:4, id = 1)
r2p_nest <- function(data,
                     names_from,
                     cols,
                     out_type = "dt",
                     id       = NULL) {

  # -- 1. Validate inputs -----------------------------------------------------
  if (!is.data.frame(data))
    stop("`data` must be a data.table or data.frame.", call. = FALSE)

  # dcast() returns new objects, so the input is never modified: no copy.
  dt <- if (data.table::is.data.table(data)) data else data.table::as.data.table(data)
  nms <- names(dt)

  names_from <- .resolve_cols(names_from, nms, "names_from")
  if (length(names_from) != 1L)
    stop("`names_from` must be a single column.", call. = FALSE)
  cols <- .resolve_cols(cols, nms, "cols")
  if (names_from %chin% cols)
    stop("`names_from` must not also appear in `cols`.", call. = FALSE)
  .check_choice(out_type, c("dt", "df"), "out_type")

  # -- 2. Identifier columns ----------------------------------------------------
  # Rows are aligned across levels of `names_from` by `id`. Other trait columns
  # must never act as identifiers: they differ between environments and would
  # prevent any pairing.
  if (is.null(id)) {
    id <- setdiff(nms, c(cols, names_from))
    if (length(id) > 0L)
      message("[ r2p_nest ] `id` not supplied; using all remaining column(s) as ",
              "identifiers: ", paste(id, collapse = ", "),
              ". Supply `id` explicitly (e.g. the animal ID) for reliable pairing.")
  } else {
    id <- .resolve_cols(id, nms, "id")
    overlap <- intersect(id, c(cols, names_from))
    if (length(overlap) > 0L)
      stop("`id` must not overlap with `cols` or `names_from`: ",
           paste(overlap, collapse = ", "), call. = FALSE)
  }
  if (length(id) == 0L)
    stop("No identifier column available; supply `id`.", call. = FALSE)

  # Without uniqueness dcast() would silently aggregate with length(),
  # replacing trait values by counts.
  if (anyDuplicated(dt, by = c(id, names_from)) > 0L)
    stop("The combination of `id` (", paste(id, collapse = ", "), ") and `names_from` (",
         names_from, ") does not uniquely identify rows; dcast() would aggregate ",
         "values into counts. Check for duplicated records or supply a more ",
         "specific `id`.", call. = FALSE)

  clash <- intersect(as.character(unique(dt[[names_from]])), id)
  if (length(clash) > 0L)
    stop("Value(s) of `names_from` coincide with `id` column name(s): ",
         paste(clash, collapse = ", "), call. = FALSE)

  form <- stats::as.formula(sprintf(
    "%s ~ %s",
    paste(sprintf("`%s`", id), collapse = " + "),
    sprintf("`%s`", names_from)
  ))

  # -- 3. Pivot each trait --------------------------------------------------------
  result_list <- lapply(cols, function(b) {
    wide <- data.table::dcast(dt, form, value.var = b)
    if (out_type == "df") data.table::setDF(wide)
    res <- data.table::data.table(name = b)
    res[, data := list(list(wide))]
    res
  })

  data.table::rbindlist(result_list)
}