Nothing
R/cifpanel.R
In cifmodeling: Visualization and Polytomous Modeling of Survival and Competing Risks
Defines functions
apply_strata_to_plots
normalize_strata_info
panel_force_apply
cifpanel
Documented in
cifpanel
#' @title Arrange multiple survival and CIF plots in a panel display
#'
#' @description
#' [cifpanel()] is the panel-building counterpart of [cifplot()].
#' It takes one or more model formulas (or, alternatively, one formula and several
#' event-coding specifications) and returns a multi-panel figure, typically as a
#' patchwork-compatible object. Most display options (axis labels, marks, style, ggsave options)
#' are shared with [cifplot()], but per-panel legends and number-at-risk tables are
#' suppressed to avoid duplicated display. Typical use cases are:
#'
#' - Compare CIF (event 1) vs CIF (event 2) in a 1×2 layout.
#' - Compare survival/CIF curves across strata with a shared legend and matched axes.
#' - Display a plot with an enlarged y-axis inside a full-scale plot.
#'
#' @inheritParams cif-stat-arguments
#' @inheritParams cif-visual-arguments
#'
#' @param plots Optional list of existing ggplot objects to be arranged into a panel.
#' When plots is supplied, no new models are fitted; the plots are used as-is.
#' @param formula A model formula specifying the time-to-event outcome on the
#' left-hand side (typically `Event(time, status)` or `Surv(time, status)`)
#' and, optionally, a stratification variable on the right-hand side.
#' Unlike [cifplot()], this function does not accept a fitted
#' `survfit` object.
#' @param formulas Optional list of formulas. When given, each formula defines
#' **one panel**. This is the most common way to create “one variable per plot”
#' panels.
#' @param code.events Optional specification of event/censoring codes.
#' For single-panel calls, supply a numeric vector. For competing-risk outcomes, use `c(event1, event2, censoring)`.
#' For survival outcomes, a length-2 or length-3 vector is allowed:
#' `c(event, censoring)` or `c(event, *, censoring)`, where any middle element is ignored.
#' When supplied, this argument overrides `code.event1`, `code.event2`, and `code.censoring` for the purpose of estimation.
#' For panel displays (e.g. `cifpanel()` or when `panel.per.event = TRUE` or
#' `panel.censoring = TRUE`), `code.events` may also be a list of such numeric vectors, one per panel.
#' @param legend.collect Logical; if `TRUE`, try to collect a single legend
#' for all panels (passed to \pkg{patchwork}). Default `TRUE`.
#' @param inset.panel Logical. If `FALSE` (default), all panels are arranged
#' in a regular grid using `patchwork::wrap_plots()` and `plot_layout()`.
#' If `TRUE`, the function switches to “inset mode”: the **first** plot becomes
#' the main plot and the **second** plot (only the second) is drawn on top of it
#' as an inset. Additional plots beyond the second are ignored in inset mode.
#' Use grid mode to display more than two panels (`inset.panel = FALSE`).
#' @param inset.left,inset.bottom,inset.right,inset.top Numeric values in the range
#' `[0, 1]` that define the inset box as fractions of the reference area.
#' `inset.left` / `inset.right` control the horizontal position,
#' `inset.bottom` / `inset.top` control the vertical position.
#' Values are interpreted as “from the left/bottom” of the reference.
#' For example, `inset.left = 0.4`, `inset.right = 1.0` draws the inset
#' over the right 60% of the reference area.
#' @param inset.align.to Character string specifying the coordinate system for the
#' inset box. One of `"panel"` (default; the box is placed relative to the panel
#' area, i.e. the plotting region excluding outer titles/margins),
#' `"plot"` (relative to the entire plot area, including axes and titles of the
#' main plot), or `"full"` (relative to the full patchwork canvas).
#' This argument is passed to `patchwork::inset_element()`.
#' @param inset.legend.position Optional legend position **for the inset plot only**.
#' If `NULL` (default), the inset plot keeps whatever legend position was
#' defined for it (often this means a legend will also be inset).
#' Set, for example, `"none"` to hide the legend inside the inset,
#' while still showing the main plot's legend.
#' @param title.panel,subtitle.panel,caption.panel Character annotations applied to the
#' **whole** panel layout (not to individual plots). These are passed to
#' `patchwork::plot_annotation()` and are useful for creating figure-like
#' outputs (title + subfigures + caption).
#' @param tag.panel Passed to `patchwork::plot_annotation()` to auto-label
#' individual panels (e.g. `"A"`, `"B"`, `"C"`). Typical values are
#' `"A"`, `"1"`, or `"a"`. See `?patchwork::plot_annotation`.
#' @param title.plot Character vector of titles for **each panel** in the order they
#' are drawn. Length-1 values are recycled to all panels. In inset mode, the first
#' element refers to the main plot and the second (if present) to the inset.
#' @param survfit.info,axis.info,visual.info,panel.info,style.info,print.info,ggsave.info,inset.info
#' Internal lists used for programmatic control. Not intended for direct user input.
#' @param engine Character string specifying the internal rendering engine used to build each panel.
#' Currently intended for internal use; default is `"cifplot"`.
#' @param ... Additional arguments forwarded to the internal `cifplot_single()`
#' calls that build each panel. Use this to pass low-level options such as
#' `competing.risk.time`, `intercurrent.event.time`, or styling overrides.
#'
#' @details
#'
#' ### Overview
#' `cifpanel()` composes multiple survival/CIF plots into a single figure.
#' For each panel, it estimates curves via `cifcurve()` and renders them with
#' `cifplot()`. You can supply a single `formula` reused across panels or a
#' list in `formulas` (one per panel). When both are provided, `formulas` wins.
#'
#' ### Outcome type & event coding
#'
#' - Use `outcome.type` to set per-panel estimator (`"survival"`=KM, `"competing-risk"`=AJ).
#' - Alternatively, pass `code.events` per panel to infer the type:
#' - length 2 = survival: `c(event1, censor)`
#' - length 3 = competing-risk: `c(event1, event2, censor)`
#' - If `code.events` is `NULL`, `code.event1`, `code.event2`, `code.censoring`
#' are combined into `code.events = list(c(code.event1, code.event2, code.censoring))`
#' with `NA` values dropped.
#' - If `outcome.type` is `NULL`, the function infers each panel from its
#' `code.events[[i]]` length. When both are given, `outcome.type` takes precedence.
#' - Control risk-set displays via `n.risk.type`, which is recycled per panel and
#' forwarded to [cifcurve()] to decide which risk set size populates `$n.risk`
#' (e.g., weighted vs. unweighted counts).
#'
#' ### Panel-wise vs shared arguments
#'
#' Panel layout is specified by length-2 vector \code{rows.columns.panel}.
#' This function can also automatically determine the panel count in the following order:
#' (1) if \code{plots} is supplied, its length defines the number of plots,
#' (2) else if \code{formulas} is supplied, its length defines the number of plots,
#' (3) else if \code{code.events} is supplied, its length defines the number of plots
#' together with formula, and (4) otherwise \code{rows.columns.panel=c(1,1)}.
#'
#' Many arguments accept a **scalar** (recycled to all panels) or a **list/vector**
#' (one entry per panel). Precedence: **panel-wise explicit values** >
#' **shared scalar** > **internal defaults**. Length-1 inputs are recycled.
#'
#' ### Grid vs inset composition
#'
#' - **Grid mode** (`inset.panel = FALSE`, default): plots are arranged with
#' `patchwork::wrap_plots()` and `plot_layout()`. If `legend.collect = TRUE`,
#' legends are collected across panels where possible.
#' - **Inset mode** (`inset.panel = TRUE`): the **second** plot is overlaid
#' into the **first** using `patchwork::inset_element()`. Only the first two
#' plots are used; extra plots are ignored. Control the inset box with
#' `inset.left`, `inset.bottom`, `inset.right`, `inset.top`, and its
#' reference frame via `inset.align.to` (`"panel"`, `"plot"`, or `"full"`).
#'
#' ### Advanced panel controls (forwarded to `cifplot()`)
#'
#' The following arguments allow **per-panel** control by supplying vectors/lists,
#' or **shared** control by supplying scalars. They are forwarded to `cifplot()`.
#'
#' - `formula` or `formulas`: one formula or a list of formulas; each entry creates a panel.
#' - `data`, `outcome.type`, `code.events`, `type.y`: recycled across panels unless a list is supplied for per-panel control.
#' - `rows.columns.panel`: specification of grid layout by c(rows, cols).
#' - `inset.panel`: inset layout.
#' - `title.panel`, `subtitle.panel`, `caption.panel`, `title.plot`: overall titles and captions.
#' - `tag.panel`: panel tag style (e.g., "A", "a", "1").
#' - `label.x`, `label.y`, `limits.x`, `limits.y`, `breaks.x`, `breaks.y`: shared axis control unless a list is supplied for per-panel control.
#'
#' #### Scale & labels
#'
#' | Argument | Meaning | Default |
#' |---|---|---|
#' | `type.y` | `"risk"` (CIF y-axis) or `NULL` (survival). | inferred |
#' | `label.x`, `label.y` | Axis labels per panel. | auto |
#' | `label.strata` | Legend labels per panel. | from data |
#' | `limits.x`, `limits.y` | Axis limits `c(min, max)`. | auto |
#' | `breaks.x`, `breaks.y` | Axis breaks (forwarded to `breaks.x`/`breaks.y`). | auto |
#'
#' #### Plot layers (toggles)
#'
#' | Argument | Effect | Default |
#' |---|---|---|
#' | `add.conf` | CI ribbon. | `TRUE` |
#' | `add.censor.mark` | Censor marks. | `TRUE` |
#' | `add.competing.risk.mark` | Marks for event2 at supplied times. | `FALSE` |
#' | `add.intercurrent.event.mark` | User-specified intercurrent marks. | `FALSE` |
#' | `add.quantile` | Quantile reference line(s). | `FALSE` |
#'
#' *(Time marks inputs such as `competing.risk.time` / `intercurrent.event.time`
#' can be given via `...` if needed; names must match strata labels.)*
#'
#' ### Legend & annotations
#'
#' - `legend.position`: `"top"`, `"right"`, `"bottom"`, `"left"`, or `"none"` (applies to all panels).
#' - Grid mode: `legend.collect = TRUE` attempts a shared legend.
#' - Panel annotations: `title.panel`, `subtitle.panel`, `caption.panel`.
#' - Tagging: `tag.panel` is passed to `patchwork::plot_annotation()`.
#' - In inset mode, `title.plot = c(title_base, title_inset)` labels the two plots.
#'
#' ### Export (optional)
#'
#' If `filename.ggsave` is non-`NULL`, the composed panel is saved with
#' `ggsave()` using `width.ggsave`, `height.ggsave`, and `dpi.ggsave`.
#' Otherwise, the function returns objects without saving.
#'
#' **Notes**
#' - Mixed panel types are supported (e.g., AJ in panel 1; KM in panel 2).
#' - If `formulas` is shorter than the grid capacity, empty slots are ignored.
#' - When supplying vectors/lists per panel, their lengths must match the number
#' of panels; length-1 inputs are recycled; otherwise an error is thrown.
#' - For CIF displays, set `type.y = "risk"`. For survival scale, use `type.y = NULL` or `= "surv"`.
#' For ADaM-style data, use `code.events=c(0,1)` or
#' `code.event1 = 0`, `code.censoring = 1`.
#' - Additional graphical options (e.g., theme) can be added post-hoc to each
#' element of `list.plot` or to the composed `patchwork`.
#'
#' @importFrom patchwork wrap_plots plot_layout inset_element plot_annotation
#'
#' @return A `"cifpanel"` object (returned invisibly), which is a list
#' with at least the following elements:
#'
#' - `list.plot`: a list of ggplot objects, one per panel
#' - `patchwork`: a patchwork object representing the composed panel
#' - `plot`: reserved for backwards compatibility (always `NULL`)
#' - metadata fields mirroring those in [cifplot()] (such as information
#' on the fitted curves and display settings)
#'
#' When `print.panel = TRUE`, the patchwork object is printed in interactive
#' sessions in addition to being returned.
#'
#' @examples
#' data(diabetes.complications)
#' output1 <- cifpanel(
#' title.panel = "A comparison of cumulative incidence of competing events",
#' rows.columns.panel = c(1,2),
#' formula = Event(t, epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type = "competing-risk",
#' code.events = list(c(1,2,0), c(2,1,0)),
#' label.y = c("Diabetic retinopathy", "Macrovascular complications"),
#' label.x = "Years from registration",
#' subtitle.panel = "Stratified by fruit intake",
#' caption.panel = "Data: diabetes.complications",
#' title.plot = c("Diabetic retinopathy", "Macrovascular complications"),
#' legend.position = "bottom",
#' legend.collect=TRUE
#' )
#' print(output1)
#'
#' output2 <- cifplot(Event(t,epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type="competing-risk",
#' code.event1=2,
#' code.event2=1,
#' add.conf = FALSE,
#' add.risktable = FALSE,
#' label.y="CIF of macrovascular complications",
#' label.x="Years from registration")
#' output3 <- cifplot(Event(t,epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type="competing-risk",
#' code.event1=2,
#' code.event2=1,
#' add.conf = FALSE,
#' add.risktable = FALSE,
#' label.y="",
#' label.x="",
#' limits.y=c(0,0.15))
#' output4 <- list(a = output2$plot, b = output3$plot)
#' output5 <- cifpanel(plots = output4,
#' inset.panel = TRUE,
#' inset.left = 0.40, inset.bottom = 0.45,
#' inset.right = 1.00, inset.top = 0.95,
#' inset.align.to = "plot",
#' inset.legend.position = "none",
#' legend.position = "bottom")
#' print(output5)
#'
#' @importFrom ggplot2 ggplot theme_void ggsave theme element_text labs
#' @importFrom patchwork wrap_plots plot_layout inset_element plot_annotation
#'
#' @name cifpanel
#' @section Lifecycle:
#' \lifecycle{experimental}
#' @seealso [polyreg()] for log-odds product modeling of CIFs; [cifcurve()] for KM/AJ estimators; [cifplot()] for display of a CIF; [ggsurvfit][ggsurvfit], [patchwork][patchwork] and [modelsummary][modelsummary] for display helpers.
#' @export
cifpanel <- function(
plots = NULL,
formula = NULL,
formulas = NULL,
data = NULL,
weights = NULL,
subset.condition = NULL,
na.action = na.omit,
outcome.type = NULL,
code.event1 = 1,
code.event2 = 2,
code.censoring = 0,
code.events = NULL,
error = NULL,
conf.type = NULL,
conf.int = NULL,
n.risk.type = c("weighted", "unweighted", "ess"),
type.y = NULL,
label.x = NULL,
label.y = NULL,
label.strata = NULL,
order.strata = NULL,
level.strata = NULL,
limits.x = NULL,
limits.y = NULL,
breaks.x = NULL,
breaks.y = NULL,
add.conf = NULL,
add.risktable = NULL,
add.estimate.table = NULL,
symbol.risk.table = NULL,
font.size.risk.table = NULL,
add.censor.mark = NULL,
shape.censor.mark = NULL,
size.censor.mark = NULL,
add.competing.risk.mark = NULL,
competing.risk.time = NULL,
shape.competing.risk.mark = NULL,
size.competing.risk.mark = NULL,
add.intercurrent.event.mark = NULL,
intercurrent.event.time = NULL,
shape.intercurrent.event.mark = NULL,
size.intercurrent.event.mark = NULL,
add.quantile = NULL,
level.quantile = NULL,
rows.columns.panel = c(1, 1),
inset.panel = FALSE,
title.panel = NULL,
subtitle.panel = NULL,
caption.panel = NULL,
tag.panel = NULL,
title.plot = NULL,
style = "classic",
palette = NULL,
linewidth = 0.8,
linetype = FALSE,
font.family = "sans",
font.size = 8,
legend.position = "top",
legend.collect = TRUE,
inset.left = 0.60,
inset.bottom = 0.05,
inset.right = 0.98,
inset.top = 0.45,
inset.align.to = c("panel","plot","full"),
inset.legend.position = NULL,
print.panel = FALSE,
filename.ggsave = NULL,
width.ggsave = NULL,
height.ggsave = NULL,
dpi.ggsave = 300,
survfit.info = NULL,
axis.info = NULL,
visual.info = NULL,
panel.info = NULL,
style.info = NULL,
inset.info = NULL,
print.info = NULL,
ggsave.info = NULL,
engine = "cifplot",
...
){
weights.expr <- substitute(weights)
weights.missing <- missing(weights)
legend.position <- "none"
add.risktable <- FALSE
add.estimate.table <- FALSE
inset.align.to <- match.arg(inset.align.to)
dots <- list(...)
call <- match.call()
plots_out <- NULL
engine.list <- panel_to_list(engine)
if (missing(n.risk.type)) n.risk.type <- "weighted"
survfit.info.user <- survfit.info
axis.info.user <- axis.info
visual.info.user <- visual.info
panel.info.user <- panel.info
style.info.user <- style.info
inset.info.user <- inset.info
print.info.user <- print.info
ggsave.info.user <- ggsave.info
survfit.info <- panel_modify_list(list(
error = error,
conf.type = conf.type,
conf.int = conf.int,
n.risk.type = n.risk.type
), survfit.info %||% list())
axis.info <- panel_modify_list(list(
type.y = type.y,
label.x = label.x,
label.y = label.y,
level.strata = level.strata,
order.strata = order.strata,
label.strata = label.strata,
limits.x = limits.x,
limits.y = limits.y,
breaks.x = breaks.x,
breaks.y = breaks.y,
use.coord.cartesian = get0("use.coord.cartesian", ifnotfound = NULL)
), axis.info %||% list())
visual.info <- panel_modify_list(list(
add.conf = add.conf,
ci.alpha = 0.25,
add.risktable = FALSE,
add.estimate.table = FALSE,
add.censor.mark = add.censor.mark,
shape.censor.mark = 3,
size.censor.mark = 2,
add.competing.risk.mark = add.competing.risk.mark,
competing.risk.time = list(),
shape.competing.risk.mark= 16,
size.competing.risk.mark = 2,
add.intercurrent.event.mark = add.intercurrent.event.mark,
intercurrent.event.time = list(),
shape.intercurrent.event.mark = 1,
size.intercurrent.event.mark = 2,
add.quantile = add.quantile,
level.quantile = 0.5,
line.size = 0.9,
symbol.risk.table = NULL,
font.size.risk.table = NULL
), visual.info %||% list())
panel.info <- panel_modify_list(list(
panel.per.event = FALSE,
panel.per.variable = FALSE,
rows.columns.panel = rows.columns.panel,
title.panel = title.panel,
subtitle.panel = subtitle.panel,
caption.panel = caption.panel,
tag.panel = tag.panel,
title.plot = title.plot
), panel.info %||% list())
style.info <- style.info %||% list()
style.info$style <- style.info$style %||% style
style.info$palette <- style.info$palette %||% palette
style.info$linewidth <- style.info$linewidth %||% linewidth
style.info$linetype <- style.info$linetype %||% linetype
style.info$font.family <- style.info$font.family %||% font.family
style.info$font.size <- style.info$font.size %||% font.size
style.info$legend.position <- style.info$legend.position %||% legend.position
style.info$legend.collect <- style.info$legend.collect %||% legend.collect
style.info <- panel_modify_list(list(
style = "classic",
palette = NULL,
linewidth = NULL,
linetype = NULL,
font.family = "sans",
font.size = 12,
legend.position = "top",
legend.collect = FALSE
), style.info)
inset.info <- panel_modify_list(list(
inset.panel = inset.panel,
inset.align.to = inset.align.to,
inset.left = inset.left,
inset.bottom = inset.bottom,
inset.right = inset.right,
inset.top = inset.top,
inset.legend.position = inset.legend.position
), inset.info %||% list())
print.info <- panel_modify_list(list(
print.panel = print.panel
), print.info %||% list())
ggsave.info <- panel_modify_list(list(
filename.ggsave = filename.ggsave,
width.ggsave = width.ggsave,
height.ggsave = height.ggsave,
dpi.ggsave = dpi.ggsave,
units = "in"
), ggsave.info %||% list())
inset.info$inset.align.to <- match.arg(inset.info$inset.align.to, c("panel","plot","full"))
rows.columns.panel <- panel.info$rows.columns.panel
title.panel <- panel.info$title.panel
subtitle.panel <- panel.info$subtitle.panel
caption.panel <- panel.info$caption.panel
tag.panel <- panel.info$tag.panel
title.plot <- panel.info$title.plot
legend.position <- style.info$legend.position
legend.collect <- isTRUE(style.info$legend.collect)
inset.panel <- isTRUE(inset.info$inset.panel)
inset.align.to <- inset.info$inset.align.to
inset.left <- inset.info$inset.left
inset.bottom <- inset.info$inset.bottom
inset.right <- inset.info$inset.right
inset.top <- inset.info$inset.top
inset.legend.position <- inset.info$inset.legend.position
print.panel <- isTRUE(print.info$print.panel)
filename.ggsave <- ggsave.info$filename.ggsave
width.ggsave <- ggsave.info$width.ggsave
height.ggsave <- ggsave.info$height.ggsave
dpi.ggsave <- ggsave.info$dpi.ggsave
ggsave.units <- ggsave.info$units %||% "in"
fonts <- panel_extract_fonts(c(style.info, dots))
style.info$font.family <- fonts$family
style.info$font.size <- fonts$size
theme.panel.unified <- panel_build_theme(font.family = fonts$family, font.size = fonts$size)
nrow <- as.integer(rows.columns.panel[1]); ncol <- as.integer(rows.columns.panel[2])
n_slots <- nrow * ncol
level_input <- axis.info$level.strata
order_input <- axis.info$order.strata
norm <- normalize_strata_info(
level.strata = axis.info$level.strata,
order.strata = axis.info$order.strata,
label.strata = axis.info$label.strata
)
axis.info$level.strata <- norm$level
axis.info$order.strata <- norm$order_data
axis.info$label.strata <- norm$label_map
if (!is.null(axis.info$label.strata)) {
stopifnot(!is.null(names(axis.info$label.strata)))
}
if (!is.null(order_input) && !is.null(level_input)) {
if (!all(as.character(order_input) %in% as.character(level_input))) {
warning("order.strata has unknown levels; ignoring order/label application.")
axis.info$order.strata <- NULL
axis.info$label.strata <- NULL
}
}
type.y <- axis.info$type.y
label.x <- axis.info$label.x
label.y <- axis.info$label.y
label.strata <- axis.info$label.strata
order.strata <- axis.info$order.strata
limits.x <- axis.info$limits.x
limits.y <- axis.info$limits.y
breaks.x <- axis.info$breaks.x
breaks.y <- axis.info$breaks.y
use.coord.cartesian <- axis.info$use.coord.cartesian
add.conf <- visual.info$add.conf
add.censor.mark <- visual.info$add.censor.mark
add.competing.risk.mark <- visual.info$add.competing.risk.mark
add.intercurrent.event.mark <- visual.info$add.intercurrent.event.mark
add.quantile <- visual.info$add.quantile
if (!is.null(plots)) {
if (!is.list(plots)) {
stop("`plots` must be a list of ggplot objects.")
}
if (length(plots) && !all(vapply(plots, function(p) inherits(p, "ggplot"), logical(1)))) {
stop("All elements of `plots` must inherit from 'ggplot'.")
}
plots <- apply_strata_to_plots(
plots,
order_data = axis.info$order.strata,
label_map = axis.info$label.strata,
touch_colour = TRUE
)
plots_out <- plots
if (isTRUE(inset.panel)) {
if (length(plots) < 2L) .err("inset_need_two")
if (length(plots) > 2L) .warn("inset_extra_drop")
p_base <- plots[[1]] + ggplot2::theme(legend.position = legend.position)
if (!is.null(title.plot) && length(title.plot) >= 1L) {
p_base <- p_base + ggplot2::labs(title = title.plot[[1]])
}
p_inset <- plots[[2]] + ggplot2::theme(legend.position = inset.legend.position)
if (!is.null(title.plot) && length(title.plot) >= 2L) {
p_inset <- p_inset + ggplot2::labs(title = title.plot[[2]])
}
out_patchwork <- p_base +
patchwork::inset_element(
p_inset,
left = inset.left,
bottom = inset.bottom,
right = inset.right,
top = inset.top,
align_to = inset.align.to
)
} else {
plots2 <- plots
if (length(plots2) < n_slots) {
plots2 <- c(
plots2,
rep(list(ggplot2::ggplot() + ggplot2::theme_void()), n_slots - length(plots2))
)
} else if (length(plots2) > n_slots) {
.warn("plots_extra_dropped", n_plots = length(plots2), n_slots = n_slots)
plots2 <- plots2[seq_len(n_slots)]
}
out_patchwork <- patchwork::wrap_plots(plots2, nrow = nrow, ncol = ncol)
if (isTRUE(legend.collect)) {
out_patchwork <- out_patchwork +
patchwork::plot_layout(guides = "collect") &
ggplot2::theme(legend.position = legend.position)
} else {
out_patchwork <- out_patchwork &
ggplot2::theme(legend.position = legend.position)
}
plots_out <- plots2
}
out_patchwork <- out_patchwork + patchwork::plot_annotation(
title = title.panel,
subtitle = subtitle.panel,
caption = caption.panel,
tag_levels = tag.panel,
theme = theme.panel.unified
)
if (interactive() && isTRUE(print.panel)) print(out_patchwork)
if (!is.null(filename.ggsave)) {
if (is.null(width.ggsave)) width.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[2])
if (is.null(height.ggsave)) height.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[1])
ggplot2::ggsave(filename.ggsave, plot = out_patchwork,
width = width.ggsave, height = height.ggsave,
dpi = dpi.ggsave, units = ggsave.units)
}
survfit.info$formula_or_fit <- survfit.info$formula_or_fit %||% list(
formula = formula,
formulas = formulas
)
survfit.info$outcome.type <- survfit.info$outcome.type %||% outcome.type
survfit.info$code.events <- survfit.info$code.events %||% code.events
survfit.info$data.name <- survfit.info$data.name %||% deparse(substitute(data))
print.info$engine <- print.info$engine %||% engine.list
res <- list(
plot = NULL,
list.plot = plots_out %||% plots,
patchwork = out_patchwork,
survfit.info = survfit.info,
axis.info = axis.info,
visual.info = visual.info,
panel.info = panel.info,
style.info = style.info,
inset.info = inset.info,
print.info = print.info,
ggsave.info = ggsave.info,
version = utils::packageVersion("cifmodeling"),
call = call
)
class(res) <- c("cifpanel", class(res))
return(invisible(res))
}
rows.columns.panel <- panel.info$rows.columns.panel
nrow <- as.integer(rows.columns.panel[1])
ncol <- as.integer(rows.columns.panel[2])
n_slots <- nrow * ncol
if (is.null(data)) stop("data must be provided.")
weights.resolved <- util_resolve_weights(
weights.expr = weights.expr,
data = data,
envir = parent.frame(),
missing = weights.missing
)
if (is.null(outcome.type) && is.null(code.events)) {
detection_formula <- if (!is.null(formulas) && length(formulas)) {
panel_as_formula(formulas[[1L]])
} else if (!is.null(formula)) {
panel_as_formula(formula)
} else {
NULL
}
if (!is.null(detection_formula)) {
outcome.type <- util_check_outcome_type_for_analysis(
formula = detection_formula,
data = data,
subset.condition = subset.condition,
na.action = na.action,
weights = weights.resolved,
auto_message = FALSE
)
}
}
if (is.null(code.events)) {
out_flag <- NULL
if (!is.null(outcome.type)) {
out0 <- if (is.list(outcome.type)) outcome.type[[1]] else outcome.type[1]
out_flag <- panel_norm_outcome(as.character(out0))
}
if (!is.null(out_flag) && identical(out_flag, "S")) {
base_codes <- c(code.event1, code.censoring)
} else {
base_codes <- c(code.event1, code.event2, code.censoring)
}
base_codes <- base_codes[!is.na(base_codes)]
if (length(base_codes) < 2L) {
.err("need_code_events")
}
code.events <- list(base_codes)
} else {
if (!is.list(code.events)) {
code.events <- list(code.events)
}
if (length(code.events) == 0L) {
.err("need_code_events")
}
}
if (!is.null(formulas) && !is.null(formula))
.warn("both_formula_forms")
if (is.null(formulas) && is.null(formula))
.err("need_formula_or_formulas")
layout_info <- panel_update_rows.columns.panel(
formulas = formulas,
code.events = code.events,
panel.info = panel.info,
n_slots = n_slots
)
K <- layout_info$K
code.events <- layout_info$code.events
panel.info$rows.columns.panel <- layout_info$rows.columns.panel
nrow <- layout_info$nrow
ncol <- layout_info$ncol
n_slots <- layout_info$n_slots
n.risk.type.list <- panel_to_list(n.risk.type)
if (!is.null(n.risk.type.list)) {
n.risk.type.list <- panel_recycle_to(n.risk.type.list, K)
n.risk.type.list <- lapply(n.risk.type.list, util_check_n_risk_type)
}
survfit.info$n.risk.type <- n.risk.type.list
use_formula_list <- !is.null(formulas)
if (use_formula_list) {
stopifnot(is.list(formulas))
formulas <- lapply(formulas, panel_as_formula)
formulas <- panel_recycle_to(formulas, K)
} else {
formula <- panel_as_formula(formula)
formulas <- rep(list(formula), K)
}
toL <- panel_to_list; rec <- panel_recycle_to
outcome.list <- toL(outcome.type); if (!is.null(outcome.list)) outcome.list <- rec(outcome.list, K)
typey.list <- toL(type.y); if (!is.null(typey.list)) typey.list <- rec(typey.list, K)
labely.list <- toL(label.y); if (!is.null(labely.list)) labely.list <- rec(labely.list, K)
labelx.list <- toL(label.x); if (!is.null(labelx.list)) labelx.list <- rec(labelx.list, K)
make_panel_list_preserve_vector <- function(x, K) {
if (is.list(x)) return(panel_recycle_to(x, K))
rep(list(x), K)
}
labelstrata.list <- make_panel_list_preserve_vector(label.strata, K)
orderstrata.list <- make_panel_list_preserve_vector(order.strata, K)
limsx.list <- NULL
if (!is.null(limits.x)) {
limsx.list <- if (is.list(limits.x)) limits.x else list(limits.x)
limsx.list <- rec(limsx.list, K)
}
limsy.list <- NULL
if (!is.null(limits.y)) {
limsy.list <- if (is.list(limits.y)) limits.y else list(limits.y)
limsy.list <- rec(limsy.list, K)
}
breakx.list <- toL(breaks.x); if (!is.null(breakx.list)) breakx.list <- rec(breakx.list, K)
breaky.list <- toL(breaks.y); if (!is.null(breaky.list)) breaky.list <- rec(breaky.list, K)
addCI.list <- toL(add.conf); if (!is.null(addCI.list)) addCI.list <- rec(addCI.list, K)
addCen.list <- toL(add.censor.mark); if (!is.null(addCen.list)) addCen.list <- rec(addCen.list, K)
addCR.list <- toL(add.competing.risk.mark); if (!is.null(addCR.list)) addCR.list <- rec(addCR.list, K)
addIC.list <- toL(add.intercurrent.event.mark); if (!is.null(addIC.list)) addIC.list <- rec(addIC.list, K)
addQ.list <- toL(add.quantile); if (!is.null(addQ.list)) addQ.list <- rec(addQ.list, K)
if (!is.null(addCI.list)) visual.info$add.conf <- NULL
if (!is.null(addCen.list)) visual.info$add.censor.mark <- NULL
if (!is.null(addCR.list)) visual.info$add.competing.risk.mark <- NULL
if (!is.null(addIC.list)) visual.info$add.intercurrent.event.mark <- NULL
if (!is.null(addQ.list)) visual.info$add.quantile <- NULL
infer_flag_by_codes <- function(v) if (length(v) == 2L) "S" else if (length(v) == 3L) "C" else NA_character_
if (!is.null(outcome.list)) {
outcome.flags <- vapply(outcome.list, panel_norm_outcome, character(1))
} else {
outcome.flags <- vapply(code.events, infer_flag_by_codes, character(1))
if (anyNA(outcome.flags)) .err("infer_outcome_fail")
}
kill_names <- c()
if (!is.null(outcome.list)) kill_names <- c(kill_names, "outcome.type")
if (!is.null(typey.list)) kill_names <- c(kill_names, "type.y")
if (!is.null(labely.list)) kill_names <- c(kill_names, "label.y")
if (!is.null(limsy.list)) kill_names <- c(kill_names, "limits.y")
if (!is.null(labelx.list)) kill_names <- c(kill_names, "label.x")
if (!is.null(limsx.list)) kill_names <- c(kill_names, "limits.x")
if (!is.null(labelstrata.list)) kill_names <- c(kill_names, "label.strata")
if (!is.null(orderstrata.list)) kill_names <- c(kill_names, "order.strata")
if (!is.null(breakx.list)) kill_names <- c(kill_names, "breaks.x")
if (!is.null(breaky.list)) kill_names <- c(kill_names, "breaks.y")
if (!is.null(addCI.list)) kill_names <- c(kill_names, "add.conf")
if (!is.null(addCen.list)) kill_names <- c(kill_names, "add.censor.mark")
if (!is.null(addCR.list)) kill_names <- c(kill_names, "add.competing.risk.mark")
if (!is.null(addIC.list)) kill_names <- c(kill_names, "add.intercurrent.event.mark")
if (!is.null(addQ.list)) kill_names <- c(kill_names, "add.quantile")
if (!is.null(n.risk.type.list)) kill_names <- c(kill_names, "n.risk.type")
dots <- panel_strip_overrides_from_dots(dots, unique(kill_names))
if (!is.null(engine.list)) {
engine.list <- panel_recycle_to(engine.list, K)
}
prep <- panel_prepare(
K = K,
formulas = formulas,
data = data,
weights = weights.resolved,
subset.condition = subset.condition,
code.events = code.events,
outcome.flags = outcome.flags,
outcome.list = outcome.list,
typey.list = typey.list,
labely.list = labely.list,
labelx.list = labelx.list,
limsx.list = limsx.list,
limsy.list = limsy.list,
breakx.list = breakx.list,
breaky.list = breaky.list,
addCI.list = addCI.list,
addCen.list = addCen.list,
addCR.list = addCR.list,
addIC.list = addIC.list,
addQ.list = addQ.list,
n.risk.type.list = n.risk.type.list,
strata.list = make_panel_list_preserve_vector(label.strata, K),
legend.position = legend.position,
survfit.info = survfit.info,
style.info = style.info,
dots = dots,
fonts = fonts,
na.action = na.action
)
survfit.info$curves <- survfit.info$curves %||% prep$curves
survfit.info$n.risk.type <- survfit.info$n.risk.type %||% n.risk.type.list
plots <- lapply(seq_len(prep$K), function(i) {
pa <- prep$plot_args[[i]]
if (!is.null(typey.list)) {
ty_i <- typey.list[[i]]
if (!is.null(ty_i)) {
pa$axis.info$type.y <- ty_i
}
}
pa$axis.info <- panel_modify_list(axis.info, pa$axis.info %||% list())
pa$visual.info <- panel_modify_list(visual.info, pa$visual.info %||% list())
pa$style.info <- panel_modify_list(style.info, pa$style.info %||% list())
pa$survfit.info <- panel_modify_list(survfit.info, pa$survfit.info %||% list())
if (!is.null(n.risk.type.list)) {
pa$survfit.info$n.risk.type <- n.risk.type.list[[i]]
pa$n.risk.type <- pa$n.risk.type %||% n.risk.type.list[[i]]
}
pa <- panel_force_apply(
pa,
i,
labelx.list = labelx.list,
labely.list = labely.list,
limsx.list = limsx.list,
limsy.list = limsy.list,
breakx.list = breakx.list,
breaky.list = breaky.list,
addCI.list = addCI.list,
addCen.list = addCen.list,
addCR.list = addCR.list,
addIC.list = addIC.list,
addQ.list = addQ.list
)
if (isTRUE(pa$add.competing.risk.mark)) {
ce <- code.events[[i]]
has_event2 <- !is.null(ce) && length(ce) >= 3L && !is.na(ce[2])
has_time <- !is.null(pa$competing.risk.time) && length(pa$competing.risk.time) > 0
if (has_event2 && !has_time) {
pa$visual.info$competing.risk.time <- extract_time_to_event(
formula = formulas[[i]],
data = data,
weights = weights.resolved,
subset.condition = subset.condition,
na.action = na.action,
which.event = "event2",
code.event1 = ce[1],
code.event2 = ce[2],
code.censoring = ce[3]
)
}
}
eng_i <- engine.list[[i]]
p_i <- if (identical(eng_i, "ggsurvfit")) {
sf_i <- prep$curves[[i]]
axis_i <- list(
type.y = pa$type.y,
label.x = pa$label.x,
label.y = pa$label.y,
label.strata = pa$label.strata,
level.strata = pa$level.strata,
order.strata = pa$order.strata,
limits.x = pa$limits.x,
limits.y = pa$limits.y,
breaks.x = pa$breaks.x,
breaks.y = pa$breaks.y,
use.coord.cartesian = pa$use.coord.cartesian
)
visual_i <- panel_modify_list(visual.info, list(
add.conf = pa$add.conf,
add.risktable = pa$add.risktable,
add.estimate.table = pa$add.estimate.table,
add.censor.mark = pa$add.censor.mark,
shape.censor.mark = pa$shape.censor.mark,
size.censor.mark = pa$size.censor.mark,
add.competing.risk.mark = pa$add.competing.risk.mark,
competing.risk.time = pa$competing.risk.time,
shape.competing.risk.mark= pa$shape.competing.risk.mark,
size.competing.risk.mark = pa$size.competing.risk.mark,
add.intercurrent.event.mark = pa$add.intercurrent.event.mark,
intercurrent.event.time = pa$intercurrent.event.time,
shape.intercurrent.event.mark = pa$shape.intercurrent.event.mark,
size.intercurrent.event.mark = pa$size.intercurrent.event.mark,
add.quantile = pa$add.quantile,
level.quantile = pa$level.quantile
))
panel_i <- list(
panel.per.event = FALSE,
panel.per.variable = FALSE,
rows.columns.panel = NULL
)
call_ggsurvfit(
survfit_object = sf_i,
survfit.info = survfit.info,
axis.info = axis_i,
visual.info = visual_i,
panel.info = panel_i,
style.info = style.info,
ggsave.info = ggsave.info
)
} else {
allowed <- setdiff(names(formals(cifplot_single)), "...")
if (!is.null(names(pa))) {
pa <- pa[intersect(names(pa), allowed)]
}
if (!"formula_or_fit" %in% names(pa)) {
pa <- c(list(formula_or_fit = prep$curves[[i]]), pa)
}
do.call(cifplot_single, pa)
}
if (!is.null(title.plot)) {
if (is.list(title.plot)) {
title_k <- title.plot[[ min(i, length(title.plot)) ]]
} else {
title_k <- title.plot[ min(i, length(title.plot)) ]
}
if (!is.null(title_k) && !identical(title_k, "")) {
p_i <- p_i + ggplot2::labs(title = title_k)
}
}
p_i
})
has_ggsurvfit <- any(vapply(engine.list, identical, logical(1), y = "ggsurvfit"))
plots <- apply_strata_to_plots(
plots,
order_data = axis.info$order.strata,
label_map = axis.info$label.strata,
touch_colour = !has_ggsurvfit
)
if (!is.null(title.plot)) {
for (i in seq_along(plots)) {
if (is.list(title.plot)) {
title_k <- title.plot[[ min(i, length(title.plot)) ]]
} else {
title_k <- title.plot[ min(i, length(title.plot)) ]
}
if (!is.null(title_k) && !identical(title_k, "")) {
plots[[i]] <- plots[[i]] + ggplot2::labs(title = title_k)
}
}
}
if (isTRUE(inset.panel)) {
if (length(plots) < 2L) .err("inset_need_two")
if (length(plots) > 2L) .warn("inset_extra_drop")
p_base <- plots[[1]] + ggplot2::theme(legend.position = legend.position)
p_inset <- plots[[2]] + ggplot2::theme(legend.position = inset.legend.position)
if (!is.null(title.plot)) {
if (length(title.plot) >= 1L) p_base <- p_base + ggplot2::labs(title = title.plot[[1]])
if (length(title.plot) >= 2L) p_inset <- p_inset + ggplot2::labs(title = title.plot[[2]])
}
out_patchwork <- p_base +
patchwork::inset_element(
p_inset, left = inset.left, bottom = inset.bottom,
right = inset.right, top = inset.top, align_to = inset.align.to
)
} else {
if (length(plots) < n_slots) {
plots <- c(plots, rep(list(ggplot2::ggplot() + ggplot2::theme_void()), n_slots - length(plots)))
} else if (length(plots) > n_slots) {
.warn("plots_extra_dropped", n_plots = length(plots), n_slots = n_slots)
plots <- plots[seq_len(n_slots)]
}
out_patchwork <- patchwork::wrap_plots(plots, nrow = nrow, ncol = ncol)
if (isTRUE(legend.collect)) {
out_patchwork <- out_patchwork +
patchwork::plot_layout(guides = "collect") &
ggplot2::theme(legend.position = legend.position)
} else {
out_patchwork <- out_patchwork &
ggplot2::theme(legend.position = legend.position)
}
}
out_patchwork <- out_patchwork + patchwork::plot_annotation(
title = title.panel,
subtitle = subtitle.panel,
caption = caption.panel,
tag_levels = tag.panel,
theme = theme.panel.unified
)
if (interactive() && isTRUE(print.panel)) print(out_patchwork)
if (!is.null(filename.ggsave)) {
if (is.null(width.ggsave)) width.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[2])
if (is.null(height.ggsave)) height.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[1])
ggplot2::ggsave(filename.ggsave, plot = out_patchwork,
width = width.ggsave, height = height.ggsave,
dpi = dpi.ggsave, units = ggsave.units)
}
survfit.info$formula_or_fit <- survfit.info$formula_or_fit %||% list(
formula = formula,
formulas = formulas
)
survfit.info$outcome.type <- survfit.info$outcome.type %||% outcome.type
survfit.info$code.events <- survfit.info$code.events %||% code.events
survfit.info$data.name <- survfit.info$data.name %||% deparse(substitute(data))
survfit.info$n.risk.type <- survfit.info$n.risk.type %||% n.risk.type.list
print.info$engine <- print.info$engine %||% engine.list
res <- list(
plot = NULL,
list.plot = plots_out %||% plots,
patchwork = out_patchwork,
survfit.info = survfit.info,
axis.info = axis.info,
visual.info = visual.info,
panel.info = panel.info,
style.info = style.info,
inset.info = inset.info,
print.info = print.info,
ggsave.info = ggsave.info,
version = utils::packageVersion("cifmodeling"),
call = call
)
class(res) <- c("cifpanel", class(res))
invisible(res)
}
panel_force_apply <- function(
pa,
i,
labelx.list = NULL,
labely.list = NULL,
limsx.list = NULL,
limsy.list = NULL,
breakx.list = NULL,
breaky.list = NULL,
addCI.list = NULL,
addCen.list = NULL,
addCR.list = NULL,
addIC.list = NULL,
addQ.list = NULL
) {
if (!is.null(labelx.list)) {
pa$label.x <- labelx.list[[i]]
pa$axis.info$label.x <- labelx.list[[i]]
}
if (!is.null(labely.list)) {
pa$label.y <- labely.list[[i]]
pa$axis.info$label.y <- labely.list[[i]]
}
if (!is.null(limsx.list)) {
pa$limits.x <- limsx.list[[i]]
pa$axis.info$limits.x <- limsx.list[[i]]
}
if (!is.null(limsy.list)) {
pa$limits.y <- limsy.list[[i]]
pa$axis.info$limits.y <- limsy.list[[i]]
}
if (!is.null(breakx.list)) {
pa$breaks.x <- breakx.list[[i]]
pa$axis.info$breaks.x <- breakx.list[[i]]
}
if (!is.null(breaky.list)) {
pa$breaks.y <- breaky.list[[i]]
pa$axis.info$breaks.y <- breaky.list[[i]]
}
if (!is.null(addCI.list)) {
v <- isTRUE(addCI.list[[i]])
pa$add.conf <- v
pa$visual.info$add.conf <- v
}
if (!is.null(addCen.list)) {
v <- isTRUE(addCen.list[[i]])
pa$add.censor.mark <- v
pa$visual.info$add.censor.mark <- v
}
if (!is.null(addCR.list)) {
v <- isTRUE(addCR.list[[i]])
pa$add.competing.risk.mark <- v
pa$visual.info$add.competing.risk.mark <- v
}
if (!is.null(addIC.list)) {
v <- isTRUE(addIC.list[[i]])
pa$add.intercurrent.event.mark <- v
pa$visual.info$add.intercurrent.event.mark <- v
}
if (!is.null(addQ.list)) {
v <- isTRUE(addQ.list[[i]])
pa$add.quantile <- v
pa$visual.info$add.quantile <- v
}
pa
}
normalize_strata_info <- function(level.strata = NULL,
order.strata = NULL,
label.strata = NULL) {
ch <- function(x) if (is.null(x)) NULL else as.character(x)
level <- ch(level.strata)
if (is.null(level) || !length(level)) {
return(list(level = NULL, order_data = NULL, label_map = NULL))
}
if (!is.null(label.strata)) {
if (is.null(names(label.strata)) || !any(nzchar(names(label.strata)))) {
if (length(label.strata) == length(level)) {
label_map <- stats::setNames(as.character(label.strata), level)
} else {
label_map <- stats::setNames(level, level)
}
} else {
lab_names <- names(label.strata)
lab_vals <- as.character(unname(label.strata))
keep <- intersect(lab_names, level)
label_map <- stats::setNames(label.strata[keep], keep)
miss <- setdiff(level, names(label_map))
if (length(miss)) {
label_map <- c(label_map, stats::setNames(miss, miss))
}
label_map <- label_map[level]
}
} else {
label_map <- stats::setNames(level, level)
}
ord <- ch(order.strata)
if (is.null(ord)) ord <- level
if (!all(ord %in% level)) {
return(list(level = level, order_data = NULL, label_map = NULL))
}
list(level = level, order_data = ord, label_map = label_map)
}
apply_strata_to_plots <- function(plots, order_data, label_map, touch_colour = TRUE) {
if (!length(plots) || is.null(order_data) || is.null(label_map)) return(plots)
brks <- as.character(order_data)
labs <- unname(as.character(label_map[brks]))
# 念のため欠損ラベルを補完
bad <- is.na(labs) | !nzchar(labs)
if (any(bad)) labs[bad] <- brks[bad]
# 既存 scale があれば「更新」、無ければ「追加」する
update_or_add_discrete_scale <- function(p, aes, add_scale_fun) {
# ggplot2内部は "colour" が正規形
aes <- if (identical(aes, "color")) "colour" else aes
sc <- p$scales$get_scales(aes)
if (is.null(sc)) {
# scale が未指定（デフォルト任せ）の場合だけ discrete scale を追加
# breaks/labels/limits を指定して legend の順序・表示名を固定する
return(
suppressMessages(
p + add_scale_fun(breaks = brks, labels = labs, limits = brks, drop = FALSE)
)
)
}
# 連続スケール等に誤爆しない（strata を想定しているので離散だけ触る）
if (!inherits(sc, "ScaleDiscrete")) return(p)
# 既存 scale（manual も含む）を“破壊せず”に legend 情報だけ更新
sc$breaks <- brks
sc$labels <- labs
# limits がある scale なら順序・マッピングも固定（manual values の上書きはしない）
# ggproto なので try で安全に
try(sc$limits <- brks, silent = TRUE)
p
}
relabel_one <- function(p) {
p <- update_or_add_discrete_scale(p, "linetype", ggplot2::scale_linetype_discrete)
p <- update_or_add_discrete_scale(p, "shape", ggplot2::scale_shape_discrete)
p <- update_or_add_discrete_scale(p, "fill", ggplot2::scale_fill_discrete)
if (isTRUE(touch_colour)) {
p <- update_or_add_discrete_scale(p, "colour", ggplot2::scale_color_discrete)
}
p
}
lapply(plots, relabel_one)
}
Try the cifmodeling package in your browser
Any scripts or data that you put into this service are public.
cifmodeling documentation built on Nov. 11, 2026, 9:06 a.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 apply_strata_to_plots normalize_strata_info panel_force_apply cifpanel
Documented in cifpanel
#' @title Arrange multiple survival and CIF plots in a panel display
#'
#' @description
#' [cifpanel()] is the panel-building counterpart of [cifplot()].
#' It takes one or more model formulas (or, alternatively, one formula and several
#' event-coding specifications) and returns a multi-panel figure, typically as a
#' patchwork-compatible object. Most display options (axis labels, marks, style, ggsave options)
#' are shared with [cifplot()], but per-panel legends and number-at-risk tables are
#' suppressed to avoid duplicated display. Typical use cases are:
#'
#' - Compare CIF (event 1) vs CIF (event 2) in a 1×2 layout.
#' - Compare survival/CIF curves across strata with a shared legend and matched axes.
#' - Display a plot with an enlarged y-axis inside a full-scale plot.
#'
#' @inheritParams cif-stat-arguments
#' @inheritParams cif-visual-arguments
#'
#' @param plots Optional list of existing ggplot objects to be arranged into a panel.
#' When plots is supplied, no new models are fitted; the plots are used as-is.
#' @param formula A model formula specifying the time-to-event outcome on the
#' left-hand side (typically `Event(time, status)` or `Surv(time, status)`)
#' and, optionally, a stratification variable on the right-hand side.
#' Unlike [cifplot()], this function does not accept a fitted
#' `survfit` object.
#' @param formulas Optional list of formulas. When given, each formula defines
#' **one panel**. This is the most common way to create “one variable per plot”
#' panels.
#' @param code.events Optional specification of event/censoring codes.
#' For single-panel calls, supply a numeric vector. For competing-risk outcomes, use `c(event1, event2, censoring)`.
#' For survival outcomes, a length-2 or length-3 vector is allowed:
#' `c(event, censoring)` or `c(event, *, censoring)`, where any middle element is ignored.
#' When supplied, this argument overrides `code.event1`, `code.event2`, and `code.censoring` for the purpose of estimation.
#' For panel displays (e.g. `cifpanel()` or when `panel.per.event = TRUE` or
#' `panel.censoring = TRUE`), `code.events` may also be a list of such numeric vectors, one per panel.
#' @param legend.collect Logical; if `TRUE`, try to collect a single legend
#' for all panels (passed to \pkg{patchwork}). Default `TRUE`.
#' @param inset.panel Logical. If `FALSE` (default), all panels are arranged
#' in a regular grid using `patchwork::wrap_plots()` and `plot_layout()`.
#' If `TRUE`, the function switches to “inset mode”: the **first** plot becomes
#' the main plot and the **second** plot (only the second) is drawn on top of it
#' as an inset. Additional plots beyond the second are ignored in inset mode.
#' Use grid mode to display more than two panels (`inset.panel = FALSE`).
#' @param inset.left,inset.bottom,inset.right,inset.top Numeric values in the range
#' `[0, 1]` that define the inset box as fractions of the reference area.
#' `inset.left` / `inset.right` control the horizontal position,
#' `inset.bottom` / `inset.top` control the vertical position.
#' Values are interpreted as “from the left/bottom” of the reference.
#' For example, `inset.left = 0.4`, `inset.right = 1.0` draws the inset
#' over the right 60% of the reference area.
#' @param inset.align.to Character string specifying the coordinate system for the
#' inset box. One of `"panel"` (default; the box is placed relative to the panel
#' area, i.e. the plotting region excluding outer titles/margins),
#' `"plot"` (relative to the entire plot area, including axes and titles of the
#' main plot), or `"full"` (relative to the full patchwork canvas).
#' This argument is passed to `patchwork::inset_element()`.
#' @param inset.legend.position Optional legend position **for the inset plot only**.
#' If `NULL` (default), the inset plot keeps whatever legend position was
#' defined for it (often this means a legend will also be inset).
#' Set, for example, `"none"` to hide the legend inside the inset,
#' while still showing the main plot's legend.
#' @param title.panel,subtitle.panel,caption.panel Character annotations applied to the
#' **whole** panel layout (not to individual plots). These are passed to
#' `patchwork::plot_annotation()` and are useful for creating figure-like
#' outputs (title + subfigures + caption).
#' @param tag.panel Passed to `patchwork::plot_annotation()` to auto-label
#' individual panels (e.g. `"A"`, `"B"`, `"C"`). Typical values are
#' `"A"`, `"1"`, or `"a"`. See `?patchwork::plot_annotation`.
#' @param title.plot Character vector of titles for **each panel** in the order they
#' are drawn. Length-1 values are recycled to all panels. In inset mode, the first
#' element refers to the main plot and the second (if present) to the inset.
#' @param survfit.info,axis.info,visual.info,panel.info,style.info,print.info,ggsave.info,inset.info
#' Internal lists used for programmatic control. Not intended for direct user input.
#' @param engine Character string specifying the internal rendering engine used to build each panel.
#' Currently intended for internal use; default is `"cifplot"`.
#' @param ... Additional arguments forwarded to the internal `cifplot_single()`
#' calls that build each panel. Use this to pass low-level options such as
#' `competing.risk.time`, `intercurrent.event.time`, or styling overrides.
#'
#' @details
#'
#' ### Overview
#' `cifpanel()` composes multiple survival/CIF plots into a single figure.
#' For each panel, it estimates curves via `cifcurve()` and renders them with
#' `cifplot()`. You can supply a single `formula` reused across panels or a
#' list in `formulas` (one per panel). When both are provided, `formulas` wins.
#'
#' ### Outcome type & event coding
#'
#' - Use `outcome.type` to set per-panel estimator (`"survival"`=KM, `"competing-risk"`=AJ).
#' - Alternatively, pass `code.events` per panel to infer the type:
#' - length 2 = survival: `c(event1, censor)`
#' - length 3 = competing-risk: `c(event1, event2, censor)`
#' - If `code.events` is `NULL`, `code.event1`, `code.event2`, `code.censoring`
#' are combined into `code.events = list(c(code.event1, code.event2, code.censoring))`
#' with `NA` values dropped.
#' - If `outcome.type` is `NULL`, the function infers each panel from its
#' `code.events[[i]]` length. When both are given, `outcome.type` takes precedence.
#' - Control risk-set displays via `n.risk.type`, which is recycled per panel and
#' forwarded to [cifcurve()] to decide which risk set size populates `$n.risk`
#' (e.g., weighted vs. unweighted counts).
#'
#' ### Panel-wise vs shared arguments
#'
#' Panel layout is specified by length-2 vector \code{rows.columns.panel}.
#' This function can also automatically determine the panel count in the following order:
#' (1) if \code{plots} is supplied, its length defines the number of plots,
#' (2) else if \code{formulas} is supplied, its length defines the number of plots,
#' (3) else if \code{code.events} is supplied, its length defines the number of plots
#' together with formula, and (4) otherwise \code{rows.columns.panel=c(1,1)}.
#'
#' Many arguments accept a **scalar** (recycled to all panels) or a **list/vector**
#' (one entry per panel). Precedence: **panel-wise explicit values** >
#' **shared scalar** > **internal defaults**. Length-1 inputs are recycled.
#'
#' ### Grid vs inset composition
#'
#' - **Grid mode** (`inset.panel = FALSE`, default): plots are arranged with
#' `patchwork::wrap_plots()` and `plot_layout()`. If `legend.collect = TRUE`,
#' legends are collected across panels where possible.
#' - **Inset mode** (`inset.panel = TRUE`): the **second** plot is overlaid
#' into the **first** using `patchwork::inset_element()`. Only the first two
#' plots are used; extra plots are ignored. Control the inset box with
#' `inset.left`, `inset.bottom`, `inset.right`, `inset.top`, and its
#' reference frame via `inset.align.to` (`"panel"`, `"plot"`, or `"full"`).
#'
#' ### Advanced panel controls (forwarded to `cifplot()`)
#'
#' The following arguments allow **per-panel** control by supplying vectors/lists,
#' or **shared** control by supplying scalars. They are forwarded to `cifplot()`.
#'
#' - `formula` or `formulas`: one formula or a list of formulas; each entry creates a panel.
#' - `data`, `outcome.type`, `code.events`, `type.y`: recycled across panels unless a list is supplied for per-panel control.
#' - `rows.columns.panel`: specification of grid layout by c(rows, cols).
#' - `inset.panel`: inset layout.
#' - `title.panel`, `subtitle.panel`, `caption.panel`, `title.plot`: overall titles and captions.
#' - `tag.panel`: panel tag style (e.g., "A", "a", "1").
#' - `label.x`, `label.y`, `limits.x`, `limits.y`, `breaks.x`, `breaks.y`: shared axis control unless a list is supplied for per-panel control.
#'
#' #### Scale & labels
#'
#' | Argument | Meaning | Default |
#' |---|---|---|
#' | `type.y` | `"risk"` (CIF y-axis) or `NULL` (survival). | inferred |
#' | `label.x`, `label.y` | Axis labels per panel. | auto |
#' | `label.strata` | Legend labels per panel. | from data |
#' | `limits.x`, `limits.y` | Axis limits `c(min, max)`. | auto |
#' | `breaks.x`, `breaks.y` | Axis breaks (forwarded to `breaks.x`/`breaks.y`). | auto |
#'
#' #### Plot layers (toggles)
#'
#' | Argument | Effect | Default |
#' |---|---|---|
#' | `add.conf` | CI ribbon. | `TRUE` |
#' | `add.censor.mark` | Censor marks. | `TRUE` |
#' | `add.competing.risk.mark` | Marks for event2 at supplied times. | `FALSE` |
#' | `add.intercurrent.event.mark` | User-specified intercurrent marks. | `FALSE` |
#' | `add.quantile` | Quantile reference line(s). | `FALSE` |
#'
#' *(Time marks inputs such as `competing.risk.time` / `intercurrent.event.time`
#' can be given via `...` if needed; names must match strata labels.)*
#'
#' ### Legend & annotations
#'
#' - `legend.position`: `"top"`, `"right"`, `"bottom"`, `"left"`, or `"none"` (applies to all panels).
#' - Grid mode: `legend.collect = TRUE` attempts a shared legend.
#' - Panel annotations: `title.panel`, `subtitle.panel`, `caption.panel`.
#' - Tagging: `tag.panel` is passed to `patchwork::plot_annotation()`.
#' - In inset mode, `title.plot = c(title_base, title_inset)` labels the two plots.
#'
#' ### Export (optional)
#'
#' If `filename.ggsave` is non-`NULL`, the composed panel is saved with
#' `ggsave()` using `width.ggsave`, `height.ggsave`, and `dpi.ggsave`.
#' Otherwise, the function returns objects without saving.
#'
#' **Notes**
#' - Mixed panel types are supported (e.g., AJ in panel 1; KM in panel 2).
#' - If `formulas` is shorter than the grid capacity, empty slots are ignored.
#' - When supplying vectors/lists per panel, their lengths must match the number
#' of panels; length-1 inputs are recycled; otherwise an error is thrown.
#' - For CIF displays, set `type.y = "risk"`. For survival scale, use `type.y = NULL` or `= "surv"`.
#' For ADaM-style data, use `code.events=c(0,1)` or
#' `code.event1 = 0`, `code.censoring = 1`.
#' - Additional graphical options (e.g., theme) can be added post-hoc to each
#' element of `list.plot` or to the composed `patchwork`.
#'
#' @importFrom patchwork wrap_plots plot_layout inset_element plot_annotation
#'
#' @return A `"cifpanel"` object (returned invisibly), which is a list
#' with at least the following elements:
#'
#' - `list.plot`: a list of ggplot objects, one per panel
#' - `patchwork`: a patchwork object representing the composed panel
#' - `plot`: reserved for backwards compatibility (always `NULL`)
#' - metadata fields mirroring those in [cifplot()] (such as information
#' on the fitted curves and display settings)
#'
#' When `print.panel = TRUE`, the patchwork object is printed in interactive
#' sessions in addition to being returned.
#'
#' @examples
#' data(diabetes.complications)
#' output1 <- cifpanel(
#' title.panel = "A comparison of cumulative incidence of competing events",
#' rows.columns.panel = c(1,2),
#' formula = Event(t, epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type = "competing-risk",
#' code.events = list(c(1,2,0), c(2,1,0)),
#' label.y = c("Diabetic retinopathy", "Macrovascular complications"),
#' label.x = "Years from registration",
#' subtitle.panel = "Stratified by fruit intake",
#' caption.panel = "Data: diabetes.complications",
#' title.plot = c("Diabetic retinopathy", "Macrovascular complications"),
#' legend.position = "bottom",
#' legend.collect=TRUE
#' )
#' print(output1)
#'
#' output2 <- cifplot(Event(t,epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type="competing-risk",
#' code.event1=2,
#' code.event2=1,
#' add.conf = FALSE,
#' add.risktable = FALSE,
#' label.y="CIF of macrovascular complications",
#' label.x="Years from registration")
#' output3 <- cifplot(Event(t,epsilon) ~ fruitq,
#' data = diabetes.complications,
#' outcome.type="competing-risk",
#' code.event1=2,
#' code.event2=1,
#' add.conf = FALSE,
#' add.risktable = FALSE,
#' label.y="",
#' label.x="",
#' limits.y=c(0,0.15))
#' output4 <- list(a = output2$plot, b = output3$plot)
#' output5 <- cifpanel(plots = output4,
#' inset.panel = TRUE,
#' inset.left = 0.40, inset.bottom = 0.45,
#' inset.right = 1.00, inset.top = 0.95,
#' inset.align.to = "plot",
#' inset.legend.position = "none",
#' legend.position = "bottom")
#' print(output5)
#'
#' @importFrom ggplot2 ggplot theme_void ggsave theme element_text labs
#' @importFrom patchwork wrap_plots plot_layout inset_element plot_annotation
#'
#' @name cifpanel
#' @section Lifecycle:
#' \lifecycle{experimental}
#' @seealso [polyreg()] for log-odds product modeling of CIFs; [cifcurve()] for KM/AJ estimators; [cifplot()] for display of a CIF; [ggsurvfit][ggsurvfit], [patchwork][patchwork] and [modelsummary][modelsummary] for display helpers.
#' @export
cifpanel <- function(
plots = NULL,
formula = NULL,
formulas = NULL,
data = NULL,
weights = NULL,
subset.condition = NULL,
na.action = na.omit,
outcome.type = NULL,
code.event1 = 1,
code.event2 = 2,
code.censoring = 0,
code.events = NULL,
error = NULL,
conf.type = NULL,
conf.int = NULL,
n.risk.type = c("weighted", "unweighted", "ess"),
type.y = NULL,
label.x = NULL,
label.y = NULL,
label.strata = NULL,
order.strata = NULL,
level.strata = NULL,
limits.x = NULL,
limits.y = NULL,
breaks.x = NULL,
breaks.y = NULL,
add.conf = NULL,
add.risktable = NULL,
add.estimate.table = NULL,
symbol.risk.table = NULL,
font.size.risk.table = NULL,
add.censor.mark = NULL,
shape.censor.mark = NULL,
size.censor.mark = NULL,
add.competing.risk.mark = NULL,
competing.risk.time = NULL,
shape.competing.risk.mark = NULL,
size.competing.risk.mark = NULL,
add.intercurrent.event.mark = NULL,
intercurrent.event.time = NULL,
shape.intercurrent.event.mark = NULL,
size.intercurrent.event.mark = NULL,
add.quantile = NULL,
level.quantile = NULL,
rows.columns.panel = c(1, 1),
inset.panel = FALSE,
title.panel = NULL,
subtitle.panel = NULL,
caption.panel = NULL,
tag.panel = NULL,
title.plot = NULL,
style = "classic",
palette = NULL,
linewidth = 0.8,
linetype = FALSE,
font.family = "sans",
font.size = 8,
legend.position = "top",
legend.collect = TRUE,
inset.left = 0.60,
inset.bottom = 0.05,
inset.right = 0.98,
inset.top = 0.45,
inset.align.to = c("panel","plot","full"),
inset.legend.position = NULL,
print.panel = FALSE,
filename.ggsave = NULL,
width.ggsave = NULL,
height.ggsave = NULL,
dpi.ggsave = 300,
survfit.info = NULL,
axis.info = NULL,
visual.info = NULL,
panel.info = NULL,
style.info = NULL,
inset.info = NULL,
print.info = NULL,
ggsave.info = NULL,
engine = "cifplot",
...
){
weights.expr <- substitute(weights)
weights.missing <- missing(weights)
legend.position <- "none"
add.risktable <- FALSE
add.estimate.table <- FALSE
inset.align.to <- match.arg(inset.align.to)
dots <- list(...)
call <- match.call()
plots_out <- NULL
engine.list <- panel_to_list(engine)
if (missing(n.risk.type)) n.risk.type <- "weighted"
survfit.info.user <- survfit.info
axis.info.user <- axis.info
visual.info.user <- visual.info
panel.info.user <- panel.info
style.info.user <- style.info
inset.info.user <- inset.info
print.info.user <- print.info
ggsave.info.user <- ggsave.info
survfit.info <- panel_modify_list(list(
error = error,
conf.type = conf.type,
conf.int = conf.int,
n.risk.type = n.risk.type
), survfit.info %||% list())
axis.info <- panel_modify_list(list(
type.y = type.y,
label.x = label.x,
label.y = label.y,
level.strata = level.strata,
order.strata = order.strata,
label.strata = label.strata,
limits.x = limits.x,
limits.y = limits.y,
breaks.x = breaks.x,
breaks.y = breaks.y,
use.coord.cartesian = get0("use.coord.cartesian", ifnotfound = NULL)
), axis.info %||% list())
visual.info <- panel_modify_list(list(
add.conf = add.conf,
ci.alpha = 0.25,
add.risktable = FALSE,
add.estimate.table = FALSE,
add.censor.mark = add.censor.mark,
shape.censor.mark = 3,
size.censor.mark = 2,
add.competing.risk.mark = add.competing.risk.mark,
competing.risk.time = list(),
shape.competing.risk.mark= 16,
size.competing.risk.mark = 2,
add.intercurrent.event.mark = add.intercurrent.event.mark,
intercurrent.event.time = list(),
shape.intercurrent.event.mark = 1,
size.intercurrent.event.mark = 2,
add.quantile = add.quantile,
level.quantile = 0.5,
line.size = 0.9,
symbol.risk.table = NULL,
font.size.risk.table = NULL
), visual.info %||% list())
panel.info <- panel_modify_list(list(
panel.per.event = FALSE,
panel.per.variable = FALSE,
rows.columns.panel = rows.columns.panel,
title.panel = title.panel,
subtitle.panel = subtitle.panel,
caption.panel = caption.panel,
tag.panel = tag.panel,
title.plot = title.plot
), panel.info %||% list())
style.info <- style.info %||% list()
style.info$style <- style.info$style %||% style
style.info$palette <- style.info$palette %||% palette
style.info$linewidth <- style.info$linewidth %||% linewidth
style.info$linetype <- style.info$linetype %||% linetype
style.info$font.family <- style.info$font.family %||% font.family
style.info$font.size <- style.info$font.size %||% font.size
style.info$legend.position <- style.info$legend.position %||% legend.position
style.info$legend.collect <- style.info$legend.collect %||% legend.collect
style.info <- panel_modify_list(list(
style = "classic",
palette = NULL,
linewidth = NULL,
linetype = NULL,
font.family = "sans",
font.size = 12,
legend.position = "top",
legend.collect = FALSE
), style.info)
inset.info <- panel_modify_list(list(
inset.panel = inset.panel,
inset.align.to = inset.align.to,
inset.left = inset.left,
inset.bottom = inset.bottom,
inset.right = inset.right,
inset.top = inset.top,
inset.legend.position = inset.legend.position
), inset.info %||% list())
print.info <- panel_modify_list(list(
print.panel = print.panel
), print.info %||% list())
ggsave.info <- panel_modify_list(list(
filename.ggsave = filename.ggsave,
width.ggsave = width.ggsave,
height.ggsave = height.ggsave,
dpi.ggsave = dpi.ggsave,
units = "in"
), ggsave.info %||% list())
inset.info$inset.align.to <- match.arg(inset.info$inset.align.to, c("panel","plot","full"))
rows.columns.panel <- panel.info$rows.columns.panel
title.panel <- panel.info$title.panel
subtitle.panel <- panel.info$subtitle.panel
caption.panel <- panel.info$caption.panel
tag.panel <- panel.info$tag.panel
title.plot <- panel.info$title.plot
legend.position <- style.info$legend.position
legend.collect <- isTRUE(style.info$legend.collect)
inset.panel <- isTRUE(inset.info$inset.panel)
inset.align.to <- inset.info$inset.align.to
inset.left <- inset.info$inset.left
inset.bottom <- inset.info$inset.bottom
inset.right <- inset.info$inset.right
inset.top <- inset.info$inset.top
inset.legend.position <- inset.info$inset.legend.position
print.panel <- isTRUE(print.info$print.panel)
filename.ggsave <- ggsave.info$filename.ggsave
width.ggsave <- ggsave.info$width.ggsave
height.ggsave <- ggsave.info$height.ggsave
dpi.ggsave <- ggsave.info$dpi.ggsave
ggsave.units <- ggsave.info$units %||% "in"
fonts <- panel_extract_fonts(c(style.info, dots))
style.info$font.family <- fonts$family
style.info$font.size <- fonts$size
theme.panel.unified <- panel_build_theme(font.family = fonts$family, font.size = fonts$size)
nrow <- as.integer(rows.columns.panel[1]); ncol <- as.integer(rows.columns.panel[2])
n_slots <- nrow * ncol
level_input <- axis.info$level.strata
order_input <- axis.info$order.strata
norm <- normalize_strata_info(
level.strata = axis.info$level.strata,
order.strata = axis.info$order.strata,
label.strata = axis.info$label.strata
)
axis.info$level.strata <- norm$level
axis.info$order.strata <- norm$order_data
axis.info$label.strata <- norm$label_map
if (!is.null(axis.info$label.strata)) {
stopifnot(!is.null(names(axis.info$label.strata)))
}
if (!is.null(order_input) && !is.null(level_input)) {
if (!all(as.character(order_input) %in% as.character(level_input))) {
warning("order.strata has unknown levels; ignoring order/label application.")
axis.info$order.strata <- NULL
axis.info$label.strata <- NULL
}
}
type.y <- axis.info$type.y
label.x <- axis.info$label.x
label.y <- axis.info$label.y
label.strata <- axis.info$label.strata
order.strata <- axis.info$order.strata
limits.x <- axis.info$limits.x
limits.y <- axis.info$limits.y
breaks.x <- axis.info$breaks.x
breaks.y <- axis.info$breaks.y
use.coord.cartesian <- axis.info$use.coord.cartesian
add.conf <- visual.info$add.conf
add.censor.mark <- visual.info$add.censor.mark
add.competing.risk.mark <- visual.info$add.competing.risk.mark
add.intercurrent.event.mark <- visual.info$add.intercurrent.event.mark
add.quantile <- visual.info$add.quantile
if (!is.null(plots)) {
if (!is.list(plots)) {
stop("`plots` must be a list of ggplot objects.")
}
if (length(plots) && !all(vapply(plots, function(p) inherits(p, "ggplot"), logical(1)))) {
stop("All elements of `plots` must inherit from 'ggplot'.")
}
plots <- apply_strata_to_plots(
plots,
order_data = axis.info$order.strata,
label_map = axis.info$label.strata,
touch_colour = TRUE
)
plots_out <- plots
if (isTRUE(inset.panel)) {
if (length(plots) < 2L) .err("inset_need_two")
if (length(plots) > 2L) .warn("inset_extra_drop")
p_base <- plots[[1]] + ggplot2::theme(legend.position = legend.position)
if (!is.null(title.plot) && length(title.plot) >= 1L) {
p_base <- p_base + ggplot2::labs(title = title.plot[[1]])
}
p_inset <- plots[[2]] + ggplot2::theme(legend.position = inset.legend.position)
if (!is.null(title.plot) && length(title.plot) >= 2L) {
p_inset <- p_inset + ggplot2::labs(title = title.plot[[2]])
}
out_patchwork <- p_base +
patchwork::inset_element(
p_inset,
left = inset.left,
bottom = inset.bottom,
right = inset.right,
top = inset.top,
align_to = inset.align.to
)
} else {
plots2 <- plots
if (length(plots2) < n_slots) {
plots2 <- c(
plots2,
rep(list(ggplot2::ggplot() + ggplot2::theme_void()), n_slots - length(plots2))
)
} else if (length(plots2) > n_slots) {
.warn("plots_extra_dropped", n_plots = length(plots2), n_slots = n_slots)
plots2 <- plots2[seq_len(n_slots)]
}
out_patchwork <- patchwork::wrap_plots(plots2, nrow = nrow, ncol = ncol)
if (isTRUE(legend.collect)) {
out_patchwork <- out_patchwork +
patchwork::plot_layout(guides = "collect") &
ggplot2::theme(legend.position = legend.position)
} else {
out_patchwork <- out_patchwork &
ggplot2::theme(legend.position = legend.position)
}
plots_out <- plots2
}
out_patchwork <- out_patchwork + patchwork::plot_annotation(
title = title.panel,
subtitle = subtitle.panel,
caption = caption.panel,
tag_levels = tag.panel,
theme = theme.panel.unified
)
if (interactive() && isTRUE(print.panel)) print(out_patchwork)
if (!is.null(filename.ggsave)) {
if (is.null(width.ggsave)) width.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[2])
if (is.null(height.ggsave)) height.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[1])
ggplot2::ggsave(filename.ggsave, plot = out_patchwork,
width = width.ggsave, height = height.ggsave,
dpi = dpi.ggsave, units = ggsave.units)
}
survfit.info$formula_or_fit <- survfit.info$formula_or_fit %||% list(
formula = formula,
formulas = formulas
)
survfit.info$outcome.type <- survfit.info$outcome.type %||% outcome.type
survfit.info$code.events <- survfit.info$code.events %||% code.events
survfit.info$data.name <- survfit.info$data.name %||% deparse(substitute(data))
print.info$engine <- print.info$engine %||% engine.list
res <- list(
plot = NULL,
list.plot = plots_out %||% plots,
patchwork = out_patchwork,
survfit.info = survfit.info,
axis.info = axis.info,
visual.info = visual.info,
panel.info = panel.info,
style.info = style.info,
inset.info = inset.info,
print.info = print.info,
ggsave.info = ggsave.info,
version = utils::packageVersion("cifmodeling"),
call = call
)
class(res) <- c("cifpanel", class(res))
return(invisible(res))
}
rows.columns.panel <- panel.info$rows.columns.panel
nrow <- as.integer(rows.columns.panel[1])
ncol <- as.integer(rows.columns.panel[2])
n_slots <- nrow * ncol
if (is.null(data)) stop("data must be provided.")
weights.resolved <- util_resolve_weights(
weights.expr = weights.expr,
data = data,
envir = parent.frame(),
missing = weights.missing
)
if (is.null(outcome.type) && is.null(code.events)) {
detection_formula <- if (!is.null(formulas) && length(formulas)) {
panel_as_formula(formulas[[1L]])
} else if (!is.null(formula)) {
panel_as_formula(formula)
} else {
NULL
}
if (!is.null(detection_formula)) {
outcome.type <- util_check_outcome_type_for_analysis(
formula = detection_formula,
data = data,
subset.condition = subset.condition,
na.action = na.action,
weights = weights.resolved,
auto_message = FALSE
)
}
}
if (is.null(code.events)) {
out_flag <- NULL
if (!is.null(outcome.type)) {
out0 <- if (is.list(outcome.type)) outcome.type[[1]] else outcome.type[1]
out_flag <- panel_norm_outcome(as.character(out0))
}
if (!is.null(out_flag) && identical(out_flag, "S")) {
base_codes <- c(code.event1, code.censoring)
} else {
base_codes <- c(code.event1, code.event2, code.censoring)
}
base_codes <- base_codes[!is.na(base_codes)]
if (length(base_codes) < 2L) {
.err("need_code_events")
}
code.events <- list(base_codes)
} else {
if (!is.list(code.events)) {
code.events <- list(code.events)
}
if (length(code.events) == 0L) {
.err("need_code_events")
}
}
if (!is.null(formulas) && !is.null(formula))
.warn("both_formula_forms")
if (is.null(formulas) && is.null(formula))
.err("need_formula_or_formulas")
layout_info <- panel_update_rows.columns.panel(
formulas = formulas,
code.events = code.events,
panel.info = panel.info,
n_slots = n_slots
)
K <- layout_info$K
code.events <- layout_info$code.events
panel.info$rows.columns.panel <- layout_info$rows.columns.panel
nrow <- layout_info$nrow
ncol <- layout_info$ncol
n_slots <- layout_info$n_slots
n.risk.type.list <- panel_to_list(n.risk.type)
if (!is.null(n.risk.type.list)) {
n.risk.type.list <- panel_recycle_to(n.risk.type.list, K)
n.risk.type.list <- lapply(n.risk.type.list, util_check_n_risk_type)
}
survfit.info$n.risk.type <- n.risk.type.list
use_formula_list <- !is.null(formulas)
if (use_formula_list) {
stopifnot(is.list(formulas))
formulas <- lapply(formulas, panel_as_formula)
formulas <- panel_recycle_to(formulas, K)
} else {
formula <- panel_as_formula(formula)
formulas <- rep(list(formula), K)
}
toL <- panel_to_list; rec <- panel_recycle_to
outcome.list <- toL(outcome.type); if (!is.null(outcome.list)) outcome.list <- rec(outcome.list, K)
typey.list <- toL(type.y); if (!is.null(typey.list)) typey.list <- rec(typey.list, K)
labely.list <- toL(label.y); if (!is.null(labely.list)) labely.list <- rec(labely.list, K)
labelx.list <- toL(label.x); if (!is.null(labelx.list)) labelx.list <- rec(labelx.list, K)
make_panel_list_preserve_vector <- function(x, K) {
if (is.list(x)) return(panel_recycle_to(x, K))
rep(list(x), K)
}
labelstrata.list <- make_panel_list_preserve_vector(label.strata, K)
orderstrata.list <- make_panel_list_preserve_vector(order.strata, K)
limsx.list <- NULL
if (!is.null(limits.x)) {
limsx.list <- if (is.list(limits.x)) limits.x else list(limits.x)
limsx.list <- rec(limsx.list, K)
}
limsy.list <- NULL
if (!is.null(limits.y)) {
limsy.list <- if (is.list(limits.y)) limits.y else list(limits.y)
limsy.list <- rec(limsy.list, K)
}
breakx.list <- toL(breaks.x); if (!is.null(breakx.list)) breakx.list <- rec(breakx.list, K)
breaky.list <- toL(breaks.y); if (!is.null(breaky.list)) breaky.list <- rec(breaky.list, K)
addCI.list <- toL(add.conf); if (!is.null(addCI.list)) addCI.list <- rec(addCI.list, K)
addCen.list <- toL(add.censor.mark); if (!is.null(addCen.list)) addCen.list <- rec(addCen.list, K)
addCR.list <- toL(add.competing.risk.mark); if (!is.null(addCR.list)) addCR.list <- rec(addCR.list, K)
addIC.list <- toL(add.intercurrent.event.mark); if (!is.null(addIC.list)) addIC.list <- rec(addIC.list, K)
addQ.list <- toL(add.quantile); if (!is.null(addQ.list)) addQ.list <- rec(addQ.list, K)
if (!is.null(addCI.list)) visual.info$add.conf <- NULL
if (!is.null(addCen.list)) visual.info$add.censor.mark <- NULL
if (!is.null(addCR.list)) visual.info$add.competing.risk.mark <- NULL
if (!is.null(addIC.list)) visual.info$add.intercurrent.event.mark <- NULL
if (!is.null(addQ.list)) visual.info$add.quantile <- NULL
infer_flag_by_codes <- function(v) if (length(v) == 2L) "S" else if (length(v) == 3L) "C" else NA_character_
if (!is.null(outcome.list)) {
outcome.flags <- vapply(outcome.list, panel_norm_outcome, character(1))
} else {
outcome.flags <- vapply(code.events, infer_flag_by_codes, character(1))
if (anyNA(outcome.flags)) .err("infer_outcome_fail")
}
kill_names <- c()
if (!is.null(outcome.list)) kill_names <- c(kill_names, "outcome.type")
if (!is.null(typey.list)) kill_names <- c(kill_names, "type.y")
if (!is.null(labely.list)) kill_names <- c(kill_names, "label.y")
if (!is.null(limsy.list)) kill_names <- c(kill_names, "limits.y")
if (!is.null(labelx.list)) kill_names <- c(kill_names, "label.x")
if (!is.null(limsx.list)) kill_names <- c(kill_names, "limits.x")
if (!is.null(labelstrata.list)) kill_names <- c(kill_names, "label.strata")
if (!is.null(orderstrata.list)) kill_names <- c(kill_names, "order.strata")
if (!is.null(breakx.list)) kill_names <- c(kill_names, "breaks.x")
if (!is.null(breaky.list)) kill_names <- c(kill_names, "breaks.y")
if (!is.null(addCI.list)) kill_names <- c(kill_names, "add.conf")
if (!is.null(addCen.list)) kill_names <- c(kill_names, "add.censor.mark")
if (!is.null(addCR.list)) kill_names <- c(kill_names, "add.competing.risk.mark")
if (!is.null(addIC.list)) kill_names <- c(kill_names, "add.intercurrent.event.mark")
if (!is.null(addQ.list)) kill_names <- c(kill_names, "add.quantile")
if (!is.null(n.risk.type.list)) kill_names <- c(kill_names, "n.risk.type")
dots <- panel_strip_overrides_from_dots(dots, unique(kill_names))
if (!is.null(engine.list)) {
engine.list <- panel_recycle_to(engine.list, K)
}
prep <- panel_prepare(
K = K,
formulas = formulas,
data = data,
weights = weights.resolved,
subset.condition = subset.condition,
code.events = code.events,
outcome.flags = outcome.flags,
outcome.list = outcome.list,
typey.list = typey.list,
labely.list = labely.list,
labelx.list = labelx.list,
limsx.list = limsx.list,
limsy.list = limsy.list,
breakx.list = breakx.list,
breaky.list = breaky.list,
addCI.list = addCI.list,
addCen.list = addCen.list,
addCR.list = addCR.list,
addIC.list = addIC.list,
addQ.list = addQ.list,
n.risk.type.list = n.risk.type.list,
strata.list = make_panel_list_preserve_vector(label.strata, K),
legend.position = legend.position,
survfit.info = survfit.info,
style.info = style.info,
dots = dots,
fonts = fonts,
na.action = na.action
)
survfit.info$curves <- survfit.info$curves %||% prep$curves
survfit.info$n.risk.type <- survfit.info$n.risk.type %||% n.risk.type.list
plots <- lapply(seq_len(prep$K), function(i) {
pa <- prep$plot_args[[i]]
if (!is.null(typey.list)) {
ty_i <- typey.list[[i]]
if (!is.null(ty_i)) {
pa$axis.info$type.y <- ty_i
}
}
pa$axis.info <- panel_modify_list(axis.info, pa$axis.info %||% list())
pa$visual.info <- panel_modify_list(visual.info, pa$visual.info %||% list())
pa$style.info <- panel_modify_list(style.info, pa$style.info %||% list())
pa$survfit.info <- panel_modify_list(survfit.info, pa$survfit.info %||% list())
if (!is.null(n.risk.type.list)) {
pa$survfit.info$n.risk.type <- n.risk.type.list[[i]]
pa$n.risk.type <- pa$n.risk.type %||% n.risk.type.list[[i]]
}
pa <- panel_force_apply(
pa,
i,
labelx.list = labelx.list,
labely.list = labely.list,
limsx.list = limsx.list,
limsy.list = limsy.list,
breakx.list = breakx.list,
breaky.list = breaky.list,
addCI.list = addCI.list,
addCen.list = addCen.list,
addCR.list = addCR.list,
addIC.list = addIC.list,
addQ.list = addQ.list
)
if (isTRUE(pa$add.competing.risk.mark)) {
ce <- code.events[[i]]
has_event2 <- !is.null(ce) && length(ce) >= 3L && !is.na(ce[2])
has_time <- !is.null(pa$competing.risk.time) && length(pa$competing.risk.time) > 0
if (has_event2 && !has_time) {
pa$visual.info$competing.risk.time <- extract_time_to_event(
formula = formulas[[i]],
data = data,
weights = weights.resolved,
subset.condition = subset.condition,
na.action = na.action,
which.event = "event2",
code.event1 = ce[1],
code.event2 = ce[2],
code.censoring = ce[3]
)
}
}
eng_i <- engine.list[[i]]
p_i <- if (identical(eng_i, "ggsurvfit")) {
sf_i <- prep$curves[[i]]
axis_i <- list(
type.y = pa$type.y,
label.x = pa$label.x,
label.y = pa$label.y,
label.strata = pa$label.strata,
level.strata = pa$level.strata,
order.strata = pa$order.strata,
limits.x = pa$limits.x,
limits.y = pa$limits.y,
breaks.x = pa$breaks.x,
breaks.y = pa$breaks.y,
use.coord.cartesian = pa$use.coord.cartesian
)
visual_i <- panel_modify_list(visual.info, list(
add.conf = pa$add.conf,
add.risktable = pa$add.risktable,
add.estimate.table = pa$add.estimate.table,
add.censor.mark = pa$add.censor.mark,
shape.censor.mark = pa$shape.censor.mark,
size.censor.mark = pa$size.censor.mark,
add.competing.risk.mark = pa$add.competing.risk.mark,
competing.risk.time = pa$competing.risk.time,
shape.competing.risk.mark= pa$shape.competing.risk.mark,
size.competing.risk.mark = pa$size.competing.risk.mark,
add.intercurrent.event.mark = pa$add.intercurrent.event.mark,
intercurrent.event.time = pa$intercurrent.event.time,
shape.intercurrent.event.mark = pa$shape.intercurrent.event.mark,
size.intercurrent.event.mark = pa$size.intercurrent.event.mark,
add.quantile = pa$add.quantile,
level.quantile = pa$level.quantile
))
panel_i <- list(
panel.per.event = FALSE,
panel.per.variable = FALSE,
rows.columns.panel = NULL
)
call_ggsurvfit(
survfit_object = sf_i,
survfit.info = survfit.info,
axis.info = axis_i,
visual.info = visual_i,
panel.info = panel_i,
style.info = style.info,
ggsave.info = ggsave.info
)
} else {
allowed <- setdiff(names(formals(cifplot_single)), "...")
if (!is.null(names(pa))) {
pa <- pa[intersect(names(pa), allowed)]
}
if (!"formula_or_fit" %in% names(pa)) {
pa <- c(list(formula_or_fit = prep$curves[[i]]), pa)
}
do.call(cifplot_single, pa)
}
if (!is.null(title.plot)) {
if (is.list(title.plot)) {
title_k <- title.plot[[ min(i, length(title.plot)) ]]
} else {
title_k <- title.plot[ min(i, length(title.plot)) ]
}
if (!is.null(title_k) && !identical(title_k, "")) {
p_i <- p_i + ggplot2::labs(title = title_k)
}
}
p_i
})
has_ggsurvfit <- any(vapply(engine.list, identical, logical(1), y = "ggsurvfit"))
plots <- apply_strata_to_plots(
plots,
order_data = axis.info$order.strata,
label_map = axis.info$label.strata,
touch_colour = !has_ggsurvfit
)
if (!is.null(title.plot)) {
for (i in seq_along(plots)) {
if (is.list(title.plot)) {
title_k <- title.plot[[ min(i, length(title.plot)) ]]
} else {
title_k <- title.plot[ min(i, length(title.plot)) ]
}
if (!is.null(title_k) && !identical(title_k, "")) {
plots[[i]] <- plots[[i]] + ggplot2::labs(title = title_k)
}
}
}
if (isTRUE(inset.panel)) {
if (length(plots) < 2L) .err("inset_need_two")
if (length(plots) > 2L) .warn("inset_extra_drop")
p_base <- plots[[1]] + ggplot2::theme(legend.position = legend.position)
p_inset <- plots[[2]] + ggplot2::theme(legend.position = inset.legend.position)
if (!is.null(title.plot)) {
if (length(title.plot) >= 1L) p_base <- p_base + ggplot2::labs(title = title.plot[[1]])
if (length(title.plot) >= 2L) p_inset <- p_inset + ggplot2::labs(title = title.plot[[2]])
}
out_patchwork <- p_base +
patchwork::inset_element(
p_inset, left = inset.left, bottom = inset.bottom,
right = inset.right, top = inset.top, align_to = inset.align.to
)
} else {
if (length(plots) < n_slots) {
plots <- c(plots, rep(list(ggplot2::ggplot() + ggplot2::theme_void()), n_slots - length(plots)))
} else if (length(plots) > n_slots) {
.warn("plots_extra_dropped", n_plots = length(plots), n_slots = n_slots)
plots <- plots[seq_len(n_slots)]
}
out_patchwork <- patchwork::wrap_plots(plots, nrow = nrow, ncol = ncol)
if (isTRUE(legend.collect)) {
out_patchwork <- out_patchwork +
patchwork::plot_layout(guides = "collect") &
ggplot2::theme(legend.position = legend.position)
} else {
out_patchwork <- out_patchwork &
ggplot2::theme(legend.position = legend.position)
}
}
out_patchwork <- out_patchwork + patchwork::plot_annotation(
title = title.panel,
subtitle = subtitle.panel,
caption = caption.panel,
tag_levels = tag.panel,
theme = theme.panel.unified
)
if (interactive() && isTRUE(print.panel)) print(out_patchwork)
if (!is.null(filename.ggsave)) {
if (is.null(width.ggsave)) width.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[2])
if (is.null(height.ggsave)) height.ggsave <- if (isTRUE(inset.panel)) 6 else max(6, 5 * rows.columns.panel[1])
ggplot2::ggsave(filename.ggsave, plot = out_patchwork,
width = width.ggsave, height = height.ggsave,
dpi = dpi.ggsave, units = ggsave.units)
}
survfit.info$formula_or_fit <- survfit.info$formula_or_fit %||% list(
formula = formula,
formulas = formulas
)
survfit.info$outcome.type <- survfit.info$outcome.type %||% outcome.type
survfit.info$code.events <- survfit.info$code.events %||% code.events
survfit.info$data.name <- survfit.info$data.name %||% deparse(substitute(data))
survfit.info$n.risk.type <- survfit.info$n.risk.type %||% n.risk.type.list
print.info$engine <- print.info$engine %||% engine.list
res <- list(
plot = NULL,
list.plot = plots_out %||% plots,
patchwork = out_patchwork,
survfit.info = survfit.info,
axis.info = axis.info,
visual.info = visual.info,
panel.info = panel.info,
style.info = style.info,
inset.info = inset.info,
print.info = print.info,
ggsave.info = ggsave.info,
version = utils::packageVersion("cifmodeling"),
call = call
)
class(res) <- c("cifpanel", class(res))
invisible(res)
}
panel_force_apply <- function(
pa,
i,
labelx.list = NULL,
labely.list = NULL,
limsx.list = NULL,
limsy.list = NULL,
breakx.list = NULL,
breaky.list = NULL,
addCI.list = NULL,
addCen.list = NULL,
addCR.list = NULL,
addIC.list = NULL,
addQ.list = NULL
) {
if (!is.null(labelx.list)) {
pa$label.x <- labelx.list[[i]]
pa$axis.info$label.x <- labelx.list[[i]]
}
if (!is.null(labely.list)) {
pa$label.y <- labely.list[[i]]
pa$axis.info$label.y <- labely.list[[i]]
}
if (!is.null(limsx.list)) {
pa$limits.x <- limsx.list[[i]]
pa$axis.info$limits.x <- limsx.list[[i]]
}
if (!is.null(limsy.list)) {
pa$limits.y <- limsy.list[[i]]
pa$axis.info$limits.y <- limsy.list[[i]]
}
if (!is.null(breakx.list)) {
pa$breaks.x <- breakx.list[[i]]
pa$axis.info$breaks.x <- breakx.list[[i]]
}
if (!is.null(breaky.list)) {
pa$breaks.y <- breaky.list[[i]]
pa$axis.info$breaks.y <- breaky.list[[i]]
}
if (!is.null(addCI.list)) {
v <- isTRUE(addCI.list[[i]])
pa$add.conf <- v
pa$visual.info$add.conf <- v
}
if (!is.null(addCen.list)) {
v <- isTRUE(addCen.list[[i]])
pa$add.censor.mark <- v
pa$visual.info$add.censor.mark <- v
}
if (!is.null(addCR.list)) {
v <- isTRUE(addCR.list[[i]])
pa$add.competing.risk.mark <- v
pa$visual.info$add.competing.risk.mark <- v
}
if (!is.null(addIC.list)) {
v <- isTRUE(addIC.list[[i]])
pa$add.intercurrent.event.mark <- v
pa$visual.info$add.intercurrent.event.mark <- v
}
if (!is.null(addQ.list)) {
v <- isTRUE(addQ.list[[i]])
pa$add.quantile <- v
pa$visual.info$add.quantile <- v
}
pa
}
normalize_strata_info <- function(level.strata = NULL,
order.strata = NULL,
label.strata = NULL) {
ch <- function(x) if (is.null(x)) NULL else as.character(x)
level <- ch(level.strata)
if (is.null(level) || !length(level)) {
return(list(level = NULL, order_data = NULL, label_map = NULL))
}
if (!is.null(label.strata)) {
if (is.null(names(label.strata)) || !any(nzchar(names(label.strata)))) {
if (length(label.strata) == length(level)) {
label_map <- stats::setNames(as.character(label.strata), level)
} else {
label_map <- stats::setNames(level, level)
}
} else {
lab_names <- names(label.strata)
lab_vals <- as.character(unname(label.strata))
keep <- intersect(lab_names, level)
label_map <- stats::setNames(label.strata[keep], keep)
miss <- setdiff(level, names(label_map))
if (length(miss)) {
label_map <- c(label_map, stats::setNames(miss, miss))
}
label_map <- label_map[level]
}
} else {
label_map <- stats::setNames(level, level)
}
ord <- ch(order.strata)
if (is.null(ord)) ord <- level
if (!all(ord %in% level)) {
return(list(level = level, order_data = NULL, label_map = NULL))
}
list(level = level, order_data = ord, label_map = label_map)
}
apply_strata_to_plots <- function(plots, order_data, label_map, touch_colour = TRUE) {
if (!length(plots) || is.null(order_data) || is.null(label_map)) return(plots)
brks <- as.character(order_data)
labs <- unname(as.character(label_map[brks]))
# 念のため欠損ラベルを補完
bad <- is.na(labs) | !nzchar(labs)
if (any(bad)) labs[bad] <- brks[bad]
# 既存 scale があれば「更新」、無ければ「追加」する
update_or_add_discrete_scale <- function(p, aes, add_scale_fun) {
# ggplot2内部は "colour" が正規形
aes <- if (identical(aes, "color")) "colour" else aes
sc <- p$scales$get_scales(aes)
if (is.null(sc)) {
# scale が未指定（デフォルト任せ）の場合だけ discrete scale を追加
# breaks/labels/limits を指定して legend の順序・表示名を固定する
return(
suppressMessages(
p + add_scale_fun(breaks = brks, labels = labs, limits = brks, drop = FALSE)
)
)
}
# 連続スケール等に誤爆しない（strata を想定しているので離散だけ触る）
if (!inherits(sc, "ScaleDiscrete")) return(p)
# 既存 scale（manual も含む）を“破壊せず”に legend 情報だけ更新
sc$breaks <- brks
sc$labels <- labs
# limits がある scale なら順序・マッピングも固定（manual values の上書きはしない）
# ggproto なので try で安全に
try(sc$limits <- brks, silent = TRUE)
p
}
relabel_one <- function(p) {
p <- update_or_add_discrete_scale(p, "linetype", ggplot2::scale_linetype_discrete)
p <- update_or_add_discrete_scale(p, "shape", ggplot2::scale_shape_discrete)
p <- update_or_add_discrete_scale(p, "fill", ggplot2::scale_fill_discrete)
if (isTRUE(touch_colour)) {
p <- update_or_add_discrete_scale(p, "colour", ggplot2::scale_color_discrete)
}
p
}
lapply(plots, relabel_one)
}
Try the cifmodeling 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.