R/add_split_table.R

In ggforestplotR: Publication-Ready Forest Plots with 'ggplot2'

.compose_split_table <- function(plot,
                                 show_terms = TRUE,
                                 show_n = NULL,
                                 show_events = NULL,
                                 show_estimate = TRUE,
                                 show_p = FALSE,
                                 left_columns = NULL,
                                 right_columns = NULL,
                                 term_header = "Term",
                                 n_header = "N",
                                 events_header = "Events",
                                 estimate_label = NULL,
                                 p_header = "P-value",
                                 column_labels = NULL,
                                 digits = NULL,
                                 estimate_digits = NULL,
                                 interval_digits = NULL,
                                 p_digits = NULL,
                                 estimate_fmt = NULL,
                                 ci_fmt = NULL,
                                 text_size = NULL,
                                 header_text_size = NULL,
                                 header_fontface = "bold",
                                 header_family = NULL,
                                 striped_rows = NULL,
                                 stripe_fill = NULL,
                                 stripe_colour = NULL,
                                 stripe_alpha = NULL,
                                 left_width = NULL,
                                 plot_width = NULL,
                                 right_width = NULL) {
  if (!inherits(plot, "ggplot")) {
    stop("`plot` must be a ggplot object created by `ggforestplot()`.", call. = FALSE)
  }

  state <- plot$ggforestplotR_state

  if (is.null(state)) {
    stop("`plot` must be created by `ggforestplot()` before calling `add_split_table()`.", call. = FALSE)
  }

  state <- align_forest_state_to_plot_y_scale(state, plot)

  if (is.null(show_n)) {
    show_n <- any(!is.na(state$forest_data$n) & nzchar(state$forest_data$n))
  }

  if (is.null(show_events)) {
    show_events <- any(!is.na(state$forest_data$events) & nzchar(state$forest_data$events))
  }

  if (is.null(digits)) {
    digits <- 2
  }

  digits <- resolve_table_digits(
    digits = digits,
    estimate_digits = estimate_digits,
    interval_digits = interval_digits,
    p_digits = p_digits
  )

  if (is.null(estimate_label)) {
    estimate_label <- state$defaults$estimate_label
  }

  if (is.null(estimate_label)) {
    estimate_label <- "Estimate"
  }

  if (is.null(text_size)) {
    text_size <- 3.2
  }

  if (is.null(header_text_size)) {
    header_text_size <- 11
  }

  if (is.null(striped_rows)) {
    striped_rows <- isTRUE(state$defaults$striped_rows)
  }

  if (is.null(stripe_fill)) {
    stripe_fill <- state$defaults$stripe_fill
  }

  if (is.null(stripe_colour)) {
    stripe_colour <- state$defaults$stripe_colour
  }

  if (is.null(stripe_alpha)) {
    stripe_alpha <- state$defaults$stripe_alpha
  }

  default_left <- c(if (isTRUE(show_terms)) "term", if (isTRUE(show_n)) "n", if (isTRUE(show_events)) "events")
  default_right <- c(if (isTRUE(show_estimate)) "estimate", if (isTRUE(show_p)) "p")
  resolved_left <- if (is.null(left_columns)) default_left else normalize_table_columns(left_columns, data = state$forest_data)
  resolved_right <- if (is.null(right_columns)) default_right else normalize_table_columns(right_columns, data = state$forest_data)

  if (length(resolved_left) == 0L) {
    stop(
      "`add_split_table()` requires at least one left-side column. Supply `left_columns` or enable `show_terms`/`show_n`.",
      call. = FALSE
    )
  }

  if (length(resolved_right) == 0L) {
    stop(
      "`add_split_table()` requires at least one right-side column. Supply `right_columns` or enable `show_estimate`/`show_p`.",
      call. = FALSE
    )
  }

  overlap <- intersect(resolved_left, resolved_right)

  if (length(overlap) > 0L) {
    stop(
      sprintf("Split table columns cannot appear on both sides: %s", paste(overlap, collapse = ", ")),
      call. = FALSE
    )
  }

  if ("n" %in% c(resolved_left, resolved_right) && all(is.na(state$forest_data$n) | !nzchar(state$forest_data$n))) {
    stop("An `n` column is required when split table columns include `n`.", call. = FALSE)
  }

  if ("events" %in% c(resolved_left, resolved_right) &&
      all(is.na(state$forest_data$events) | !nzchar(state$forest_data$events))) {
    stop("An `events` column is required when split table columns include `events`.", call. = FALSE)
  }

  if ("p" %in% c(resolved_left, resolved_right) && all(is.na(state$forest_data$p.value))) {
    stop("A `p.value` column is required when split table columns include `p`.", call. = FALSE)
  }

  left_spec <- build_forest_table_data(
    state$forest_data,
    show_terms = FALSE,
    show_n = FALSE,
    show_estimate = FALSE,
    show_p = FALSE,
    term_header = term_header,
    n_header = n_header,
    events_header = events_header,
    estimate_label = estimate_label,
    p_header = p_header,
    column_labels = column_labels,
    estimate_digits = digits$estimate_digits,
    interval_digits = digits$interval_digits,
    p_digits = digits$p_digits,
    estimate_fmt = estimate_fmt,
    ci_fmt = ci_fmt,
    columns = resolved_left
  )

  right_spec <- build_forest_table_data(
    state$forest_data,
    show_terms = FALSE,
    show_n = FALSE,
    show_estimate = FALSE,
    show_p = FALSE,
    term_header = term_header,
    n_header = n_header,
    events_header = events_header,
    estimate_label = estimate_label,
    p_header = p_header,
    column_labels = column_labels,
    estimate_digits = digits$estimate_digits,
    interval_digits = digits$interval_digits,
    p_digits = digits$p_digits,
    estimate_fmt = estimate_fmt,
    ci_fmt = ci_fmt,
    columns = resolved_right
  )

  left_spec <- layout_split_table_spec(
    left_spec,
    text_size = text_size,
    header_text_size = header_text_size,
    header_fontface = header_fontface,
    header_family = if (is.null(header_family)) "" else header_family,
    alignment = "left"
  )
  right_spec <- layout_split_table_spec(
    right_spec,
    text_size = text_size,
    header_text_size = header_text_size,
    header_fontface = header_fontface,
    header_family = if (is.null(header_family)) "" else header_family,
    alignment = "right"
  )

  if (is.null(plot_width)) {
    plot_width <- 2.5
  }

  if (is.null(left_width)) {
    left_width <- plot_width * split_table_width_multiplier(length(left_spec$column_keys))
  }

  if (is.null(right_width)) {
    right_width <- plot_width * split_table_width_multiplier(length(right_spec$column_keys))
  }

  left_plot <- build_forest_table_plot(
    table_spec = left_spec,
    stripe_data = state$stripe_data,
    has_groupings = state$has_groupings,
    grouping_strip_position = state$grouping_strip_position,
    table_position = "left",
    striped_rows = striped_rows,
    stripe_fill = stripe_fill,
    stripe_colour = stripe_colour,
    stripe_alpha = stripe_alpha,
    text_size = text_size,
    grid_lines = FALSE,
    plot_margin = ggplot2::margin(5.5, 0, 5.5, 5.5),
    text_hjust = 0,
    header_hjust = 0,
    header_text_size = header_text_size,
    header_fontface = header_fontface,
    header_family = header_family
  )

  right_plot <- build_forest_table_plot(
    table_spec = right_spec,
    stripe_data = state$stripe_data,
    has_groupings = state$has_groupings,
    grouping_strip_position = state$grouping_strip_position,
    table_position = "right",
    striped_rows = striped_rows,
    stripe_fill = stripe_fill,
    stripe_colour = stripe_colour,
    stripe_alpha = stripe_alpha,
    text_size = text_size,
    grid_lines = FALSE,
    plot_margin = ggplot2::margin(5.5, 5.5, 5.5, 0),
    text_hjust = 1,
    header_hjust = 1,
    header_text_size = header_text_size,
    header_fontface = header_fontface,
    header_family = header_family
  )

  plot_theme_args <- list(
    axis.text.y = ggplot2::element_blank(),
    axis.ticks.y = ggplot2::element_blank(),
    axis.title.y = ggplot2::element_blank(),
    panel.border = ggplot2::element_blank(),
    axis.line.y = ggplot2::element_blank(),
    panel.grid.major = ggplot2::element_blank(),
    panel.grid.minor = ggplot2::element_blank()
  )

  if (is.null(plot$theme$axis.line.x)) {
    plot_theme_args$axis.line.x <- ggplot2::element_line(colour = "black")
  }

  if (is.null(plot$theme$plot.margin)) {
    plot_theme_args$plot.margin <- ggplot2::margin(5.5, 0, 5.5, 0)
  }

  plot_out <- plot + do.call(ggplot2::theme, plot_theme_args)

  left_spec$content_width <- left_width
  right_spec$content_width <- right_width

  combine_split_forest_plot(
    plot = plot_out,
    left_table = left_plot,
    right_table = right_plot,
    left_spec = left_spec,
    right_spec = right_spec,
    plot_width = plot_width
  )
}

