R/quick-summary.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ============================================================================
# Quick console summaries for checking active data
# ============================================================================

.r4vn_qs_missing_key <- "<R4VN_MISSING_7e4f9c>"

.r4vn_qs_label <- function(x, fallback) {
  z <- attr(x, "label", exact = TRUE)
  if (is.null(z) || !length(z) || is.na(z[1L]) || !nzchar(as.character(z[1L]))) {
    fallback
  } else {
    as.character(z[1L])
  }
}

.r4vn_qs_fmt <- function(x, digits = 2L) {
  if (length(x) != 1L || is.na(x)) return("")
  if (is.infinite(x)) return(if (x > 0) "Inf" else "-Inf")
  formatC(x, format = "f", digits = digits)
}

.r4vn_qs_percent <- function(percent) {
  if (length(percent) != 1L || is.na(percent)) {
    stop("`percent` must contain one value.", call. = FALSE)
  }
  percent <- tolower(as.character(percent))
  aliases <- c(within = "column", overall = "cell", total = "cell", col = "column")
  if (percent %in% names(aliases)) percent <- unname(aliases[percent])
  match.arg(percent, c("column", "row", "cell", "none"))
}

.r4vn_qs_context <- function(exprs, data_expr, data_supplied, env) {
  .r4vn_read_context(
    exprs = exprs,
    data_expr = data_expr,
    data_supplied = data_supplied,
    env = env
  )
}

.r4vn_qs_select <- function(exprs, data_names, allow_empty = FALSE) {
  out <- .r4vn_select_dots(exprs, data_names)
  if (!length(out) && !isTRUE(allow_empty)) {
    stop("Specify at least one variable.", call. = FALSE)
  }
  out
}

.r4vn_qs_by_names <- function(expr, data_names) {
  if (is.null(expr) || identical(expr, quote(NULL))) return(character())
  .r4vn_selector(expr, data_names)
}

.r4vn_qs_key <- function(x) {
  out <- as.character(x)
  out[is.na(x)] <- .r4vn_qs_missing_key
  out
}

.r4vn_qs_display_key <- function(x) {
  ifelse(x == .r4vn_qs_missing_key, "Missing", x)
}

.r4vn_qs_levels <- function(x, index = rep(TRUE, length(x)),
                            include_missing = FALSE, drop = TRUE) {
  index[is.na(index)] <- FALSE
  observed <- x[index & !is.na(x)]

  if (is.factor(x)) {
    values <- levels(x)
    if (isTRUE(drop)) values <- values[values %in% as.character(observed)]
  } else if (is.logical(x)) {
    values <- c("FALSE", "TRUE")
    if (isTRUE(drop)) values <- values[values %in% as.character(observed)]
  } else if (is.numeric(x)) {
    values <- as.character(sort(unique(observed)))
  } else {
    values <- sort(unique(as.character(observed)), na.last = TRUE)
  }

  values <- as.character(values)
  if (isTRUE(include_missing) && any(index & is.na(x))) {
    values <- c(values, .r4vn_qs_missing_key)
  }
  unique(values)
}

.r4vn_qs_make_strata <- function(data, by_names, missing) {
  if (!length(by_names)) return(list(strata = list(), eligible = rep(TRUE, nrow(data))))

  include_missing <- missing != "no"
  key <- lapply(data[by_names], .r4vn_qs_key)
  eligible <- rep(TRUE, nrow(data))
  if (!include_missing) eligible <- stats::complete.cases(data[by_names])

  output <- list()
  recurse <- function(level, index, path, prefix_n) {
    x <- data[[by_names[level]]]
    levels_here <- .r4vn_qs_levels(
      x,
      index = index,
      include_missing = include_missing,
      drop = TRUE
    )

    for (value in levels_here) {
      index2 <- index & key[[level]] == value
      index2[is.na(index2)] <- FALSE
      if (!any(index2)) next

      display_value <- if (identical(value, .r4vn_qs_missing_key)) {
        "Missing"
      } else {
        .r4vn_value_label(x, which(index2)[1L])
      }
      path2 <- c(path, stats::setNames(display_value, by_names[level]))
      prefix2 <- c(prefix_n, sum(index2))

      if (level == length(by_names)) {
        output[[length(output) + 1L]] <<- list(
          path = path2,
          prefix_n = prefix2,
          index = index2,
          n = sum(index2)
        )
      } else {
        recurse(level + 1L, index2, path2, prefix2)
      }
    }
  }

  recurse(1L, eligible, character(), integer())
  list(strata = output, eligible = eligible)
}

