R/desc_stats.R

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

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

#' Descriptive Statistics by Group, with an Optional Total Row
#'
#' @description
#' `desc_stats()` computes descriptive statistics for numeric columns, overall
#' or by group, in one tidy table (one row per group x variable, or one row
#' per group in wide shape). The statistic sets follow
#' `rstatix::get_summary_stats()`. An optional total row gives the
#' statistics of every variable over all records; results can be returned
#' as numbers or as report-ready text such as `"26.66 ± 4.51"`.
#'
#' @param data A `data.frame` or `data.table`. It is never modified.
#' @param cols Numeric columns to summarise, as names or indices. Default
#'   `NULL`: every numeric column not in `by`.
#' @param by Grouping column(s), as names or indices. Default `NULL`. Must not
#'   be named `variable` or `value`.
#' @param type Preset set of statistics (ignored when `stats` or `fmt` is
#'   given):
#'   \describe{
#'     \item{`"full"`}{n, min, max, median, q1, q3, iqr, mad, mean, sd, se, ci,
#'       cv, skew, kurt}
#'     \item{`"common"` (default)}{n, min, max, median, iqr, mean, sd, se, ci}
#'     \item{`"robust"`}{n, median, iqr}
#'     \item{`"five_number"`}{n, min, q1, median, q3, max}
#'     \item{`"mean_sd"`, `"mean_se"`}{n, mean and sd / se}
#'     \item{`"mean_ci"`}{n, mean, ci_low, ci_high}
#'     \item{`"median_iqr"`, `"median_mad"`}{n, median and iqr / mad}
#'     \item{`"quantile"`}{n and the quantiles given by `probs`}
#'     \item{`"mean"`, `"median"`}{n and the mean / median}
#'   }
#' @param stats Optional character vector of statistics, overriding `type`:
#'   any of `"n"`, `"n_miss"`, `"min"`, `"max"`, `"mean"`, `"median"`,
#'   `"q1"`, `"q3"`, `"iqr"`, `"mad"`, `"sd"`, `"se"`, `"ci"`, `"ci_low"`,
#'   `"ci_high"`, `"cv"`, `"skew"`, `"kurt"` and `"quantile"`, in the order
#'   wanted.
#' @param total Logical. If `TRUE`, add totals following one rule: across
#'   groups the statistics are recomputed on all records, across variables
#'   only counts are added up (different variables are not one quantity).
#'   \itemize{
#'     \item **Total row** (with `by`): an extra group whose `by` columns hold
#'       `total_label`; every variable is summarised over all records, so its
#'       `n` is the sum of the group `n`.
#'     \item **Total variable / column** (with two or more variables, when
#'       `n` or `n_miss` is requested or a `fmt` template uses only counts):
#'       an extra variable
#'       `total_label`, last, whose `n` / `n_miss` are the sums over the
#'       variables in each row; its other statistics are `NA`, and in wide
#'       shape its empty columns are dropped. A count-only wide table thus
#'       gets row and column totals, as `janitor::adorn_totals()`.
#'   }
#'   Without `by` only the total variable is added. Default `FALSE`.
#' @param total_label Label of the total row and the total variable. Default
#'   `"Total"`. Must not already occur in a `by` column or as a variable name
#'   (or label).
#' @param min_n Minimum number of (non-missing) values a group needs for its
#'   statistics to be reported. Groups with fewer values keep `n` / `n_miss`
#'   but all other statistics are `NA`, so that e.g. the SD of a farm with
#'   two animals is not mistaken for a reliable figure. Default `1`.
#' @param probs Probabilities for `"quantile"`; output columns are named
#'   `q0`, `q25`, `q2.5`, ... Default `c(0, 0.25, 0.5, 0.75, 1)`.
#' @param conf_level Confidence level of `ci`. Default `0.95`.
#' @param na_rm Logical. If `TRUE` (default) missing values are removed
#'   before computing statistics, and `n` counts the non-missing values. If
#'   `FALSE`, any missing value makes the statistics `NA` and `n` counts all
#'   values.
#' @param digits `NULL` (default, no rounding), one non-negative integer for
#'   all variables, or a named vector per variable, optionally with one
#'   unnamed default: `c(2, adg = 0, bf = 1)` rounds `adg` to 0, `bf` to 1
#'   and every other variable to 2 decimals (variables without a value are
#'   not rounded). The counts `n` / `n_miss` are integers. With `fmt`, these
#'   are the decimals of placeholders without their own `{stat:d}` (default
#'   2).
#' @param fmt `NULL` (default) or a character vector of templates that turn
#'   the statistics into report-ready text, e.g. `"{mean} ± {sd}"`. Each
#'   template becomes one text column, replacing the numeric statistics;
#'   name the elements to name the columns (default: the template without
#'   braces, e.g. `"mean ± sd"`). Placeholders:
#'   \itemize{
#'     \item `{stat}` — any statistic listed in `stats` (except
#'       `"quantile"`), with `digits` decimals (counts without decimals).
#'     \item `{stat:d}` — with `d` decimals, e.g. `{mean:1}`.
#'     \item `{stat:d\%}` — multiplied by 100 and followed by `\%`, e.g.
#'       `{cv:1\%}`.
#'     \item `{q2.5}`, `{q97.5}`, ... — percentiles (`{q1}` / `{q3}` are the
#'       quartiles).
#'   }
#'   The statistics needed by the templates are computed automatically;
#'   `type`, `stats` and `probs` are then ignored. Missing values are shown
#'   as `"NA"` (e.g. the SD of a single record).
#' @param labels `NULL` (default) or a named character vector of display
#'   names for the variables, e.g. `c(adg = "ADG (g)", bf = "Backfat (mm)")`.
#'   Applied to the `variable` column (long shape) or the column names (wide
#'   shape). Variables without a label keep their name.
#' @param shape `"long"` (default): one row per group x variable, one column
#'   per statistic. `"wide"`: one row per group (total row last), columns
#'   `<variable><sep><statistic>` in variable order, as
#'   in a typical report table. With a single statistic or template (e.g.
#'   `stats = "mean"`, `fmt = "{mean} ± {sd}"`) the columns are simply named
#'   after the variables. Both shapes show the same numbers.
#' @param sep Separator between variable and statistic in wide column names.
#'   Default `"_"`.
#' @param out_type `"dt"` (default) for a `data.table`, `"df"` for a
#'   `data.frame`.
#'
#' @details
#' Definitions: `q1` / `q3` and `quantile` use `stats::quantile()`
#' (type 7), `iqr = q3 - q1`, `mad` is `stats::mad()` (scaled by 1.4826),
#' `se = sd / sqrt(n)`, `ci` is the half-width of the t-based confidence
#' interval of the mean (`qt((1 + conf_level) / 2, n - 1) * se`), and
#' `ci_low` / `ci_high` are its bounds (`mean -/+ ci`),
#' `cv = sd / mean` as a ratio (shown in percent with `fmt = "{cv:1\%}"`),
#' `skew` is the adjusted Fisher-Pearson skewness G1 and `kurt` the excess
#' kurtosis G2, as in SAS, SPSS and Excel's `SKEW()` / `KURT()` (`NA` with
#' fewer than 3 / 4 values).
#' The CV is only meaningful for strictly positive data and is `NA` when a
#' group contains values <= 0. Statistics that are undefined for a group
#' (e.g. `sd` with one value) are `NA`.
#'
#' Computation: statistics are computed column by column on the input table
#' (no reshaping to long format, so memory use stays close to the input
#' size). `n`, `mean`, `sd`, `min`, `max` and `median` use data.table's
#' optimised grouped functions, quantiles are read off once-sorted groups,
#' so tens of thousands of groups (sires, litters, pens) are summarised in
#' about a second per million records.
#'
#' Rows are ordered by variable (in the order of `cols`),
#' then by group (in the original order of the `by` values: numeric order,
#' factor levels, alphabetical for text), with the total row last. With a
#' total row, `by` columns that are not factors or character are returned as
#' character; factors gain the label as their last level.
#'
#' @return A `data.table` (or `data.frame`). Long shape: the `by` columns,
#'   `variable` and one column per statistic (or per `fmt` template, as
#'   text). Wide shape: the `by` columns followed by one column per
#'   variable x statistic (or template).
#'
#' @seealso [top_perc()] for statistics of the top / bottom X% per group.
#'
#' @import data.table
#' @importFrom stats qt quantile median mad sd
#' @export
#' @examples
#' # Example 1: Common statistics for every numeric column of iris
#' desc_stats(iris)
#'
#' # Example 2: Mean and SD by group, with a total row over all records
#' desc_stats(
#'   iris,
#'   by = "Species",                 # Grouping column
#'   type = "mean_sd",               # Preset: n, mean, sd
#'   total = TRUE,                   # n = sum of the groups, mean / sd of all records
#'   digits = 2                      # Round the statistics
#' )
#'
#' # Example 3: Count table with row and column totals
#' # (counts are the only statistic that adds up across variables)
#' desc_stats(
#'   iris,
#'   by = "Species",
#'   stats = "n",
#'   total = TRUE,                   # Total row and Total column
#'   shape = "wide"
#' )
#'
#' # Without groups the total adds up the counts of all variables
#' desc_stats(iris, type = "mean_sd", total = TRUE, digits = 2)
#'
#' # Example 3b: Report table - groups in rows, traits in columns, "mean ± sd"
#' desc_stats(
#'   mtcars,
#'   cols = c("mpg", "hp", "wt"),
#'   by = "cyl",
#'   fmt = "{mean} ± {sd}",          # Report-ready text
#'   total = TRUE,
#'   shape = "wide"                  # One row per group, one column per trait
#' )
#'
#' # Example 4: Several templates, per-placeholder decimals, CV in percent and
#' # percentiles
#' desc_stats(
#'   mtcars,
#'   cols = c("mpg", "wt"),
#'   by = "am",
#'   fmt = c(N = "{n}",
#'           "Mean ± SD" = "{mean:1} ± {sd:1}",
#'           "CV" = "{cv:1%}",
#'           "Median [P2.5, P97.5]" = "{median:1} [{q2.5:1}, {q97.5:1}]"),
#'   total = TRUE
#' )
#'
#' # Example 5: Quantiles, returned as a data.frame
#' desc_stats(iris, cols = 1:2, type = "quantile",
#'            probs = c(0.05, 0.5, 0.95), out_type = "df")
desc_stats <- function(data,
                       cols        = NULL,
                       by          = NULL,
                       type        = "common",
                       stats       = NULL,
                       total       = FALSE,
                       total_label = "Total",
                       min_n       = 1L,
                       probs       = c(0, 0.25, 0.5, 0.75, 1),
                       conf_level  = 0.95,
                       na_rm       = TRUE,
                       digits      = NULL,
                       fmt         = NULL,
                       labels      = NULL,
                       shape       = "long",
                       sep         = "_",
                       out_type    = "dt") {
  variable <- .var_ord <- .is_total <- .variable <- NULL

  # -- 1. Data and columns --------------------------------------------------------
  if (!is.data.frame(data))
    stop("`data` must be a data.frame or data.table.", call. = FALSE)
  # Read-only use below (statistics are computed column by column on the
  # original table), so no copy is needed.
  dt <- if (data.table::is.data.table(data)) data else data.table::as.data.table(data)

  by <- .resolve_cols(by, names(dt), "by", allow_null = TRUE)
  reserved <- intersect(by, c("variable", ".variable", ".var_ord"))
  if (length(reserved))
    stop("`by` column(s) must not be named 'variable' (used in the result); ",
         "rename: ", paste(reserved, collapse = ", "), call. = FALSE)
  if (is.null(cols)) {
    cols <- setdiff(names(dt)[vapply(dt, is.numeric, logical(1L))], by)
    if (!length(cols))
      stop("`data` has no numeric columns outside `by`.", call. = FALSE)
  } else {
    cols <- .resolve_cols(cols, names(dt), "cols")
  }
  overlap <- intersect(cols, by)
  if (length(overlap))
    stop("Column(s) appear in both `cols` and `by`: ", paste(overlap, collapse = ", "),
         call. = FALSE)
  non_num <- cols[!vapply(cols, function(cn) is.numeric(dt[[cn]]), logical(1L))]
  if (length(non_num))
    stop("`cols` must be numeric; not numeric: ", paste(non_num, collapse = ", "),
         call. = FALSE)

  # -- 2. Statistics to compute ---------------------------------------------------
  presets <- list(
    full        = c("n", "min", "max", "median", "q1", "q3", "iqr", "mad",
                    "mean", "sd", "se", "ci", "cv", "skew", "kurt"),
    common      = c("n", "min", "max", "median", "iqr", "mean", "sd", "se", "ci"),
    robust      = c("n", "median", "iqr"),
    five_number = c("n", "min", "q1", "median", "q3", "max"),
    mean_sd     = c("n", "mean", "sd"),
    mean_se     = c("n", "mean", "se"),
    mean_ci     = c("n", "mean", "ci_low", "ci_high"),
    median_iqr  = c("n", "median", "iqr"),
    median_mad  = c("n", "median", "mad"),
    quantile    = c("n", "quantile"),
    mean        = c("n", "mean"),
    median      = c("n", "median")
  )
  available <- c("n", "n_miss", "min", "max", "mean", "median", "q1", "q3",
                 "iqr", "mad", "sd", "se", "ci", "ci_low", "ci_high", "cv",
                 "skew", "kurt", "quantile")
  if (!is.null(fmt)) {
    # The template decides which statistics are computed.
    if (!missing(stats) || !missing(type))
      warning("`fmt` is supplied, so `type` / `stats` are ignored.", call. = FALSE)
    spec  <- .fmt_spec(fmt, available)
    stats <- spec$stats
    if (length(spec$probs)) probs <- spec$probs
  } else if (is.null(stats)) {
    .check_choice(type, names(presets), "type")
    stats <- presets[[type]]
  } else {
    if (!is.character(stats) || !length(stats) || anyNA(stats))
      stop("`stats` must be a character vector of statistic names.", call. = FALSE)
    bad <- setdiff(stats, available)
    if (length(bad))
      stop("Unknown statistic(s) in `stats`: ", paste(bad, collapse = ", "),
           ". Available: ", paste(available, collapse = ", "), call. = FALSE)
    stats <- unique(stats)
  }
  if ("quantile" %in% stats &&
      (!is.numeric(probs) || !length(probs) || anyNA(probs) || any(probs < 0 | probs > 1)))
    stop("`probs` must be numeric values in [0, 1].", call. = FALSE)
  if (!is.numeric(conf_level) || length(conf_level) != 1L || is.na(conf_level) ||
      conf_level <= 0 || conf_level >= 1)
    stop("`conf_level` must be a single number in (0, 1).", call. = FALSE)
  .check_flag(total, "total")
  if (!is.character(total_label) || length(total_label) != 1L || is.na(total_label) ||
      !nzchar(total_label))
    stop("`total_label` must be a single non-empty string.", call. = FALSE)
  min_n <- .check_count(min_n, "min_n", 1L)
  .check_flag(na_rm, "na_rm")
  .check_choice(shape, c("long", "wide"), "shape")
  if (!is.character(sep) || length(sep) != 1L || is.na(sep))
    stop("`sep` must be a single character string.", call. = FALSE)
  .check_choice(out_type, c("dt", "df"), "out_type")

  # digits: one number for all variables, or a (partly) named vector,
  # e.g. c(2, adg = 0): unnamed element = default, names = per variable.
  digits_of <- NULL
  if (!is.null(digits)) {
    if (!is.numeric(digits) || !length(digits) || anyNA(digits) ||
        any(digits < 0 | digits != floor(digits)))
      stop("`digits` must be non-negative whole number(s).", call. = FALSE)
    nms <- names(digits)
    if (is.null(nms)) nms <- rep("", length(digits))
    if (sum(!nzchar(nms)) > 1L)
      stop("`digits` may contain at most one unnamed (default) value.", call. = FALSE)
    unknown <- setdiff(nms[nzchar(nms)], cols)
    if (length(unknown))
      stop("`digits` names not in `cols`: ", paste(unknown, collapse = ", "), call. = FALSE)
    default <- if (any(!nzchar(nms))) as.integer(digits[!nzchar(nms)]) else NA_integer_
    digits_of <- stats::setNames(rep(default, length(cols)), cols)
    digits_of[nms[nzchar(nms)]] <- as.integer(digits[nzchar(nms)])
  }

  # labels: display names for the variables, e.g. c(adg = "ADG (g)")
  if (!is.null(labels)) {
    if (!is.character(labels) || is.null(names(labels)) || anyNA(labels) ||
        any(!nzchar(names(labels))) || anyDuplicated(names(labels)))
      stop("`labels` must be a character vector named by variable, ",
           "e.g. c(adg = \"ADG (g)\").", call. = FALSE)
    unknown <- setdiff(names(labels), cols)
    if (length(unknown))
      stop("`labels` names not in `cols`: ", paste(unknown, collapse = ", "), call. = FALSE)
    shown <- cols
    shown[match(names(labels), cols)] <- labels
    if (anyDuplicated(shown))
      stop("`labels` would give several variables the same name: ",
           paste(unique(shown[duplicated(shown)]), collapse = ", "), call. = FALSE)
  }

  # Totals follow one rule: across groups, statistics are recomputed on all
  # records (total row); across variables only counts are added up (total
  # variable / column), because different variables are not one quantity.
  count_tpl <- if (!is.null(fmt))
    vapply(spec$templates, function(t) all(t$col %in% c("n", "n_miss")), logical(1L))
  total_row <- total && length(by) > 0L
  # A total over a single variable would just repeat it.
  total_var <- total && length(cols) >= 2L &&
    (if (is.null(fmt)) any(c("n", "n_miss") %in% stats) else any(count_tpl))
  if (total && !total_row && !total_var)
    warning("Nothing to total: without `by`, `total = TRUE` only adds up counts ",
            "(\"n\" / \"n_miss\") across two or more variables.", call. = FALSE)
  if (total_var) {
    shown_names <- if (is.null(labels)) cols else { x <- cols; x[match(names(labels), cols)] <- labels; x }
    if (total_label %in% shown_names)
      stop("`total_label` '", total_label, "' is also a variable name; choose another.",
           call. = FALSE)
  }
  if (total_row) {
    clash <- by[vapply(by, function(b) total_label %in% as.character(dt[[b]]), logical(1L))]
    if (length(clash))
      stop("`total_label` '", total_label, "' already occurs in `by` column(s): ",
           paste(clash, collapse = ", "), call. = FALSE)
  }

  # -- 3. Statistics per group and variable ---------------------------------------
  engine <- function(by_cols)
    .desc_engine(dt, cols, by_cols, stats, probs = probs, conf_level = conf_level,
                 na_rm = na_rm, min_n = min_n)
  res <- engine(by)
  # Sort groups on their original type (numeric 9 before 10, factor levels in
  # level order) before a total row may turn them into character.
  data.table::setorderv(res, c(".var_ord", by), na.last = TRUE)

  # -- 4. Total row ---------------------------------------------------------------
  # Statistics of each variable over all records, ignoring the groups. Group
  # statistics are never added up or averaged; only the counts add up
  # (n of the total row = sum of the group n).
  res[, .is_total := FALSE]
  if (total_row) {
    tot <- engine(NULL)
    for (b in by) {
      x <- res[[b]]
      if (is.factor(x)) {
        lev <- c(levels(x), total_label)
        data.table::set(res, j = b, value = factor(as.character(x), levels = lev))
        data.table::set(tot, j = b, value = factor(rep(total_label, nrow(tot)), levels = lev))
      } else {
        if (!is.character(x)) data.table::set(res, j = b, value = as.character(x))
        data.table::set(tot, j = b, value = rep(total_label, nrow(tot)))
      }
    }
    tot[, .is_total := TRUE]
    res <- data.table::rbindlist(list(res, tot), use.names = TRUE)
    # setorderv() is stable: groups keep their order, the total row comes last.
    data.table::setorderv(res, c(".var_ord", ".is_total"))
  }

  # -- 4b. Total variable: counts of every row summed over the variables ---------
  # One extra variable (last) per group and for the total row; only n /
  # n_miss are filled, the other statistics stay NA.
  if (total_var) {
    cnt  <- intersect(c("n", "n_miss"), names(res))
    keys <- c(by, ".is_total")
    tv <- if (length(cnt)) res[, lapply(.SD, sum), by = keys, .SDcols = cnt]
          else unique(res[, keys, with = FALSE])
    data.table::set(tv, j = ".variable", value = rep(total_label, nrow(tv)))
    data.table::set(tv, j = ".var_ord", value = rep(length(cols) + 1L, nrow(tv)))
    res <- data.table::rbindlist(list(res, tv), use.names = TRUE, fill = TRUE)
    data.table::setorderv(res, c(".var_ord", ".is_total"))
  }
  res[, .is_total := NULL]
  data.table::setnames(res, ".variable", "variable")

  # -- 5. Rounding or formatted text -----------------------------------------------
  stat_cols <- setdiff(names(res), c(by, "variable", ".var_ord"))
  row_digits <- if (is.null(digits_of)) rep(NA_integer_, nrow(res))
                else unname(digits_of[res$variable])
  if (!is.null(fmt)) {
    row_digits[is.na(row_digits)] <- 2L
    out_cols <- .fmt_apply(res, spec, default_digits = row_digits)
    if (total_var) {
      # Total variable: only count-only templates are meaningful.
      tv_rows <- which(res$variable == total_label)
      for (nm in names(out_cols)[!count_tpl]) out_cols[[nm]][tv_rows] <- NA_character_
    }
    clash <- intersect(names(out_cols), c(by, "variable"))
    if (length(clash))
      stop("`fmt` name(s) clash with grouping / variable columns: ",
           paste(clash, collapse = ", "), call. = FALSE)
    res[, (stat_cols) := NULL]
    for (nm in names(out_cols)) data.table::set(res, j = nm, value = out_cols[[nm]])
  } else if (!all(is.na(row_digits))) {
    for (cn in stat_cols[vapply(stat_cols, function(cn) is.double(res[[cn]]), logical(1L))]) {
      v <- res[[cn]]
      for (dd in unique(row_digits[!is.na(row_digits)])) {
        i <- which(row_digits == dd)
        v[i] <- round(v[i], dd)
      }
      data.table::set(res, j = cn, value = v)
    }
  }
  res[, .var_ord := NULL]

  # -- 6. Variable labels, optional wide layout ----------------------------------
  if (!is.null(labels)) {
    hit <- res$variable %in% names(labels)
    data.table::set(res, i = which(hit), j = "variable", value = unname(labels[res$variable[hit]]))
  }
  data.table::setcolorder(res, c(by, "variable"))
  if (shape == "wide") {
    res <- .desc_wide(res, by, sep)
    if (total_var) {
      # Drop the empty (non-count) columns of the total variable.
      tot_cols <- grep(paste0("^", .re_escape(total_label), "(", .re_escape(sep), "|$)"),
                       names(res), value = TRUE)
      empty <- tot_cols[vapply(tot_cols, function(cn) all(is.na(res[[cn]])), logical(1L))]
      if (length(empty)) res[, (empty) := NULL]
    }
  }

  if (out_type == "df") data.table::setDF(res)
  res[]
}

