R/zzz-r4vn-graphs.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ==========================================================================
# R4VN graph collections: vars(...) + hierarchical by = vars(...)
# ==========================================================================
# Late wrappers around the established graph engines. The original engines
# remain responsible for all plotting details and file formats.

.r4vn_gbar_engine <- gbar
.r4vn_ghist_engine <- ghist
.r4vn_gbox_engine <- gbox
.r4vn_gscatter_engine <- gscatter
.r4vn_gline_engine <- gline
.r4vn_gdensity_engine <- gdensity
.r4vn_gpie_engine <- gpie
.r4vn_groc_engine <- groc

.r4vn_graph_call_preserve <- function(fun, call, env, drop = character()) {
  cl <- call
  cl[[1L]] <- quote(.r4vn_graph_wrapped_engine)
  aa <- as.list(cl)
  if (length(drop)) aa[intersect(names(aa), drop)] <- NULL
  cl <- as.call(aa)
  ee <- new.env(parent = env)
  ee$.r4vn_graph_wrapped_engine <- fun
  eval(cl, envir = ee)
}

.r4vn_graph_simple_by <- function(expr, data = NULL, env = parent.frame()) {
  .r4vn_expr_is_null(expr) || !.r4vn_is_vars_spec_expr(expr, data, env)
}

.r4vn_graph_forward <- function(call, env, drop) {
  aa <- as.list(call)[-1L]
  aa[intersect(names(aa), drop)] <- NULL
  lapply(aa, function(z) eval(z, envir = env))
}

.r4vn_graph_file_index <- function(file, i, n) {
  if (is.null(file) || n <= 1L) return(file)
  ext <- tools::file_ext(file)
  if (nzchar(ext)) {
    stem <- substr(file, 1L, nchar(file) - nchar(ext) - 1L)
    paste0(stem, "-", i, ".", ext)
  } else paste0(file, "-", i)
}

.r4vn_graph_selected <- function(primary_expr, vars_expr, data, env, primary_arg,
                                 numeric_only = FALSE) {
  out <- character()
  if (!.r4vn_expr_is_null(primary_expr)) {
    out <- .r4vn_resolve_name_spec(primary_expr, data, env, primary_arg,
                                   multiple = FALSE, allow_null = TRUE)
  }
  if (!.r4vn_expr_is_null(vars_expr)) {
    out <- unique(c(out, .r4vn_vars_spec_names(vars_expr, data, env, "vars",
                                               numeric_only = numeric_only)))
  }
  if (!length(out)) stop(sprintf("Supply `%s` or `vars = vars(...)`.", primary_arg), call. = FALSE)
  out
}

.r4vn_graph_collect <- function(engine, data, variables, byspec, native_by = FALSE,
                                primary_arg = "x", forwarded = list(), file = NULL,
                                extra_split_by = FALSE, call = NULL,
                                combine = FALSE, ncol = NULL, show = TRUE,
                                width = 7, height = 5, dpi = 300, bg = "white") {
  if (!is.logical(combine) || length(combine) != 1L || is.na(combine)) {
    stop("`combine` must be TRUE or FALSE.", call. = FALSE)
  }
  split_vars <- byspec$strata
  if (!isTRUE(native_by) || isTRUE(extra_split_by)) split_vars <- byspec$all
  ids <- .r4vn_strata_indices(data, split_vars)
  if (!length(split_vars)) ids <- list(Overall = seq_len(nrow(data)))
  total <- length(variables) * length(ids)
  if (!total) stop("No complete groups are available for graphing.", call. = FALSE)
  combine <- isTRUE(combine) && total > 1L
  graphs <- list(); labels <- character(); counter <- 0L
  supplied_title <- forwarded$title %||% NULL

  for (nm in variables) {
    for (idx in ids) {
      counter <- counter + 1L
      dd <- data[idx, , drop = FALSE]
      context <- if (length(split_vars)) .r4vn_stratum_label(data, split_vars, idx) else "Overall"
      args <- forwarded
      args$data <- dd
      args[[primary_arg]] <- nm
      if (isTRUE(native_by) && !is.null(byspec$by) && !isTRUE(extra_split_by)) args$by <- byspec$by
      variable_label <- .r4vn_variable_label(data, nm)
      panel_label <- if (context == "Overall") {
        variable_label
      } else {
        paste(variable_label, context, sep = " | ")
      }
      if (total > 1L) {
        args$title <- if (is.null(supplied_title)) {
          panel_label
        } else {
          paste(supplied_title, panel_label, sep = " - ")
        }
      }
      args$show <- if (combine) FALSE else show
      if ("file" %in% names(formals(engine)) || !is.null(file)) {
        args$file <- if (combine) NULL else .r4vn_graph_file_index(file, counter, total)
      }
      z <- do.call(engine, args)
      z$label <- panel_label
      graphs[[length(graphs) + 1L]] <- z; labels <- c(labels, panel_label)
    }
  }
  if (length(graphs) == 1L) return(graphs[[1L]])
  names(graphs) <- make.unique(labels)
  out <- .r4vn_graph_set(
    graphs, labels = labels, call = call, combined = combine,
    ncol = ncol, file = if (combine) file else NULL
  )
  if (combine) {
    .r4vn_render(
      function() .r4vn_draw_graph_set(out, ncol = ncol),
      file = file, show = show, width = width, height = height,
      dpi = dpi, bg = bg
    )
  }
  out
}