.r4vn_qs_count_table <- function(x, index, global_index, missing,
                                 percent, digits, drop) {
  index[is.na(index)] <- FALSE
  global_index[is.na(global_index)] <- FALSE

  include_missing <- missing == "always" ||
    (missing == "ifany" && any(index & is.na(x)))
  levels_here <- .r4vn_qs_levels(
    x,
    index = index,
    include_missing = include_missing,
    drop = drop
  )
  if (missing == "always" && !.r4vn_qs_missing_key %in% levels_here) {
    levels_here <- c(levels_here, .r4vn_qs_missing_key)
  }

  key <- .r4vn_qs_key(x)
  counts <- vapply(levels_here, function(level) {
    sum(index & key == level, na.rm = TRUE)
  }, integer(1))

  denominator_within <- if (missing == "no") {
    sum(index & !is.na(x))
  } else {
    sum(index)
  }
  denominator_cell <- if (missing == "no") {
    sum(global_index & !is.na(x))
  } else {
    sum(global_index)
  }
  denominator_row <- vapply(levels_here, function(level) {
    sum(global_index & key == level, na.rm = TRUE)
  }, integer(1))

  pct <- switch(
    percent,
    column = if (denominator_within > 0L) 100 * counts / denominator_within else rep(NA_real_, length(counts)),
    row = ifelse(denominator_row > 0L, 100 * counts / denominator_row, NA_real_),
    cell = if (denominator_cell > 0L) 100 * counts / denominator_cell else rep(NA_real_, length(counts)),
    none = rep(NA_real_, length(counts))
  )

  out <- data.frame(
    Level = .r4vn_qs_display_key(levels_here),
    n = counts,
    stringsAsFactors = FALSE,
    check.names = FALSE
  )
  if (percent != "none") {
    out$Percent <- ifelse(is.na(pct), "", paste0(.r4vn_qs_fmt(pct, digits), "%"))
  }
  out
}

.r4vn_qs_numeric_table <- function(x, index, digits, detail) {
  z0 <- x[index]
  good <- is.finite(z0)
  z <- z0[good]
  n <- length(z)
  missing_n <- length(z0) - n

  mean0 <- if (n) mean(z) else NA_real_
  sd0 <- if (n > 1L) stats::sd(z) else NA_real_
  median0 <- if (n) stats::median(z) else NA_real_
  min0 <- if (n) min(z) else NA_real_
  max0 <- if (n) max(z) else NA_real_

  out <- data.frame(
    N = n,
    Missing = missing_n,
    Mean = .r4vn_qs_fmt(mean0, digits),
    SD = .r4vn_qs_fmt(sd0, digits),
    Median = .r4vn_qs_fmt(median0, digits),
    Min = .r4vn_qs_fmt(min0, digits),
    Max = .r4vn_qs_fmt(max0, digits),
    stringsAsFactors = FALSE,
    check.names = FALSE
  )

  if (isTRUE(detail)) {
    q <- if (n) stats::quantile(z, c(.25, .75), names = FALSE, type = 2) else c(NA_real_, NA_real_)
    variance <- if (n > 1L) stats::var(z) else NA_real_
    se <- if (n > 1L) sd0 / sqrt(n) else NA_real_
    range0 <- if (n) max0 - min0 else NA_real_
    cv <- if (n > 1L && is.finite(mean0) && mean0 != 0) 100 * sd0 / abs(mean0) else NA_real_

    skewness <- kurtosis <- NA_real_
    if (n >= 3L) {
      centered <- z - mean0
      m2 <- mean(centered^2)
      if (is.finite(m2) && m2 > 0) {
        skewness <- mean(centered^3) / (m2^(3 / 2))
        kurtosis <- mean(centered^4) / (m2^2)
      }
    }

    out <- data.frame(
      N = n,
      Missing = missing_n,
      Mean = .r4vn_qs_fmt(mean0, digits),
      SE = .r4vn_qs_fmt(se, digits),
      SD = .r4vn_qs_fmt(sd0, digits),
      Variance = .r4vn_qs_fmt(variance, digits),
      Median = .r4vn_qs_fmt(median0, digits),
      Q1 = .r4vn_qs_fmt(q[1L], digits),
      Q3 = .r4vn_qs_fmt(q[2L], digits),
      IQR = .r4vn_qs_fmt(q[2L] - q[1L], digits),
      Min = .r4vn_qs_fmt(min0, digits),
      Max = .r4vn_qs_fmt(max0, digits),
      Range = .r4vn_qs_fmt(range0, digits),
      CV = if (is.na(cv)) "" else paste0(.r4vn_qs_fmt(cv, digits), "%"),
      Skewness = .r4vn_qs_fmt(skewness, digits),
      Kurtosis = .r4vn_qs_fmt(kurtosis, digits),
      stringsAsFactors = FALSE,
      check.names = FALSE
    )
  }

  out
}