#' Reshape a long desc_stats() result to one row per group (internal)
#'
#' Columns are `<variable><sep><stat>` in variable order (input order, total
#' column last), or just `<variable>` when a single statistic is present.
#' Row order is the group order of the long table (total row last).
#' @noRd
.desc_wide <- function(res, by, sep) {
  variable <- .row <- NULL
  stat_cols <- setdiff(names(res), c(by, "variable"))
  vars      <- unique(res$variable)
  col_name  <- function(v, st) if (length(stat_cols) == 1L) v else paste(v, st, sep = sep)

  if (length(by)) {
    keys <- unique(res[, by, with = FALSE])           # first-appearance order
    out  <- data.table::copy(keys)
  } else {
    out  <- data.table::data.table(.row = 1L)
  }
  for (v in vars) {
    sub <- res[variable == v]
    idx <- if (length(by)) sub[keys, on = by, which = TRUE] else 1L
    for (st in stat_cols)
      data.table::set(out, j = col_name(v, st), value = sub[[st]][idx])
  }
  if (!length(by)) out[, .row := NULL]
  out[]
}

#' Parse a desc_stats() `fmt` template (internal)
#'
#' Placeholders: `{stat}`, `{stat:d}` (d decimals) and `{stat:d%}` (x 100,
#' followed by "%"). `q1` / `q3` are quartiles; `q<number>` (e.g. `q2.5`,
#' `q97.5`) are percentiles and switch on the `"quantile"` statistic.
#' @return list(templates, stats, probs)
#' @noRd
.fmt_spec <- function(fmt, available) {
  if (!is.character(fmt) || !length(fmt) || anyNA(fmt) || any(!nzchar(fmt)))
    stop("`fmt` must be a character vector of non-empty templates.", call. = FALSE)
  pat <- "\\{([A-Za-z0-9_.]+)(?::([0-9]+)(%?))?\\}"
  nms <- names(fmt)
  if (is.null(nms)) nms <- rep("", length(fmt))
  auto <- !nzchar(nms)
  # Default column name: the template without braces / format specs.
  nms[auto] <- gsub("\\{([A-Za-z0-9_.]+)[^}]*\\}", "\\1", fmt[auto], perl = TRUE)
  if (anyDuplicated(nms))
    stop("`fmt` produces duplicated column names: ",
         paste(unique(nms[duplicated(nms)]), collapse = ", "), call. = FALSE)

  plain <- setdiff(available, "quantile")
  templates <- lapply(seq_along(fmt), function(i) {
    m    <- gregexpr(pat, fmt[[i]], perl = TRUE)
    toks <- regmatches(fmt[[i]], m)[[1L]]
    if (!length(toks))
      stop("`fmt` template '", fmt[[i]], "' contains no {statistic} placeholder.",
           call. = FALSE)
    lits  <- regmatches(fmt[[i]], m, invert = TRUE)[[1L]]
    parts <- regmatches(toks, regexec(pat, toks, perl = TRUE))
    stat  <- vapply(parts, `[[`, character(1L), 2L)
    dig   <- vapply(parts, function(p) if (nzchar(p[[3L]])) as.integer(p[[3L]]) else NA_integer_,
                    integer(1L))
    pct   <- vapply(parts, function(p) nzchar(p[[4L]]), logical(1L))
    is_q  <- !stat %in% plain & grepl("^q[0-9]+(\\.[0-9]+)?$", stat)
    bad   <- stat[!stat %in% plain & !is_q]
    if (length(bad))
      stop("Unknown statistic(s) in `fmt`: ", paste(unique(bad), collapse = ", "),
           ". Available: ", paste(plain, collapse = ", "),
           ", and percentiles such as q2.5 / q97.5.", call. = FALSE)
    p <- rep(NA_real_, length(stat))
    p[is_q] <- as.numeric(sub("^q", "", stat[is_q])) / 100
    if (any(p > 1, na.rm = TRUE))
      stop("Percentile placeholders must be between q0 and q100.", call. = FALSE)
    # column produced by the quantile statistic for this percentile
    col <- stat
    col[is_q] <- paste0("q", format(p[is_q] * 100, trim = TRUE, drop0trailing = TRUE))
    list(lits = lits, col = col, dig = dig, pct = pct, prob = p, is_q = is_q)
  })
  names(templates) <- nms

  all_stat <- unique(unlist(lapply(templates, function(t) t$col[!t$is_q])))
  probs    <- sort(unique(unlist(lapply(templates, function(t) t$prob[t$is_q]))))
  stats    <- c(intersect(plain, all_stat), if (length(probs)) "quantile")
  list(templates = templates, stats = stats, probs = probs)
}

#' Render the `fmt` templates for every row of a long desc_stats() table
#' @noRd
.fmt_apply <- function(res, spec, default_digits) {
  lapply(spec$templates, function(t) {
    vals <- lapply(seq_along(t$col), function(k) {
      x <- res[[t$col[k]]]
      if (t$pct[k]) x <- x * 100
      d   <- if (is.na(t$dig[k])) default_digits else rep(t$dig[k], length(x))
      txt <- character(length(x))
      for (dd in unique(d)) {                          # vectorised per digit value
        i <- which(d == dd)
        txt[i] <- formatC(x[i], format = "f", digits = dd)
      }
      # Counts are integers and shown without decimals.
      if (is.integer(x) && !t$pct[k]) txt <- as.character(x)
      txt[is.na(x)] <- "NA"
      if (t$pct[k]) txt[!is.na(x)] <- paste0(txt[!is.na(x)], "%")
      txt
    })
    out <- t$lits[[1L]]
    for (k in seq_along(vals)) out <- paste0(out, vals[[k]], t$lits[[k + 1L]])
    out
  })
}

#' Escape regular-expression metacharacters (internal)
#' @noRd
.re_escape <- function(x) gsub("([][{}()+*^$|\\\\?.])", "\\\\\\1", x)