R/vars.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

#' Specify Variables for R4VN Tables
#'
#' Captures variable specifications without evaluating them immediately.
#' Prefixes determine how variables are summarized and which observed
#' categorical level is used as the model reference category. The `i.` prefix
#' is accepted as an explicit categorical declaration so the same syntax can be
#' reused in regression and survival commands.
#'
#' The function also supports deferred selectors:
#' \code{.} for all variables, wildcard selectors using \code{*}, and
#' exclusions using unary \code{-}. Deferred selectors are expanded only
#' after the calling analysis function knows which data frame is being used.
#'
#' @usage vars(...)
#'
#' @param ... One or more unquoted variable specifications or selectors.
#'   Examples include \code{sex}, \code{i.sex}, \code{b2.age_group}, \code{c.age},
#'   \code{q.weight}, \code{f.gestational_age}, \code{.},
#'   \code{`kt*`}, \code{`*score`}, \code{`*kt*`}, and
#'   \code{vars(., -id)}.
#'
#' @details
#' Supported prefixes are:
#' \itemize{
#'   \item no prefix: automatic typing from the data. Numeric/integer variables
#'     use mean and standard deviation; factor/character/logical variables are
#'     categorical using their first observed level as reference;
#'   \item \code{i.}: force categorical treatment and use the first observed
#'     level as reference. This is equivalent to \code{b1.} and makes
#'     \code{vars(i.sex)} consistent with regression-model syntax;
#'   \item \code{b1.}, \code{b2.}, \code{b3.}, ...: force categorical treatment and use the
#'     first, second, third, or corresponding observed level as reference;
#'   \item \code{c.}: numeric variable summarized by mean and standard
#'     deviation;
#'   \item \code{q.}: numeric variable summarized by median and interquartile
#'     range;
#'   \item \code{f.}: numeric variable summarized by mean, median, and range.
#' }
#'
#' Selector syntax:
#' \itemize{
#'   \item \code{vars(.)}: select all variables intentionally;
#'   \item \code{vars(`kt*`)}: names beginning with \code{kt};
#'   \item \code{vars(`*kt`)}: names ending with \code{kt};
#'   \item \code{vars(`*kt*`)}: names containing \code{kt};
#'   \item \code{vars(., -id)}: all variables except \code{id};
#'   \item \code{vars(`kt*`, -kt_total)}: wildcard selection except
#'     \code{kt_total};
#'   \item \code{vars(., -`id*`)}: all variables except names beginning
#'     with \code{id}.
#' }
#'
#' Because \code{*} is an R operator, wildcard specifications must be written
#' inside backticks. Thus use \code{vars(`kt*`)}, not \code{vars(kt*)}.
#' A selector consisting only of asterisks is deliberately rejected; use
#' \code{vars(.)} when all variables are intended.
#'
#' Prefixes can be combined with wildcard selectors, for example
#' \code{vars(`c.lab*`)}, \code{vars(`q.score*`)}, or
#' \code{vars(`b2.item*`)}.
#'
#' Exact specifications are more specific than wildcard specifications, and
#' wildcard specifications are more specific than \code{.}. Therefore an
#' exact specification can override a broader selector. For example,
#' \code{vars(`c.lab*`, q.lab_crp)} declares all \code{lab*} variables as
#' mean/SD except \code{lab_crp}, which is median/IQR. When two selectors
#' have the same specificity, the later one wins. Exclusions are applied last
#' and always win.
#'
#' Unprefixed variables and deferred selectors such as \code{.} and
#' \code{`kt*`} are stored with type \code{"default"} until they are resolved
#' against a data frame. With \code{default_type = "auto"} in
#' \code{.r4vn_resolve_vars()}, factor/character/logical columns become
#' categorical and numeric/integer columns become mean/SD variables. Use an
#' explicit \code{b1.}, \code{b2.}, ... prefix when a numeric-coded variable
#' should be treated as categorical instead.
#'
#' Prefixes are declaration syntax only. For example, \code{c.age} refers to
#' the \code{age} column; the data do not need a column named \code{c.age}.
#' For factors, observed-level order follows \code{levels()}. Set factor levels
#' before calling \code{tab()} or \code{tabmulti()} when exact ordering or
#' reference categories are important.
#'
#' \code{vars()} with no arguments remains an error by design. This avoids
#' accidentally selecting every variable.
#'
#' @return A data frame of class \code{r4vn_vars} with columns
#'   \code{variable}, \code{type}, \code{specification}, and
#'   \code{reference_index}. Deferred selectors are expanded by
#'   \code{.r4vn_resolve_vars()} inside R4VN analysis functions.
#'
#' @seealso \code{\link{tab}} and \code{\link{tabmulti}}.
#' @family R4VN tables
#'
#' @examples
#' # Existing declaration syntax.
#' specification <- vars(i.sex, b3.education, c.age, q.bmi, f.sbp)
#' specification
#' # i.sex is an explicit categorical declaration with the first level as reference.
#' vars(i.sex)
#'
#' # Deferred selectors are captured by vars() and resolved by public
#' # R4VN analysis functions once a data frame is supplied.
#' vars(.)
#' vars(`kt*`)
#' vars(`*score`)
#' vars(`*kt*`)
#' vars(., -id)
#' vars(`c.lab*`, q.lab_crp)
#'
#' dat <- data.frame(
#'   id = 1:5,
#'   age = c(31, 42, 38, 50, 46),
#'   sex = factor(c("F", "M", "F", "M", "F")),
#'   kt1 = 1:5,
#'   kt2 = 6:10,
#'   kt_total = 11:15,
#'   score_kt = 16:20
#' )
#'
#' # Unprefixed variables are typed automatically from the actual data:
#' # age is numeric -> mean (SD); sex is a factor -> categorical.
#' t_auto <- tab(dat, vars = vars(age, sex), show = FALSE)
#'
#' # Select all variables.
#' t_all <- tab(dat, vars = vars(.), show = FALSE)
#'
#' # Prefix wildcard.
#' t_kt <- tab(dat, vars = vars(`kt*`), show = FALSE)
#'
#' # Select all except id.
#' t_no_id <- tab(dat, vars = vars(., -id), show = FALSE)
#'
#' # Typed wildcard with an exact override.
#' t_typed <- tab(
#'   dat,
#'   vars = vars(`c.kt*`, q.kt_total),
#'   show = FALSE
#' )
#'
#' t_kt$data
#' @export
vars <- function(...) {
  expressions <- as.list(substitute(list(...)))[-1L]

  if (!length(expressions)) {
    stop(
      "At least one variable must be specified. Use `vars(.)` to intentionally select all variables.",
      call. = FALSE
    )
  }

  output <- vector("list", length(expressions))

  for (i in seq_along(expressions)) {
    expression <- expressions[[i]]
    exclude <- FALSE

    # Allow exclusions such as -id and -`id*`.
    if (is.call(expression) &&
        length(expression) == 2L &&
        identical(as.character(expression[[1L]]), "-")) {
      exclude <- TRUE
      expression <- expression[[2L]]
    }

    if (!is.symbol(expression)) {
      stop(
        paste0(
          "Each item in `vars()` must be a variable name or selector. ",
          "Examples: `sex`, `i.sex`, `b2.age_group`, `c.age`, `.`, ",
          "`kt*` (inside backticks), or `-id`."
        ),
        call. = FALSE
      )
    }

    specification_core <- as.character(expression)
    variable <- specification_core
    type <- "default"
    reference_index <- NA_integer_
    explicit_prefix <- FALSE

    # Parse R4VN declaration prefixes first.
    if (grepl("^b[1-9][0-9]*\\.", specification_core)) {
      explicit_prefix <- TRUE
      type <- "categorical"
      reference_index <- as.integer(
        sub("^b([1-9][0-9]*)\\..*$", "\\1", specification_core)
      )
      variable <- sub("^b[1-9][0-9]*\\.", "", specification_core)
    } else if (startsWith(specification_core, "i.") && nchar(specification_core) > 2L) {
      explicit_prefix <- TRUE
      type <- "categorical"
      variable <- sub("^i\\.", "", specification_core)
      reference_index <- 1L
    } else if (startsWith(specification_core, "c.")) {
      explicit_prefix <- TRUE
      type <- "mean"
      variable <- sub("^c\\.", "", specification_core)
      reference_index <- NA_integer_
    } else if (startsWith(specification_core, "q.")) {
      explicit_prefix <- TRUE
      type <- "median"
      variable <- sub("^q\\.", "", specification_core)
      reference_index <- NA_integer_
    } else if (startsWith(specification_core, "f.")) {
      explicit_prefix <- TRUE
      type <- "full"
      variable <- sub("^f\\.", "", specification_core)
      reference_index <- NA_integer_
    }

    if (!nzchar(variable)) {
      stop("A prefix must be followed by a variable name or wildcard selector.", call. = FALSE)
    }

    is_all <- identical(variable, ".")
    is_wildcard <- grepl("*", variable, fixed = TRUE)

    if (is_all && explicit_prefix) {
      stop(
        "Do not combine `.` with i./c./q./f./b# prefixes. Use `vars(.)` for all variables and exact or wildcard specifications to override selected variables.",
        call. = FALSE
      )
    }

    if (is_wildcard) {
      non_star <- gsub("*", "", variable, fixed = TRUE)
      if (!nzchar(non_star)) {
        stop(
          "A wildcard containing only `*` is not allowed. Use `vars(.)` to intentionally select all variables.",
          call. = FALSE
        )
      }
    }

    # Unprefixed exact variables and deferred selectors are all resolved from
    # the actual data type by the calling analysis function. This gives the
    # end-user rule: numeric -> mean/SD; factor/character/logical -> categorical.
    if (!explicit_prefix) {
      type <- "default"
      reference_index <- NA_integer_
    }

    specification <- if (exclude) {
      paste0("-", specification_core)
    } else {
      specification_core
    }

    output[[i]] <- data.frame(
      variable = variable,
      type = type,
      specification = specification,
      reference_index = reference_index,
      stringsAsFactors = FALSE
    )
  }

  output <- do.call(rbind, output)
  rownames(output) <- NULL
  class(output) <- c("r4vn_vars", "data.frame")
  output
}