.r4vn_qs_result <- function(type, data_name, by, by_labels, variables,
                            detail = FALSE, call = NULL) {
  structure(
    list(
      type = type,
      data_name = data_name,
      by = by,
      by_labels = by_labels,
      variables = variables,
      detail = detail,
      call = call
    ),
    class = "r4vn_quick"
  )
}

.r4vn_qs_print_df <- function(x, indent = "", max_columns = 8L) {
  if (!nrow(x)) {
    cat(indent, "<no observations>\n", sep = "")
    return(invisible(NULL))
  }

  chunks <- split(seq_len(ncol(x)), ceiling(seq_len(ncol(x)) / max_columns))
  for (i in seq_along(chunks)) {
    lines <- capture.output(print(x[chunks[[i]]], row.names = FALSE, right = TRUE))
    cat(paste0(indent, lines, collapse = "\n"), "\n", sep = "")
    if (i < length(chunks)) cat("\n")
  }
  invisible(NULL)
}

.r4vn_qs_print_strata <- function(strata, by_labels) {
  previous <- character()

  for (stratum in strata) {
    path <- unname(stratum$path)
    names(path) <- names(stratum$path)
    common <- 0L
    if (length(previous)) {
      m <- min(length(previous), length(path))
      while (common < m && identical(previous[common + 1L], path[common + 1L])) {
        common <- common + 1L
      }
    }

    if (common < length(path)) {
      for (level in seq.int(common + 1L, length(path))) {
        variable <- names(path)[level]
        label <- by_labels[[variable]]
        indent <- paste(rep("  ", level - 1L), collapse = "")
        if (level == 1L) cat("\n", paste(rep("=", 72L), collapse = ""), "\n", sep = "")
        cat(indent, label, " (", path[level], ") (n = ",
            stratum$prefix_n[level], ")\n", sep = "")
        if (level == 1L) cat(paste(rep("=", 72L), collapse = ""), "\n", sep = "")
      }
    }

    .r4vn_qs_print_df(stratum$table, indent = paste(rep("  ", length(path)), collapse = ""))
    previous <- path
  }
  invisible(NULL)
}

