R/zzz-r4vn-tab-hierarchical.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ==========================================================================
# R4VN hierarchical by=vars(...) convention for tab()
# ==========================================================================
# Loaded after tab.R. The original table engine remains untouched and is used
# for every ordinary call. Only by=vars(...) is translated to the established
# tab(superby=..., by=...) engine.

.r4vn_tab_legacy <- tab

.r4vn_tab_by_final_expr <- function(resolved_row) {
  nm <- as.character(resolved_row$variable[1L])
  tp <- as.character(resolved_row$type[1L])
  if (identical(tp, "mean")) return(as.name(paste0("c.", nm)))
  if (identical(tp, "median")) return(as.name(paste0("q.", nm)))
  # `full` is a predictor-summary declaration, not an outcome declaration;
  # use the actual variable as a categorical by variable for compatibility.
  as.name(nm)
}

.r4vn_tab_hierarchy_factor <- function(data, variables) {
  if (!length(variables)) stop("Internal error: no hierarchy variables.", call. = FALSE)
  ok <- stats::complete.cases(data[variables])
  lab <- rep(NA_character_, nrow(data))
  if (any(ok)) {
    parts <- lapply(variables, function(nm) {
      vapply(
        seq_len(nrow(data)),
        function(i) .r4vn_stratum_component(data, nm, i),
        character(1)
      )
    })
    lab[ok] <- Reduce(function(a, b) paste(a, b, sep = " > "), parts)[ok]
  }
  factor(lab, levels = unique(lab[ok]))
}

#' @rdname tab
#' @export
tab <- function(..., data = NULL, vars = NULL, by = NULL, superby = NULL, digit = 1, p_digit = 3, effect_digit = 2,
                missing = "ifany", row = FALSE, col = TRUE, cell = FALSE,
                overall = "first", descriptive = TRUE, rvrow = NULL, rvcol = FALSE, test = TRUE,
                pvalue = TRUE, bold_p = TRUE, p_bold = 0.05, test_note = TRUE, interaction = TRUE,
                or = FALSE, rr = FALSE, pr = FALSE, event = NULL,
                adjusted = NULL, multi = NULL, effect_ref = NULL,
                template = c("journal", "clean", "minimal"), append = NULL,
                file = NULL, raw = FALSE, name = FALSE, title = NULL,
                show = TRUE, mode = c("auto", "console", "table")) {
  call <- match.call()
  env <- parent.frame()
  by_expr <- substitute(by)

  # The public dispatcher accepts legacy positional data/vars arguments through
  # `...`. Resolve a positional data frame here only for hierarchy inspection;
  # the unchanged call is still forwarded to the dispatcher below.
  d <- data
  if (is.null(d)) {
    mc <- match.call(expand.dots = FALSE)
    dots <- as.list(mc$...)
    dot_names <- names(dots)
    if (is.null(dot_names)) dot_names <- rep("", length(dots))
    dot_names[is.na(dot_names)] <- ""
    for (i in which(dot_names == "")) {
      candidate <- tryCatch(eval(dots[[i]], envir = env),
                            error = function(e) NULL)
      if (is.data.frame(candidate)) {
        d <- candidate
        break
      }
    }
  }
  if (is.null(d)) d <- .r4vn_get_active()
  if (!is.data.frame(d)) stop("`data` must be a data frame.", call. = FALSE)

  # Every pre-1.4 call and every ordinary one-variable by call goes directly to
  # the proven engine, so existing behavior is unchanged. Saved selectors such
  # as `g <- vars(province, sex)` are treated exactly like literal vars(...).
  if (!.r4vn_is_vars_spec_expr(by_expr, d, env)) {
    return(.r4vn_call_preserve(.r4vn_tab_legacy, call, env))
  }

  by_obj <- eval(by_expr, envir = env)
  by_meta <- .r4vn_resolve_vars(by_obj, data = d, default_type = "auto", strict = TRUE)
  if (!nrow(by_meta)) stop("`by = vars(...)` selected no variables.", call. = FALSE)
  if (anyDuplicated(by_meta$variable)) stop("Each variable in `by = vars(...)` may appear only once.", call. = FALSE)

  inner <- tail(by_meta$variable, 1L)
  inner_expr <- .r4vn_tab_by_final_expr(by_meta[nrow(by_meta), , drop = FALSE])
  outer <- if (nrow(by_meta) > 1L) head(by_meta$variable, -1L) else character()

  # Backward-compatible explicit superby is treated as an additional outermost
  # hierarchy when by=vars(...) is used.
  super_expr <- substitute(superby)
  if (!.r4vn_expr_is_null(super_expr)) {
    explicit_super <- .r4vn_resolve_name_spec(super_expr, d, env, "superby", multiple = TRUE, allow_null = TRUE)
    outer <- unique(c(explicit_super, outer))
  }
  outer <- setdiff(outer, inner)

  # by=vars(outcome) is simply the one-variable by syntax with optional type
  # declaration such as vars(c.sbp) or vars(q.sbp).
  if (!length(outer)) {
    cl <- call
    cl[[1L]] <- quote(.r4vn_tab_legacy)
    cl$by <- inner_expr
    cl$superby <- NULL
    ee <- new.env(parent = env)
    ee$.r4vn_tab_legacy <- .r4vn_tab_legacy
    return(eval(cl, envir = ee))
  }

  # A single outer variable can use the native superby engine directly. More
  # than one outer level is represented by an ordered combined factor whose
  # labels retain the full hierarchy (province > sex > ...).
  hd <- d
  if (length(outer) == 1L) {
    super_name <- outer[1L]
    hd[[super_name]] <- .r4vn_tab_hierarchy_factor(hd, outer)
  } else {
    super_name <- ".r4vn_hierarchical_superby"
    while (super_name %in% names(hd)) super_name <- paste0(super_name, "_")
    hd[[super_name]] <- .r4vn_tab_hierarchy_factor(hd, outer)
  }

  cl <- call
  cl[[1L]] <- quote(.r4vn_tab_legacy)
  cl$data <- quote(.r4vn_hierarchical_data)
  cl$by <- inner_expr
  cl$superby <- as.name(super_name)
  ee <- new.env(parent = env)
  ee$.r4vn_tab_legacy <- .r4vn_tab_legacy
  ee$.r4vn_hierarchical_data <- hd
  out <- eval(cl, envir = ee)
  if (inherits(out, "r4vn_tab")) {
    out$hierarchical_by <- list(
      all = by_meta$variable, strata = outer, by = inner,
      all_labels = vapply(by_meta$variable, function(nm) .r4vn_variable_label(d, nm), character(1)),
      strata_labels = vapply(outer, function(nm) .r4vn_variable_label(d, nm), character(1)),
      by_label = .r4vn_variable_label(d, inner)
    )
    out$superby_variables <- outer
    out$call <- call
  }
  invisible(out)
}