# Internal helpers ------------------------------------------------------------

.r4vn_vars_selector_kind <- function(variable) {
  if (identical(variable, ".")) return("all")
  if (grepl("*", variable, fixed = TRUE)) return("wildcard")
  "exact"
}


.r4vn_vars_is_exclusion <- function(specification) {
  startsWith(as.character(specification), "-")
}


.r4vn_vars_expand_one <- function(variable, data_names, source_specification,
                                  strict = TRUE) {
  kind <- .r4vn_vars_selector_kind(variable)

  if (kind == "all") {
    return(data_names)
  }

  if (kind == "exact") {
    if (variable %in% data_names) return(variable)

    if (isTRUE(strict)) {
      stop(
        sprintf(
          "Variable `%s` from `vars()` was not found in `data`.",
          variable
        ),
        call. = FALSE
      )
    }
    return(character())
  }

  # glob2rx safely converts shell-style * wildcards to an anchored regex.
  pattern <- utils::glob2rx(variable)
  matched <- data_names[grepl(pattern, data_names)]

  if (!length(matched) && isTRUE(strict)) {
    stop(
      sprintf(
        "No variables matched selector `%s`.",
        source_specification
      ),
      call. = FALSE
    )
  }

  matched
}


.r4vn_vars_auto_type <- function(x) {
  if (is.factor(x) || is.character(x) || is.logical(x)) {
    return("categorical")
  }

  if (is.numeric(x) || is.integer(x)) {
    return("mean")
  }

  # Conservative fallback for unsupported/special classes.
  "categorical"
}