#' Print a quick R4VN console summary
#'
#' @param x An object returned by `tab1()` or `sum1()`.
#' @param ... Unused.
#' @return `x`, invisibly.
#' @export
print.r4vn_quick <- function(x, ...) {
  for (variable in x$variables) {
    heading <- if (identical(variable$label, variable$name)) {
      variable$name
    } else {
      paste0(variable$label, " [", variable$name, "]")
    }

    cat("\n", paste(rep("=", 72L), collapse = ""), "\n", sep = "")
    cat(heading, "\n", sep = "")
    cat(paste(rep("=", 72L), collapse = ""), "\n", sep = "")

    if (!is.null(variable$overall)) {
      cat("\nOverall\n")
      cat(paste(rep("-", 72L), collapse = ""), "\n", sep = "")
      .r4vn_qs_print_df(variable$overall)
    }

    if (length(variable$strata)) {
      .r4vn_qs_print_strata(variable$strata, x$by_labels)
    }
  }
  invisible(x)
}

#' Quick one-way frequency tables
#'
#' Displays formatted frequency tables for one or more categorical variables in the Viewer, with optional Console output.
#' Data may be supplied explicitly, but when `data = NULL` the active data set
#' selected by `usedf()` is used.
#'
#' `by` accepts one or more nested stratification variables. For example,
#' `by = c(sex, agegroup)` first separates results by sex and then displays
#' age-group-specific results inside each sex group. Three or more nested
#' stratification variables are also supported.
#'
#' @param ... One or more variables. An explicit data frame may be supplied as
#'   the first unnamed argument for backward-compatible R4VN syntax.
#' @param by Optional grouping variables supplied as one bare name,
#'   `c(sex, agegroup)`, or `vars(sex, agegroup)`.
#' @param data Optional data frame. When omitted, active data is used.
#' @param missing Missing-value display: `"no"`, `"ifany"`, or `"always"`.
#'   For grouping variables, `"ifany"` and `"always"` retain observed missing
#'   strata.
#' @param percent Percentage denominator: `"column"` or `"within"` for the
#'   terminal stratum, `"row"` for each response level across strata,
#'   `"cell"` or `"overall"` for all eligible observations, or `"none"`.
#' @param digits Decimal places for percentages.
#' @param overall Logical; display the unstratified overall distribution.
#' @param drop Logical; omit unused factor levels.
#' @param show Logical; open the formatted result in the Viewer. Default `TRUE`.
#' @param console Logical; also print the traditional result in the Console. Default `FALSE`.
#'
#' @return Invisibly returns an object of class `r4vn_quick`.
#' @export
#'
#' @examples
#' d <- data.frame(
#'   sex = factor(c("Female", "Male", "Female", "Male", "Female", "Male")),
#'   agegroup = factor(c("<40", "<40", "40+", "40+", "<40", "40+")),
#'   smoking = factor(c("No", "Yes", "No", "Yes", NA, "No")),
#'   vaccinated = factor(c("Yes", "No", "Yes", "Yes", "No", "No"))
#' )
#' usedf(d, quiet = TRUE)
#'
#' tab1(smoking)
#' tab1(smoking, vaccinated)
#' tab1(smoking, by = sex)
#' tab1(smoking, vaccinated, by = c(sex, agegroup))
#' tab1(smoking, by = c(sex, agegroup), missing = "always")
#'
#' usedf(clear = TRUE, quiet = TRUE)
#'
#' # Extended usage examples
#' \donttest{
#' d <- data.frame(
#'   sex = factor(c("Female", "Male", "Female", "Male", "Female", "Male")),
#'   agegroup = factor(c("<40", "<40", "40+", "40+", "<40", "40+")),
#'   province = factor(c("HCMC", "HCMC", "HCMC", "Other", "Other", "Other")),
#'   smoking = factor(c("No", "Yes", "No", "Yes", NA, "No")),
#'   vaccinated = factor(c("Yes", "No", "Yes", "Yes", "No", "No"))
#' )
#' usedf(d)
#'
#' # One or several categorical variables
#' tab1(smoking)
#' tab1(smoking, vaccinated)
#'
#' # One level of stratification
#' tab1(smoking, by = sex)
#'
#' # Nested stratification: age groups are shown within each sex
#' tab1(smoking, by = c(sex, agegroup))
#'
#' # Three nested levels, evaluated in the supplied order
#' tab1(smoking, vaccinated, by = c(province, sex, agegroup))
#'
#' # Percentage denominators
#' tab1(smoking, by = c(sex, agegroup), percent = "column")
#' tab1(smoking, by = c(sex, agegroup), percent = "row")
#' tab1(smoking, by = c(sex, agegroup), percent = "cell")
#' tab1(smoking, by = c(sex, agegroup), percent = "none")
#'
#' # Missing values and unused factor levels
#' tab1(smoking, missing = "no")
#' tab1(smoking, missing = "ifany")
#' tab1(smoking, missing = "always", drop = FALSE)
#'
#' # Hide the overall section or retain the result without printing
#' tab1(smoking, by = sex, overall = FALSE)
#' result <- tab1(smoking, by = sex, show = FALSE)
#' result$variables[[1]]$strata
#'
#' # Explicit data remains supported
#' tab1(d, smoking, vaccinated, by = c(sex, agegroup))
#' tab1(smoking, data = d)
#' }
tab1 <- function(..., by = NULL, data = NULL,
                 missing = c("ifany", "no", "always"),
                 percent = "column", digits = 1,
                 overall = TRUE, drop = TRUE, show = TRUE, console = FALSE) {
  env <- parent.frame()
  exprs <- as.list(substitute(list(...)))[-1L]
  context <- .r4vn_qs_context(exprs, substitute(data), !missing(data), env)
  data <- context$data
  exprs <- context$args

  variables <- .r4vn_qs_select(exprs, names(data))
  by_names <- .r4vn_qs_by_names(substitute(by), names(data))
  missing <- match.arg(missing)
  percent <- .r4vn_qs_percent(percent)
  digits <- as.integer(digits)
  if (!is.finite(digits) || digits < 0L) stop("`digits` must be a non-negative integer.", call. = FALSE)
  if (anyDuplicated(by_names)) stop("Each `by` variable may appear only once.", call. = FALSE)

  strata_info <- .r4vn_qs_make_strata(data, by_names, missing)
  global_index <- strata_info$eligible
  by_labels <- stats::setNames(
    vapply(by_names, function(v) .r4vn_qs_label(data[[v]], v), character(1)),
    by_names
  )

  results <- lapply(variables, function(variable) {
    x <- data[[variable]]
    if (is.data.frame(x) || is.matrix(x) || is.list(x)) {
      stop("`", variable, "` is not a one-dimensional categorical variable.", call. = FALSE)
    }

    overall_table <- if (isTRUE(overall)) {
      .r4vn_qs_count_table(
        x,
        index = rep(TRUE, nrow(data)),
        global_index = rep(TRUE, nrow(data)),
        missing = missing,
        percent = if (percent == "row") "column" else percent,
        digits = digits,
        drop = drop
      )
    } else NULL

    strata <- lapply(strata_info$strata, function(stratum) {
      stratum$table <- .r4vn_qs_count_table(
        x,
        index = stratum$index,
        global_index = global_index,
        missing = missing,
        percent = percent,
        digits = digits,
        drop = drop
      )
      stratum
    })

    list(
      name = variable,
      label = .r4vn_qs_label(x, variable),
      overall = overall_table,
      strata = strata
    )
  })

  out <- .r4vn_qs_result(
    type = "tab1",
    data_name = .r4vn_active_name(),
    by = by_names,
    by_labels = by_labels,
    variables = results,
    call = match.call()
  )
  .r4vn_show(out, show = show, console = console)
}