# gbar: vars() selects several categorical x variables; the last by variable is
# displayed within each panel and all earlier variables are strata.
gbar <- function(data = NULL, x = NULL, vars = NULL, y = NULL, by = NULL, stat = c("mean", "median"), percent = FALSE, position = c("dodge", "stack"), ci = FALSE, label = FALSE, digits = 1, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 1, border_color = NA, border_lwd = 1, legend = TRUE, legend_position = "topright", missing = FALSE, missing_label = "Missing", xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && .r4vn_graph_simple_by(substitute(by), d, env)) {
    return(.r4vn_graph_call_preserve(.r4vn_gbar_engine, call, env, drop = c("vars", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(x), substitute(vars), d, env, "x")
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "vars", "y", "by", "combine", "ncol", "file"))
  if (!.r4vn_expr_is_null(substitute(y))) fwd$y <- .r4vn_resolve_name_spec(substitute(y), d, env, "y", multiple = FALSE)
  .r4vn_graph_collect(.r4vn_gbar_engine, d, sel, bs, native_by = TRUE, primary_arg = "x", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

# Histogram grouping is intentionally panel-based: overlaid histograms quickly
# become ambiguous; use gdensity() when a same-panel grouped distribution is desired.
ghist <- function(data = NULL, x = NULL, vars = NULL, by = NULL, bins = "Sturges", density = FALSE, normal = FALSE, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = NULL, xbreaks = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 0.85, border_color = "white", normal_color = "black", normal_lty = 1, normal_lwd = 2, xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && (missing(by) || .r4vn_expr_is_null(substitute(by)))) {
    return(.r4vn_graph_call_preserve(.r4vn_ghist_engine, call, env, drop = c("vars", "by", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(x), substitute(vars), d, env, "x", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "vars", "by", "combine", "ncol", "file"))
  .r4vn_graph_collect(.r4vn_ghist_engine, d, sel, bs, native_by = FALSE, primary_arg = "x", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

gbox <- function(data = NULL, x = NULL, y = NULL, vars = NULL, by = NULL, horizontal = FALSE, points = FALSE, outliers = TRUE, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = NULL, xbreaks = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 0.7, border_color = "gray30", point_color = "black", point_alpha = 0.45, point_size = 0.55, point_pch = 16, xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && (missing(by) || .r4vn_expr_is_null(substitute(by)))) {
    return(.r4vn_graph_call_preserve(.r4vn_gbox_engine, call, env, drop = c("vars", "by", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(y), substitute(vars), d, env, "y", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "y", "vars", "by", "combine", "ncol", "file"))
  x_given <- !.r4vn_expr_is_null(substitute(x))
  if (x_given) fwd$x <- .r4vn_resolve_name_spec(substitute(x), d, env, "x", multiple = FALSE)
  if (!x_given && !is.null(bs$by)) {
    fwd$x <- bs$by
    # final by is used as the box grouping, only preceding variables split panels
    bs2 <- bs; bs2$by <- NULL; bs2$all <- bs$strata
    return(.r4vn_graph_collect(.r4vn_gbox_engine, d, sel, bs2, native_by = FALSE, primary_arg = "y", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg))
  }
  # With an explicit x, a requested by is an additional panel hierarchy.
  .r4vn_graph_collect(.r4vn_gbox_engine, d, sel, bs, native_by = FALSE, primary_arg = "y", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

gscatter <- function(data = NULL, x, y = NULL, vars = NULL, by = NULL, fit = FALSE, fit_color = NULL, fit_lty = 1, fit_lwd = 2, cor = FALSE, pch = 16, point_size = 1, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = NULL, xbreaks = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 0.75, legend = TRUE, legend_position = "topright", xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && .r4vn_graph_simple_by(substitute(by), d, env)) {
    return(.r4vn_graph_call_preserve(.r4vn_gscatter_engine, call, env, drop = c("vars", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(y), substitute(vars), d, env, "y", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "y", "vars", "by", "combine", "ncol", "file"))
  fwd$x <- .r4vn_resolve_name_spec(substitute(x), d, env, "x", multiple = FALSE)
  .r4vn_graph_collect(.r4vn_gscatter_engine, d, sel, bs, native_by = TRUE, primary_arg = "y", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

gline <- function(data = NULL, x, y = NULL, vars = NULL, by = NULL, stat = c("identity", "mean", "median"), points = TRUE, line_width = 2, line_type = 1, sort = TRUE, pch = 16, point_size = 0.9, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = NULL, xbreaks = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 1, legend = TRUE, legend_position = "topright", xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && .r4vn_graph_simple_by(substitute(by), d, env)) {
    return(.r4vn_graph_call_preserve(.r4vn_gline_engine, call, env, drop = c("vars", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(y), substitute(vars), d, env, "y", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "y", "vars", "by", "combine", "ncol", "file"))
  fwd$x <- .r4vn_resolve_name_spec(substitute(x), d, env, "x", multiple = FALSE)
  .r4vn_graph_collect(.r4vn_gline_engine, d, sel, bs, native_by = TRUE, primary_arg = "y", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

gdensity <- function(data = NULL, x = NULL, vars = NULL, by = NULL, adjust = 1, fill = FALSE, line_width = 2, line_type = 1, xlab = NULL, ylab = NULL, xtitle = NULL, ytitle = "Density", xbreaks = NULL, ybreaks = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 0.35, legend = TRUE, legend_position = "topright", xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && .r4vn_graph_simple_by(substitute(by), d, env)) {
    return(.r4vn_graph_call_preserve(.r4vn_gdensity_engine, call, env, drop = c("vars", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(x), substitute(vars), d, env, "x", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "vars", "by", "combine", "ncol", "file"))
  .r4vn_graph_collect(.r4vn_gdensity_engine, d, sel, bs, native_by = TRUE, primary_arg = "x", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

gpie <- function(data = NULL, x = NULL, vars = NULL, by = NULL, donut = FALSE, label = TRUE, percent = TRUE, digits = 1, xlab = NULL, title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "default", alpha = 1, border_color = "white", border_lwd = 1, clockwise = TRUE, missing = FALSE, missing_label = "Missing", theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 7, height = 5, dpi = 300, show = TRUE, bg = "white") {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && (missing(by) || .r4vn_expr_is_null(substitute(by)))) {
    return(.r4vn_graph_call_preserve(.r4vn_gpie_engine, call, env, drop = c("vars", "by", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(x), substitute(vars), d, env, "x")
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "x", "vars", "by", "combine", "ncol", "file"))
  .r4vn_graph_collect(.r4vn_gpie_engine, d, sel, bs, native_by = FALSE, primary_arg = "x", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}

groc <- function(data = NULL, outcome, pred = NULL, vars = NULL, by = NULL, event = NULL, diagonal = TRUE, auc = TRUE, digits = 3, curve_lty = 1, curve_lwd = 2.5, diagonal_color = "gray60", diagonal_lty = 2, diagonal_lwd = 1, xlab = NULL, ylab = NULL, xtitle = "1 - Specificity", ytitle = "Sensitivity", title = NULL, subtitle = NULL, note = NULL, color = NULL, palette = "journal", xline = NULL, yline = NULL, ref_color = "gray40", ref_lty = 2, ref_lwd = 1, theme = "journal", size = 11, combine = FALSE, ncol = NULL, file = NULL, width = 6, height = 6, dpi = 300, show = TRUE, bg = "white", vline = NULL, hline = NULL) {
  call <- match.call(); env <- parent.frame(); d <- .r4vn_get_data(data)
  if ((missing(vars) || .r4vn_expr_is_null(substitute(vars))) && (missing(by) || .r4vn_expr_is_null(substitute(by)))) {
    return(.r4vn_graph_call_preserve(.r4vn_groc_engine, call, env, drop = c("vars", "by", "combine", "ncol")))
  }
  sel <- .r4vn_graph_selected(substitute(pred), substitute(vars), d, env, "pred", numeric_only = TRUE)
  bs <- .r4vn_by_spec(substitute(by), d, env, allow_null = TRUE)
  fwd <- .r4vn_graph_forward(call, env, c("data", "outcome", "pred", "vars", "by", "combine", "ncol", "file"))
  fwd$outcome <- .r4vn_resolve_name_spec(substitute(outcome), d, env, "outcome", multiple = FALSE)
  .r4vn_graph_collect(.r4vn_groc_engine, d, sel, bs, native_by = FALSE, primary_arg = "pred", forwarded = fwd, file = file, call = call, combine = combine, ncol = ncol, show = show, width = width, height = height, dpi = dpi, bg = bg)
}