.r4vn_vars_concrete_spec <- function(variable, type, reference_index, force_categorical = FALSE) {
  if (identical(type, "mean")) {
    return(paste0("c.", variable))
  }

  if (identical(type, "median")) {
    return(paste0("q.", variable))
  }

  if (identical(type, "full")) {
    return(paste0("f.", variable))
  }

  if (identical(type, "categorical")) {
    # Under automatic typing an unprefixed factor/character/logical variable may
    # safely remain unprefixed. An explicitly b#-declared numeric variable must
    # keep its b# prefix, including b1., otherwise reparsing the concrete
    # specification would incorrectly turn it back into a continuous variable.
    if (isTRUE(force_categorical)) {
      idx <- if (!is.na(reference_index) && reference_index >= 1L) as.integer(reference_index) else 1L
      return(paste0("b", idx, ".", variable))
    }
    if (!is.na(reference_index) && reference_index > 1L) {
      return(paste0("b", as.integer(reference_index), ".", variable))
    }
    return(variable)
  }

  # "default" or a future caller-defined type.
  variable
}


.r4vn_vars_resolve_default <- function(type, reference_index, variable, data,
                                       default_type) {
  if (!identical(type, "default")) {
    return(list(type = type, reference_index = reference_index))
  }

  resolved_type <- if (identical(default_type, "auto")) {
    .r4vn_vars_auto_type(data[[variable]])
  } else {
    default_type
  }

  resolved_reference <- if (identical(resolved_type, "categorical")) {
    1L
  } else {
    NA_integer_
  }

  list(
    type = resolved_type,
    reference_index = resolved_reference
  )
}