#' Add split tables around a forest plot
#'
#' Compose split table blocks around a forest plot so that summary data appear
#' on both sides of the plotting panel.
#'
#' @param plot A plot created by [ggforestplot()]. Leave as `NULL` to use
#'   `+ add_split_table(...)` syntax.
#' @param show_terms Whether to include the term column in the default
#'   left-side selection when `left_columns` is not supplied.
#' @param show_n Whether to include the `N` column in the default left-side
#'   selection when `left_columns` is not supplied. Defaults to `TRUE` when
#'   the underlying plot data include an `n` column.
#' @param show_events Whether to include the `Events` column in the default
#'   left-side selection when `left_columns` is not supplied. Defaults to
#'   `TRUE` when the underlying plot data include an `events` column.
#' @param show_estimate Whether to include the formatted estimate and
#'   confidence interval column in the default right-side selection when
#'   `right_columns` is not supplied.
#' @param show_p Whether to include the p-value column in the default
#'   right-side selection when `right_columns` is not supplied.
#' @param left_columns Optional explicit columns to place on the left side of
#'   the forest plot. Accepts built-in names such as `"term"`, `"n"`,
#'   `"events"`, `"estimate"`, `"ci"`, and `"p"`, arbitrary original
#'   dataframe columns, or positions corresponding to the built-in columns.
#'   `"conf.low"` and `"conf.high"` are accepted as aliases for `"ci"`.
#' @param right_columns Optional explicit columns to place on the right side
#'   of the forest plot. Accepts built-in names such as `"estimate"`, `"ci"`,
#'   and `"p"`, arbitrary original dataframe columns, or positions
#'   corresponding to the built-in columns. `"conf.low"` and `"conf.high"` are
#'   accepted as aliases for `"ci"`.
#' @param term_header Header text for the term column.
#' @param n_header Header text for the `N` column.
#' @param events_header Header text for the `Events` column.
#' @param estimate_label Header label for the estimate column. Defaults to the
#'   model-derived label when available.
#' @param p_header Header text for the p-value column.
#' @param column_labels Optional named vector used to relabel table column
#'   headers. Names should match values supplied to `left_columns` or
#'   `right_columns` after column resolution, such as `"term"`, `"estimate"`,
#'   `"ci"`, `"p"`, or an arbitrary original dataframe column.
#' @param digits Deprecated. Number of digits used when formatting estimates
#'   and p-values. Defaults to `2`. Use `estimate_digits`, `interval_digits`,
#'   and `p_digits` for separate control.
#' @param estimate_digits Number of digits used for point estimates.
#' @param interval_digits Number of digits used for confidence interval bounds.
#' @param p_digits Number of digits used for p-values.
#' @param estimate_fmt Format string for the estimate column. Use
#'   `{estimate}`, `{conf.low}`, and `{conf.high}` as placeholders. The
#'   shorthand `{conf.low, conf.high}` is also supported. Defaults to
#'   `"{estimate} ({conf.low}, {conf.high})"`, or `"{estimate}"` when table
#'   columns include `"ci"`.
#' @param ci_fmt Format string for the confidence interval column when
#'   table columns include `"ci"`. Use `{conf.low}` and `{conf.high}` as
#'   placeholders. The shorthand `{conf.low, conf.high}` is also supported.
#'   Defaults to `"({conf.low}, {conf.high})"`.
#' @param text_size Text size for table contents. Defaults to `3.2`.
#' @param header_text_size Header text size for table column labels. Defaults
#'   to `11`.
#' @param header_fontface Font face used for table column labels. Defaults to
#'   `"bold"`.
#' @param header_family Optional font family used for table column labels.
#' @param striped_rows Whether to draw alternating row stripes behind the
#'   split table layout. Defaults to the stripe setting used in
#'   [ggforestplot()].
#' @param stripe_fill Fill colour used for striped rows. Defaults to the
#'   stripe fill used in [ggforestplot()].
#' @param stripe_colour Outline colour for striped rows. Defaults to the
#'   stripe outline used in [ggforestplot()].
#' @param stripe_alpha Transparency for striped rows. Defaults to the stripe
#'   alpha used in [ggforestplot()].
#' @param left_width Optional width allocated to the left table block. By
#'   default this is derived from the number of displayed left-side columns
#'   relative to `plot_width`.
#' @param plot_width Optional width allocated to the forest plot panel.
#'   Defaults to `2.5`.
#' @param right_width Optional width allocated to the right table block. By
#'   default this is derived from the number of displayed right-side columns
#'   relative to `plot_width`.
#'
#' @return A patchwork-composed plot containing a left table, the forest plot,
#'   and a right table, or a ggplot add-on object when `plot = NULL`.
#' @export
#'
#' @examples
#' coefs <- data.frame(
#'   term = c("Age", "BMI", "Treatment"),
#'   estimate = c(0.3, -0.2, 0.4),
#'   conf.low = c(0.1, -0.4, 0.2),
#'   conf.high = c(0.5, 0.0, 0.6),
#'   sample_size = c(120, 115, 98),
#'   p_value = c(0.012, 0.031, 0.004)
#' )
#'
#' p <- ggforestplot(coefs, n = "sample_size", p.value = "p_value")
#' add_split_table(
#'   p,
#'   left_columns = c("term", "n"),
#'   right_columns = c("estimate", "p"),
#'   estimate_label = "HR"
#' )
#'
#' ggforestplot(coefs, n = "sample_size", p.value = "p_value") +
#'   add_split_table(
#'     left_columns = c(1, 2),
#'     right_columns = c(4, 5),
#'     estimate_label = "HR"
#'   )
add_split_table <- function(plot = NULL,
                            show_terms = TRUE,
                            show_n = NULL,
                            show_events = NULL,
                            show_estimate = TRUE,
                            show_p = FALSE,
                            left_columns = NULL,
                            right_columns = NULL,
                            term_header = "Term",
                            n_header = "N",
                            events_header = "Events",
                            estimate_label = NULL,
                            p_header = "P-value",
                            column_labels = NULL,
                            digits = NULL,
                            estimate_digits = NULL,
                            interval_digits = NULL,
                            p_digits = NULL,
                            estimate_fmt = NULL,
                            ci_fmt = NULL,
                            text_size = NULL,
                            header_text_size = NULL,
                            header_fontface = "bold",
                            header_family = NULL,
                            striped_rows = NULL,
                            stripe_fill = NULL,
                            stripe_colour = NULL,
                            stripe_alpha = NULL,
                            left_width = NULL,
                            plot_width = NULL,
                            right_width = NULL) {
  if (!missing(digits)) {
    warn_deprecated_argument("digits", "`estimate_digits`, `interval_digits`, and `p_digits`")
  }

  if (is.null(plot)) {
    return(structure(
      list(
        show_terms = show_terms,
        show_n = show_n,
        show_events = show_events,
        show_estimate = show_estimate,
        show_p = show_p,
        left_columns = left_columns,
        right_columns = right_columns,
        term_header = term_header,
        n_header = n_header,
        events_header = events_header,
        estimate_label = estimate_label,
        p_header = p_header,
        column_labels = column_labels,
        digits = digits,
        estimate_digits = estimate_digits,
        interval_digits = interval_digits,
        p_digits = p_digits,
        estimate_fmt = estimate_fmt,
        ci_fmt = ci_fmt,
        text_size = text_size,
        header_text_size = header_text_size,
        header_fontface = header_fontface,
        header_family = header_family,
        striped_rows = striped_rows,
        stripe_fill = stripe_fill,
        stripe_colour = stripe_colour,
        stripe_alpha = stripe_alpha,
        left_width = left_width,
        plot_width = plot_width,
        right_width = right_width
      ),
      class = "ggforestplot_split_table_adder"
    ))
  }

  .compose_split_table(
    plot = plot,
    show_terms = show_terms,
    show_n = show_n,
    show_events = show_events,
    show_estimate = show_estimate,
    show_p = show_p,
    left_columns = left_columns,
    right_columns = right_columns,
    term_header = term_header,
    n_header = n_header,
    events_header = events_header,
    estimate_label = estimate_label,
    p_header = p_header,
    column_labels = column_labels,
    digits = digits,
    estimate_digits = estimate_digits,
    interval_digits = interval_digits,
    p_digits = p_digits,
    estimate_fmt = estimate_fmt,
    ci_fmt = ci_fmt,
    text_size = text_size,
    header_text_size = header_text_size,
    header_fontface = header_fontface,
    header_family = header_family,
    striped_rows = striped_rows,
    stripe_fill = stripe_fill,
    stripe_colour = stripe_colour,
    stripe_alpha = stripe_alpha,
    left_width = left_width,
    plot_width = plot_width,
    right_width = right_width
  )
}

#' @export
#' @keywords internal
ggplot_add.ggforestplot_split_table_adder <- function(object, plot, ...) {
  do.call(
    .compose_split_table,
    c(list(plot = plot), object)
  )
}