#' Quick numeric descriptive statistics
#'
#' Displays console descriptive statistics for one or more numeric variables.
#' With nested grouping such as `by = c(sex, agegroup)`, results are first
#' separated by sex and then summarized for each age group within sex.
#'
#' @param ... One or more numeric variables. An explicit data frame may be
#'   supplied as the first unnamed argument.
#' @param by Optional grouping variables supplied as one bare name,
#'   `c(sex, agegroup)`, or `vars(sex, agegroup)`.
#' @param data Optional data frame. When omitted, active data is used.
#' @param detail Logical. If `FALSE`, reports N, missing, mean, SD, median,
#'   minimum, and maximum. If `TRUE`, also reports SE, variance, quartiles,
#'   IQR, range, coefficient of variation, skewness, and kurtosis.
#' @param digits Decimal places.
#' @param missing Missing handling for grouping variables: `"no"` excludes
#'   records missing any grouping variable; `"ifany"` and `"always"` retain
#'   observed missing strata. Missing numeric values are always excluded from
#'   calculations and counted in the `Missing` column.
#' @param overall Logical; display the unstratified overall summary.
#' @param show Logical; open the formatted result in the Viewer. Default `TRUE`.
#' @param console Logical; also print the traditional result in the Console. Default `FALSE`.
#'
#' @return Invisibly returns an object of class `r4vn_quick`.
#' @export
#'
#' @examples
#' d <- data.frame(
#'   sex = factor(rep(c("Female", "Male"), each = 4)),
#'   agegroup = factor(rep(c("<40", "40+"), 4)),
#'   age = c(25, 42, 31, 55, 29, 48, 36, 61),
#'   bmi = c(20.1, 23.5, 21.7, 25.2, 22.4, 26.1, NA, 24.8)
#' )
#' usedf(d, quiet = TRUE)
#'
#' sum1(age)
#' sum1(age, bmi)
#' sum1(age, by = sex)
#' sum1(age, bmi, by = c(sex, agegroup))
#' sum1(age, detail = TRUE)
#'
#' usedf(clear = TRUE, quiet = TRUE)
#'
#' # Extended usage examples
#' \donttest{
#' d <- data.frame(
#'   sex = factor(rep(c("Female", "Male"), each = 6)),
#'   agegroup = factor(rep(c("<40", "40+"), 6)),
#'   province = factor(rep(c("HCMC", "Other"), each = 3, times = 2)),
#'   age = c(25, 42, 31, 55, 29, 48, 36, 61, 33, 47, 52, 40),
#'   bmi = c(20.1, 23.5, 21.7, 25.2, 22.4, 26.1, NA, 24.8, 23.0, 27.1, 22.8, 24.2),
#'   sbp = c(110, 128, 118, 145, 121, 138, 125, 151, 130, 142, 136, 129)
#' )
#' usedf(d)
#'
#' # One or several numeric variables
#' sum1(age)
#' sum1(age, bmi, sbp)
#'
#' # One and several nested grouping variables
#' sum1(age, by = sex)
#' sum1(age, bmi, by = c(sex, agegroup))
#' sum1(age, bmi, by = c(province, sex, agegroup))
#'
#' # Detailed statistics
#' sum1(age, bmi, detail = TRUE)
#'
#' # Missing grouping strata, decimal places, and overall display
#' sum1(age, by = sex, missing = "no", digits = 1)
#' sum1(age, by = sex, missing = "ifany", overall = FALSE)
#'
#' # Retain results without printing and use explicit data
#' result <- sum1(age, bmi, by = sex, show = FALSE)
#' result$variables[[1]]$overall
#' sum1(d, age, bmi, by = c(sex, agegroup))
#' sum1(age, bmi, data = d)
#' }
sum1 <- function(..., by = NULL, data = NULL, detail = FALSE,
                 digits = 2, missing = c("ifany", "no", "always"),
                 overall = TRUE, show = TRUE, console = FALSE) {
  env <- parent.frame()
  exprs <- as.list(substitute(list(...)))[-1L]
  context <- .r4vn_qs_context(exprs, substitute(data), !missing(data), env)
  data <- context$data
  exprs <- context$args

  variables <- .r4vn_qs_select(exprs, names(data))
  by_names <- .r4vn_qs_by_names(substitute(by), names(data))
  missing <- match.arg(missing)
  digits <- as.integer(digits)
  if (!is.finite(digits) || digits < 0L) stop("`digits` must be a non-negative integer.", call. = FALSE)
  if (anyDuplicated(by_names)) stop("Each `by` variable may appear only once.", call. = FALSE)

  strata_info <- .r4vn_qs_make_strata(data, by_names, missing)
  by_labels <- stats::setNames(
    vapply(by_names, function(v) .r4vn_qs_label(data[[v]], v), character(1)),
    by_names
  )

  results <- lapply(variables, function(variable) {
    x <- data[[variable]]
    if (!is.numeric(x)) stop("`", variable, "` must be numeric.", call. = FALSE)

    overall_table <- if (isTRUE(overall)) {
      .r4vn_qs_numeric_table(x, rep(TRUE, nrow(data)), digits, detail)
    } else NULL

    strata <- lapply(strata_info$strata, function(stratum) {
      stratum$table <- .r4vn_qs_numeric_table(x, stratum$index, digits, detail)
      stratum
    })

    list(
      name = variable,
      label = .r4vn_qs_label(x, variable),
      overall = overall_table,
      strata = strata
    )
  })

  out <- .r4vn_qs_result(
    type = "sum1",
    data_name = .r4vn_active_name(),
    by = by_names,
    by_labels = by_labels,
    variables = results,
    detail = isTRUE(detail),
    call = match.call()
  )
  .r4vn_show(out, show = show, console = console)
}

