Nothing
R/tabconti.R
In R4VN: Health Data Analysis and Publication-Ready Reporting
Defines functions
.tab_continuous
#============================================================
# tabconti.R
# Internal engine used by tab() when by = c.outcome or q.outcome.
# This function is intentionally not exported. Users continue to call tab().
#============================================================
#' Internal Engine for Continuous Outcomes
#'
#' Internal function called automatically by \code{tab()} when the outcome is
#' declared as \code{by = c.outcome} or \code{by = q.outcome}. Users should
#' call \code{tab()} rather than this function directly.
#'
#' \code{c.outcome} uses mean (SD), t-tests/ANOVA, and Pearson correlation.
#' \code{q.outcome} uses median (IQR), Wilcoxon/Kruskal-Wallis tests, and
#' Spearman correlation. Both modes report unstandardized beta coefficients
#' from linear regression.
#'
#' @keywords internal
#' @noRd
.tab_continuous <- function(data, vars, outcome_spec, digit = 1, p_digit = 3,
effect_digit = 2, missing = "ifany", overall = "first",
descriptive = TRUE, rvrow_expr = quote(NULL), test = TRUE,
pvalue = TRUE, bold_p = TRUE, p_bold = 0.05,
test_note = TRUE, or = FALSE, rr = FALSE, pr = FALSE,
event = NULL, adjusted_expr = quote(NULL),
multi_expr = quote(NULL), effect_ref = NULL,
template = c("journal", "clean", "minimal"),
append = NULL, file = NULL, raw = FALSE,
name = FALSE, title = NULL, show = TRUE,
caller_env = parent.frame(), user_call = NULL) {
if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)
if (!inherits(vars, "r4vn_vars")) stop("`vars` must be created using `vars()`.", call. = FALSE)
if (!is.character(outcome_spec) || length(outcome_spec) != 1L || !grepl("^[cq]\\.", outcome_spec)) {
stop("A continuous outcome must be declared as `by = c.outcome` or `by = q.outcome`.", call. = FALSE)
}
if (any(c(or, rr, pr))) stop("`or`, `rr`, and `pr` are not applicable to a continuous outcome.", call. = FALSE)
if (!is.null(event)) warning("`event` is ignored because the outcome is continuous.", call. = FALSE)
outcome_mode <- if (startsWith(outcome_spec, "c.")) "mean" else "median"
outcome_name <- sub("^[cq]\\.", "", outcome_spec)
if (!nzchar(outcome_name)) stop("The `c.` or `q.` prefix must be followed by an outcome variable name.", call. = FALSE)
if (!outcome_name %in% names(data)) stop(sprintf("Outcome variable `%s` was not found in `data`.", outcome_name), call. = FALSE)
y <- data[[outcome_name]]
if (!is.numeric(y)) stop(sprintf("Continuous outcome `%s` must be numeric.", outcome_name), call. = FALSE)
valid_y <- is.finite(y)
if (sum(valid_y) < 3L) stop("The continuous outcome must contain at least three finite observations.", call. = FALSE)
missing <- match.arg(missing, c("no", "ifany", "always"))
template <- match.arg(template)
if (is.logical(overall) && length(overall) == 1L && !is.na(overall)) overall <- if (overall) "first" else "none"
overall <- match.arg(overall, c("none", "first", "last"))
duplicated_variables <- unique(vars$variable[duplicated(vars$variable)])
if (length(duplicated_variables)) stop(sprintf("Duplicated variable specification: %s.", paste(duplicated_variables, collapse = ", ")), call. = FALSE)
absent_variables <- setdiff(vars$variable, names(data))
if (length(absent_variables)) stop(sprintf("Variables not found in `data`: %s.", paste(absent_variables, collapse = ", ")), call. = FALSE)
if (outcome_name %in% vars$variable) stop("The continuous outcome cannot also be included in `vars`.", call. = FALSE)
escape_html <- function(x) {
x <- as.character(x)
x <- gsub("&", "&", x, fixed = TRUE)
x <- gsub("<", "<", x, fixed = TRUE)
x <- gsub(">", ">", x, fixed = TRUE)
x <- gsub('"', """, x, fixed = TRUE)
gsub("'", "'", x, fixed = TRUE)
}
format_number <- function(x, digits = digit) {
if (!length(x) || is.na(x) || !is.finite(x)) return("")
formatC(x, format = "f", digits = digits, big.mark = ",")
}
format_count <- function(x) {
if (!length(x) || is.na(x)) return("")
format(x, big.mark = ",", scientific = FALSE, trim = TRUE)
}
format_p <- function(x) {
if (!length(x) || is.na(x) || !is.finite(x)) return("")
limit <- 10^(-p_digit)
text <- if (x < limit) paste0("<", formatC(limit, format = "f", digits = p_digit)) else formatC(x, format = "f", digits = p_digit)
if (isTRUE(bold_p) && x < p_bold) paste0("<strong>", text, "</strong>") else text
}
get_label <- function(x, variable) {
label <- attr(x, "label", exact = TRUE)
if (is.null(label) || !length(label) || is.na(label[1L]) || !nzchar(as.character(label[1L]))) variable else as.character(label[1L])
}
display_label <- function(label, variable) {
if (!isTRUE(name)) return(escape_html(label))
paste0(escape_html(label), " <span class=\"variable-code\">[", escape_html(variable), "]</span>")
}
get_levels <- function(x, reverse = FALSE) {
observed <- x[!is.na(x)]
values <- if (is.factor(x)) levels(x) else if (is.logical(x)) c(FALSE, TRUE) else {
z <- unique(observed)
if (is.numeric(z)) sort(z) else z
}
values <- values[values %in% observed]
if (reverse) rev(values) else values
}
summarize_mean <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
c(first = format_number(mean(x)), second = format_number(if (length(x) > 1L) stats::sd(x) else NA_real_))
}
summarize_median <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
q <- stats::quantile(x, c(.25, .5, .75), names = FALSE, type = 7)
c(first = format_number(q[2L]), second = paste0(format_number(q[1L]), " - ", format_number(q[3L])))
}
summarize_range <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
c(first = format_number(min(x)), second = format_number(max(x)))
}
summarize_outcome <- function(x) if (outcome_mode == "mean") summarize_mean(x) else summarize_median(x)
compact_value <- function(z, kind) {
if (is.null(z) || !length(z)) return("")
if (kind %in% c("categorical", "mean", "median", "outcome")) return(if (nzchar(z["first"])) paste0(z["first"], " (", z["second"], ")") else "")
if (kind == "range") return(if (nzchar(z["first"])) paste0(z["first"], " - ", z["second"]) else "")
""
}
clean_export_text <- function(x) {
x <- as.character(x)
x <- gsub("<br\\s*/?>", " ", x, ignore.case = TRUE)
x <- gsub("<[^>]+>", "", x)
x <- gsub("<", "<", x, fixed = TRUE)
x <- gsub(">", ">", x, fixed = TRUE)
x <- gsub(""", "\"", x, fixed = TRUE)
x <- gsub("'", "'", x, fixed = TRUE)
x <- gsub(" ", " ", x, fixed = TRUE)
x <- gsub("&", "&", x, fixed = TRUE)
x <- gsub("[\r\n\t]+", " ", x)
x <- gsub("\\s+", " ", x)
trimws(x)
}
parse_simple_variable_list <- function(expression, available = NULL) {
if (identical(expression, quote(NULL))) return(character())
if (is.logical(expression) && length(expression) == 1L) return(if (isTRUE(expression) && !is.null(available)) available else character())
if (is.character(expression)) return(expression)
if (is.symbol(expression)) {
object_name <- as.character(expression)
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (is.logical(value) && length(value) == 1L) return(if (isTRUE(value) && !is.null(available)) available else character())
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
return(object_name)
}
if (is.call(expression) && as.character(expression[[1L]]) %in% c("c", "vars")) {
items <- as.list(expression)[-1L]
if (all(vapply(items, is.symbol, logical(1)))) {
values <- vapply(items, as.character, character(1))
values <- sub("^b[1-9][0-9]*\\.", "", values)
values <- sub("^[cqf]\\.", "", values)
return(values)
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
stop("The variable list could not be parsed.", call. = FALSE)
}
infer_metadata <- function(variable_names) {
variable_names <- unique(as.character(variable_names))
if (!length(variable_names)) {
output <- data.frame(variable = character(), type = character(), specification = character(), reference_index = integer(), stringsAsFactors = FALSE)
class(output) <- c("r4vn_vars", "data.frame")
return(output)
}
output <- vector("list", length(variable_names))
for (i in seq_along(variable_names)) {
variable <- variable_names[i]
if (!variable %in% names(data)) stop(sprintf("Model variable `%s` was not found in `data`.", variable), call. = FALSE)
table_index <- match(variable, vars$variable)
if (!is.na(table_index)) {
output[[i]] <- vars[table_index, , drop = FALSE]
} else {
x <- data[[variable]]
categorical <- is.factor(x) || is.character(x) || is.logical(x)
output[[i]] <- data.frame(variable = variable, type = if (categorical) "categorical" else "mean",
specification = variable, reference_index = if (categorical) 1L else NA_integer_,
stringsAsFactors = FALSE)
}
}
output <- do.call(rbind, output)
rownames(output) <- NULL
class(output) <- c("r4vn_vars", "data.frame")
output
}
parse_model_metadata <- function(expression) {
empty <- infer_metadata(character())
if (identical(expression, quote(NULL))) return(list(all = FALSE, meta = empty))
if (is.logical(expression) && length(expression) == 1L) return(list(all = isTRUE(expression), meta = if (isTRUE(expression)) vars else empty))
if (is.character(expression)) {
if (length(expression) == 1L && toupper(expression) == "ALL") return(list(all = TRUE, meta = vars))
return(list(all = FALSE, meta = infer_metadata(expression)))
}
if (is.symbol(expression)) {
object_name <- as.character(expression)
if (toupper(object_name) == "ALL") return(list(all = TRUE, meta = vars))
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(list(all = FALSE, meta = value))
if (is.logical(value) && length(value) == 1L && isTRUE(value)) return(list(all = TRUE, meta = vars))
if (is.character(value)) {
if (length(value) == 1L && toupper(value) == "ALL") return(list(all = TRUE, meta = vars))
return(list(all = FALSE, meta = infer_metadata(value)))
}
return(list(all = FALSE, meta = infer_metadata(object_name)))
}
if (is.call(expression) && identical(as.character(expression[[1L]]), "vars")) {
value <- eval(expression, envir = caller_env)
if (!inherits(value, "r4vn_vars")) stop("`vars(...)` did not create a valid variable specification.", call. = FALSE)
return(list(all = FALSE, meta = value))
}
if (is.call(expression) && identical(as.character(expression[[1L]]), "c")) {
items <- as.list(expression)[-1L]
if (all(vapply(items, is.symbol, logical(1)))) {
specifications <- vapply(items, as.character, character(1))
plain <- sub("^b[1-9][0-9]*\\.", "", specifications)
plain <- sub("^[cqf]\\.", "", plain)
return(list(all = FALSE, meta = infer_metadata(plain)))
}
value <- eval(expression, envir = caller_env)
if (is.character(value)) return(list(all = FALSE, meta = infer_metadata(value)))
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(list(all = FALSE, meta = value))
if (is.character(value)) return(list(all = FALSE, meta = infer_metadata(value)))
stop("Model variables must be NULL, TRUE, 'ALL', vars(...), c(...), or a character vector.", call. = FALSE)
}
categorical_variables <- vars$variable[vars$type == "categorical"]
reverse_rows <- parse_simple_variable_list(rvrow_expr, categorical_variables)
invalid_reverse_rows <- setdiff(reverse_rows, categorical_variables)
if (length(invalid_reverse_rows)) stop(sprintf("Invalid `rvrow` variables: %s.", paste(invalid_reverse_rows, collapse = ", ")), call. = FALSE)
resolve_model_meta <- function(meta, arg) {
if (is.null(meta) || !nrow(meta) || !inherits(meta, "r4vn_vars")) return(meta)
needs_resolution <- any(
meta$type == "default" | meta$variable == "." | grepl("*", meta$variable, fixed = TRUE)
)
if (!isTRUE(needs_resolution)) return(meta)
.r4vn_resolve_vars_input(meta, data = data, arg = arg, default_type = "auto", strict = TRUE)
}
adjustment <- parse_model_metadata(adjusted_expr)
adjust_all <- isTRUE(adjustment$all)
adjusted_meta <- resolve_model_meta(adjustment$meta, "adjusted")
if (adjust_all) adjusted_meta <- vars
if (anyDuplicated(adjusted_meta$variable)) adjusted_meta <- adjusted_meta[!duplicated(adjusted_meta$variable), , drop = FALSE]
if (outcome_name %in% adjusted_meta$variable) stop("The outcome variable cannot be included in `adjusted`.", call. = FALSE)
outside_adjusted <- setdiff(adjusted_meta$variable, names(data))
if (length(outside_adjusted)) stop(sprintf("Variables in `adjusted` were not found in `data`: %s.", paste(outside_adjusted, collapse = ", ")), call. = FALSE)
has_adjusted <- nrow(adjusted_meta) > 0L
multi_specification <- parse_model_metadata(multi_expr)
multi_all <- isTRUE(multi_specification$all)
multi_meta <- resolve_model_meta(multi_specification$meta, "multi")
if (multi_all) multi_meta <- vars
if (anyDuplicated(multi_meta$variable)) multi_meta <- multi_meta[!duplicated(multi_meta$variable), , drop = FALSE]
if (nrow(multi_meta)) {
if (outcome_name %in% multi_meta$variable) stop("The outcome variable cannot be included in `multi`.", call. = FALSE)
absent_multi <- setdiff(multi_meta$variable, names(data))
if (length(absent_multi)) stop(sprintf("Variables in `multi` were not found in `data`: %s.", paste(absent_multi, collapse = ", ")), call. = FALSE)
outside_table <- setdiff(multi_meta$variable, vars$variable)
if (length(outside_table)) stop(sprintf("Variables in `multi` must also appear in `vars`: %s.", paste(outside_table, collapse = ", ")), call. = FALSE)
}
has_multi <- nrow(multi_meta) > 0L
reference_for <- function(variable, levels_original, index_from_prefix) {
if (!is.null(effect_ref)) {
if (is.list(effect_ref) && !is.null(names(effect_ref)) && variable %in% names(effect_ref)) {
candidate <- as.character(effect_ref[[variable]])[1L]
if (candidate %in% levels_original) return(candidate)
}
if (is.atomic(effect_ref) && !is.null(names(effect_ref)) && variable %in% names(effect_ref)) {
candidate <- as.character(effect_ref[[variable]])[1L]
if (candidate %in% levels_original) return(candidate)
}
if (length(effect_ref) == 1L && as.character(effect_ref)[1L] %in% levels_original) return(as.character(effect_ref)[1L])
}
if (is.na(index_from_prefix) || index_from_prefix < 1L || index_from_prefix > length(levels_original)) {
stop(sprintf("The reference index is invalid for variable `%s`, which has %s observed levels.", variable, length(levels_original)), call. = FALSE)
}
as.character(levels_original[index_from_prefix])
}
combined_model_metadata <- function(focal_variable = NULL, extra_meta = NULL) {
meta <- vars
if (!is.null(extra_meta) && nrow(extra_meta)) meta <- rbind(meta, extra_meta)
meta <- meta[!duplicated(meta$variable, fromLast = TRUE), , drop = FALSE]
if (!is.null(focal_variable)) {
focal_index <- match(focal_variable, vars$variable)
if (!is.na(focal_index)) {
meta <- meta[meta$variable != focal_variable, , drop = FALSE]
meta <- rbind(vars[focal_index, , drop = FALSE], meta)
}
}
rownames(meta) <- NULL
meta
}
prepare_model_data <- function(model_variables, model_meta) {
model_variables <- unique(model_variables)
model_data <- data[c(outcome_name, model_variables)]
model_data$.outcome <- as.numeric(model_data[[outcome_name]])
keep <- is.finite(model_data$.outcome)
for (z in model_variables) {
meta_index <- match(z, model_meta$variable)
declared_type <- if (is.na(meta_index)) NULL else model_meta$type[meta_index]
if (!is.null(declared_type) && declared_type == "categorical") {
original <- get_levels(data[[z]], FALSE)
if (length(original) < 2L) return(NULL)
ref <- reference_for(z, original, model_meta$reference_index[meta_index])
model_data[[z]] <- factor(model_data[[z]], levels = original)
model_data[[z]] <- stats::relevel(model_data[[z]], ref = ref)
keep <- keep & !is.na(model_data[[z]])
} else if (!is.null(declared_type) && declared_type %in% c("mean", "median", "full")) {
model_data[[z]] <- suppressWarnings(as.numeric(model_data[[z]]))
keep <- keep & is.finite(model_data[[z]])
} else if (is.factor(model_data[[z]]) || is.character(model_data[[z]]) || is.logical(model_data[[z]])) {
model_data[[z]] <- factor(model_data[[z]])
keep <- keep & !is.na(model_data[[z]])
} else {
model_data[[z]] <- suppressWarnings(as.numeric(model_data[[z]]))
keep <- keep & is.finite(model_data[[z]])
}
}
model_data <- model_data[keep, c(".outcome", model_variables), drop = FALSE]
if (nrow(model_data) < max(3L, length(model_variables) + 2L)) return(NULL)
model_data
}
coefficient_terms_for <- function(fit, variable) {
X <- stats::model.matrix(fit)
assignment <- attr(X, "assign")
labels <- attr(stats::terms(fit), "term.labels")
clean_labels <- gsub("`", "", labels, fixed = TRUE)
position <- which(clean_labels == variable)
if (!length(position)) return(character())
colnames(X)[assignment %in% position]
}
extract_effects <- function(fit, selected_terms) {
beta <- stats::coef(fit)
covariance <- tryCatch(stats::vcov(fit), error = function(e) NULL)
if (is.null(covariance)) return(list())
selected_terms <- intersect(selected_terms, names(beta))
selected_terms <- selected_terms[selected_terms != "(Intercept)" & is.finite(beta[selected_terms])]
if (!length(selected_terms)) return(list())
beta <- beta[selected_terms]
covariance <- covariance[selected_terms, selected_terms, drop = FALSE]
se <- sqrt(diag(covariance))
valid <- is.finite(beta) & is.finite(se) & se > 0
beta <- beta[valid]
se <- se[valid]
selected_terms <- selected_terms[valid]
if (!length(beta)) return(list())
critical <- stats::qt(.975, df = stats::df.residual(fit))
lower <- beta - critical * se
upper <- beta + critical * se
p <- 2 * stats::pt(abs(beta / se), df = stats::df.residual(fit), lower.tail = FALSE)
output <- vector("list", length(beta))
names(output) <- selected_terms
for (j in seq_along(beta)) {
output[[j]] <- list(estimate = unname(beta[j]), lower = unname(lower[j]), upper = unname(upper[j]), p = unname(p[j]),
text = paste0(format_number(beta[j], effect_digit), " (", format_number(lower[j], effect_digit), " - ", format_number(upper[j], effect_digit), ")"))
}
output
}
model_effects <- function(predictor_name, categorical, reference = NULL, adjustment_metadata = NULL) {
if (is.null(adjustment_metadata)) adjustment_metadata <- adjusted_meta[0, , drop = FALSE]
model_variables <- unique(c(predictor_name, adjustment_metadata$variable))
model_variables <- setdiff(model_variables, outcome_name)
model_meta <- combined_model_metadata(predictor_name, adjustment_metadata)
model_data <- prepare_model_data(model_variables, model_meta)
if (is.null(model_data)) return(list())
if (!categorical) {
if (!is.finite(stats::sd(model_data[[predictor_name]])) || stats::sd(model_data[[predictor_name]]) == 0) return(list())
} else {
original <- get_levels(data[[predictor_name]], FALSE)
model_data[[predictor_name]] <- factor(model_data[[predictor_name]], levels = original)
model_data[[predictor_name]] <- stats::relevel(model_data[[predictor_name]], ref = reference)
}
formula <- stats::reformulate(model_variables, response = ".outcome")
fit <- tryCatch(stats::lm(formula, data = model_data), error = function(e) NULL)
if (is.null(fit)) return(list())
extract_effects(fit, coefficient_terms_for(fit, predictor_name))
}
find_category_effect <- function(effect_list, variable, level) {
if (!length(effect_list)) return(NULL)
original_names <- names(effect_list)
normalized_names <- gsub("`", "", original_names, fixed = TRUE)
candidate <- paste0(variable, level)
exact <- which(normalized_names == candidate)
if (length(exact) == 1L) return(effect_list[[exact]])
matches <- which(startsWith(normalized_names, variable) & endsWith(normalized_names, as.character(level)))
if (length(matches) == 1L) effect_list[[matches]] else NULL
}
find_numeric_effect <- function(effect_list, variable) {
if (!length(effect_list)) return(NULL)
normalized_names <- gsub("`", "", names(effect_list), fixed = TRUE)
index <- which(normalized_names == variable)
if (length(index) == 1L) effect_list[[index]] else NULL
}
numeric_test <- function(x) {
complete <- is.finite(x) & valid_y
if (sum(complete) < 3L || stats::sd(x[complete]) == 0 || stats::sd(y[complete]) == 0) return(list(p = NA_real_, method = NULL))
method <- if (outcome_mode == "mean") "pearson" else "spearman"
result <- tryCatch(suppressWarnings(stats::cor.test(x[complete], y[complete], method = method, exact = FALSE)), error = function(e) NULL)
list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = if (method == "pearson") "Pearson correlation test" else "Spearman rank correlation test")
}
categorical_test <- function(x) {
complete <- !is.na(x) & valid_y
g <- droplevels(factor(x[complete]))
yy <- y[complete]
if (nlevels(g) < 2L) return(list(p = NA_real_, method = NULL))
if (outcome_mode == "median") {
if (nlevels(g) == 2L) {
result <- tryCatch(stats::wilcox.test(yy ~ g, exact = FALSE), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = "Wilcoxon rank-sum test"))
}
result <- tryCatch(stats::kruskal.test(yy ~ g), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = "Kruskal-Wallis test"))
}
if (nlevels(g) == 2L) {
split_y <- split(yy, g)
equal_variance <- FALSE
if (all(vapply(split_y, length, integer(1)) >= 2L)) {
variance_result <- tryCatch(stats::var.test(split_y[[1L]], split_y[[2L]]), error = function(e) NULL)
equal_variance <- !is.null(variance_result) && is.finite(variance_result$p.value) && variance_result$p.value >= .05
}
result <- tryCatch(stats::t.test(yy ~ g, var.equal = equal_variance), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = if (equal_variance) "Student's t-test (equal variances)" else "Welch's t-test"))
}
p <- tryCatch(summary(stats::aov(yy ~ g))[[1L]][["Pr(>F)"]][1L], error = function(e) NA_real_)
list(p = unname(p), method = "One-way analysis of variance")
}
model_vif_range <- function(fit) {
X <- stats::model.matrix(fit)
X <- X[, colnames(X) != "(Intercept)", drop = FALSE]
if (ncol(X) < 2L) return(c(min = 1, max = 1))
variable_ok <- apply(X, 2L, function(z) is.finite(stats::sd(z)) && stats::sd(z) > 0)
X <- X[, variable_ok, drop = FALSE]
if (ncol(X) < 2L) return(c(min = 1, max = 1))
correlation <- suppressWarnings(stats::cor(X))
inverse <- tryCatch(solve(correlation), error = function(e) tryCatch(qr.solve(correlation), error = function(e2) NULL))
if (is.null(inverse)) return(c(min = NA_real_, max = NA_real_))
values <- diag(inverse)
values <- values[is.finite(values) & values >= 1]
if (!length(values)) return(c(min = NA_real_, max = NA_real_))
c(min = min(values), max = max(values))
}
breusch_pagan_test <- function(fit) {
X <- stats::model.matrix(fit)
X <- X[, colnames(X) != "(Intercept)", drop = FALSE]
if (!ncol(X)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
ok <- apply(X, 2L, function(z) is.finite(stats::sd(z)) && stats::sd(z) > 0)
X <- X[, ok, drop = FALSE]
if (!ncol(X)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
e2 <- stats::residuals(fit)^2
auxiliary <- tryCatch(stats::lm(e2 ~ X), error = function(e) NULL)
if (is.null(auxiliary)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
r2 <- summary(auxiliary)$r.squared
df <- max(1L, qr(cbind(1, X))$rank - 1L)
statistic <- length(e2) * r2
list(statistic = statistic, df = df, p = stats::pchisq(statistic, df = df, lower.tail = FALSE))
}
fit_multi_model <- function() {
if (!has_multi) return(NULL)
model_variables <- multi_meta$variable
model_meta <- combined_model_metadata(NULL, multi_meta)
model_data <- prepare_model_data(model_variables, model_meta)
if (is.null(model_data)) return(NULL)
formula <- stats::reformulate(model_variables, response = ".outcome")
fit <- tryCatch(stats::lm(formula, data = model_data), error = function(e) NULL)
if (is.null(fit)) return(NULL)
all_terms <- unlist(lapply(model_variables, function(z) coefficient_terms_for(fit, z)), use.names = FALSE)
effects <- extract_effects(fit, all_terms)
summary_fit <- summary(fit)
fstat <- summary_fit$fstatistic
overall_p <- if (is.null(fstat) || any(!is.finite(fstat))) NA_real_ else stats::pf(fstat[1L], fstat[2L], fstat[3L], lower.tail = FALSE)
bp <- breusch_pagan_test(fit)
diagnostics <- list(adjusted_r2 = unname(summary_fit$adj.r.squared), overall_p = unname(overall_p),
bp_statistic = bp$statistic, bp_df = bp$df, bp_p = bp$p,
vif = model_vif_range(fit), n = stats::nobs(fit))
list(fit = fit, effects = effects, diagnostics = diagnostics, metadata = multi_meta)
}
multi_model <- fit_multi_model()
make_row <- function(variable, label, item, type, kind, overall_value = NULL,
outcome_value = NULL, test_p = NA_real_, test_method = NULL,
crude = "", crude_p = NA_real_, adjusted = "",
adjusted_p = NA_real_, multi = "", multi_p = NA_real_,
variable_start = FALSE, raw_values = NULL) {
list(variable = variable, label = label, item = item, type = type, kind = kind,
overall_value = overall_value, outcome_value = outcome_value,
test_p = test_p, test_method = test_method, crude = crude, crude_p = crude_p,
adjusted = adjusted, adjusted_p = adjusted_p, multi = multi, multi_p = multi_p,
variable_start = variable_start, raw = raw_values)
}
table_rows <- list()
for (i in seq_len(nrow(vars))) {
variable <- vars$variable[i]
summary_type <- vars$type[i]
x <- data[[variable]]
base_label <- get_label(x, variable)
label <- display_label(base_label, variable)
omnibus <- list(p = NA_real_, method = NULL)
if (isTRUE(test)) omnibus <- if (summary_type == "categorical") categorical_test(x) else numeric_test(as.numeric(x))
focal_adjusted_meta <- adjusted_meta[adjusted_meta$variable != variable, , drop = FALSE]
variable_in_multi <- has_multi && variable %in% multi_meta$variable && !is.null(multi_model)
if (summary_type %in% c("mean", "median", "full")) {
if (!is.numeric(x)) stop(sprintf("Variable `%s` must be numeric.", variable), call. = FALSE)
crude_effects <- model_effects(variable, FALSE, adjustment_metadata = adjusted_meta[0, , drop = FALSE])
adjusted_effects <- if (has_adjusted) model_effects(variable, FALSE, adjustment_metadata = focal_adjusted_meta) else list()
crude_entry <- if (length(crude_effects)) crude_effects[[1L]] else NULL
adjusted_entry <- if (length(adjusted_effects)) adjusted_effects[[1L]] else NULL
multi_entry <- if (variable_in_multi) find_numeric_effect(multi_model$effects, variable) else NULL
if (summary_type == "full") {
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "", "numeric_header", "", test_p = omnibus$p,
test_method = omnibus$method, crude = if (is.null(crude_entry)) "" else crude_entry$text,
crude_p = if (is.null(crude_entry)) NA_real_ else crude_entry$p,
adjusted = if (is.null(adjusted_entry)) "" else adjusted_entry$text,
adjusted_p = if (is.null(adjusted_entry)) NA_real_ else adjusted_entry$p,
multi = if (is.null(multi_entry)) "" else multi_entry$text,
multi_p = if (is.null(multi_entry)) NA_real_ else multi_entry$p, variable_start = TRUE)
methods <- c("mean", "median", "range")
} else methods <- summary_type
for (method in methods) {
item <- if (summary_type == "full") switch(method, mean = "Mean (SD)", median = "Median (IQR)", range = "Range") else ""
shown_label <- if (summary_type == "mean") display_label(paste0(base_label, ", M (SD)"), variable) else if (summary_type == "median") display_label(paste0(base_label, ", Median (IQR)"), variable) else label
overall_value <- switch(method, mean = summarize_mean(x[valid_y]), median = summarize_median(x[valid_y]), range = summarize_range(x[valid_y]))
attach_model <- summary_type != "full"
table_rows[[length(table_rows) + 1L]] <- make_row(variable, shown_label, item,
if (summary_type == "full") "numeric_detail" else "numeric", method,
overall_value = overall_value, outcome_value = NULL,
test_p = if (attach_model) omnibus$p else NA_real_, test_method = if (attach_model) omnibus$method else NULL,
crude = if (attach_model && !is.null(crude_entry)) crude_entry$text else "",
crude_p = if (attach_model && !is.null(crude_entry)) crude_entry$p else NA_real_,
adjusted = if (attach_model && !is.null(adjusted_entry)) adjusted_entry$text else "",
adjusted_p = if (attach_model && !is.null(adjusted_entry)) adjusted_entry$p else NA_real_,
multi = if (attach_model && !is.null(multi_entry)) multi_entry$text else "",
multi_p = if (attach_model && !is.null(multi_entry)) multi_entry$p else NA_real_,
variable_start = attach_model, raw_values = list(values = x[valid_y]))
}
next
}
levels_original <- get_levels(x, FALSE)
if (!length(levels_original)) stop(sprintf("Categorical variable `%s` has no observed levels.", variable), call. = FALSE)
reference <- reference_for(variable, levels_original, vars$reference_index[i])
multi_reference <- NULL
if (variable_in_multi) {
multi_index <- match(variable, multi_meta$variable)
multi_reference <- reference_for(variable, levels_original, multi_meta$reference_index[multi_index])
}
levels_to_show <- get_levels(x, variable %in% reverse_rows)
crude_effects <- model_effects(variable, TRUE, reference, adjusted_meta[0, , drop = FALSE])
adjusted_effects <- if (has_adjusted) model_effects(variable, TRUE, reference, focal_adjusted_meta) else list()
multi_effects <- if (variable_in_multi) multi_model$effects else list()
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "", "categorical_header", "",
test_p = omnibus$p, test_method = omnibus$method, variable_start = TRUE)
variable_observed <- !is.na(x) & valid_y
denominator <- sum(variable_observed)
for (level_value in levels_to_show) {
level_mask <- !is.na(x) & x == level_value & valid_y
count <- sum(level_mask)
percent <- if (denominator > 0L) 100 * count / denominator else NA_real_
overall_value <- c(first = format_count(count), second = format_number(percent))
outcome_values <- y[level_mask]
outcome_value <- summarize_outcome(outcome_values)
crude_text <- adjusted_text <- multi_text <- ""
crude_p <- adjusted_p <- multi_p <- NA_real_
if (as.character(level_value) == reference) {
crude_text <- "Ref"
if (has_adjusted) adjusted_text <- "Ref"
} else {
crude_entry <- find_category_effect(crude_effects, variable, level_value)
adjusted_entry <- find_category_effect(adjusted_effects, variable, level_value)
if (!is.null(crude_entry)) { crude_text <- crude_entry$text; crude_p <- crude_entry$p }
if (!is.null(adjusted_entry)) { adjusted_text <- adjusted_entry$text; adjusted_p <- adjusted_entry$p }
}
if (variable_in_multi) {
if (as.character(level_value) == multi_reference) multi_text <- "Ref" else {
multi_entry <- find_category_effect(multi_effects, variable, level_value)
if (!is.null(multi_entry)) { multi_text <- multi_entry$text; multi_p <- multi_entry$p }
}
}
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, as.character(level_value), "categorical_level", "categorical",
overall_value = overall_value, outcome_value = outcome_value, crude = crude_text, crude_p = crude_p,
adjusted = adjusted_text, adjusted_p = adjusted_p, multi = multi_text, multi_p = multi_p,
raw_values = list(n = count, percent = percent, outcome = outcome_values))
}
missing_count <- sum(is.na(x) & valid_y)
include_missing <- identical(missing, "always") || (identical(missing, "ifany") && missing_count > 0L)
if (include_missing) {
percent <- if (sum(valid_y) > 0L) 100 * missing_count / sum(valid_y) else NA_real_
missing_y <- y[is.na(x) & valid_y]
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "Missing", "missing", "categorical",
overall_value = c(first = format_count(missing_count), second = format_number(percent)),
outcome_value = summarize_outcome(missing_y), raw_values = list(n = missing_count, percent = percent, outcome = missing_y))
}
}
tests_used <- unique(vapply(table_rows, function(z) if (is.null(z$test_method)) "" else z$test_method, character(1)))
tests_used <- tests_used[nzchar(tests_used)]
test_letters <- stats::setNames(c(letters, paste0("a", letters))[seq_along(tests_used)], tests_used)
outcome_label <- get_label(y, outcome_name)
outcome_summary_label <- if (outcome_mode == "mean") paste0(outcome_label, ", M (SD)") else paste0(outcome_label, ", Median (IQR)")
overall_outcome <- compact_value(summarize_outcome(y[valid_y]), "outcome")
result_columns <- list()
if (isTRUE(descriptive)) {
overall_header <- paste0("Overall<span class=\"header-n\">n = ", format_count(sum(valid_y)), "</span>")
outcome_header <- paste0(escape_html(outcome_summary_label), "<span class=\"header-n\">Overall = ", escape_html(overall_outcome), "; n = ", format_count(sum(valid_y)), "</span>")
if (overall == "first") result_columns <- list(list(type = "overall", label = "Overall", html = overall_header), list(type = "outcome", label = outcome_summary_label, html = outcome_header))
if (overall == "last") result_columns <- list(list(type = "outcome", label = outcome_summary_label, html = outcome_header), list(type = "overall", label = "Overall", html = overall_header))
if (overall == "none") result_columns <- list(list(type = "outcome", label = outcome_summary_label, html = outcome_header))
}
result_header_cells <- paste0("<th class=\"result-head\">", vapply(result_columns, `[[`, character(1), "html"), "</th>", collapse = "")
extra <- as.integer(test) + 1L + as.integer(pvalue) + as.integer(has_adjusted) + as.integer(has_adjusted && pvalue) + as.integer(has_multi) + as.integer(has_multi && pvalue)
header_html <- paste0("<thead><tr class=\"by-title\"><th></th><th colspan=\"", length(result_columns) + extra, "\">Continuous outcome: ",
escape_html(outcome_label), if (name) paste0(" <span class=\"variable-code\">[", escape_html(outcome_name), "]</span>") else "",
"</th></tr><tr><th>Characteristic</th>", result_header_cells,
if (test) "<th>Test p</th>" else "", "<th>Crude \u03b2 (95% CI)</th>", if (pvalue) "<th>p-value</th>" else "",
if (has_adjusted) "<th>Adjusted \u03b2 (95% CI)</th>" else "", if (has_adjusted && pvalue) "<th>p-value</th>" else "",
if (has_multi) "<th>Multivariable \u03b2 (95% CI)</th>" else "", if (has_multi && pvalue) "<th>p-value</th>" else "", "</tr></thead>")
body_html <- character(length(table_rows))
for (i in seq_along(table_rows)) {
current <- table_rows[[i]]
characteristic <- if (current$type %in% c("categorical_header", "numeric_header", "numeric")) paste0("<span class=\"variable-name\">", current$label, "</span>") else paste0("<span class=\"level-name", if (current$type == "missing") " missing-name" else "", "\">", escape_html(current$item), "</span>")
value_cells <- vapply(result_columns, function(column) {
value <- if (column$type == "overall") current$overall_value else current$outcome_value
text <- if (is.null(value) || current$type %in% c("categorical_header", "numeric_header") || (column$type == "outcome" && current$type %in% c("numeric", "numeric_detail"))) "" else compact_value(value, if (column$type == "outcome") "outcome" else current$kind)
paste0("<td class=\"result\">", escape_html(text), "</td>")
}, character(1))
test_cell <- if (test) {
p <- format_p(current$test_p)
if (nzchar(p) && test_note && !is.null(current$test_method)) p <- paste0(p, "<sup>", test_letters[[current$test_method]], "</sup>")
paste0("<td class=\"test-p\">", p, "</td>")
} else ""
crude_cell <- paste0("<td class=\"effect\">", escape_html(current$crude), "</td>")
crude_p_cell <- if (pvalue) paste0("<td class=\"effect-p\">", format_p(current$crude_p), "</td>") else ""
adjusted_cell <- if (has_adjusted) paste0("<td class=\"effect\">", escape_html(current$adjusted), "</td>") else ""
adjusted_p_cell <- if (has_adjusted && pvalue) paste0("<td class=\"effect-p\">", format_p(current$adjusted_p), "</td>") else ""
multi_cell <- if (has_multi) paste0("<td class=\"effect\">", escape_html(current$multi), "</td>") else ""
multi_p_cell <- if (has_multi && pvalue) paste0("<td class=\"effect-p\">", format_p(current$multi_p), "</td>") else ""
row_class <- paste0("row-", gsub("_", "-", current$type, fixed = TRUE), if (current$variable_start) " variable-start" else "")
body_html[i] <- paste0("<tr class=\"", row_class, "\"><td>", characteristic, "</td>", paste(value_cells, collapse = ""), test_cell, crude_cell, crude_p_cell, adjusted_cell, adjusted_p_cell, multi_cell, multi_p_cell, "</tr>")
}
descriptive_note <- if (isTRUE(descriptive)) paste0("<div class=\"table-note\">Categorical predictors are shown as n (%). Numeric predictor summaries follow their c., q., or f. declarations in vars(). The outcome is summarized as ", if (outcome_mode == "mean") "mean (SD)" else "median (IQR)", ". Observations with a missing or non-finite outcome are excluded.</div>") else ""
test_footnotes <- if (test && test_note && length(tests_used)) {
entries <- paste0("<sup>", unname(test_letters[tests_used]), "</sup> ", escape_html(tests_used))
paste0("<div class=\"test-note\">", paste(entries, collapse = "; "), ".</div>")
} else ""
adjustment_note <- if (has_adjusted) {
if (adjust_all) "Adjusted estimates include all other variables listed in the table." else paste0("Adjusted estimates include: ", paste(escape_html(adjusted_meta$specification), collapse = ", "), ".")
} else ""
effect_note <- paste0("<div class=\"effect-note\">\u03b2 is the unstandardized linear regression coefficient with 95% confidence interval. Categorical reference categories are marked Ref. Continuous estimates are reported per one-unit increase.", if (nzchar(adjustment_note)) paste0(" ", adjustment_note) else "", "</div>")
multi_note <- ""
if (has_multi && !is.null(multi_model)) {
diagnostics <- multi_model$diagnostics
vif_text <- if (all(is.finite(diagnostics$vif))) paste0(format_number(diagnostics$vif[1L], 2L), " - ", format_number(diagnostics$vif[2L], 2L)) else "not estimable"
r2_text <- if (is.finite(diagnostics$adjusted_r2)) format_number(diagnostics$adjusted_r2, 3L) else "not estimable"
f_text <- if (is.finite(diagnostics$overall_p)) paste0("p = ", clean_export_text(format_p(diagnostics$overall_p))) else "p not estimable"
bp_text <- if (is.finite(diagnostics$bp_p)) paste0("p = ", clean_export_text(format_p(diagnostics$bp_p))) else "p not estimable"
multi_note <- paste0("<div class=\"model-note\">Final multivariable linear model: ", paste(escape_html(multi_meta$specification), collapse = ", "),
". n = ", format_count(diagnostics$n), "; adjusted R\u00b2 = ", r2_text, "; overall F-test ", escape_html(f_text),
"; Breusch-Pagan ", escape_html(bp_text), "; coefficient-level VIF range = ", vif_text, ".</div>")
}
note_html <- paste0(descriptive_note, test_footnotes, effect_note, multi_note)
title_html <- if (is.null(title) || !nzchar(as.character(title)[1L])) "" else paste0("<div class=\"table-title\">", escape_html(as.character(title)[1L]), "</div>")
css <- switch(template,
journal = "body{font-family:'Times New Roman',Times,serif;background:#fff;color:#111;margin:18px}.table-title{font-size:18px;font-weight:700;margin:0 0 8px}table{border-collapse:collapse;width:auto;min-width:820px;border-top:2px solid #111;border-bottom:2px solid #111}th{padding:4px 9px;text-align:right;border-bottom:1.5px solid #111;font-weight:700;white-space:nowrap;background:#fff}th:first-child{text-align:left;min-width:260px}td{padding:3px 9px;vertical-align:top;border:0}tr.variable-start td{border-top:1px solid #aaa}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;border-bottom:1px solid #777}",
clean = "body{font-family:Arial,Helvetica,sans-serif;background:#fff;color:#111;margin:18px}.table-title{font-size:18px;font-weight:700;margin:0 0 8px}table{border-collapse:collapse;width:auto;min-width:820px;border-top:2px solid #222;border-bottom:2px solid #222}th{padding:6px 10px;text-align:right;border-bottom:1.5px solid #222;font-weight:700;white-space:nowrap;background:#f3f3f3}th:first-child{text-align:left;min-width:260px}td{padding:4px 10px;vertical-align:top;border-bottom:1px solid #ddd}tr.variable-start td{border-top:1px solid #999}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;background:#fff;border-bottom:1px solid #999}",
minimal = "body{font-family:Arial,Helvetica,sans-serif;background:#fff;color:#111;margin:18px}.table-title{font-size:17px;font-weight:700;margin:0 0 7px}table{border-collapse:collapse;width:auto;min-width:780px;border-top:1.5px solid #222;border-bottom:1.5px solid #222}th{padding:4px 8px;text-align:right;border-bottom:1px solid #555;font-weight:700;white-space:nowrap;background:#fff}th:first-child{text-align:left;min-width:240px}td{padding:3px 8px;vertical-align:top;border:0}tr.variable-start td{border-top:1px solid #ddd}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;border-bottom:1px solid #aaa}")
common_css <- ".table-wrapper{display:inline-block;max-width:100%;overflow-x:auto}.variable-name{font-weight:700}.variable-code{font-family:Consolas,monospace;font-size:.78em;color:#666;font-weight:400}.level-name{display:inline-block;padding-left:22px;white-space:nowrap}.missing-name{font-style:italic}.header-n{display:block;font-size:.78em;font-weight:400;text-align:right;margin-top:1px}.result-head{text-align:right}.table-note,.test-note,.effect-note,.model-note{font-size:12px;color:#333;margin-top:6px;line-height:1.35}.table-separator{height:24px}sup{font-size:.72em;vertical-align:super;margin-left:1px}"
table_block <- paste0("<section class=\"r4vn-table\">", title_html, "<table>", header_html, "<tbody>", paste(body_html, collapse = ""), "</tbody></table>", note_html, "</section>")
blocks <- table_block
if (inherits(append, "r4vn_tab")) blocks <- c(append$blocks, table_block)
document <- paste0("<!DOCTYPE html><html><head><meta charset=\"UTF-8\"><meta name=\"viewport\" content=\"width=device-width,initial-scale=1\"><style>", css, common_css, "</style></head><body><div class=\"table-wrapper\">", paste(blocks, collapse = "<div class=\"table-separator\"></div>"), "</div></body></html>")
if (is.null(file)) file <- tempfile(pattern = "r4vn-tab-", fileext = ".html")
if (!is.character(file) || length(file) != 1L || !nzchar(file)) stop("`file` must be a single valid file path.", call. = FALSE)
if (is.character(append) && length(append) == 1L && file.exists(append)) {
old <- paste(readLines(append, warn = FALSE, encoding = "UTF-8"), collapse = "\n")
if (grepl("</body>", old, fixed = TRUE)) {
document <- sub("</body>", paste0("<div class=\"table-separator\"></div>", table_block, "</body>"), old, fixed = TRUE)
file <- append
}
}
writeLines(enc2utf8(document), file, useBytes = TRUE)
raw_output <- if (isTRUE(raw)) lapply(table_rows, function(z) list(variable = z$variable, label = z$label, item = z$item,
type = z$type, overall = z$overall_value, outcome = z$outcome_value, test_p = z$test_p, test_method = z$test_method,
crude = z$crude, crude_p = z$crude_p, adjusted = z$adjusted, adjusted_p = z$adjusted_p,
multi = z$multi, multi_p = z$multi_p, values = z$raw)) else NULL
export_result_names <- if (length(result_columns)) vapply(result_columns, function(z) as.character(z$label), character(1)) else character()
export_column_names <- c("Characteristic", export_result_names)
if (test) export_column_names <- c(export_column_names, "Test p")
export_column_names <- c(export_column_names, "Crude \u03b2 (95% CI)")
if (pvalue) export_column_names <- c(export_column_names, "Crude p-value")
if (has_adjusted) export_column_names <- c(export_column_names, "Adjusted \u03b2 (95% CI)")
if (has_adjusted && pvalue) export_column_names <- c(export_column_names, "Adjusted p-value")
if (has_multi) export_column_names <- c(export_column_names, "Multivariable \u03b2 (95% CI)")
if (has_multi && pvalue) export_column_names <- c(export_column_names, "Multivariable p-value")
export_rows <- lapply(table_rows, function(current) {
characteristic <- if (current$type %in% c("categorical_header", "numeric_header", "numeric")) clean_export_text(current$label) else paste0(" ", clean_export_text(current$item))
values <- if (length(result_columns)) vapply(result_columns, function(column) {
value <- if (column$type == "overall") current$overall_value else current$outcome_value
if (is.null(value) || current$type %in% c("categorical_header", "numeric_header") || (column$type == "outcome" && current$type %in% c("numeric", "numeric_detail"))) "" else compact_value(value, if (column$type == "outcome") "outcome" else current$kind)
}, character(1)) else character()
output_row <- c(characteristic, values)
if (test) {
test_text <- clean_export_text(format_p(current$test_p))
if (nzchar(test_text) && test_note && !is.null(current$test_method) && length(test_letters)) {
letter <- unname(test_letters[current$test_method])
if (length(letter) && !is.na(letter) && nzchar(letter)) test_text <- paste0(test_text, " (", letter, ")")
}
output_row <- c(output_row, test_text)
}
output_row <- c(output_row, clean_export_text(current$crude))
if (pvalue) output_row <- c(output_row, clean_export_text(format_p(current$crude_p)))
if (has_adjusted) output_row <- c(output_row, clean_export_text(current$adjusted))
if (has_adjusted && pvalue) output_row <- c(output_row, clean_export_text(format_p(current$adjusted_p)))
if (has_multi) output_row <- c(output_row, clean_export_text(current$multi))
if (has_multi && pvalue) output_row <- c(output_row, clean_export_text(format_p(current$multi_p)))
output_row
})
if (length(export_rows)) table_df <- as.data.frame(do.call(rbind, export_rows), stringsAsFactors = FALSE, check.names = FALSE) else table_df <- as.data.frame(matrix(character(), nrow = 0L, ncol = length(export_column_names)), stringsAsFactors = FALSE, check.names = FALSE)
names(table_df) <- make.unique(export_column_names, sep = "_")
rownames(table_df) <- NULL
column_headers_html <- c(
if (length(result_columns)) vapply(result_columns, function(z) z$html, character(1)) else character(),
if (test) "Test p" else character(),
"Crude beta (95% CI)",
if (pvalue) "p-value" else character(),
if (has_adjusted) "Adjusted beta (95% CI)" else character(),
if (has_adjusted && pvalue) "p-value" else character(),
if (has_multi) "Multivariable beta (95% CI)" else character(),
if (has_multi && pvalue) "p-value" else character()
)
row_keys <- .r4vn_superby_row_keys(table_rows)
output <- list(data = table_df, rows = table_rows, row_keys = row_keys, raw = raw_output, metadata = vars, by = outcome_name,
by_specification = outcome_spec, outcome_type = "continuous", outcome_summary = outcome_mode,
by_levels = character(), effect_type = "BETA", event = NULL,
adjusted = adjusted_meta, adjusted_all = adjust_all, multi = multi_meta,
multi_model = if (is.null(multi_model)) NULL else multi_model$fit,
multi_diagnostics = if (is.null(multi_model)) NULL else multi_model$diagnostics,
descriptive = descriptive, html = document, table_html = table_block, note_html = note_html,
column_headers_html = column_headers_html, css = css, common_css = common_css, blocks = blocks,
file = normalizePath(file, winslash = "/", mustWork = TRUE), call = if (is.null(user_call)) match.call() else user_call)
class(output) <- "r4vn_tab"
if (show) {
viewer <- getOption("viewer")
if (is.function(viewer)) viewer(output$file) else utils::browseURL(output$file)
}
invisible(output)
}
Try the R4VN package in your browser
Any scripts or data that you put into this service are public.
R4VN documentation built on Sept. 30, 2026, 5:13 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .tab_continuous
#============================================================
# tabconti.R
# Internal engine used by tab() when by = c.outcome or q.outcome.
# This function is intentionally not exported. Users continue to call tab().
#============================================================
#' Internal Engine for Continuous Outcomes
#'
#' Internal function called automatically by \code{tab()} when the outcome is
#' declared as \code{by = c.outcome} or \code{by = q.outcome}. Users should
#' call \code{tab()} rather than this function directly.
#'
#' \code{c.outcome} uses mean (SD), t-tests/ANOVA, and Pearson correlation.
#' \code{q.outcome} uses median (IQR), Wilcoxon/Kruskal-Wallis tests, and
#' Spearman correlation. Both modes report unstandardized beta coefficients
#' from linear regression.
#'
#' @keywords internal
#' @noRd
.tab_continuous <- function(data, vars, outcome_spec, digit = 1, p_digit = 3,
effect_digit = 2, missing = "ifany", overall = "first",
descriptive = TRUE, rvrow_expr = quote(NULL), test = TRUE,
pvalue = TRUE, bold_p = TRUE, p_bold = 0.05,
test_note = TRUE, or = FALSE, rr = FALSE, pr = FALSE,
event = NULL, adjusted_expr = quote(NULL),
multi_expr = quote(NULL), effect_ref = NULL,
template = c("journal", "clean", "minimal"),
append = NULL, file = NULL, raw = FALSE,
name = FALSE, title = NULL, show = TRUE,
caller_env = parent.frame(), user_call = NULL) {
if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)
if (!inherits(vars, "r4vn_vars")) stop("`vars` must be created using `vars()`.", call. = FALSE)
if (!is.character(outcome_spec) || length(outcome_spec) != 1L || !grepl("^[cq]\\.", outcome_spec)) {
stop("A continuous outcome must be declared as `by = c.outcome` or `by = q.outcome`.", call. = FALSE)
}
if (any(c(or, rr, pr))) stop("`or`, `rr`, and `pr` are not applicable to a continuous outcome.", call. = FALSE)
if (!is.null(event)) warning("`event` is ignored because the outcome is continuous.", call. = FALSE)
outcome_mode <- if (startsWith(outcome_spec, "c.")) "mean" else "median"
outcome_name <- sub("^[cq]\\.", "", outcome_spec)
if (!nzchar(outcome_name)) stop("The `c.` or `q.` prefix must be followed by an outcome variable name.", call. = FALSE)
if (!outcome_name %in% names(data)) stop(sprintf("Outcome variable `%s` was not found in `data`.", outcome_name), call. = FALSE)
y <- data[[outcome_name]]
if (!is.numeric(y)) stop(sprintf("Continuous outcome `%s` must be numeric.", outcome_name), call. = FALSE)
valid_y <- is.finite(y)
if (sum(valid_y) < 3L) stop("The continuous outcome must contain at least three finite observations.", call. = FALSE)
missing <- match.arg(missing, c("no", "ifany", "always"))
template <- match.arg(template)
if (is.logical(overall) && length(overall) == 1L && !is.na(overall)) overall <- if (overall) "first" else "none"
overall <- match.arg(overall, c("none", "first", "last"))
duplicated_variables <- unique(vars$variable[duplicated(vars$variable)])
if (length(duplicated_variables)) stop(sprintf("Duplicated variable specification: %s.", paste(duplicated_variables, collapse = ", ")), call. = FALSE)
absent_variables <- setdiff(vars$variable, names(data))
if (length(absent_variables)) stop(sprintf("Variables not found in `data`: %s.", paste(absent_variables, collapse = ", ")), call. = FALSE)
if (outcome_name %in% vars$variable) stop("The continuous outcome cannot also be included in `vars`.", call. = FALSE)
escape_html <- function(x) {
x <- as.character(x)
x <- gsub("&", "&", x, fixed = TRUE)
x <- gsub("<", "<", x, fixed = TRUE)
x <- gsub(">", ">", x, fixed = TRUE)
x <- gsub('"', """, x, fixed = TRUE)
gsub("'", "'", x, fixed = TRUE)
}
format_number <- function(x, digits = digit) {
if (!length(x) || is.na(x) || !is.finite(x)) return("")
formatC(x, format = "f", digits = digits, big.mark = ",")
}
format_count <- function(x) {
if (!length(x) || is.na(x)) return("")
format(x, big.mark = ",", scientific = FALSE, trim = TRUE)
}
format_p <- function(x) {
if (!length(x) || is.na(x) || !is.finite(x)) return("")
limit <- 10^(-p_digit)
text <- if (x < limit) paste0("<", formatC(limit, format = "f", digits = p_digit)) else formatC(x, format = "f", digits = p_digit)
if (isTRUE(bold_p) && x < p_bold) paste0("<strong>", text, "</strong>") else text
}
get_label <- function(x, variable) {
label <- attr(x, "label", exact = TRUE)
if (is.null(label) || !length(label) || is.na(label[1L]) || !nzchar(as.character(label[1L]))) variable else as.character(label[1L])
}
display_label <- function(label, variable) {
if (!isTRUE(name)) return(escape_html(label))
paste0(escape_html(label), " <span class=\"variable-code\">[", escape_html(variable), "]</span>")
}
get_levels <- function(x, reverse = FALSE) {
observed <- x[!is.na(x)]
values <- if (is.factor(x)) levels(x) else if (is.logical(x)) c(FALSE, TRUE) else {
z <- unique(observed)
if (is.numeric(z)) sort(z) else z
}
values <- values[values %in% observed]
if (reverse) rev(values) else values
}
summarize_mean <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
c(first = format_number(mean(x)), second = format_number(if (length(x) > 1L) stats::sd(x) else NA_real_))
}
summarize_median <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
q <- stats::quantile(x, c(.25, .5, .75), names = FALSE, type = 7)
c(first = format_number(q[2L]), second = paste0(format_number(q[1L]), " - ", format_number(q[3L])))
}
summarize_range <- function(x) {
x <- x[is.finite(x)]
if (!length(x)) return(c(first = "", second = ""))
c(first = format_number(min(x)), second = format_number(max(x)))
}
summarize_outcome <- function(x) if (outcome_mode == "mean") summarize_mean(x) else summarize_median(x)
compact_value <- function(z, kind) {
if (is.null(z) || !length(z)) return("")
if (kind %in% c("categorical", "mean", "median", "outcome")) return(if (nzchar(z["first"])) paste0(z["first"], " (", z["second"], ")") else "")
if (kind == "range") return(if (nzchar(z["first"])) paste0(z["first"], " - ", z["second"]) else "")
""
}
clean_export_text <- function(x) {
x <- as.character(x)
x <- gsub("<br\\s*/?>", " ", x, ignore.case = TRUE)
x <- gsub("<[^>]+>", "", x)
x <- gsub("<", "<", x, fixed = TRUE)
x <- gsub(">", ">", x, fixed = TRUE)
x <- gsub(""", "\"", x, fixed = TRUE)
x <- gsub("'", "'", x, fixed = TRUE)
x <- gsub(" ", " ", x, fixed = TRUE)
x <- gsub("&", "&", x, fixed = TRUE)
x <- gsub("[\r\n\t]+", " ", x)
x <- gsub("\\s+", " ", x)
trimws(x)
}
parse_simple_variable_list <- function(expression, available = NULL) {
if (identical(expression, quote(NULL))) return(character())
if (is.logical(expression) && length(expression) == 1L) return(if (isTRUE(expression) && !is.null(available)) available else character())
if (is.character(expression)) return(expression)
if (is.symbol(expression)) {
object_name <- as.character(expression)
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (is.logical(value) && length(value) == 1L) return(if (isTRUE(value) && !is.null(available)) available else character())
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
return(object_name)
}
if (is.call(expression) && as.character(expression[[1L]]) %in% c("c", "vars")) {
items <- as.list(expression)[-1L]
if (all(vapply(items, is.symbol, logical(1)))) {
values <- vapply(items, as.character, character(1))
values <- sub("^b[1-9][0-9]*\\.", "", values)
values <- sub("^[cqf]\\.", "", values)
return(values)
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(value$variable)
if (is.character(value)) return(value)
stop("The variable list could not be parsed.", call. = FALSE)
}
infer_metadata <- function(variable_names) {
variable_names <- unique(as.character(variable_names))
if (!length(variable_names)) {
output <- data.frame(variable = character(), type = character(), specification = character(), reference_index = integer(), stringsAsFactors = FALSE)
class(output) <- c("r4vn_vars", "data.frame")
return(output)
}
output <- vector("list", length(variable_names))
for (i in seq_along(variable_names)) {
variable <- variable_names[i]
if (!variable %in% names(data)) stop(sprintf("Model variable `%s` was not found in `data`.", variable), call. = FALSE)
table_index <- match(variable, vars$variable)
if (!is.na(table_index)) {
output[[i]] <- vars[table_index, , drop = FALSE]
} else {
x <- data[[variable]]
categorical <- is.factor(x) || is.character(x) || is.logical(x)
output[[i]] <- data.frame(variable = variable, type = if (categorical) "categorical" else "mean",
specification = variable, reference_index = if (categorical) 1L else NA_integer_,
stringsAsFactors = FALSE)
}
}
output <- do.call(rbind, output)
rownames(output) <- NULL
class(output) <- c("r4vn_vars", "data.frame")
output
}
parse_model_metadata <- function(expression) {
empty <- infer_metadata(character())
if (identical(expression, quote(NULL))) return(list(all = FALSE, meta = empty))
if (is.logical(expression) && length(expression) == 1L) return(list(all = isTRUE(expression), meta = if (isTRUE(expression)) vars else empty))
if (is.character(expression)) {
if (length(expression) == 1L && toupper(expression) == "ALL") return(list(all = TRUE, meta = vars))
return(list(all = FALSE, meta = infer_metadata(expression)))
}
if (is.symbol(expression)) {
object_name <- as.character(expression)
if (toupper(object_name) == "ALL") return(list(all = TRUE, meta = vars))
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(list(all = FALSE, meta = value))
if (is.logical(value) && length(value) == 1L && isTRUE(value)) return(list(all = TRUE, meta = vars))
if (is.character(value)) {
if (length(value) == 1L && toupper(value) == "ALL") return(list(all = TRUE, meta = vars))
return(list(all = FALSE, meta = infer_metadata(value)))
}
return(list(all = FALSE, meta = infer_metadata(object_name)))
}
if (is.call(expression) && identical(as.character(expression[[1L]]), "vars")) {
value <- eval(expression, envir = caller_env)
if (!inherits(value, "r4vn_vars")) stop("`vars(...)` did not create a valid variable specification.", call. = FALSE)
return(list(all = FALSE, meta = value))
}
if (is.call(expression) && identical(as.character(expression[[1L]]), "c")) {
items <- as.list(expression)[-1L]
if (all(vapply(items, is.symbol, logical(1)))) {
specifications <- vapply(items, as.character, character(1))
plain <- sub("^b[1-9][0-9]*\\.", "", specifications)
plain <- sub("^[cqf]\\.", "", plain)
return(list(all = FALSE, meta = infer_metadata(plain)))
}
value <- eval(expression, envir = caller_env)
if (is.character(value)) return(list(all = FALSE, meta = infer_metadata(value)))
}
value <- tryCatch(eval(expression, envir = caller_env), error = function(e) NULL)
if (inherits(value, "r4vn_vars")) return(list(all = FALSE, meta = value))
if (is.character(value)) return(list(all = FALSE, meta = infer_metadata(value)))
stop("Model variables must be NULL, TRUE, 'ALL', vars(...), c(...), or a character vector.", call. = FALSE)
}
categorical_variables <- vars$variable[vars$type == "categorical"]
reverse_rows <- parse_simple_variable_list(rvrow_expr, categorical_variables)
invalid_reverse_rows <- setdiff(reverse_rows, categorical_variables)
if (length(invalid_reverse_rows)) stop(sprintf("Invalid `rvrow` variables: %s.", paste(invalid_reverse_rows, collapse = ", ")), call. = FALSE)
resolve_model_meta <- function(meta, arg) {
if (is.null(meta) || !nrow(meta) || !inherits(meta, "r4vn_vars")) return(meta)
needs_resolution <- any(
meta$type == "default" | meta$variable == "." | grepl("*", meta$variable, fixed = TRUE)
)
if (!isTRUE(needs_resolution)) return(meta)
.r4vn_resolve_vars_input(meta, data = data, arg = arg, default_type = "auto", strict = TRUE)
}
adjustment <- parse_model_metadata(adjusted_expr)
adjust_all <- isTRUE(adjustment$all)
adjusted_meta <- resolve_model_meta(adjustment$meta, "adjusted")
if (adjust_all) adjusted_meta <- vars
if (anyDuplicated(adjusted_meta$variable)) adjusted_meta <- adjusted_meta[!duplicated(adjusted_meta$variable), , drop = FALSE]
if (outcome_name %in% adjusted_meta$variable) stop("The outcome variable cannot be included in `adjusted`.", call. = FALSE)
outside_adjusted <- setdiff(adjusted_meta$variable, names(data))
if (length(outside_adjusted)) stop(sprintf("Variables in `adjusted` were not found in `data`: %s.", paste(outside_adjusted, collapse = ", ")), call. = FALSE)
has_adjusted <- nrow(adjusted_meta) > 0L
multi_specification <- parse_model_metadata(multi_expr)
multi_all <- isTRUE(multi_specification$all)
multi_meta <- resolve_model_meta(multi_specification$meta, "multi")
if (multi_all) multi_meta <- vars
if (anyDuplicated(multi_meta$variable)) multi_meta <- multi_meta[!duplicated(multi_meta$variable), , drop = FALSE]
if (nrow(multi_meta)) {
if (outcome_name %in% multi_meta$variable) stop("The outcome variable cannot be included in `multi`.", call. = FALSE)
absent_multi <- setdiff(multi_meta$variable, names(data))
if (length(absent_multi)) stop(sprintf("Variables in `multi` were not found in `data`: %s.", paste(absent_multi, collapse = ", ")), call. = FALSE)
outside_table <- setdiff(multi_meta$variable, vars$variable)
if (length(outside_table)) stop(sprintf("Variables in `multi` must also appear in `vars`: %s.", paste(outside_table, collapse = ", ")), call. = FALSE)
}
has_multi <- nrow(multi_meta) > 0L
reference_for <- function(variable, levels_original, index_from_prefix) {
if (!is.null(effect_ref)) {
if (is.list(effect_ref) && !is.null(names(effect_ref)) && variable %in% names(effect_ref)) {
candidate <- as.character(effect_ref[[variable]])[1L]
if (candidate %in% levels_original) return(candidate)
}
if (is.atomic(effect_ref) && !is.null(names(effect_ref)) && variable %in% names(effect_ref)) {
candidate <- as.character(effect_ref[[variable]])[1L]
if (candidate %in% levels_original) return(candidate)
}
if (length(effect_ref) == 1L && as.character(effect_ref)[1L] %in% levels_original) return(as.character(effect_ref)[1L])
}
if (is.na(index_from_prefix) || index_from_prefix < 1L || index_from_prefix > length(levels_original)) {
stop(sprintf("The reference index is invalid for variable `%s`, which has %s observed levels.", variable, length(levels_original)), call. = FALSE)
}
as.character(levels_original[index_from_prefix])
}
combined_model_metadata <- function(focal_variable = NULL, extra_meta = NULL) {
meta <- vars
if (!is.null(extra_meta) && nrow(extra_meta)) meta <- rbind(meta, extra_meta)
meta <- meta[!duplicated(meta$variable, fromLast = TRUE), , drop = FALSE]
if (!is.null(focal_variable)) {
focal_index <- match(focal_variable, vars$variable)
if (!is.na(focal_index)) {
meta <- meta[meta$variable != focal_variable, , drop = FALSE]
meta <- rbind(vars[focal_index, , drop = FALSE], meta)
}
}
rownames(meta) <- NULL
meta
}
prepare_model_data <- function(model_variables, model_meta) {
model_variables <- unique(model_variables)
model_data <- data[c(outcome_name, model_variables)]
model_data$.outcome <- as.numeric(model_data[[outcome_name]])
keep <- is.finite(model_data$.outcome)
for (z in model_variables) {
meta_index <- match(z, model_meta$variable)
declared_type <- if (is.na(meta_index)) NULL else model_meta$type[meta_index]
if (!is.null(declared_type) && declared_type == "categorical") {
original <- get_levels(data[[z]], FALSE)
if (length(original) < 2L) return(NULL)
ref <- reference_for(z, original, model_meta$reference_index[meta_index])
model_data[[z]] <- factor(model_data[[z]], levels = original)
model_data[[z]] <- stats::relevel(model_data[[z]], ref = ref)
keep <- keep & !is.na(model_data[[z]])
} else if (!is.null(declared_type) && declared_type %in% c("mean", "median", "full")) {
model_data[[z]] <- suppressWarnings(as.numeric(model_data[[z]]))
keep <- keep & is.finite(model_data[[z]])
} else if (is.factor(model_data[[z]]) || is.character(model_data[[z]]) || is.logical(model_data[[z]])) {
model_data[[z]] <- factor(model_data[[z]])
keep <- keep & !is.na(model_data[[z]])
} else {
model_data[[z]] <- suppressWarnings(as.numeric(model_data[[z]]))
keep <- keep & is.finite(model_data[[z]])
}
}
model_data <- model_data[keep, c(".outcome", model_variables), drop = FALSE]
if (nrow(model_data) < max(3L, length(model_variables) + 2L)) return(NULL)
model_data
}
coefficient_terms_for <- function(fit, variable) {
X <- stats::model.matrix(fit)
assignment <- attr(X, "assign")
labels <- attr(stats::terms(fit), "term.labels")
clean_labels <- gsub("`", "", labels, fixed = TRUE)
position <- which(clean_labels == variable)
if (!length(position)) return(character())
colnames(X)[assignment %in% position]
}
extract_effects <- function(fit, selected_terms) {
beta <- stats::coef(fit)
covariance <- tryCatch(stats::vcov(fit), error = function(e) NULL)
if (is.null(covariance)) return(list())
selected_terms <- intersect(selected_terms, names(beta))
selected_terms <- selected_terms[selected_terms != "(Intercept)" & is.finite(beta[selected_terms])]
if (!length(selected_terms)) return(list())
beta <- beta[selected_terms]
covariance <- covariance[selected_terms, selected_terms, drop = FALSE]
se <- sqrt(diag(covariance))
valid <- is.finite(beta) & is.finite(se) & se > 0
beta <- beta[valid]
se <- se[valid]
selected_terms <- selected_terms[valid]
if (!length(beta)) return(list())
critical <- stats::qt(.975, df = stats::df.residual(fit))
lower <- beta - critical * se
upper <- beta + critical * se
p <- 2 * stats::pt(abs(beta / se), df = stats::df.residual(fit), lower.tail = FALSE)
output <- vector("list", length(beta))
names(output) <- selected_terms
for (j in seq_along(beta)) {
output[[j]] <- list(estimate = unname(beta[j]), lower = unname(lower[j]), upper = unname(upper[j]), p = unname(p[j]),
text = paste0(format_number(beta[j], effect_digit), " (", format_number(lower[j], effect_digit), " - ", format_number(upper[j], effect_digit), ")"))
}
output
}
model_effects <- function(predictor_name, categorical, reference = NULL, adjustment_metadata = NULL) {
if (is.null(adjustment_metadata)) adjustment_metadata <- adjusted_meta[0, , drop = FALSE]
model_variables <- unique(c(predictor_name, adjustment_metadata$variable))
model_variables <- setdiff(model_variables, outcome_name)
model_meta <- combined_model_metadata(predictor_name, adjustment_metadata)
model_data <- prepare_model_data(model_variables, model_meta)
if (is.null(model_data)) return(list())
if (!categorical) {
if (!is.finite(stats::sd(model_data[[predictor_name]])) || stats::sd(model_data[[predictor_name]]) == 0) return(list())
} else {
original <- get_levels(data[[predictor_name]], FALSE)
model_data[[predictor_name]] <- factor(model_data[[predictor_name]], levels = original)
model_data[[predictor_name]] <- stats::relevel(model_data[[predictor_name]], ref = reference)
}
formula <- stats::reformulate(model_variables, response = ".outcome")
fit <- tryCatch(stats::lm(formula, data = model_data), error = function(e) NULL)
if (is.null(fit)) return(list())
extract_effects(fit, coefficient_terms_for(fit, predictor_name))
}
find_category_effect <- function(effect_list, variable, level) {
if (!length(effect_list)) return(NULL)
original_names <- names(effect_list)
normalized_names <- gsub("`", "", original_names, fixed = TRUE)
candidate <- paste0(variable, level)
exact <- which(normalized_names == candidate)
if (length(exact) == 1L) return(effect_list[[exact]])
matches <- which(startsWith(normalized_names, variable) & endsWith(normalized_names, as.character(level)))
if (length(matches) == 1L) effect_list[[matches]] else NULL
}
find_numeric_effect <- function(effect_list, variable) {
if (!length(effect_list)) return(NULL)
normalized_names <- gsub("`", "", names(effect_list), fixed = TRUE)
index <- which(normalized_names == variable)
if (length(index) == 1L) effect_list[[index]] else NULL
}
numeric_test <- function(x) {
complete <- is.finite(x) & valid_y
if (sum(complete) < 3L || stats::sd(x[complete]) == 0 || stats::sd(y[complete]) == 0) return(list(p = NA_real_, method = NULL))
method <- if (outcome_mode == "mean") "pearson" else "spearman"
result <- tryCatch(suppressWarnings(stats::cor.test(x[complete], y[complete], method = method, exact = FALSE)), error = function(e) NULL)
list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = if (method == "pearson") "Pearson correlation test" else "Spearman rank correlation test")
}
categorical_test <- function(x) {
complete <- !is.na(x) & valid_y
g <- droplevels(factor(x[complete]))
yy <- y[complete]
if (nlevels(g) < 2L) return(list(p = NA_real_, method = NULL))
if (outcome_mode == "median") {
if (nlevels(g) == 2L) {
result <- tryCatch(stats::wilcox.test(yy ~ g, exact = FALSE), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = "Wilcoxon rank-sum test"))
}
result <- tryCatch(stats::kruskal.test(yy ~ g), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = "Kruskal-Wallis test"))
}
if (nlevels(g) == 2L) {
split_y <- split(yy, g)
equal_variance <- FALSE
if (all(vapply(split_y, length, integer(1)) >= 2L)) {
variance_result <- tryCatch(stats::var.test(split_y[[1L]], split_y[[2L]]), error = function(e) NULL)
equal_variance <- !is.null(variance_result) && is.finite(variance_result$p.value) && variance_result$p.value >= .05
}
result <- tryCatch(stats::t.test(yy ~ g, var.equal = equal_variance), error = function(e) NULL)
return(list(p = if (is.null(result)) NA_real_ else unname(result$p.value), method = if (equal_variance) "Student's t-test (equal variances)" else "Welch's t-test"))
}
p <- tryCatch(summary(stats::aov(yy ~ g))[[1L]][["Pr(>F)"]][1L], error = function(e) NA_real_)
list(p = unname(p), method = "One-way analysis of variance")
}
model_vif_range <- function(fit) {
X <- stats::model.matrix(fit)
X <- X[, colnames(X) != "(Intercept)", drop = FALSE]
if (ncol(X) < 2L) return(c(min = 1, max = 1))
variable_ok <- apply(X, 2L, function(z) is.finite(stats::sd(z)) && stats::sd(z) > 0)
X <- X[, variable_ok, drop = FALSE]
if (ncol(X) < 2L) return(c(min = 1, max = 1))
correlation <- suppressWarnings(stats::cor(X))
inverse <- tryCatch(solve(correlation), error = function(e) tryCatch(qr.solve(correlation), error = function(e2) NULL))
if (is.null(inverse)) return(c(min = NA_real_, max = NA_real_))
values <- diag(inverse)
values <- values[is.finite(values) & values >= 1]
if (!length(values)) return(c(min = NA_real_, max = NA_real_))
c(min = min(values), max = max(values))
}
breusch_pagan_test <- function(fit) {
X <- stats::model.matrix(fit)
X <- X[, colnames(X) != "(Intercept)", drop = FALSE]
if (!ncol(X)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
ok <- apply(X, 2L, function(z) is.finite(stats::sd(z)) && stats::sd(z) > 0)
X <- X[, ok, drop = FALSE]
if (!ncol(X)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
e2 <- stats::residuals(fit)^2
auxiliary <- tryCatch(stats::lm(e2 ~ X), error = function(e) NULL)
if (is.null(auxiliary)) return(list(statistic = NA_real_, df = NA_integer_, p = NA_real_))
r2 <- summary(auxiliary)$r.squared
df <- max(1L, qr(cbind(1, X))$rank - 1L)
statistic <- length(e2) * r2
list(statistic = statistic, df = df, p = stats::pchisq(statistic, df = df, lower.tail = FALSE))
}
fit_multi_model <- function() {
if (!has_multi) return(NULL)
model_variables <- multi_meta$variable
model_meta <- combined_model_metadata(NULL, multi_meta)
model_data <- prepare_model_data(model_variables, model_meta)
if (is.null(model_data)) return(NULL)
formula <- stats::reformulate(model_variables, response = ".outcome")
fit <- tryCatch(stats::lm(formula, data = model_data), error = function(e) NULL)
if (is.null(fit)) return(NULL)
all_terms <- unlist(lapply(model_variables, function(z) coefficient_terms_for(fit, z)), use.names = FALSE)
effects <- extract_effects(fit, all_terms)
summary_fit <- summary(fit)
fstat <- summary_fit$fstatistic
overall_p <- if (is.null(fstat) || any(!is.finite(fstat))) NA_real_ else stats::pf(fstat[1L], fstat[2L], fstat[3L], lower.tail = FALSE)
bp <- breusch_pagan_test(fit)
diagnostics <- list(adjusted_r2 = unname(summary_fit$adj.r.squared), overall_p = unname(overall_p),
bp_statistic = bp$statistic, bp_df = bp$df, bp_p = bp$p,
vif = model_vif_range(fit), n = stats::nobs(fit))
list(fit = fit, effects = effects, diagnostics = diagnostics, metadata = multi_meta)
}
multi_model <- fit_multi_model()
make_row <- function(variable, label, item, type, kind, overall_value = NULL,
outcome_value = NULL, test_p = NA_real_, test_method = NULL,
crude = "", crude_p = NA_real_, adjusted = "",
adjusted_p = NA_real_, multi = "", multi_p = NA_real_,
variable_start = FALSE, raw_values = NULL) {
list(variable = variable, label = label, item = item, type = type, kind = kind,
overall_value = overall_value, outcome_value = outcome_value,
test_p = test_p, test_method = test_method, crude = crude, crude_p = crude_p,
adjusted = adjusted, adjusted_p = adjusted_p, multi = multi, multi_p = multi_p,
variable_start = variable_start, raw = raw_values)
}
table_rows <- list()
for (i in seq_len(nrow(vars))) {
variable <- vars$variable[i]
summary_type <- vars$type[i]
x <- data[[variable]]
base_label <- get_label(x, variable)
label <- display_label(base_label, variable)
omnibus <- list(p = NA_real_, method = NULL)
if (isTRUE(test)) omnibus <- if (summary_type == "categorical") categorical_test(x) else numeric_test(as.numeric(x))
focal_adjusted_meta <- adjusted_meta[adjusted_meta$variable != variable, , drop = FALSE]
variable_in_multi <- has_multi && variable %in% multi_meta$variable && !is.null(multi_model)
if (summary_type %in% c("mean", "median", "full")) {
if (!is.numeric(x)) stop(sprintf("Variable `%s` must be numeric.", variable), call. = FALSE)
crude_effects <- model_effects(variable, FALSE, adjustment_metadata = adjusted_meta[0, , drop = FALSE])
adjusted_effects <- if (has_adjusted) model_effects(variable, FALSE, adjustment_metadata = focal_adjusted_meta) else list()
crude_entry <- if (length(crude_effects)) crude_effects[[1L]] else NULL
adjusted_entry <- if (length(adjusted_effects)) adjusted_effects[[1L]] else NULL
multi_entry <- if (variable_in_multi) find_numeric_effect(multi_model$effects, variable) else NULL
if (summary_type == "full") {
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "", "numeric_header", "", test_p = omnibus$p,
test_method = omnibus$method, crude = if (is.null(crude_entry)) "" else crude_entry$text,
crude_p = if (is.null(crude_entry)) NA_real_ else crude_entry$p,
adjusted = if (is.null(adjusted_entry)) "" else adjusted_entry$text,
adjusted_p = if (is.null(adjusted_entry)) NA_real_ else adjusted_entry$p,
multi = if (is.null(multi_entry)) "" else multi_entry$text,
multi_p = if (is.null(multi_entry)) NA_real_ else multi_entry$p, variable_start = TRUE)
methods <- c("mean", "median", "range")
} else methods <- summary_type
for (method in methods) {
item <- if (summary_type == "full") switch(method, mean = "Mean (SD)", median = "Median (IQR)", range = "Range") else ""
shown_label <- if (summary_type == "mean") display_label(paste0(base_label, ", M (SD)"), variable) else if (summary_type == "median") display_label(paste0(base_label, ", Median (IQR)"), variable) else label
overall_value <- switch(method, mean = summarize_mean(x[valid_y]), median = summarize_median(x[valid_y]), range = summarize_range(x[valid_y]))
attach_model <- summary_type != "full"
table_rows[[length(table_rows) + 1L]] <- make_row(variable, shown_label, item,
if (summary_type == "full") "numeric_detail" else "numeric", method,
overall_value = overall_value, outcome_value = NULL,
test_p = if (attach_model) omnibus$p else NA_real_, test_method = if (attach_model) omnibus$method else NULL,
crude = if (attach_model && !is.null(crude_entry)) crude_entry$text else "",
crude_p = if (attach_model && !is.null(crude_entry)) crude_entry$p else NA_real_,
adjusted = if (attach_model && !is.null(adjusted_entry)) adjusted_entry$text else "",
adjusted_p = if (attach_model && !is.null(adjusted_entry)) adjusted_entry$p else NA_real_,
multi = if (attach_model && !is.null(multi_entry)) multi_entry$text else "",
multi_p = if (attach_model && !is.null(multi_entry)) multi_entry$p else NA_real_,
variable_start = attach_model, raw_values = list(values = x[valid_y]))
}
next
}
levels_original <- get_levels(x, FALSE)
if (!length(levels_original)) stop(sprintf("Categorical variable `%s` has no observed levels.", variable), call. = FALSE)
reference <- reference_for(variable, levels_original, vars$reference_index[i])
multi_reference <- NULL
if (variable_in_multi) {
multi_index <- match(variable, multi_meta$variable)
multi_reference <- reference_for(variable, levels_original, multi_meta$reference_index[multi_index])
}
levels_to_show <- get_levels(x, variable %in% reverse_rows)
crude_effects <- model_effects(variable, TRUE, reference, adjusted_meta[0, , drop = FALSE])
adjusted_effects <- if (has_adjusted) model_effects(variable, TRUE, reference, focal_adjusted_meta) else list()
multi_effects <- if (variable_in_multi) multi_model$effects else list()
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "", "categorical_header", "",
test_p = omnibus$p, test_method = omnibus$method, variable_start = TRUE)
variable_observed <- !is.na(x) & valid_y
denominator <- sum(variable_observed)
for (level_value in levels_to_show) {
level_mask <- !is.na(x) & x == level_value & valid_y
count <- sum(level_mask)
percent <- if (denominator > 0L) 100 * count / denominator else NA_real_
overall_value <- c(first = format_count(count), second = format_number(percent))
outcome_values <- y[level_mask]
outcome_value <- summarize_outcome(outcome_values)
crude_text <- adjusted_text <- multi_text <- ""
crude_p <- adjusted_p <- multi_p <- NA_real_
if (as.character(level_value) == reference) {
crude_text <- "Ref"
if (has_adjusted) adjusted_text <- "Ref"
} else {
crude_entry <- find_category_effect(crude_effects, variable, level_value)
adjusted_entry <- find_category_effect(adjusted_effects, variable, level_value)
if (!is.null(crude_entry)) { crude_text <- crude_entry$text; crude_p <- crude_entry$p }
if (!is.null(adjusted_entry)) { adjusted_text <- adjusted_entry$text; adjusted_p <- adjusted_entry$p }
}
if (variable_in_multi) {
if (as.character(level_value) == multi_reference) multi_text <- "Ref" else {
multi_entry <- find_category_effect(multi_effects, variable, level_value)
if (!is.null(multi_entry)) { multi_text <- multi_entry$text; multi_p <- multi_entry$p }
}
}
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, as.character(level_value), "categorical_level", "categorical",
overall_value = overall_value, outcome_value = outcome_value, crude = crude_text, crude_p = crude_p,
adjusted = adjusted_text, adjusted_p = adjusted_p, multi = multi_text, multi_p = multi_p,
raw_values = list(n = count, percent = percent, outcome = outcome_values))
}
missing_count <- sum(is.na(x) & valid_y)
include_missing <- identical(missing, "always") || (identical(missing, "ifany") && missing_count > 0L)
if (include_missing) {
percent <- if (sum(valid_y) > 0L) 100 * missing_count / sum(valid_y) else NA_real_
missing_y <- y[is.na(x) & valid_y]
table_rows[[length(table_rows) + 1L]] <- make_row(variable, label, "Missing", "missing", "categorical",
overall_value = c(first = format_count(missing_count), second = format_number(percent)),
outcome_value = summarize_outcome(missing_y), raw_values = list(n = missing_count, percent = percent, outcome = missing_y))
}
}
tests_used <- unique(vapply(table_rows, function(z) if (is.null(z$test_method)) "" else z$test_method, character(1)))
tests_used <- tests_used[nzchar(tests_used)]
test_letters <- stats::setNames(c(letters, paste0("a", letters))[seq_along(tests_used)], tests_used)
outcome_label <- get_label(y, outcome_name)
outcome_summary_label <- if (outcome_mode == "mean") paste0(outcome_label, ", M (SD)") else paste0(outcome_label, ", Median (IQR)")
overall_outcome <- compact_value(summarize_outcome(y[valid_y]), "outcome")
result_columns <- list()
if (isTRUE(descriptive)) {
overall_header <- paste0("Overall<span class=\"header-n\">n = ", format_count(sum(valid_y)), "</span>")
outcome_header <- paste0(escape_html(outcome_summary_label), "<span class=\"header-n\">Overall = ", escape_html(overall_outcome), "; n = ", format_count(sum(valid_y)), "</span>")
if (overall == "first") result_columns <- list(list(type = "overall", label = "Overall", html = overall_header), list(type = "outcome", label = outcome_summary_label, html = outcome_header))
if (overall == "last") result_columns <- list(list(type = "outcome", label = outcome_summary_label, html = outcome_header), list(type = "overall", label = "Overall", html = overall_header))
if (overall == "none") result_columns <- list(list(type = "outcome", label = outcome_summary_label, html = outcome_header))
}
result_header_cells <- paste0("<th class=\"result-head\">", vapply(result_columns, `[[`, character(1), "html"), "</th>", collapse = "")
extra <- as.integer(test) + 1L + as.integer(pvalue) + as.integer(has_adjusted) + as.integer(has_adjusted && pvalue) + as.integer(has_multi) + as.integer(has_multi && pvalue)
header_html <- paste0("<thead><tr class=\"by-title\"><th></th><th colspan=\"", length(result_columns) + extra, "\">Continuous outcome: ",
escape_html(outcome_label), if (name) paste0(" <span class=\"variable-code\">[", escape_html(outcome_name), "]</span>") else "",
"</th></tr><tr><th>Characteristic</th>", result_header_cells,
if (test) "<th>Test p</th>" else "", "<th>Crude \u03b2 (95% CI)</th>", if (pvalue) "<th>p-value</th>" else "",
if (has_adjusted) "<th>Adjusted \u03b2 (95% CI)</th>" else "", if (has_adjusted && pvalue) "<th>p-value</th>" else "",
if (has_multi) "<th>Multivariable \u03b2 (95% CI)</th>" else "", if (has_multi && pvalue) "<th>p-value</th>" else "", "</tr></thead>")
body_html <- character(length(table_rows))
for (i in seq_along(table_rows)) {
current <- table_rows[[i]]
characteristic <- if (current$type %in% c("categorical_header", "numeric_header", "numeric")) paste0("<span class=\"variable-name\">", current$label, "</span>") else paste0("<span class=\"level-name", if (current$type == "missing") " missing-name" else "", "\">", escape_html(current$item), "</span>")
value_cells <- vapply(result_columns, function(column) {
value <- if (column$type == "overall") current$overall_value else current$outcome_value
text <- if (is.null(value) || current$type %in% c("categorical_header", "numeric_header") || (column$type == "outcome" && current$type %in% c("numeric", "numeric_detail"))) "" else compact_value(value, if (column$type == "outcome") "outcome" else current$kind)
paste0("<td class=\"result\">", escape_html(text), "</td>")
}, character(1))
test_cell <- if (test) {
p <- format_p(current$test_p)
if (nzchar(p) && test_note && !is.null(current$test_method)) p <- paste0(p, "<sup>", test_letters[[current$test_method]], "</sup>")
paste0("<td class=\"test-p\">", p, "</td>")
} else ""
crude_cell <- paste0("<td class=\"effect\">", escape_html(current$crude), "</td>")
crude_p_cell <- if (pvalue) paste0("<td class=\"effect-p\">", format_p(current$crude_p), "</td>") else ""
adjusted_cell <- if (has_adjusted) paste0("<td class=\"effect\">", escape_html(current$adjusted), "</td>") else ""
adjusted_p_cell <- if (has_adjusted && pvalue) paste0("<td class=\"effect-p\">", format_p(current$adjusted_p), "</td>") else ""
multi_cell <- if (has_multi) paste0("<td class=\"effect\">", escape_html(current$multi), "</td>") else ""
multi_p_cell <- if (has_multi && pvalue) paste0("<td class=\"effect-p\">", format_p(current$multi_p), "</td>") else ""
row_class <- paste0("row-", gsub("_", "-", current$type, fixed = TRUE), if (current$variable_start) " variable-start" else "")
body_html[i] <- paste0("<tr class=\"", row_class, "\"><td>", characteristic, "</td>", paste(value_cells, collapse = ""), test_cell, crude_cell, crude_p_cell, adjusted_cell, adjusted_p_cell, multi_cell, multi_p_cell, "</tr>")
}
descriptive_note <- if (isTRUE(descriptive)) paste0("<div class=\"table-note\">Categorical predictors are shown as n (%). Numeric predictor summaries follow their c., q., or f. declarations in vars(). The outcome is summarized as ", if (outcome_mode == "mean") "mean (SD)" else "median (IQR)", ". Observations with a missing or non-finite outcome are excluded.</div>") else ""
test_footnotes <- if (test && test_note && length(tests_used)) {
entries <- paste0("<sup>", unname(test_letters[tests_used]), "</sup> ", escape_html(tests_used))
paste0("<div class=\"test-note\">", paste(entries, collapse = "; "), ".</div>")
} else ""
adjustment_note <- if (has_adjusted) {
if (adjust_all) "Adjusted estimates include all other variables listed in the table." else paste0("Adjusted estimates include: ", paste(escape_html(adjusted_meta$specification), collapse = ", "), ".")
} else ""
effect_note <- paste0("<div class=\"effect-note\">\u03b2 is the unstandardized linear regression coefficient with 95% confidence interval. Categorical reference categories are marked Ref. Continuous estimates are reported per one-unit increase.", if (nzchar(adjustment_note)) paste0(" ", adjustment_note) else "", "</div>")
multi_note <- ""
if (has_multi && !is.null(multi_model)) {
diagnostics <- multi_model$diagnostics
vif_text <- if (all(is.finite(diagnostics$vif))) paste0(format_number(diagnostics$vif[1L], 2L), " - ", format_number(diagnostics$vif[2L], 2L)) else "not estimable"
r2_text <- if (is.finite(diagnostics$adjusted_r2)) format_number(diagnostics$adjusted_r2, 3L) else "not estimable"
f_text <- if (is.finite(diagnostics$overall_p)) paste0("p = ", clean_export_text(format_p(diagnostics$overall_p))) else "p not estimable"
bp_text <- if (is.finite(diagnostics$bp_p)) paste0("p = ", clean_export_text(format_p(diagnostics$bp_p))) else "p not estimable"
multi_note <- paste0("<div class=\"model-note\">Final multivariable linear model: ", paste(escape_html(multi_meta$specification), collapse = ", "),
". n = ", format_count(diagnostics$n), "; adjusted R\u00b2 = ", r2_text, "; overall F-test ", escape_html(f_text),
"; Breusch-Pagan ", escape_html(bp_text), "; coefficient-level VIF range = ", vif_text, ".</div>")
}
note_html <- paste0(descriptive_note, test_footnotes, effect_note, multi_note)
title_html <- if (is.null(title) || !nzchar(as.character(title)[1L])) "" else paste0("<div class=\"table-title\">", escape_html(as.character(title)[1L]), "</div>")
css <- switch(template,
journal = "body{font-family:'Times New Roman',Times,serif;background:#fff;color:#111;margin:18px}.table-title{font-size:18px;font-weight:700;margin:0 0 8px}table{border-collapse:collapse;width:auto;min-width:820px;border-top:2px solid #111;border-bottom:2px solid #111}th{padding:4px 9px;text-align:right;border-bottom:1.5px solid #111;font-weight:700;white-space:nowrap;background:#fff}th:first-child{text-align:left;min-width:260px}td{padding:3px 9px;vertical-align:top;border:0}tr.variable-start td{border-top:1px solid #aaa}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;border-bottom:1px solid #777}",
clean = "body{font-family:Arial,Helvetica,sans-serif;background:#fff;color:#111;margin:18px}.table-title{font-size:18px;font-weight:700;margin:0 0 8px}table{border-collapse:collapse;width:auto;min-width:820px;border-top:2px solid #222;border-bottom:2px solid #222}th{padding:6px 10px;text-align:right;border-bottom:1.5px solid #222;font-weight:700;white-space:nowrap;background:#f3f3f3}th:first-child{text-align:left;min-width:260px}td{padding:4px 10px;vertical-align:top;border-bottom:1px solid #ddd}tr.variable-start td{border-top:1px solid #999}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;background:#fff;border-bottom:1px solid #999}",
minimal = "body{font-family:Arial,Helvetica,sans-serif;background:#fff;color:#111;margin:18px}.table-title{font-size:17px;font-weight:700;margin:0 0 7px}table{border-collapse:collapse;width:auto;min-width:780px;border-top:1.5px solid #222;border-bottom:1.5px solid #222}th{padding:4px 8px;text-align:right;border-bottom:1px solid #555;font-weight:700;white-space:nowrap;background:#fff}th:first-child{text-align:left;min-width:240px}td{padding:3px 8px;vertical-align:top;border:0}tr.variable-start td{border-top:1px solid #ddd}td.result,td.test-p,td.effect,td.effect-p{text-align:right;white-space:nowrap}.by-title th{text-align:center;border-bottom:1px solid #aaa}")
common_css <- ".table-wrapper{display:inline-block;max-width:100%;overflow-x:auto}.variable-name{font-weight:700}.variable-code{font-family:Consolas,monospace;font-size:.78em;color:#666;font-weight:400}.level-name{display:inline-block;padding-left:22px;white-space:nowrap}.missing-name{font-style:italic}.header-n{display:block;font-size:.78em;font-weight:400;text-align:right;margin-top:1px}.result-head{text-align:right}.table-note,.test-note,.effect-note,.model-note{font-size:12px;color:#333;margin-top:6px;line-height:1.35}.table-separator{height:24px}sup{font-size:.72em;vertical-align:super;margin-left:1px}"
table_block <- paste0("<section class=\"r4vn-table\">", title_html, "<table>", header_html, "<tbody>", paste(body_html, collapse = ""), "</tbody></table>", note_html, "</section>")
blocks <- table_block
if (inherits(append, "r4vn_tab")) blocks <- c(append$blocks, table_block)
document <- paste0("<!DOCTYPE html><html><head><meta charset=\"UTF-8\"><meta name=\"viewport\" content=\"width=device-width,initial-scale=1\"><style>", css, common_css, "</style></head><body><div class=\"table-wrapper\">", paste(blocks, collapse = "<div class=\"table-separator\"></div>"), "</div></body></html>")
if (is.null(file)) file <- tempfile(pattern = "r4vn-tab-", fileext = ".html")
if (!is.character(file) || length(file) != 1L || !nzchar(file)) stop("`file` must be a single valid file path.", call. = FALSE)
if (is.character(append) && length(append) == 1L && file.exists(append)) {
old <- paste(readLines(append, warn = FALSE, encoding = "UTF-8"), collapse = "\n")
if (grepl("</body>", old, fixed = TRUE)) {
document <- sub("</body>", paste0("<div class=\"table-separator\"></div>", table_block, "</body>"), old, fixed = TRUE)
file <- append
}
}
writeLines(enc2utf8(document), file, useBytes = TRUE)
raw_output <- if (isTRUE(raw)) lapply(table_rows, function(z) list(variable = z$variable, label = z$label, item = z$item,
type = z$type, overall = z$overall_value, outcome = z$outcome_value, test_p = z$test_p, test_method = z$test_method,
crude = z$crude, crude_p = z$crude_p, adjusted = z$adjusted, adjusted_p = z$adjusted_p,
multi = z$multi, multi_p = z$multi_p, values = z$raw)) else NULL
export_result_names <- if (length(result_columns)) vapply(result_columns, function(z) as.character(z$label), character(1)) else character()
export_column_names <- c("Characteristic", export_result_names)
if (test) export_column_names <- c(export_column_names, "Test p")
export_column_names <- c(export_column_names, "Crude \u03b2 (95% CI)")
if (pvalue) export_column_names <- c(export_column_names, "Crude p-value")
if (has_adjusted) export_column_names <- c(export_column_names, "Adjusted \u03b2 (95% CI)")
if (has_adjusted && pvalue) export_column_names <- c(export_column_names, "Adjusted p-value")
if (has_multi) export_column_names <- c(export_column_names, "Multivariable \u03b2 (95% CI)")
if (has_multi && pvalue) export_column_names <- c(export_column_names, "Multivariable p-value")
export_rows <- lapply(table_rows, function(current) {
characteristic <- if (current$type %in% c("categorical_header", "numeric_header", "numeric")) clean_export_text(current$label) else paste0(" ", clean_export_text(current$item))
values <- if (length(result_columns)) vapply(result_columns, function(column) {
value <- if (column$type == "overall") current$overall_value else current$outcome_value
if (is.null(value) || current$type %in% c("categorical_header", "numeric_header") || (column$type == "outcome" && current$type %in% c("numeric", "numeric_detail"))) "" else compact_value(value, if (column$type == "outcome") "outcome" else current$kind)
}, character(1)) else character()
output_row <- c(characteristic, values)
if (test) {
test_text <- clean_export_text(format_p(current$test_p))
if (nzchar(test_text) && test_note && !is.null(current$test_method) && length(test_letters)) {
letter <- unname(test_letters[current$test_method])
if (length(letter) && !is.na(letter) && nzchar(letter)) test_text <- paste0(test_text, " (", letter, ")")
}
output_row <- c(output_row, test_text)
}
output_row <- c(output_row, clean_export_text(current$crude))
if (pvalue) output_row <- c(output_row, clean_export_text(format_p(current$crude_p)))
if (has_adjusted) output_row <- c(output_row, clean_export_text(current$adjusted))
if (has_adjusted && pvalue) output_row <- c(output_row, clean_export_text(format_p(current$adjusted_p)))
if (has_multi) output_row <- c(output_row, clean_export_text(current$multi))
if (has_multi && pvalue) output_row <- c(output_row, clean_export_text(format_p(current$multi_p)))
output_row
})
if (length(export_rows)) table_df <- as.data.frame(do.call(rbind, export_rows), stringsAsFactors = FALSE, check.names = FALSE) else table_df <- as.data.frame(matrix(character(), nrow = 0L, ncol = length(export_column_names)), stringsAsFactors = FALSE, check.names = FALSE)
names(table_df) <- make.unique(export_column_names, sep = "_")
rownames(table_df) <- NULL
column_headers_html <- c(
if (length(result_columns)) vapply(result_columns, function(z) z$html, character(1)) else character(),
if (test) "Test p" else character(),
"Crude beta (95% CI)",
if (pvalue) "p-value" else character(),
if (has_adjusted) "Adjusted beta (95% CI)" else character(),
if (has_adjusted && pvalue) "p-value" else character(),
if (has_multi) "Multivariable beta (95% CI)" else character(),
if (has_multi && pvalue) "p-value" else character()
)
row_keys <- .r4vn_superby_row_keys(table_rows)
output <- list(data = table_df, rows = table_rows, row_keys = row_keys, raw = raw_output, metadata = vars, by = outcome_name,
by_specification = outcome_spec, outcome_type = "continuous", outcome_summary = outcome_mode,
by_levels = character(), effect_type = "BETA", event = NULL,
adjusted = adjusted_meta, adjusted_all = adjust_all, multi = multi_meta,
multi_model = if (is.null(multi_model)) NULL else multi_model$fit,
multi_diagnostics = if (is.null(multi_model)) NULL else multi_model$diagnostics,
descriptive = descriptive, html = document, table_html = table_block, note_html = note_html,
column_headers_html = column_headers_html, css = css, common_css = common_css, blocks = blocks,
file = normalizePath(file, winslash = "/", mustWork = TRUE), call = if (is.null(user_call)) match.call() else user_call)
class(output) <- "r4vn_tab"
if (show) {
viewer <- getOption("viewer")
if (is.function(viewer)) viewer(output$file) else utils::browseURL(output$file)
}
invisible(output)
}
Try the R4VN package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.