#' Resolve an R4VN Variable Specification Against Data
#'
#' Internal R4VN helper that expands \code{.}, wildcard selectors, and
#' exclusions after the analysis function has obtained its data frame.
#'
#' @param x An object created by \code{vars()}.
#' @param data Data frame against which selectors are resolved.
#' @param default_type How unprefixed deferred selectors are typed.
#'   \code{"auto"} uses categorical for factor/character/logical columns and
#'   mean/SD for numeric columns. Other supported values are
#'   \code{"categorical"}, \code{"mean"}, \code{"median"}, \code{"full"}, and
#'   \code{"default"}.
#' @param strict If \code{TRUE}, missing exact variables or wildcard selectors
#'   that match nothing are errors.
#'
#' @return A fully expanded \code{r4vn_vars} object containing concrete
#'   variable names in the order requested in \code{vars()}. Variables
#'   expanded from the same wildcard or all-variable selector retain their
#'   original order in \code{data}.
#'
#' @keywords internal
.r4vn_resolve_vars <- function(x, data, default_type = "auto", strict = TRUE) {
  if (!inherits(x, "r4vn_vars")) {
    stop("`x` must be created using `vars()`.", call. = FALSE)
  }

  if (!is.data.frame(data)) {
    stop("`data` must be a data frame.", call. = FALSE)
  }

  if (!is.logical(strict) || length(strict) != 1L || is.na(strict)) {
    stop("`strict` must be TRUE or FALSE.", call. = FALSE)
  }

  default_type <- match.arg(
    default_type,
    c("auto", "categorical", "mean", "median", "full", "default")
  )

  data_names <- names(data)

  if (!length(data_names)) {
    stop("`data` has no variables.", call. = FALSE)
  }

  if (anyDuplicated(data_names)) {
    duplicated_names <- unique(data_names[duplicated(data_names)])
    stop(
      sprintf(
        "`data` contains duplicated variable names: %s.",
        paste(duplicated_names, collapse = ", ")
      ),
      call. = FALSE
    )
  }

  excluded_row <- vapply(
    x$specification,
    .r4vn_vars_is_exclusion,
    logical(1)
  )

  include_index <- which(!excluded_row)
  exclude_index <- which(excluded_row)

  if (!length(include_index)) {
    stop(
      "At least one inclusion selector is required. For example, use `vars(., -id)` rather than `vars(-id)`.",
      call. = FALSE
    )
  }

  candidates <- list()
  candidate_id <- 0L

  for (i in include_index) {
    variable_selector <- x$variable[i]
    selector_kind <- .r4vn_vars_selector_kind(variable_selector)
    source_specification <- x$specification[i]

    matched <- .r4vn_vars_expand_one(
      variable = variable_selector,
      data_names = data_names,
      source_specification = source_specification,
      strict = strict
    )

    if (!length(matched)) next

    specificity <- switch(
      selector_kind,
      all = 1L,
      wildcard = 2L,
      exact = 3L
    )

    for (variable in matched) {
      candidate_id <- candidate_id + 1L

      resolved <- .r4vn_vars_resolve_default(
        type = x$type[i],
        reference_index = x$reference_index[i],
        variable = variable,
        data = data,
        default_type = default_type
      )

      concrete_specification <- .r4vn_vars_concrete_spec(
        variable = variable,
        type = resolved$type,
        reference_index = resolved$reference_index,
        force_categorical = identical(x$type[i], "categorical")
      )

      candidates[[candidate_id]] <- data.frame(
        variable = variable,
        type = resolved$type,
        specification = concrete_specification,
        reference_index = resolved$reference_index,
        .specificity = specificity,
        .source_order = i,
        stringsAsFactors = FALSE
      )
    }
  }

  if (!length(candidates)) {
    stop("No variables were selected by `vars()`.", call. = FALSE)
  }

  candidates <- do.call(rbind, candidates)
  rownames(candidates) <- NULL

  # Exact > wildcard > all. Within equal specificity, the later declaration
  # wins. Display order follows the order requested in vars().
  #
  # `candidates` is built in declaration order. Therefore the first occurrence
  # of each concrete variable defines its display position. If the same
  # variable is selected again by a more specific or later selector, that
  # selector may override the type/reference specification without moving the
  # variable to a different display position.
  #
  # Variables expanded from the same wildcard or from vars(.) retain the
  # original data-frame column order because .r4vn_vars_expand_one() returns
  # matches in data_names order.
  winner_rows <- integer()

  variable_order <- unique(candidates$variable)

  for (variable in variable_order) {
    index <- which(candidates$variable == variable)
    if (!length(index)) next

    best_specificity <- max(candidates$.specificity[index])
    index <- index[candidates$.specificity[index] == best_specificity]

    best_source_order <- max(candidates$.source_order[index])
    index <- index[candidates$.source_order[index] == best_source_order]

    winner_rows <- c(winner_rows, index[length(index)])
  }

  output <- candidates[
    winner_rows,
    c("variable", "type", "specification", "reference_index"),
    drop = FALSE
  ]

  # Exclusions are expanded against the same data and applied last.
  if (length(exclude_index)) {
    excluded_variables <- character()

    for (i in exclude_index) {
      source_specification <- sub("^-", "", x$specification[i])

      matched <- .r4vn_vars_expand_one(
        variable = x$variable[i],
        data_names = data_names,
        source_specification = source_specification,
        strict = strict
      )

      excluded_variables <- c(excluded_variables, matched)
    }

    excluded_variables <- unique(excluded_variables)
    output <- output[
      !output$variable %in% excluded_variables,
      ,
      drop = FALSE
    ]
  }

  if (!nrow(output)) {
    stop("`vars()` selected no variables after exclusions were applied.", call. = FALSE)
  }

  rownames(output) <- NULL
  class(output) <- c("r4vn_vars", "data.frame")
  output
}


# Convenience internal wrapper for analysis functions.
.r4vn_resolve_vars_input <- function(x, data, arg = "vars",
                                     default_type = "auto",
                                     strict = TRUE) {
  if (is.null(x)) return(NULL)

  if (!inherits(x, "r4vn_vars")) {
    stop(
      sprintf("`%s` must be created using `vars()`.", arg),
      call. = FALSE
    )
  }

  .r4vn_resolve_vars(
    x = x,
    data = data,
    default_type = default_type,
    strict = strict
  )
}