.r4vn_describe_type <- function(x) {
  if (is.ordered(x)) return("ordered factor")
  if (is.factor(x)) return("factor")
  if (inherits(x, "Date")) return("date")
  if (inherits(x, c("POSIXct", "POSIXlt"))) return("datetime")
  if (is.integer(x)) return("integer")
  if (is.numeric(x)) return("numeric")
  if (is.logical(x)) return("logical")
  if (is.character(x)) return("character")
  class(x)[1L]
}

#' Describe variables in the active data
#'
#' Displays a compact description of variable names, types, missing
#' values, distinct values, labels, and factor levels. This is intended for
#' quickly checking the structure of active data without opening an HTML file.
#'
#' @param ... Optional variables. If omitted, all variables are described. An
#'   explicit data frame may be supplied as the first unnamed argument.
#' @param data Optional data frame. When omitted, active data is used.
#' @param show Logical; open the formatted result in the Viewer. Default `TRUE`.
#' @param console Logical; also print the traditional result in the Console. Default `FALSE`.
#'
#' @return Invisibly returns a data frame.
#' @export
#'
#' @examples
#' d <- data.frame(
#'   id = 1:4,
#'   sex = factor(c("Female", "Male", "Female", "Male")),
#'   age = c(25, 40, NA, 52)
#' )
#' attr(d$sex, "label") <- "Sex"
#' usedf(d, quiet = TRUE)
#' describe()
#' describe(sex, age)
#' usedf(clear = TRUE, quiet = TRUE)
#'
#' # Extended usage examples
#' \donttest{
#' patient <- data.frame(
#'   id = 1:4,
#'   sex = factor(c("Female", "Male", "Female", "Male")),
#'   age = c(25, 40, NA, 52),
#'   outcome = c(FALSE, TRUE, FALSE, TRUE)
#' )
#' attr(patient$sex, "label") <- "Sex"
#' usedf(patient)
#'
#' # Describe every variable or selected variables
#' describe()
#' describe(sex)
#' describe(sex, age, outcome)
#'
#' # Explicit data and invisible returned metadata
#' describe(patient)
#' info <- describe(age, sex, data = patient, show = FALSE)
#' info
#' }
describe <- function(..., data = NULL, show = TRUE, console = FALSE) {
  env <- parent.frame()
  exprs <- as.list(substitute(list(...)))[-1L]
  context <- .r4vn_qs_context(exprs, substitute(data), !missing(data), env)
  data <- context$data
  exprs <- context$args

  variables <- .r4vn_qs_select(exprs, names(data), allow_empty = TRUE)
  if (!length(variables)) variables <- names(data)

  out <- do.call(rbind, lapply(variables, function(variable) {
    x <- data[[variable]]
    levels_text <- if (is.factor(x)) {
      paste(levels(x), collapse = " | ")
    } else if (is.logical(x)) {
      "FALSE | TRUE"
    } else {
      ""
    }

    data.frame(
      Name = variable,
      Type = .r4vn_describe_type(x),
      N = length(x) - sum(is.na(x)),
      Missing = sum(is.na(x)),
      Unique = length(unique(x[!is.na(x)])),
      Label = .r4vn_qs_label(x, ""),
      Levels = levels_text,
      stringsAsFactors = FALSE,
      check.names = FALSE
    )
  }))

  active_name <- .r4vn_active_name()
  if (isTRUE(show)) {
    rendered <- .r4vn_describe_viewer(out, data_name = active_name, n = nrow(data), p = ncol(data))
    attr(out, "html") <- rendered$html
    attr(out, "file") <- rendered$file
    .r4vn_view_open(rendered$file)
  }
  if (isTRUE(console)) {
    cat("\nData: ", if (is.null(active_name)) "<explicit>" else active_name,
        " (", nrow(data), " observations, ", ncol(data), " variables)\n", sep = "")
    cat(paste(rep("-", 72L), collapse = ""), "\n", sep = "")
    .r4vn_qs_print_df(out, max_columns = 7L)
  }

  invisible(out)
}


