R/surv-export.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# R4VN survival export helpers --------------------------------------------

#' Extract Tables from an R4VN Survival Result
#'
#' Converts every non-empty report component of a `tabsurv()` result to a named
#' list of data frames, including descriptive, life-table, and optional
#' interpretation tables. For a
#' hierarchical result, tables are retained separately for every outer stratum.
#' This keeps survival export compatible with the existing `tabexport()`
#' data-frame workflow without changing `tabexport()` itself. Examples are self-contained.
#'
#' @param x An object returned by `tabsurv()`.
#' @return A named list of data frames.
#' @examples
#' if (requireNamespace("survival", quietly = TRUE)) {
#'   d <- data.frame(time = c(5, 8, 10, 12, 15, 18),
#'                   event = c(1, 0, 1, 1, 0, 1),
#'                   group = factor(rep(c("A", "B"), 3)))
#'   s <- tabsurv(time, event, by = group, data = d, show = FALSE)
#'   z <- surv_tables(s)
#'   names(z)
#' }
#' @export
surv_tables <- function(x) {
  if (!inherits(x, "r4vn_surv")) stop("`x` must be returned by `tabsurv()`.", call. = FALSE)
  if (!is.null(x$hierarchical_results)) {
    out <- list(Overview = x$overview)
    if (is.data.frame(x$descriptive) && nrow(x$descriptive)) {
      out[["Descriptive by stratum and group"]] <- x$descriptive
    }
    for (i in seq_along(x$hierarchical_results)) {
      label <- names(x$hierarchical_results)[i]
      if (is.null(label) || is.na(label) || !nzchar(label)) label <- paste0("Stratum ", i)
      subtables <- surv_tables(x$hierarchical_results[[i]])
      for (nm in names(subtables)) out[[paste0(label, " - ", nm)]] <- subtables[[nm]]
    }
    if (is.data.frame(x$interpretation) && nrow(x$interpretation)) {
      out[["Interpretation"]] <- x$interpretation
    }
    return(out)
  }
  out <- list()
  add <- function(name, value) {
    if (is.data.frame(value) && nrow(value)) out[[name]] <<- value
  }
  add("Overview", x$overview)
  add("Descriptive by group", x$descriptive)
  add("Follow-up", x$followup)
  add("Median survival", x$median)
  add("Life table", x$lifetable)
  add("Survival at times", x$at)
  add(if (isTRUE(x$metadata$competing)) "Cumulative incidence" else "Cumulative risk", x$risk)
  add("Incidence rate", x$rate)
  add("Risk comparison", x$risk_compare)
  add("Incidence rate ratio", x$irr)
  add("Log-rank", x$logrank)
  if (!is.null(x$rmst)) {
    add("RMST", x$rmst$table)
    add("RMST difference", x$rmst$difference)
  }
  if (!is.null(x$cox)) {
    add("Crude Cox", x$cox$crude)
    add("Adjusted Cox", x$cox$adjusted)
    add("Multivariable Cox", x$cox$multi)
    add("Cox interaction", x$cox$interaction)
    add("Cox diagnostics", x$cox$diagnostics)
  }
  add("PH diagnostics", x$ph)
  if (!is.null(x$finegray)) add("Fine-Gray", x$finegray$table)
  if (!is.null(x$subgroup) && length(x$subgroup)) {
    for (nm in names(x$subgroup)) add(paste0("Subgroup - ", nm), x$subgroup[[nm]]$table)
  }
  add("Interpretation", x$interpretation)
  out
}

#' Export an R4VN Survival Analysis
#'
#' Passes all non-empty tables from `tabsurv()` to the existing `tabexport()`
#' function. It is also called internally when `tabsurv(export=, file=)` is
#' used, so a complete Word/Excel/HTML report can be requested in one command.
#'
#' @param x An object returned by `tabsurv()`.
#' @param export,file,open,title,sheet,overwrite,quiet Passed to `tabexport()`.
#' @return The result returned by `tabexport()`.
#' @examples
#' if (requireNamespace("survival", quietly = TRUE)) {
#'   d <- data.frame(time = c(5, 8, 10, 12, 15, 18),
#'                   event = c(1, 0, 1, 1, 0, 1),
#'                   group = factor(rep(c("A", "B"), 3)))
#'   s <- tabsurv(time, event, by = group, data = d, show = FALSE)
#'   # Export when a file is wanted, for example:
#'   # survexport(s, export = "xlsx", file = tempfile(fileext = ".xlsx"))
#' }
#' @export
survexport <- function(x, export = NULL, file = NULL, open = FALSE, title = NULL,
                       sheet = NULL, overwrite = TRUE, quiet = FALSE) {
  f <- get0("tabexport", mode = "function", inherits = TRUE)
  if (is.null(f)) stop("`tabexport()` is not available in this R4VN build.", call. = FALSE)
  tabs <- surv_tables(x)
  if (!length(tabs)) stop("No non-empty survival tables are available for export.", call. = FALSE)
  args <- c(list(tabs), list(export = export, file = file, open = open, title = title,
                             sheet = sheet, overwrite = overwrite, quiet = quiet))
  do.call(f, args)
}