# ============================================================================
# Viewer renderers for quick summaries
# ============================================================================
.r4vn_qs_stratum_title <- function(stratum, by_labels) {
  if (!length(stratum$path)) return("")
  parts <- vapply(seq_along(stratum$path), function(i) {
    nm <- names(stratum$path)[i]
    lab <- by_labels[[nm]] %||% nm
    paste0(lab, " (", unname(stratum$path[i]), ") (n = ",
           stratum$prefix_n[i], ")")
  }, character(1))
  paste(parts, collapse = " > ")
}

.r4vn_qs_viewer <- function(x, subtitle) {
  blocks <- character()
  for (variable in x$variables) {
    heading <- if (identical(variable$label, variable$name)) variable$name else paste0(variable$label, " [", variable$name, "]")
    inner <- character()
    if (!is.null(variable$overall)) {
      inner <- c(inner, '<h3 style="font-size:13px;margin:2px 0 8px;color:#475569">Overall</h3>',
                 .r4vn_view_table(variable$overall))
    }
    if (length(variable$strata)) {
      for (stratum in variable$strata) {
        st <- .r4vn_qs_stratum_title(stratum, x$by_labels)
        inner <- c(inner, paste0('<h3 style="font-size:13px;margin:16px 0 8px;color:#475569">', .r4vn_view_escape(st), '</h3>'),
                   .r4vn_view_table(stratum$table))
      }
    }
    blocks <- c(blocks, paste0('<section class="r4vn-section"><h2>', .r4vn_view_escape(heading), '</h2>',
                               paste0(inner, collapse = ""), '</section>'))
  }
  meta <- if (is.null(x$data_name)) NULL else paste0("Active data: ", x$data_name)
  .r4vn_view_document(if (identical(x$type, "tab1")) "Quick frequency tables" else "Quick numeric summaries",
                      paste0(blocks, collapse = ""), subtitle = paste(c(subtitle, meta), collapse = " \u00b7 "),
                      prefix = "r4vn-quick-")
}

.r4vn_viewer_tab1 <- function(x) .r4vn_qs_viewer(x, "Categorical summary")
.r4vn_viewer_sum1 <- function(x) .r4vn_qs_viewer(x, "Continuous summary")

.r4vn_describe_viewer <- function(out, data_name = NULL, n = NULL, p = NULL) {
  subtitle <- paste0("Data: ", data_name %||% "<explicit>",
                     if (!is.null(n) && !is.null(p)) paste0(" \u00b7 ", n, " observations \u00b7 ", p, " variables") else "")
  body <- .r4vn_view_section("Variables", out)
  .r4vn_view_document("Describe data", body, subtitle = subtitle, prefix = "r4vn-describe-")
}