From a5577c0cd5843bed351462efd67c8bfa94376408 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 5 Dec 2023 18:47:07 -0500 Subject: [PATCH 01/26] temp --- DESCRIPTION | 1 + R/g_forest_new.R | 382 ++++++++++++++++++++++++++++++++++++++++++++ man/g_forest_new.Rd | 271 +++++++++++++++++++++++++++++++ 3 files changed, 654 insertions(+) create mode 100644 R/g_forest_new.R create mode 100644 man/g_forest_new.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 24abb6bb15..589db31d4d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -116,6 +116,7 @@ Collate: 'fit_rsp_step.R' 'fit_survival_step.R' 'g_forest.R' + 'g_forest_new.R' 'g_lineplot.R' 'g_step.R' 'g_waterfall.R' diff --git a/R/g_forest_new.R b/R/g_forest_new.R new file mode 100644 index 0000000000..4528a9ff55 --- /dev/null +++ b/R/g_forest_new.R @@ -0,0 +1,382 @@ +#' #' Create a Forest Plot based on a Table +#' #' +#' #' Create a forest plot from any [rtables::rtable()] object that has a +#' #' column with a single value and a column with 2 values. +#' #' +#' #' @description `r lifecycle::badge("stable")` +#' #' +#' #' @inheritParams grid::gTree +#' #' @inheritParams argument_convention +#' #' @param tbl (`rtable`) +#' #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from +#' #' `tbl` attribute `col_x`, otherwise needs to be manually specified. +#' #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries +#' #' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified. +#' #' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. +#' #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. +#' #' If `vline = NULL` then `forest_header` needs to be `NULL` too. +#' #' By default tries to get this from `tbl` attribute `forest_header`. +#' #' @param xlim (`numeric`)\cr limits for x axis. +#' #' @param logx (`flag`)\cr show the x-values on logarithm scale. +#' #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. +#' #' @param width_row_names (`unit`)\cr width for row names. +#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' #' @param width_columns (`unit`)\cr widths for the table columns. +#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' #' @param width_forest (`unit`)\cr width for the forest column. +#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used +#' #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional +#' #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. +#' #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. +#' #' @param col (`character`)\cr color(s). +#' #' +#' #' @return `gTree` object containing the forest plot and table. +#' #' +#' #' @examples +#' #' \donttest{ +#' #' library(dplyr) +#' #' library(forcats) +#' #' library(nestcolor) +#' #' +#' #' adrs <- tern_ex_adrs +#' #' n_records <- 20 +#' #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) +#' #' adrs <- adrs %>% +#' #' filter(PARAMCD == "BESRSPI") %>% +#' #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% +#' #' slice(seq_len(n_records)) %>% +#' #' droplevels() %>% +#' #' mutate( +#' #' # Reorder levels of factor to make the placebo group the reference arm. +#' #' ARM = fct_relevel(ARM, "B: Placebo"), +#' #' rsp = AVALC == "CR" +#' #' ) +#' #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") +#' #' df <- extract_rsp_subgroups( +#' #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), +#' #' data = adrs +#' #' ) +#' #' # Full commonly used response table. +#' #' +#' #' tbl <- basic_table() %>% +#' #' tabulate_rsp_subgroups(df) +#' #' p <- g_forest_new(tbl, gp = grid::gpar(fontsize = 10)) +#' #' +#' #' draw_grob(p) +#' #' +#' #' # Odds ratio only table. +#' #' +#' #' tbl_or <- basic_table() %>% +#' #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) +#' #' tbl_or +#' #' p <- g_forest_new( +#' #' tbl_or, +#' #' forest_header = c("Comparison\nBetter", "Treatment\nBetter") +#' #' ) +#' #' +#' #' draw_grob(p) +#' #' +#' #' # Survival forest plot example. +#' #' adtte <- tern_ex_adtte +#' #' # Save variable labels before data processing steps. +#' #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) +#' #' adtte_f <- adtte %>% +#' #' filter( +#' #' PARAMCD == "OS", +#' #' ARM %in% c("B: Placebo", "A: Drug X"), +#' #' SEX %in% c("M", "F") +#' #' ) %>% +#' #' mutate( +#' #' # Reorder levels of ARM to display reference arm before treatment arm. +#' #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), +#' #' SEX = droplevels(SEX), +#' #' AVALU = as.character(AVALU), +#' #' is_event = CNSR == 0 +#' #' ) +#' #' labels <- list( +#' #' "ARM" = adtte_labels["ARM"], +#' #' "SEX" = adtte_labels["SEX"], +#' #' "AVALU" = adtte_labels["AVALU"], +#' #' "is_event" = "Event Flag" +#' #' ) +#' #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) +#' #' df <- extract_survival_subgroups( +#' #' variables = list( +#' #' tte = "AVAL", +#' #' is_event = "is_event", +#' #' arm = "ARM", subgroups = c("SEX", "BMRKR2") +#' #' ), +#' #' data = adtte_f +#' #' ) +#' #' table_hr <- basic_table() %>% +#' #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) +#' #' g_forest_new(table_hr) +#' #' # Works with any `rtable`. +#' #' tbl <- rtable( +#' #' header = c("E", "CI", "N"), +#' #' rrow("", 1, c(.8, 1.2), 200), +#' #' rrow("", 1.2, c(1.1, 1.4), 50) +#' #' ) +#' #' g_forest_new( +#' #' tbl = tbl, +#' #' col_x = 1, +#' #' col_ci = 2, +#' #' xlim = c(0.5, 2), +#' #' x_at = c(0.5, 1, 2), +#' #' col_symbol_size = 3 +#' #' ) +#' #' tbl <- rtable( +#' #' header = rheader( +#' #' rrow("", rcell("A", colspan = 2)), +#' #' rrow("", "c1", "c2") +#' #' ), +#' #' rrow("row 1", 1, c(.8, 1.2)), +#' #' rrow("row 2", 1.2, c(1.1, 1.4)) +#' #' ) +#' #' g_forest_new( +#' #' tbl = tbl, +#' #' col_x = 1, +#' #' col_ci = 2, +#' #' xlim = c(0.5, 2), +#' #' x_at = c(0.5, 1, 2), +#' #' vline = 1, +#' #' forest_header = c("Hello", "World") +#' #' ) +#' #' } +#' #' +#' #' @export +#' g_forest_new <- function(tbl, +#' col_x = attr(tbl, "col_x"), +#' col_ci = attr(tbl, "col_ci"), +#' vline = 1, +#' forest_header = attr(tbl, "forest_header"), +#' xlim = c(0.1, 10), +#' logx = TRUE, +#' x_at = c(0.1, 1, 10), +#' width_row_names = NULL, +#' width_columns = NULL, +#' width_forest = grid::unit(1, "null"), +#' col_symbol_size = attr(tbl, "col_symbol_size"), +#' col = getOption("ggplot2.discrete.colour")[1], +#' gp = NULL, +#' draw = TRUE, +#' newpage = TRUE) { +#' checkmate::assert_class(tbl, "VTableTree") +#' +#' nr <- nrow(tbl) +#' nc <- ncol(tbl) +#' if (is.null(col)) { +#' col <- "blue" +#' } +#' +#' checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) +#' checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) +#' checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) +#' checkmate::assert_true(col_x > 0) +#' checkmate::assert_true(col_ci > 0) +#' checkmate::assert_character(col) +#' if (!is.null(col_symbol_size)) { +#' checkmate::assert_true(col_symbol_size > 0) +#' } +#' +#' x_e <- vapply(seq_len(nr), function(i) { +#' # If a label row is selected NULL is returned with a warning (suppressed) +#' xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE])) +#' +#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { +#' xi +#' } else { +#' NA_real_ +#' } +#' }, numeric(1)) +#' +#' x_ci <- lapply(seq_len(nr), function(i) { +#' xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above +#' +#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { +#' if (length(xi) != 2) { +#' stop("ci column needs two elements") +#' } +#' xi +#' } else { +#' c(NA_real_, NA_real_) +#' } +#' }) +#' +#' lower <- vapply(x_ci, `[`, numeric(1), 1) +#' upper <- vapply(x_ci, `[`, numeric(1), 2) +#' +#' symbol_size <- if (!is.null(col_symbol_size)) { +#' tmp_symbol_size <- vapply(seq_len(nr), function(i) { +#' suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE])) +#' +#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { +#' xi +#' } else { +#' NA_real_ +#' } +#' }, numeric(1)) +#' +#' # Scale symbol size. +#' tmp_symbol_size <- sqrt(tmp_symbol_size) +#' max_size <- max(tmp_symbol_size, na.rm = TRUE) +#' # Biggest points have radius is 2 * (1/3.5) lines not to overlap. +#' # See forest_dot_line. +#' 2 * tmp_symbol_size / max_size +#' } else { +#' NULL +#' } +#' +#' grob_forest <- forest_grob( +#' tbl, +#' x_e, +#' lower, +#' upper, +#' vline, +#' forest_header, +#' xlim, +#' logx, +#' x_at, +#' width_row_names, +#' width_columns, +#' width_forest, +#' symbol_size = symbol_size, +#' col = col, +#' gp = gp, +#' vp = grid::plotViewport(margins = rep(1, 4)) +#' ) +#' +#' if (draw) { +#' if (newpage) grid::grid.newpage() +#' grid::grid.draw(grob_forest) +#' } +#' +#' invisible(grob_forest) +#' } + +g_forest_new <- function(tbl, + vline = 1, + fontsize = 4, + xlim = c(0.1, 10), + logx = TRUE, + x_at = c(0.1, 1, 10), + symbol_size = attr(tbl, "col_symbol_size"), + col = getOption("ggplot2.discrete.colour")[1], + width_plot = 0.25) { + checkmate::assert_class(tbl, "VTableTree") + + gg_table <- rtable2gg(tbl) + + theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) + gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) + + mat <- matrix_form(tbl) + mat_strings <- formatters::mf_strings(mat) + nlines_hdr <- formatters::mf_nlheader(mat) + nrows_body <- nrow(mat_strings) - nlines_hdr + if (nlines_hdr == 2) { + gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 + gg_table$scales$scales[[2]]$expand <- c(0, 0) + arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) + } else { + arms <- NULL + } + tbl_stats <- mat_strings[nlines_hdr, -1] + + tbl_df <- as_result_df(tbl) + dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) + tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] + names(tbl_df) <- c("row_num", tbl_stats) + + tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[["95% CI"]], unlist)) + tbl_df <- tbl_df[names(tbl_df) != "95% CI"] + tbl_df[, -1] <- apply(tbl_df[, -1], 2, unlist) + + tbl_df[["row_num"]] <- nlines_hdr + 1 + nrow(tbl_df) - tbl_df[["row_num"]] + + if (is.null(x_at)) x_at <- c(0.1, 1, 10) + x_labels <- x_at + if (logx) { + xlim_t <- log(xlim) + tbl_df[["Odds Ratio"]] <- log(tbl_df[["Odds Ratio"]]) + tbl_df[["ci_lwr"]] <- log(tbl_df[["ci_lwr"]]) + tbl_df[["ci_upr"]] <- log(tbl_df[["ci_upr"]]) + } else { + xlim_t <- xlim + } + # # Rescale input values for modified x-axis + # rescale_x_val <- function(x) if (x < 1) (x - 0.1) / (1 - 0.1) * (1 - -9) + -9 else x + # tbl_df[["Odds Ratio"]] <- sapply(tbl_df[["Odds Ratio"]], rescale_x_val) + # tbl_df[["ci_lwr"]] <- sapply(tbl_df[["ci_lwr"]], rescale_x_val) + # tbl_df[["ci_upr"]] <- sapply(tbl_df[["ci_upr"]], rescale_x_val) + # vline <- rescale_x_val(vline) + + gg_plt <- ggplot(data = tbl_df) + + theme( + panel.background = element_blank(), + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.title.x = element_blank(), + axis.title.y = element_blank(), + axis.line.x = element_line(), + legend.position = "none", + plot.margin = margin(0, 0.1, 0.05, 0, "npc") + ) + + scale_x_continuous( + trans = ifelse(logx, "log", "identity"), + limits = xlim, + breaks = x_at, + labels = x_labels, + expand = c(0, 0) + ) + + scale_y_continuous( + limits = c(0, nrow(mat_strings) + as.numeric(nlines_hdr == 2)), + breaks = NULL, + expand = c(0, 0) + ) + + coord_cartesian(clip = "off") + + geom_rect(data = NULL, aes(xmin = xlim[1], xmax = xlim[2], ymin = 0, ymax = nrows_body + 0.5), fill = "grey92") + + geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + + geom_point(x = tbl_df[["Odds Ratio"]], y = tbl_df[["row_num"]], aes(size = `Total n`, color = col)) + + mid_pt <- if (!is.null(vline)) vline else if (length(x_at) == 3) x_at[2] else mean(xlim) + gg_plt <- gg_plt + + geom_text( + x = mean(log(c(xlim[1], mid_pt))), y = nrows_body + 1.25, + label = paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), + size = fontsize, + lineheight = 0.9 + ) + + geom_text( + x = mean(log(c(mid_pt, xlim[2]))), y = nrows_body + 1.25, + label = paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n"), + size = fontsize, + lineheight = 0.9 + ) + + for (i in seq_len(nrow(tbl_df))) { + which_arrow <- c(tbl_df[i, "ci_lwr"] < xlim_t[1], tbl_df[i, "ci_upr"] > xlim_t[2]) + which_arrow <- case_when( + all(which_arrow) ~ "both", + which_arrow[1] ~ "first", + which_arrow[2] ~ "last", + TRUE ~ NA + ) + + gg_plt <- gg_plt + + geom_segment( + x = if (!which_arrow %in% c("first", "both")) tbl_df[["ci_lwr"]][i] else xlim_t[1], + xend = if (!which_arrow %in% c("last", "both")) tbl_df[["ci_upr"]][i] else xlim_t[2], + y = tbl_df[["row_num"]][i], yend = tbl_df[["row_num"]][i], + color = col, + arrow = if (is.na(which_arrow)) NULL else arrow(length = unit(0.05, "npc"), ends = which_arrow) + ) + } + + cowplot::plot_grid( + gg_table, + gg_plt, + align = "h", + rel_widths = c(1 - width_plot, width_plot) + ) +} diff --git a/man/g_forest_new.Rd b/man/g_forest_new.Rd new file mode 100644 index 0000000000..bc1d5eb74a --- /dev/null +++ b/man/g_forest_new.Rd @@ -0,0 +1,271 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/g_forest_new.R +\name{g_forest_new} +\alias{g_forest_new} +\title{#' Create a Forest Plot based on a Table +#' +#' Create a forest plot from any \code{\link[rtables:rtable]{rtables::rtable()}} object that has a +#' column with a single value and a column with 2 values. +#' +#' @description \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} +#' +#' @inheritParams grid::gTree +#' @inheritParams argument_convention +#' @param tbl (\code{rtable}) +#' @param col_x (\code{integer})\cr column index with estimator. By default tries to get this from +#' \code{tbl} attribute \code{col_x}, otherwise needs to be manually specified. +#' @param col_ci (\code{integer})\cr column index with confidence intervals. By default tries +#' to get this from \code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified. +#' @param vline (\code{number})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted. +#' @param forest_header (\code{character}, length 2)\cr text displayed to the left and right of \code{vline}, respectively. +#' If \code{vline = NULL} then \code{forest_header} needs to be \code{NULL} too. +#' By default tries to get this from \code{tbl} attribute \code{forest_header}. +#' @param xlim (\code{numeric})\cr limits for x axis. +#' @param logx (\code{flag})\cr show the x-values on logarithm scale. +#' @param x_at (\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen. +#' @param width_row_names (\code{unit})\cr width for row names. +#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. +#' @param width_columns (\code{unit})\cr widths for the table columns. +#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. +#' @param width_forest (\code{unit})\cr width for the forest column. +#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. +#' @param col_symbol_size (\code{integer})\cr column index from \code{tbl} containing data to be used +#' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional +#' to the sample size used to calculate the estimator. If \code{NULL}, the same symbol size is used for all subgroups. +#' By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, otherwise needs to be manually specified. +#' @param col (\code{character})\cr color(s). +#' +#' @return \code{gTree} object containing the forest plot and table. +#' +#' @examples +#' \donttest{ +#' library(dplyr) +#' library(forcats) +#' library(nestcolor) +#' +#' adrs <- tern_ex_adrs +#' n_records <- 20 +#' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) +#' adrs <- adrs %>% +#' filter(PARAMCD == "BESRSPI") %>% +#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% +#' slice(seq_len(n_records)) %>% +#' droplevels() %>% +#' mutate( +#' # Reorder levels of factor to make the placebo group the reference arm. +#' ARM = fct_relevel(ARM, "B: Placebo"), +#' rsp = AVALC == "CR" +#' ) +#' formatters::var_labels(adrs) <- c(adrs_labels, "Response") +#' df <- extract_rsp_subgroups( +#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), +#' data = adrs +#' ) +#' # Full commonly used response table. +#' +#' tbl <- basic_table() %>% +#' tabulate_rsp_subgroups(df) +#' p <- g_forest_new(tbl, gp = grid::gpar(fontsize = 10)) +#' +#' draw_grob(p) +#' +#' # Odds ratio only table. +#' +#' tbl_or <- basic_table() %>% +#' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) +#' tbl_or +#' p <- g_forest_new( +#' tbl_or, +#' forest_header = c("Comparison\nBetter", "Treatment\nBetter") +#' ) +#' +#' draw_grob(p) +#' +#' # Survival forest plot example. +#' adtte <- tern_ex_adtte +#' # Save variable labels before data processing steps. +#' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) +#' adtte_f <- adtte %>% +#' filter( +#' PARAMCD == "OS", +#' ARM %in% c("B: Placebo", "A: Drug X"), +#' SEX %in% c("M", "F") +#' ) %>% +#' mutate( +#' # Reorder levels of ARM to display reference arm before treatment arm. +#' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), +#' SEX = droplevels(SEX), +#' AVALU = as.character(AVALU), +#' is_event = CNSR == 0 +#' ) +#' labels <- list( +#' "ARM" = adtte_labels["ARM"], +#' "SEX" = adtte_labels["SEX"], +#' "AVALU" = adtte_labels["AVALU"], +#' "is_event" = "Event Flag" +#' ) +#' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) +#' df <- extract_survival_subgroups( +#' variables = list( +#' tte = "AVAL", +#' is_event = "is_event", +#' arm = "ARM", subgroups = c("SEX", "BMRKR2") +#' ), +#' data = adtte_f +#' ) +#' table_hr <- basic_table() %>% +#' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) +#' g_forest_new(table_hr) +#' # Works with any `rtable`. +#' tbl <- rtable( +#' header = c("E", "CI", "N"), +#' rrow("", 1, c(.8, 1.2), 200), +#' rrow("", 1.2, c(1.1, 1.4), 50) +#' ) +#' g_forest_new( +#' tbl = tbl, +#' col_x = 1, +#' col_ci = 2, +#' xlim = c(0.5, 2), +#' x_at = c(0.5, 1, 2), +#' col_symbol_size = 3 +#' ) +#' tbl <- rtable( +#' header = rheader( +#' rrow("", rcell("A", colspan = 2)), +#' rrow("", "c1", "c2") +#' ), +#' rrow("row 1", 1, c(.8, 1.2)), +#' rrow("row 2", 1.2, c(1.1, 1.4)) +#' ) +#' g_forest_new( +#' tbl = tbl, +#' col_x = 1, +#' col_ci = 2, +#' xlim = c(0.5, 2), +#' x_at = c(0.5, 1, 2), +#' vline = 1, +#' forest_header = c("Hello", "World") +#' ) +#' } +#' +#' @export +g_forest_new <- function(tbl, +col_x = attr(tbl, "col_x"), +col_ci = attr(tbl, "col_ci"), +vline = 1, +forest_header = attr(tbl, "forest_header"), +xlim = c(0.1, 10), +logx = TRUE, +x_at = c(0.1, 1, 10), +width_row_names = NULL, +width_columns = NULL, +width_forest = grid::unit(1, "null"), +col_symbol_size = attr(tbl, "col_symbol_size"), +col = getOption("ggplot2.discrete.colour")\link{1}, +gp = NULL, +draw = TRUE, +newpage = TRUE) { +checkmate::assert_class(tbl, "VTableTree")} +\usage{ +g_forest_new(tbl, fontsize = 3.5, col = "blue", width_plot = 0.25) +} +\description{ +nr <- nrow(tbl) +nc <- ncol(tbl) +if (is.null(col)) { +col <- "blue" +} +} +\details{ +checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) +checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) +checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) +checkmate::assert_true(col_x > 0) +checkmate::assert_true(col_ci > 0) +checkmate::assert_character(col) +if (!is.null(col_symbol_size)) { +checkmate::assert_true(col_symbol_size > 0) +} + +x_e <- vapply(seq_len(nr), function(i) { +# If a label row is selected NULL is returned with a warning (suppressed) +xi <- suppressWarnings(as.vector(tbl\link{i, col_x, drop = TRUE})) + +\if{html}{\out{
}}\preformatted{if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ + xi +\} else \{ + NA_real_ +\} +}\if{html}{\out{
}} + +}, numeric(1)) + +x_ci <- lapply(seq_len(nr), function(i) { +xi <- suppressWarnings(as.vector(tbl\link{i, col_ci, drop = TRUE})) # as above + +\if{html}{\out{
}}\preformatted{if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ + if (length(xi) != 2) \{ + stop("ci column needs two elements") + \} + xi +\} else \{ + c(NA_real_, NA_real_) +\} +}\if{html}{\out{
}} + +}) + +lower <- vapply(x_ci, \code{[}, numeric(1), 1) +upper <- vapply(x_ci, \code{[}, numeric(1), 2) + +symbol_size <- if (!is.null(col_symbol_size)) { +tmp_symbol_size <- vapply(seq_len(nr), function(i) { +suppressWarnings(xi <- as.vector(tbl\link{i, col_symbol_size, drop = TRUE})) + +\if{html}{\out{
}}\preformatted{ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ + xi + \} else \{ + NA_real_ + \} +\}, numeric(1)) + +# Scale symbol size. +tmp_symbol_size <- sqrt(tmp_symbol_size) +max_size <- max(tmp_symbol_size, na.rm = TRUE) +# Biggest points have radius is 2 * (1/3.5) lines not to overlap. +# See forest_dot_line. +2 * tmp_symbol_size / max_size +}\if{html}{\out{
}} + +} else { +NULL +} + +grob_forest <- forest_grob( +tbl, +x_e, +lower, +upper, +vline, +forest_header, +xlim, +logx, +x_at, +width_row_names, +width_columns, +width_forest, +symbol_size = symbol_size, +col = col, +gp = gp, +vp = grid::plotViewport(margins = rep(1, 4)) +) + +if (draw) { +if (newpage) grid::grid.newpage() +grid::grid.draw(grob_forest) +} + +invisible(grob_forest) +} +} From 663883f3e17007369599dedd1335be4dd279d48e Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 5 Dec 2023 19:06:46 -0500 Subject: [PATCH 02/26] Update params --- R/g_forest_new.R | 40 +++++++++++++++++++++++++--------------- man/g_forest_new.Rd | 13 ++++++++++++- 2 files changed, 37 insertions(+), 16 deletions(-) diff --git a/R/g_forest_new.R b/R/g_forest_new.R index 4528a9ff55..f07c2505ef 100644 --- a/R/g_forest_new.R +++ b/R/g_forest_new.R @@ -257,13 +257,14 @@ g_forest_new <- function(tbl, vline = 1, + forest_header = NULL, fontsize = 4, xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - symbol_size = attr(tbl, "col_symbol_size"), + symbol_size = NULL, col = getOption("ggplot2.discrete.colour")[1], - width_plot = 0.25) { + rel_width_plot = 0.25) { checkmate::assert_class(tbl, "VTableTree") gg_table <- rtable2gg(tbl) + @@ -291,11 +292,12 @@ g_forest_new <- function(tbl, tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[["95% CI"]], unlist)) tbl_df <- tbl_df[names(tbl_df) != "95% CI"] tbl_df[, -1] <- apply(tbl_df[, -1], 2, unlist) - tbl_df[["row_num"]] <- nlines_hdr + 1 + nrow(tbl_df) - tbl_df[["row_num"]] if (is.null(x_at)) x_at <- c(0.1, 1, 10) x_labels <- x_at + mid_pt <- if (!is.null(vline)) vline else if (length(x_at) == 3) x_at[2] else mean(xlim) + if (logx) { xlim_t <- log(xlim) tbl_df[["Odds Ratio"]] <- log(tbl_df[["Odds Ratio"]]) @@ -304,12 +306,13 @@ g_forest_new <- function(tbl, } else { xlim_t <- xlim } - # # Rescale input values for modified x-axis - # rescale_x_val <- function(x) if (x < 1) (x - 0.1) / (1 - 0.1) * (1 - -9) + -9 else x - # tbl_df[["Odds Ratio"]] <- sapply(tbl_df[["Odds Ratio"]], rescale_x_val) - # tbl_df[["ci_lwr"]] <- sapply(tbl_df[["ci_lwr"]], rescale_x_val) - # tbl_df[["ci_upr"]] <- sapply(tbl_df[["ci_upr"]], rescale_x_val) - # vline <- rescale_x_val(vline) + + if (is.null(forest_header)) { + forest_header <- c( + paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), + paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n") + ) + } gg_plt <- ggplot(data = tbl_df) + theme( @@ -335,21 +338,28 @@ g_forest_new <- function(tbl, expand = c(0, 0) ) + coord_cartesian(clip = "off") + - geom_rect(data = NULL, aes(xmin = xlim[1], xmax = xlim[2], ymin = 0, ymax = nrows_body + 0.5), fill = "grey92") + + geom_rect( + data = NULL, + aes(xmin = xlim[1], xmax = xlim[2], ymin = 0, ymax = nrows_body + 0.5), + fill = "grey92" + ) + geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + - geom_point(x = tbl_df[["Odds Ratio"]], y = tbl_df[["row_num"]], aes(size = `Total n`, color = col)) + geom_point( + x = tbl_df[["Odds Ratio"]], + y = tbl_df[["row_num"]], + aes(size = if (is.null(symbol_size)) `Total n` else symbol_size, color = col) + ) - mid_pt <- if (!is.null(vline)) vline else if (length(x_at) == 3) x_at[2] else mean(xlim) gg_plt <- gg_plt + geom_text( x = mean(log(c(xlim[1], mid_pt))), y = nrows_body + 1.25, - label = paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), + label = forest_header[1], size = fontsize, lineheight = 0.9 ) + geom_text( x = mean(log(c(mid_pt, xlim[2]))), y = nrows_body + 1.25, - label = paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n"), + label = forest_header[2], size = fontsize, lineheight = 0.9 ) @@ -377,6 +387,6 @@ g_forest_new <- function(tbl, gg_table, gg_plt, align = "h", - rel_widths = c(1 - width_plot, width_plot) + rel_widths = c(1 - rel_width_plot, rel_width_plot) ) } diff --git a/man/g_forest_new.Rd b/man/g_forest_new.Rd index bc1d5eb74a..268e9ddb88 100644 --- a/man/g_forest_new.Rd +++ b/man/g_forest_new.Rd @@ -168,7 +168,18 @@ draw = TRUE, newpage = TRUE) { checkmate::assert_class(tbl, "VTableTree")} \usage{ -g_forest_new(tbl, fontsize = 3.5, col = "blue", width_plot = 0.25) +g_forest_new( + tbl, + vline = 1, + forest_header = NULL, + fontsize = 4, + xlim = c(0.1, 10), + logx = TRUE, + x_at = c(0.1, 1, 10), + symbol_size = NULL, + col = getOption("ggplot2.discrete.colour")[1], + rel_width_plot = 0.25 +) } \description{ nr <- nrow(tbl) From f8087c4d4211c5ec519c9d8ff9dd2243ad11783f Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 7 Dec 2023 15:59:37 -0500 Subject: [PATCH 03/26] Fix overlaid text labels in `rtable2gg` --- R/utils_ggplot.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/utils_ggplot.R b/R/utils_ggplot.R index ccd9288e5c..6cb4694f35 100644 --- a/R/utils_ggplot.R +++ b/R/utils_ggplot.R @@ -95,7 +95,8 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) ) res <- res + - geom_text( + annotate( + "text", x = mean(line_pos), y = nrow(mat_strings) + 1 - hr, label = cur_lbl, @@ -113,7 +114,8 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) # Add table columns for (i in seq_len(ncol(tbl_df))) { - res <- res + geom_text( + res <- res + annotate( + "text", x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, y = rev(seq_len(nrow(tbl_df))), label = tbl_df[, i], From e98089e4a5d268fbfb16552a36b4d6840c372868 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 7 Dec 2023 18:08:54 -0500 Subject: [PATCH 04/26] Add missing params --- R/g_forest_new.R | 199 ++++++++++++++++++++++++++++++++++------------- 1 file changed, 146 insertions(+), 53 deletions(-) diff --git a/R/g_forest_new.R b/R/g_forest_new.R index f07c2505ef..ddccdd4098 100644 --- a/R/g_forest_new.R +++ b/R/g_forest_new.R @@ -256,25 +256,68 @@ #' } g_forest_new <- function(tbl, + col_x = attr(tbl, "col_x"), + col_ci = attr(tbl, "col_ci"), vline = 1, - forest_header = NULL, - fontsize = 4, + forest_header = attr(tbl, "forest_header"), xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - symbol_size = NULL, + width_row_names = lifecycle::deprecated(), + width_columns = NULL, + width_forest = lifecycle::deprecated(), + lbl_col_padding = 0, + rel_width_forest = 0.25, + font_size = 4, + col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], - rel_width_plot = 0.25) { - checkmate::assert_class(tbl, "VTableTree") + ggtheme = NULL, + gp = lifecycle::deprecated(), + draw = lifecycle::deprecated(), + newpage = lifecycle::deprecated()) { + # Deprecated argument warnings + if (lifecycle::is_present(width_row_names)) {lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", + details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." + )} + if (lifecycle::is_present(width_forest)) {lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)", + details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." + )} + if (lifecycle::is_present(gp)) {lifecycle::deprecate_warn( + "0.9.3", "g_forest(gp)", "g_forest(ggtheme)", + details = paste( + "`g_forest` is now generated as a `ggplot` object.", + "Additional display settings should be supplied via the `ggtheme` parameter." + ) + )} + if (lifecycle::is_present(draw)) {lifecycle::deprecate_warn( + "0.9.3", "g_forest(draw)", + details = "`g_forest` is now generated as a `ggplot` object. This parameter has no effect." + )} + if (lifecycle::is_present(newpage)) {lifecycle::deprecate_warn( + "0.9.3", "g_forest(newpage)", + details = "`g_forest` is now generated as a `ggplot` object. This parameter has no effect." + )} - gg_table <- rtable2gg(tbl) + - theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) - gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) + checkmate::assert_class(tbl, "VTableTree") + checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(font_size, lower = 0) + checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_character(col, null.ok = TRUE) + # Extract info from table mat <- matrix_form(tbl) mat_strings <- formatters::mf_strings(mat) nlines_hdr <- formatters::mf_nlheader(mat) nrows_body <- nrow(mat_strings) - nlines_hdr + tbl_stats <- mat_strings[nlines_hdr, -1] + + # Generate and modify table as ggplot object + gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + + theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) + gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) if (nlines_hdr == 2) { gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 gg_table$scales$scales[[2]]$expand <- c(0, 0) @@ -282,41 +325,58 @@ g_forest_new <- function(tbl, } else { arms <- NULL } - tbl_stats <- mat_strings[nlines_hdr, -1] tbl_df <- as_result_df(tbl) dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] names(tbl_df) <- c("row_num", tbl_stats) - tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[["95% CI"]], unlist)) - tbl_df <- tbl_df[names(tbl_df) != "95% CI"] - tbl_df[, -1] <- apply(tbl_df[, -1], 2, unlist) - tbl_df[["row_num"]] <- nlines_hdr + 1 + nrow(tbl_df) - tbl_df[["row_num"]] + # Check table data columns + if (!is.null(col_ci)) { + ci_col <- col_ci + 1 + } else { + tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) + ci_col <- which(names(tbl_df) == "empty_ci") + } + if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).") + + if (!is.null(col_x)) { + x_col <- col_x + 1 + } else { + tbl_df[["empty_x"]] <- NA_real_ + x_col <- which(names(tbl_df) == "empty_x") + } + if (!is.null(col_symbol_size)) { + sym_size <- unlist(tbl_df[, col_symbol_size + 1]) + } else { + sym_size <- 1 + } + + tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist)) + x <- unlist(tbl_df[, x_col]) + lwr <- unlist(tbl_df[["ci_lwr"]]) + upr <- unlist(tbl_df[["ci_upr"]]) + row_num <- nlines_hdr + 1 + nrow(tbl_df) - tbl_df[["row_num"]] - if (is.null(x_at)) x_at <- c(0.1, 1, 10) + if (is.null(col)) col <- "#343cff" + if (is.null(x_at)) x_at <- union(xlim, vline) x_labels <- x_at - mid_pt <- if (!is.null(vline)) vline else if (length(x_at) == 3) x_at[2] else mean(xlim) + # Apply log transformation if (logx) { + x <- log(x) + lwr_t <- log(lwr) + upr_t <- log(upr) xlim_t <- log(xlim) - tbl_df[["Odds Ratio"]] <- log(tbl_df[["Odds Ratio"]]) - tbl_df[["ci_lwr"]] <- log(tbl_df[["ci_lwr"]]) - tbl_df[["ci_upr"]] <- log(tbl_df[["ci_upr"]]) } else { + lwr_t <- lwr + upr_t <- upr xlim_t <- xlim } - if (is.null(forest_header)) { - forest_header <- c( - paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), - paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n") - ) - } - - gg_plt <- ggplot(data = tbl_df) + + # Set up plot area + gg_plt <- ggplot() + theme( - panel.background = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), axis.title.x = element_blank(), @@ -340,32 +400,56 @@ g_forest_new <- function(tbl, coord_cartesian(clip = "off") + geom_rect( data = NULL, - aes(xmin = xlim[1], xmax = xlim[2], ymin = 0, ymax = nrows_body + 0.5), - fill = "grey92" - ) + - geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + - geom_point( - x = tbl_df[["Odds Ratio"]], - y = tbl_df[["row_num"]], - aes(size = if (is.null(symbol_size)) `Total n` else symbol_size, color = col) + aes( + xmin = xlim[1], + xmax = xlim[2], + ymin = nrows_body + 0.5, + ymax = nrow(mat_strings) + as.numeric(nlines_hdr == 2) + ), + fill = "white" ) - gg_plt <- gg_plt + - geom_text( - x = mean(log(c(xlim[1], mid_pt))), y = nrows_body + 1.25, - label = forest_header[1], - size = fontsize, - lineheight = 0.9 - ) + - geom_text( - x = mean(log(c(mid_pt, xlim[2]))), y = nrows_body + 1.25, - label = forest_header[2], - size = fontsize, - lineheight = 0.9 + # Add points to plot + if (any(!is.na(x))) { + gg_plt <- gg_plt + geom_point( + x = x, + y = row_num, + aes(size = sym_size, color = col) ) + } + + if (!is.null(vline)) { + # Set default forest header + if (is.null(forest_header)) { + forest_header <- c( + paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), + paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n") + ) + } + + # Add vline and forest header labels + mid_pts <- exp(c(mean(log(c(xlim[1], vline))), mean(log(c(vline, xlim[2]))))) + gg_plt <- gg_plt + + geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + + annotate( + "text", + x = mid_pts[1], y = nrows_body + 1.25, + label = forest_header[1], + size = font_size, + lineheight = 0.9 + ) + + annotate( + "text", + x = mid_pts[2], y = nrows_body + 1.25, + label = forest_header[2], + size = font_size, + lineheight = 0.9 + ) + } for (i in seq_len(nrow(tbl_df))) { - which_arrow <- c(tbl_df[i, "ci_lwr"] < xlim_t[1], tbl_df[i, "ci_upr"] > xlim_t[2]) + # Determine which arrow(s) to add to CI lines + which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) which_arrow <- case_when( all(which_arrow) ~ "both", which_arrow[1] ~ "first", @@ -373,20 +457,29 @@ g_forest_new <- function(tbl, TRUE ~ NA ) + # Add CI lines gg_plt <- gg_plt + - geom_segment( - x = if (!which_arrow %in% c("first", "both")) tbl_df[["ci_lwr"]][i] else xlim_t[1], - xend = if (!which_arrow %in% c("last", "both")) tbl_df[["ci_upr"]][i] else xlim_t[2], - y = tbl_df[["row_num"]][i], yend = tbl_df[["row_num"]][i], + annotate( + "segment", + x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], + xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], + y = row_num[i], yend = row_num[i], color = col, arrow = if (is.na(which_arrow)) NULL else arrow(length = unit(0.05, "npc"), ends = which_arrow) ) } + # Apply custom ggtheme to table and plot + if (!is.null(ggtheme)) { + gg_table <- gg_table + ggtheme + gg_plt <- gg_plt + ggtheme + } + cowplot::plot_grid( gg_table, gg_plt, align = "h", - rel_widths = c(1 - rel_width_plot, rel_width_plot) + axis = "tblr", + rel_widths = c(1 - rel_width_forest, rel_width_forest) ) } From 41062fecfae9856aba2499eba7d274c4966f57f0 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Thu, 7 Dec 2023 19:25:28 -0500 Subject: [PATCH 05/26] Replace old g_forest function --- DESCRIPTION | 1 - R/g_forest.R | 315 ++++++++++++++++++++-------- R/g_forest_new.R | 485 -------------------------------------------- man/g_forest.Rd | 31 ++- man/g_forest_new.Rd | 282 -------------------------- 5 files changed, 242 insertions(+), 872 deletions(-) delete mode 100644 R/g_forest_new.R delete mode 100644 man/g_forest_new.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 589db31d4d..24abb6bb15 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -116,7 +116,6 @@ Collate: 'fit_rsp_step.R' 'fit_survival_step.R' 'g_forest.R' - 'g_forest_new.R' 'g_lineplot.R' 'g_step.R' 'g_waterfall.R' diff --git a/R/g_forest.R b/R/g_forest.R index 1c965a4fad..2f5b61940e 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -19,12 +19,10 @@ #' @param xlim (`numeric`)\cr limits for x axis. #' @param logx (`flag`)\cr show the x-values on logarithm scale. #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. -#' @param width_row_names (`unit`)\cr width for row names. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' @param width_row_names (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead. #' @param width_columns (`unit`)\cr widths for the table columns. #' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' @param width_forest (`unit`)\cr width for the forest column. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' @param width_forest (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. @@ -61,22 +59,17 @@ #' #' tbl <- basic_table() %>% #' tabulate_rsp_subgroups(df) -#' p <- g_forest(tbl, gp = grid::gpar(fontsize = 10)) -#' -#' draw_grob(p) +#' g_forest(tbl) #' #' # Odds ratio only table. #' #' tbl_or <- basic_table() %>% #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -#' tbl_or -#' p <- g_forest( +#' g_forest( #' tbl_or, #' forest_header = c("Comparison\nBetter", "Treatment\nBetter") #' ) #' -#' draw_grob(p) -#' #' # Survival forest plot example. #' adtte <- tern_ex_adtte #' # Save variable labels before data processing steps. @@ -112,6 +105,7 @@ #' table_hr <- basic_table() %>% #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) #' g_forest(table_hr) +#' #' # Works with any `rtable`. #' tbl <- rtable( #' header = c("E", "CI", "N"), @@ -126,6 +120,7 @@ #' x_at = c(0.5, 1, 2), #' col_symbol_size = 3 #' ) +#' #' tbl <- rtable( #' header = rheader( #' rrow("", rcell("A", colspan = 2)), @@ -154,105 +149,244 @@ g_forest <- function(tbl, xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - width_row_names = NULL, + width_row_names = lifecycle::deprecated(), width_columns = NULL, - width_forest = grid::unit(1, "null"), + width_forest = lifecycle::deprecated(), + lbl_col_padding = 0, + rel_width_forest = 0.25, + font_size = 4, col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], - gp = NULL, - draw = TRUE, - newpage = TRUE) { + ggtheme = NULL, + gp = lifecycle::deprecated(), + draw = lifecycle::deprecated(), + newpage = lifecycle::deprecated()) { + # Deprecated argument warnings + if (lifecycle::is_present(width_row_names)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", + details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." + ) + } + if (lifecycle::is_present(width_forest)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)", + details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." + ) + } + if (lifecycle::is_present(gp)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(gp)", "g_forest(ggtheme)", + details = paste( + "`g_forest` is now generated as a `ggplot` object.", + "Additional display settings should be supplied via the `ggtheme` parameter." + ) + ) + } + if (lifecycle::is_present(draw)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(draw)", + details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." + ) + } + if (lifecycle::is_present(newpage)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(newpage)", + details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." + ) + } + checkmate::assert_class(tbl, "VTableTree") + checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(font_size, lower = 0) + checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_character(col, null.ok = TRUE) + + # Extract info from table + mat <- matrix_form(tbl) + mat_strings <- formatters::mf_strings(mat) + nlines_hdr <- formatters::mf_nlheader(mat) + nrows_body <- nrow(mat_strings) - nlines_hdr + tbl_stats <- mat_strings[nlines_hdr, -1] + + # Generate and modify table as ggplot object + gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + + theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) + gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) + gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 + if (nlines_hdr == 2) { + gg_table$scales$scales[[2]]$expand <- c(0, 0) + arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) + } else { + arms <- NULL + } - nr <- nrow(tbl) - nc <- ncol(tbl) - if (is.null(col)) { - col <- "blue" + tbl_df <- as_result_df(tbl) + dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) + tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] + names(tbl_df) <- c("row_num", tbl_stats) + + # Check table data columns + if (!is.null(col_ci)) { + ci_col <- col_ci + 1 + } else { + tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) + ci_col <- which(names(tbl_df) == "empty_ci") } + if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).") - checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) - checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) - checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) - checkmate::assert_true(col_x > 0) - checkmate::assert_true(col_ci > 0) - checkmate::assert_character(col) + if (!is.null(col_x)) { + x_col <- col_x + 1 + } else { + tbl_df[["empty_x"]] <- NA_real_ + x_col <- which(names(tbl_df) == "empty_x") + } if (!is.null(col_symbol_size)) { - checkmate::assert_true(col_symbol_size > 0) + sym_size <- unlist(tbl_df[, col_symbol_size + 1]) + } else { + sym_size <- 1 } - x_e <- vapply(seq_len(nr), function(i) { - # If a label row is selected NULL is returned with a warning (suppressed) - xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE])) + tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist)) + x <- unlist(tbl_df[, x_col]) + lwr <- unlist(tbl_df[["ci_lwr"]]) + upr <- unlist(tbl_df[["ci_upr"]]) + row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - xi - } else { - NA_real_ - } - }, numeric(1)) + if (is.null(col)) col <- "#343cff" + if (is.null(x_at)) x_at <- union(xlim, vline) + x_labels <- x_at - x_ci <- lapply(seq_len(nr), function(i) { - xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above + # Apply log transformation + if (logx) { + x <- log(x) + lwr_t <- log(lwr) + upr_t <- log(upr) + xlim_t <- log(xlim) + } else { + lwr_t <- lwr + upr_t <- upr + xlim_t <- xlim + } - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - if (length(xi) != 2) { - stop("ci column needs two elements") - } - xi - } else { - c(NA_real_, NA_real_) + # Set up plot area + gg_plt <- ggplot(data = tbl_df) + + theme( + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.title.x = element_blank(), + axis.title.y = element_blank(), + axis.line.x = element_line(), + legend.position = "none", + plot.margin = margin(0, 0.1, 0.05, 0, "npc") + ) + + scale_x_continuous( + trans = ifelse(logx, "log", "identity"), + limits = xlim, + breaks = x_at, + labels = x_labels, + expand = c(0, 0) + ) + + scale_y_continuous( + limits = c(0, nrow(mat_strings) + 1), + breaks = NULL, + expand = c(0, 0) + ) + + coord_cartesian(clip = "off") + + geom_rect( + data = NULL, + aes( + xmin = xlim[1], + xmax = xlim[2], + ymin = nrows_body + 0.5, + ymax = nrow(mat_strings) + 1 + ), + fill = "white" + ) + + # Add points to plot + if (any(!is.na(x))) { + gg_plt <- gg_plt + geom_point( + x = x, + y = row_num, + aes(size = sym_size, color = col) + ) + } + + if (!is.null(vline)) { + # Set default forest header + if (is.null(forest_header)) { + forest_header <- c( + paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), + paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n") + ) } - }) - lower <- vapply(x_ci, `[`, numeric(1), 1) - upper <- vapply(x_ci, `[`, numeric(1), 2) + # Add vline and forest header labels + mid_pts <- exp(c(mean(log(c(xlim[1], vline))), mean(log(c(vline, xlim[2]))))) + gg_plt <- gg_plt + + geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + + annotate( + "text", + x = mid_pts[1], y = nrows_body + 1.25, + label = forest_header[1], + size = font_size, + lineheight = 0.9 + ) + + annotate( + "text", + x = mid_pts[2], y = nrows_body + 1.25, + label = forest_header[2], + size = font_size, + lineheight = 0.9 + ) + } - symbol_size <- if (!is.null(col_symbol_size)) { - tmp_symbol_size <- vapply(seq_len(nr), function(i) { - suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE])) + for (i in seq_len(nrow(tbl_df))) { + # Determine which arrow(s) to add to CI lines + which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) + which_arrow <- case_when( + all(which_arrow) ~ "both", + which_arrow[1] ~ "first", + which_arrow[2] ~ "last", + TRUE ~ NA + ) - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - xi + # Add CI lines + gg_plt <- gg_plt + + if (!is.na(which_arrow)) { + annotate( + "segment", + x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], + xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], + y = row_num[i], yend = row_num[i], + color = col, + arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow) + ) } else { - NA_real_ + annotate( + "segment", + x = lwr[i], xend = upr[i], + y = row_num[i], yend = row_num[i], + color = col + ) } - }, numeric(1)) - - # Scale symbol size. - tmp_symbol_size <- sqrt(tmp_symbol_size) - max_size <- max(tmp_symbol_size, na.rm = TRUE) - # Biggest points have radius is 2 * (1/3.5) lines not to overlap. - # See forest_dot_line. - 2 * tmp_symbol_size / max_size - } else { - NULL } - grob_forest <- forest_grob( - tbl, - x_e, - lower, - upper, - vline, - forest_header, - xlim, - logx, - x_at, - width_row_names, - width_columns, - width_forest, - symbol_size = symbol_size, - col = col, - gp = gp, - vp = grid::plotViewport(margins = rep(1, 4)) - ) - - if (draw) { - if (newpage) grid::grid.newpage() - grid::grid.draw(grob_forest) + # Apply custom ggtheme to table and plot + if (!is.null(ggtheme)) { + gg_table <- gg_table + ggtheme + gg_plt <- gg_plt + ggtheme } - invisible(grob_forest) + cowplot::plot_grid( + gg_table, + gg_plt, + align = "h", + axis = "tblr", + rel_widths = c(1 - rel_width_forest, rel_width_forest) + ) } #' Forest Plot Grob @@ -497,7 +631,6 @@ forest_grob <- function(tbl, ) } - cell_in_rows <- function(row_name, cells, cell_spans, @@ -699,6 +832,12 @@ forest_viewport <- function(tbl, gap_column = grid::unit(1, "lines"), gap_header = grid::unit(1, "lines"), mat_form = NULL) { + lifecycle::deprecate_warn( + "0.9.3", + "forest_viewport()", + details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." + ) + checkmate::assert_class(tbl, "VTableTree") checkmate::assert_true(grid::is.unit(width_forest)) if (!is.null(width_row_names)) { diff --git a/R/g_forest_new.R b/R/g_forest_new.R deleted file mode 100644 index ddccdd4098..0000000000 --- a/R/g_forest_new.R +++ /dev/null @@ -1,485 +0,0 @@ -#' #' Create a Forest Plot based on a Table -#' #' -#' #' Create a forest plot from any [rtables::rtable()] object that has a -#' #' column with a single value and a column with 2 values. -#' #' -#' #' @description `r lifecycle::badge("stable")` -#' #' -#' #' @inheritParams grid::gTree -#' #' @inheritParams argument_convention -#' #' @param tbl (`rtable`) -#' #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from -#' #' `tbl` attribute `col_x`, otherwise needs to be manually specified. -#' #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries -#' #' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified. -#' #' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. -#' #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. -#' #' If `vline = NULL` then `forest_header` needs to be `NULL` too. -#' #' By default tries to get this from `tbl` attribute `forest_header`. -#' #' @param xlim (`numeric`)\cr limits for x axis. -#' #' @param logx (`flag`)\cr show the x-values on logarithm scale. -#' #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. -#' #' @param width_row_names (`unit`)\cr width for row names. -#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' #' @param width_columns (`unit`)\cr widths for the table columns. -#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' #' @param width_forest (`unit`)\cr width for the forest column. -#' #' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used -#' #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional -#' #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. -#' #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. -#' #' @param col (`character`)\cr color(s). -#' #' -#' #' @return `gTree` object containing the forest plot and table. -#' #' -#' #' @examples -#' #' \donttest{ -#' #' library(dplyr) -#' #' library(forcats) -#' #' library(nestcolor) -#' #' -#' #' adrs <- tern_ex_adrs -#' #' n_records <- 20 -#' #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) -#' #' adrs <- adrs %>% -#' #' filter(PARAMCD == "BESRSPI") %>% -#' #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% -#' #' slice(seq_len(n_records)) %>% -#' #' droplevels() %>% -#' #' mutate( -#' #' # Reorder levels of factor to make the placebo group the reference arm. -#' #' ARM = fct_relevel(ARM, "B: Placebo"), -#' #' rsp = AVALC == "CR" -#' #' ) -#' #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") -#' #' df <- extract_rsp_subgroups( -#' #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), -#' #' data = adrs -#' #' ) -#' #' # Full commonly used response table. -#' #' -#' #' tbl <- basic_table() %>% -#' #' tabulate_rsp_subgroups(df) -#' #' p <- g_forest_new(tbl, gp = grid::gpar(fontsize = 10)) -#' #' -#' #' draw_grob(p) -#' #' -#' #' # Odds ratio only table. -#' #' -#' #' tbl_or <- basic_table() %>% -#' #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -#' #' tbl_or -#' #' p <- g_forest_new( -#' #' tbl_or, -#' #' forest_header = c("Comparison\nBetter", "Treatment\nBetter") -#' #' ) -#' #' -#' #' draw_grob(p) -#' #' -#' #' # Survival forest plot example. -#' #' adtte <- tern_ex_adtte -#' #' # Save variable labels before data processing steps. -#' #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) -#' #' adtte_f <- adtte %>% -#' #' filter( -#' #' PARAMCD == "OS", -#' #' ARM %in% c("B: Placebo", "A: Drug X"), -#' #' SEX %in% c("M", "F") -#' #' ) %>% -#' #' mutate( -#' #' # Reorder levels of ARM to display reference arm before treatment arm. -#' #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), -#' #' SEX = droplevels(SEX), -#' #' AVALU = as.character(AVALU), -#' #' is_event = CNSR == 0 -#' #' ) -#' #' labels <- list( -#' #' "ARM" = adtte_labels["ARM"], -#' #' "SEX" = adtte_labels["SEX"], -#' #' "AVALU" = adtte_labels["AVALU"], -#' #' "is_event" = "Event Flag" -#' #' ) -#' #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) -#' #' df <- extract_survival_subgroups( -#' #' variables = list( -#' #' tte = "AVAL", -#' #' is_event = "is_event", -#' #' arm = "ARM", subgroups = c("SEX", "BMRKR2") -#' #' ), -#' #' data = adtte_f -#' #' ) -#' #' table_hr <- basic_table() %>% -#' #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) -#' #' g_forest_new(table_hr) -#' #' # Works with any `rtable`. -#' #' tbl <- rtable( -#' #' header = c("E", "CI", "N"), -#' #' rrow("", 1, c(.8, 1.2), 200), -#' #' rrow("", 1.2, c(1.1, 1.4), 50) -#' #' ) -#' #' g_forest_new( -#' #' tbl = tbl, -#' #' col_x = 1, -#' #' col_ci = 2, -#' #' xlim = c(0.5, 2), -#' #' x_at = c(0.5, 1, 2), -#' #' col_symbol_size = 3 -#' #' ) -#' #' tbl <- rtable( -#' #' header = rheader( -#' #' rrow("", rcell("A", colspan = 2)), -#' #' rrow("", "c1", "c2") -#' #' ), -#' #' rrow("row 1", 1, c(.8, 1.2)), -#' #' rrow("row 2", 1.2, c(1.1, 1.4)) -#' #' ) -#' #' g_forest_new( -#' #' tbl = tbl, -#' #' col_x = 1, -#' #' col_ci = 2, -#' #' xlim = c(0.5, 2), -#' #' x_at = c(0.5, 1, 2), -#' #' vline = 1, -#' #' forest_header = c("Hello", "World") -#' #' ) -#' #' } -#' #' -#' #' @export -#' g_forest_new <- function(tbl, -#' col_x = attr(tbl, "col_x"), -#' col_ci = attr(tbl, "col_ci"), -#' vline = 1, -#' forest_header = attr(tbl, "forest_header"), -#' xlim = c(0.1, 10), -#' logx = TRUE, -#' x_at = c(0.1, 1, 10), -#' width_row_names = NULL, -#' width_columns = NULL, -#' width_forest = grid::unit(1, "null"), -#' col_symbol_size = attr(tbl, "col_symbol_size"), -#' col = getOption("ggplot2.discrete.colour")[1], -#' gp = NULL, -#' draw = TRUE, -#' newpage = TRUE) { -#' checkmate::assert_class(tbl, "VTableTree") -#' -#' nr <- nrow(tbl) -#' nc <- ncol(tbl) -#' if (is.null(col)) { -#' col <- "blue" -#' } -#' -#' checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) -#' checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) -#' checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) -#' checkmate::assert_true(col_x > 0) -#' checkmate::assert_true(col_ci > 0) -#' checkmate::assert_character(col) -#' if (!is.null(col_symbol_size)) { -#' checkmate::assert_true(col_symbol_size > 0) -#' } -#' -#' x_e <- vapply(seq_len(nr), function(i) { -#' # If a label row is selected NULL is returned with a warning (suppressed) -#' xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE])) -#' -#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { -#' xi -#' } else { -#' NA_real_ -#' } -#' }, numeric(1)) -#' -#' x_ci <- lapply(seq_len(nr), function(i) { -#' xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above -#' -#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { -#' if (length(xi) != 2) { -#' stop("ci column needs two elements") -#' } -#' xi -#' } else { -#' c(NA_real_, NA_real_) -#' } -#' }) -#' -#' lower <- vapply(x_ci, `[`, numeric(1), 1) -#' upper <- vapply(x_ci, `[`, numeric(1), 2) -#' -#' symbol_size <- if (!is.null(col_symbol_size)) { -#' tmp_symbol_size <- vapply(seq_len(nr), function(i) { -#' suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE])) -#' -#' if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { -#' xi -#' } else { -#' NA_real_ -#' } -#' }, numeric(1)) -#' -#' # Scale symbol size. -#' tmp_symbol_size <- sqrt(tmp_symbol_size) -#' max_size <- max(tmp_symbol_size, na.rm = TRUE) -#' # Biggest points have radius is 2 * (1/3.5) lines not to overlap. -#' # See forest_dot_line. -#' 2 * tmp_symbol_size / max_size -#' } else { -#' NULL -#' } -#' -#' grob_forest <- forest_grob( -#' tbl, -#' x_e, -#' lower, -#' upper, -#' vline, -#' forest_header, -#' xlim, -#' logx, -#' x_at, -#' width_row_names, -#' width_columns, -#' width_forest, -#' symbol_size = symbol_size, -#' col = col, -#' gp = gp, -#' vp = grid::plotViewport(margins = rep(1, 4)) -#' ) -#' -#' if (draw) { -#' if (newpage) grid::grid.newpage() -#' grid::grid.draw(grob_forest) -#' } -#' -#' invisible(grob_forest) -#' } - -g_forest_new <- function(tbl, - col_x = attr(tbl, "col_x"), - col_ci = attr(tbl, "col_ci"), - vline = 1, - forest_header = attr(tbl, "forest_header"), - xlim = c(0.1, 10), - logx = TRUE, - x_at = c(0.1, 1, 10), - width_row_names = lifecycle::deprecated(), - width_columns = NULL, - width_forest = lifecycle::deprecated(), - lbl_col_padding = 0, - rel_width_forest = 0.25, - font_size = 4, - col_symbol_size = attr(tbl, "col_symbol_size"), - col = getOption("ggplot2.discrete.colour")[1], - ggtheme = NULL, - gp = lifecycle::deprecated(), - draw = lifecycle::deprecated(), - newpage = lifecycle::deprecated()) { - # Deprecated argument warnings - if (lifecycle::is_present(width_row_names)) {lifecycle::deprecate_warn( - "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", - details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." - )} - if (lifecycle::is_present(width_forest)) {lifecycle::deprecate_warn( - "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)", - details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." - )} - if (lifecycle::is_present(gp)) {lifecycle::deprecate_warn( - "0.9.3", "g_forest(gp)", "g_forest(ggtheme)", - details = paste( - "`g_forest` is now generated as a `ggplot` object.", - "Additional display settings should be supplied via the `ggtheme` parameter." - ) - )} - if (lifecycle::is_present(draw)) {lifecycle::deprecate_warn( - "0.9.3", "g_forest(draw)", - details = "`g_forest` is now generated as a `ggplot` object. This parameter has no effect." - )} - if (lifecycle::is_present(newpage)) {lifecycle::deprecate_warn( - "0.9.3", "g_forest(newpage)", - details = "`g_forest` is now generated as a `ggplot` object. This parameter has no effect." - )} - - checkmate::assert_class(tbl, "VTableTree") - checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) - checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) - checkmate::assert_number(font_size, lower = 0) - checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) - checkmate::assert_character(col, null.ok = TRUE) - - # Extract info from table - mat <- matrix_form(tbl) - mat_strings <- formatters::mf_strings(mat) - nlines_hdr <- formatters::mf_nlheader(mat) - nrows_body <- nrow(mat_strings) - nlines_hdr - tbl_stats <- mat_strings[nlines_hdr, -1] - - # Generate and modify table as ggplot object - gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + - theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) - gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) - if (nlines_hdr == 2) { - gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 - gg_table$scales$scales[[2]]$expand <- c(0, 0) - arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) - } else { - arms <- NULL - } - - tbl_df <- as_result_df(tbl) - dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) - tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] - names(tbl_df) <- c("row_num", tbl_stats) - - # Check table data columns - if (!is.null(col_ci)) { - ci_col <- col_ci + 1 - } else { - tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) - ci_col <- which(names(tbl_df) == "empty_ci") - } - if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).") - - if (!is.null(col_x)) { - x_col <- col_x + 1 - } else { - tbl_df[["empty_x"]] <- NA_real_ - x_col <- which(names(tbl_df) == "empty_x") - } - if (!is.null(col_symbol_size)) { - sym_size <- unlist(tbl_df[, col_symbol_size + 1]) - } else { - sym_size <- 1 - } - - tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist)) - x <- unlist(tbl_df[, x_col]) - lwr <- unlist(tbl_df[["ci_lwr"]]) - upr <- unlist(tbl_df[["ci_upr"]]) - row_num <- nlines_hdr + 1 + nrow(tbl_df) - tbl_df[["row_num"]] - - if (is.null(col)) col <- "#343cff" - if (is.null(x_at)) x_at <- union(xlim, vline) - x_labels <- x_at - - # Apply log transformation - if (logx) { - x <- log(x) - lwr_t <- log(lwr) - upr_t <- log(upr) - xlim_t <- log(xlim) - } else { - lwr_t <- lwr - upr_t <- upr - xlim_t <- xlim - } - - # Set up plot area - gg_plt <- ggplot() + - theme( - panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), - axis.title.x = element_blank(), - axis.title.y = element_blank(), - axis.line.x = element_line(), - legend.position = "none", - plot.margin = margin(0, 0.1, 0.05, 0, "npc") - ) + - scale_x_continuous( - trans = ifelse(logx, "log", "identity"), - limits = xlim, - breaks = x_at, - labels = x_labels, - expand = c(0, 0) - ) + - scale_y_continuous( - limits = c(0, nrow(mat_strings) + as.numeric(nlines_hdr == 2)), - breaks = NULL, - expand = c(0, 0) - ) + - coord_cartesian(clip = "off") + - geom_rect( - data = NULL, - aes( - xmin = xlim[1], - xmax = xlim[2], - ymin = nrows_body + 0.5, - ymax = nrow(mat_strings) + as.numeric(nlines_hdr == 2) - ), - fill = "white" - ) - - # Add points to plot - if (any(!is.na(x))) { - gg_plt <- gg_plt + geom_point( - x = x, - y = row_num, - aes(size = sym_size, color = col) - ) - } - - if (!is.null(vline)) { - # Set default forest header - if (is.null(forest_header)) { - forest_header <- c( - paste(if (!is.null(arms)) arms[1] else "Comparison", "Better", sep = "\n"), - paste(if (!is.null(arms)) arms[2] else "Treatment", "Better", sep = "\n") - ) - } - - # Add vline and forest header labels - mid_pts <- exp(c(mean(log(c(xlim[1], vline))), mean(log(c(vline, xlim[2]))))) - gg_plt <- gg_plt + - geom_segment(aes(x = vline, xend = vline, y = 0, yend = nrows_body + 0.5)) + - annotate( - "text", - x = mid_pts[1], y = nrows_body + 1.25, - label = forest_header[1], - size = font_size, - lineheight = 0.9 - ) + - annotate( - "text", - x = mid_pts[2], y = nrows_body + 1.25, - label = forest_header[2], - size = font_size, - lineheight = 0.9 - ) - } - - for (i in seq_len(nrow(tbl_df))) { - # Determine which arrow(s) to add to CI lines - which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) - which_arrow <- case_when( - all(which_arrow) ~ "both", - which_arrow[1] ~ "first", - which_arrow[2] ~ "last", - TRUE ~ NA - ) - - # Add CI lines - gg_plt <- gg_plt + - annotate( - "segment", - x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], - xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], - y = row_num[i], yend = row_num[i], - color = col, - arrow = if (is.na(which_arrow)) NULL else arrow(length = unit(0.05, "npc"), ends = which_arrow) - ) - } - - # Apply custom ggtheme to table and plot - if (!is.null(ggtheme)) { - gg_table <- gg_table + ggtheme - gg_plt <- gg_plt + ggtheme - } - - cowplot::plot_grid( - gg_table, - gg_plt, - align = "h", - axis = "tblr", - rel_widths = c(1 - rel_width_forest, rel_width_forest) - ) -} diff --git a/man/g_forest.Rd b/man/g_forest.Rd index 36d161cd12..715dc5df54 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -13,14 +13,18 @@ g_forest( xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - width_row_names = NULL, + width_row_names = lifecycle::deprecated(), width_columns = NULL, - width_forest = grid::unit(1, "null"), + width_forest = lifecycle::deprecated(), + lbl_col_padding = 0, + rel_width_forest = 0.25, + font_size = 4, col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], - gp = NULL, - draw = TRUE, - newpage = TRUE + ggtheme = NULL, + gp = lifecycle::deprecated(), + draw = lifecycle::deprecated(), + newpage = lifecycle::deprecated() ) } \arguments{ @@ -44,14 +48,12 @@ By default tries to get this from \code{tbl} attribute \code{forest_header}.} \item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen.} -\item{width_row_names}{(\code{unit})\cr width for row names. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_row_names}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument instead.} \item{width_columns}{(\code{unit})\cr widths for the table columns. If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} -\item{width_forest}{(\code{unit})\cr width for the forest column. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_forest}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument instead.} \item{col_symbol_size}{(\code{integer})\cr column index from \code{tbl} containing data to be used to determine relative size for estimator plot symbol. Typically, the symbol size is proportional @@ -107,22 +109,17 @@ df <- extract_rsp_subgroups( tbl <- basic_table() \%>\% tabulate_rsp_subgroups(df) -p <- g_forest(tbl, gp = grid::gpar(fontsize = 10)) - -draw_grob(p) +g_forest(tbl) # Odds ratio only table. tbl_or <- basic_table() \%>\% tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -tbl_or -p <- g_forest( +g_forest( tbl_or, forest_header = c("Comparison\nBetter", "Treatment\nBetter") ) -draw_grob(p) - # Survival forest plot example. adtte <- tern_ex_adtte # Save variable labels before data processing steps. @@ -158,6 +155,7 @@ df <- extract_survival_subgroups( table_hr <- basic_table() \%>\% tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) g_forest(table_hr) + # Works with any `rtable`. tbl <- rtable( header = c("E", "CI", "N"), @@ -172,6 +170,7 @@ g_forest( x_at = c(0.5, 1, 2), col_symbol_size = 3 ) + tbl <- rtable( header = rheader( rrow("", rcell("A", colspan = 2)), diff --git a/man/g_forest_new.Rd b/man/g_forest_new.Rd deleted file mode 100644 index 268e9ddb88..0000000000 --- a/man/g_forest_new.Rd +++ /dev/null @@ -1,282 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/g_forest_new.R -\name{g_forest_new} -\alias{g_forest_new} -\title{#' Create a Forest Plot based on a Table -#' -#' Create a forest plot from any \code{\link[rtables:rtable]{rtables::rtable()}} object that has a -#' column with a single value and a column with 2 values. -#' -#' @description \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -#' -#' @inheritParams grid::gTree -#' @inheritParams argument_convention -#' @param tbl (\code{rtable}) -#' @param col_x (\code{integer})\cr column index with estimator. By default tries to get this from -#' \code{tbl} attribute \code{col_x}, otherwise needs to be manually specified. -#' @param col_ci (\code{integer})\cr column index with confidence intervals. By default tries -#' to get this from \code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified. -#' @param vline (\code{number})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted. -#' @param forest_header (\code{character}, length 2)\cr text displayed to the left and right of \code{vline}, respectively. -#' If \code{vline = NULL} then \code{forest_header} needs to be \code{NULL} too. -#' By default tries to get this from \code{tbl} attribute \code{forest_header}. -#' @param xlim (\code{numeric})\cr limits for x axis. -#' @param logx (\code{flag})\cr show the x-values on logarithm scale. -#' @param x_at (\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen. -#' @param width_row_names (\code{unit})\cr width for row names. -#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. -#' @param width_columns (\code{unit})\cr widths for the table columns. -#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. -#' @param width_forest (\code{unit})\cr width for the forest column. -#' If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}. -#' @param col_symbol_size (\code{integer})\cr column index from \code{tbl} containing data to be used -#' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional -#' to the sample size used to calculate the estimator. If \code{NULL}, the same symbol size is used for all subgroups. -#' By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, otherwise needs to be manually specified. -#' @param col (\code{character})\cr color(s). -#' -#' @return \code{gTree} object containing the forest plot and table. -#' -#' @examples -#' \donttest{ -#' library(dplyr) -#' library(forcats) -#' library(nestcolor) -#' -#' adrs <- tern_ex_adrs -#' n_records <- 20 -#' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) -#' adrs <- adrs %>% -#' filter(PARAMCD == "BESRSPI") %>% -#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>% -#' slice(seq_len(n_records)) %>% -#' droplevels() %>% -#' mutate( -#' # Reorder levels of factor to make the placebo group the reference arm. -#' ARM = fct_relevel(ARM, "B: Placebo"), -#' rsp = AVALC == "CR" -#' ) -#' formatters::var_labels(adrs) <- c(adrs_labels, "Response") -#' df <- extract_rsp_subgroups( -#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), -#' data = adrs -#' ) -#' # Full commonly used response table. -#' -#' tbl <- basic_table() %>% -#' tabulate_rsp_subgroups(df) -#' p <- g_forest_new(tbl, gp = grid::gpar(fontsize = 10)) -#' -#' draw_grob(p) -#' -#' # Odds ratio only table. -#' -#' tbl_or <- basic_table() %>% -#' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -#' tbl_or -#' p <- g_forest_new( -#' tbl_or, -#' forest_header = c("Comparison\nBetter", "Treatment\nBetter") -#' ) -#' -#' draw_grob(p) -#' -#' # Survival forest plot example. -#' adtte <- tern_ex_adtte -#' # Save variable labels before data processing steps. -#' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) -#' adtte_f <- adtte %>% -#' filter( -#' PARAMCD == "OS", -#' ARM %in% c("B: Placebo", "A: Drug X"), -#' SEX %in% c("M", "F") -#' ) %>% -#' mutate( -#' # Reorder levels of ARM to display reference arm before treatment arm. -#' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), -#' SEX = droplevels(SEX), -#' AVALU = as.character(AVALU), -#' is_event = CNSR == 0 -#' ) -#' labels <- list( -#' "ARM" = adtte_labels["ARM"], -#' "SEX" = adtte_labels["SEX"], -#' "AVALU" = adtte_labels["AVALU"], -#' "is_event" = "Event Flag" -#' ) -#' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) -#' df <- extract_survival_subgroups( -#' variables = list( -#' tte = "AVAL", -#' is_event = "is_event", -#' arm = "ARM", subgroups = c("SEX", "BMRKR2") -#' ), -#' data = adtte_f -#' ) -#' table_hr <- basic_table() %>% -#' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) -#' g_forest_new(table_hr) -#' # Works with any `rtable`. -#' tbl <- rtable( -#' header = c("E", "CI", "N"), -#' rrow("", 1, c(.8, 1.2), 200), -#' rrow("", 1.2, c(1.1, 1.4), 50) -#' ) -#' g_forest_new( -#' tbl = tbl, -#' col_x = 1, -#' col_ci = 2, -#' xlim = c(0.5, 2), -#' x_at = c(0.5, 1, 2), -#' col_symbol_size = 3 -#' ) -#' tbl <- rtable( -#' header = rheader( -#' rrow("", rcell("A", colspan = 2)), -#' rrow("", "c1", "c2") -#' ), -#' rrow("row 1", 1, c(.8, 1.2)), -#' rrow("row 2", 1.2, c(1.1, 1.4)) -#' ) -#' g_forest_new( -#' tbl = tbl, -#' col_x = 1, -#' col_ci = 2, -#' xlim = c(0.5, 2), -#' x_at = c(0.5, 1, 2), -#' vline = 1, -#' forest_header = c("Hello", "World") -#' ) -#' } -#' -#' @export -g_forest_new <- function(tbl, -col_x = attr(tbl, "col_x"), -col_ci = attr(tbl, "col_ci"), -vline = 1, -forest_header = attr(tbl, "forest_header"), -xlim = c(0.1, 10), -logx = TRUE, -x_at = c(0.1, 1, 10), -width_row_names = NULL, -width_columns = NULL, -width_forest = grid::unit(1, "null"), -col_symbol_size = attr(tbl, "col_symbol_size"), -col = getOption("ggplot2.discrete.colour")\link{1}, -gp = NULL, -draw = TRUE, -newpage = TRUE) { -checkmate::assert_class(tbl, "VTableTree")} -\usage{ -g_forest_new( - tbl, - vline = 1, - forest_header = NULL, - fontsize = 4, - xlim = c(0.1, 10), - logx = TRUE, - x_at = c(0.1, 1, 10), - symbol_size = NULL, - col = getOption("ggplot2.discrete.colour")[1], - rel_width_plot = 0.25 -) -} -\description{ -nr <- nrow(tbl) -nc <- ncol(tbl) -if (is.null(col)) { -col <- "blue" -} -} -\details{ -checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) -checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) -checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) -checkmate::assert_true(col_x > 0) -checkmate::assert_true(col_ci > 0) -checkmate::assert_character(col) -if (!is.null(col_symbol_size)) { -checkmate::assert_true(col_symbol_size > 0) -} - -x_e <- vapply(seq_len(nr), function(i) { -# If a label row is selected NULL is returned with a warning (suppressed) -xi <- suppressWarnings(as.vector(tbl\link{i, col_x, drop = TRUE})) - -\if{html}{\out{
}}\preformatted{if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ - xi -\} else \{ - NA_real_ -\} -}\if{html}{\out{
}} - -}, numeric(1)) - -x_ci <- lapply(seq_len(nr), function(i) { -xi <- suppressWarnings(as.vector(tbl\link{i, col_ci, drop = TRUE})) # as above - -\if{html}{\out{
}}\preformatted{if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ - if (length(xi) != 2) \{ - stop("ci column needs two elements") - \} - xi -\} else \{ - c(NA_real_, NA_real_) -\} -}\if{html}{\out{
}} - -}) - -lower <- vapply(x_ci, \code{[}, numeric(1), 1) -upper <- vapply(x_ci, \code{[}, numeric(1), 2) - -symbol_size <- if (!is.null(col_symbol_size)) { -tmp_symbol_size <- vapply(seq_len(nr), function(i) { -suppressWarnings(xi <- as.vector(tbl\link{i, col_symbol_size, drop = TRUE})) - -\if{html}{\out{
}}\preformatted{ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) \{ - xi - \} else \{ - NA_real_ - \} -\}, numeric(1)) - -# Scale symbol size. -tmp_symbol_size <- sqrt(tmp_symbol_size) -max_size <- max(tmp_symbol_size, na.rm = TRUE) -# Biggest points have radius is 2 * (1/3.5) lines not to overlap. -# See forest_dot_line. -2 * tmp_symbol_size / max_size -}\if{html}{\out{
}} - -} else { -NULL -} - -grob_forest <- forest_grob( -tbl, -x_e, -lower, -upper, -vline, -forest_header, -xlim, -logx, -x_at, -width_row_names, -width_columns, -width_forest, -symbol_size = symbol_size, -col = col, -gp = gp, -vp = grid::plotViewport(margins = rep(1, 4)) -) - -if (draw) { -if (newpage) grid::grid.newpage() -grid::grid.draw(grob_forest) -} - -invisible(grob_forest) -} -} From 39dbde8b3ed62725673a27502ff962906e57c40a Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 14:11:30 -0500 Subject: [PATCH 06/26] Update docs --- R/g_forest.R | 17 ++++++++++++----- man/g_forest.Rd | 22 ++++++++++++---------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/R/g_forest.R b/R/g_forest.R index 2f5b61940e..ae92fda4af 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -1,11 +1,10 @@ -#' Create a Forest Plot based on a Table +#' Create a forest plot based on a table #' #' Create a forest plot from any [rtables::rtable()] object that has a #' column with a single value and a column with 2 values. #' #' @description `r lifecycle::badge("stable")` #' -#' @inheritParams grid::gTree #' @inheritParams argument_convention #' @param tbl (`rtable`) #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from @@ -19,17 +18,25 @@ #' @param xlim (`numeric`)\cr limits for x axis. #' @param logx (`flag`)\cr show the x-values on logarithm scale. #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. -#' @param width_row_names (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead. +#' @param width_row_names (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument +#' instead. #' @param width_columns (`unit`)\cr widths for the table columns. #' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' @param width_forest (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. +#' @param width_forest (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument +#' instead. #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. #' @param col (`character`)\cr color(s). +#' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. +#' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. +#' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. #' -#' @return `gTree` object containing the forest plot and table. +#' @return `ggplot` forest plot and table. #' #' @examples #' \donttest{ diff --git a/man/g_forest.Rd b/man/g_forest.Rd index 715dc5df54..0ce3f33553 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/g_forest.R \name{g_forest} \alias{g_forest} -\title{Create a Forest Plot based on a Table} +\title{Create a forest plot based on a table} \usage{ g_forest( tbl, @@ -48,12 +48,14 @@ By default tries to get this from \code{tbl} attribute \code{forest_header}.} \item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen.} -\item{width_row_names}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument instead.} +\item{width_row_names}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument +instead.} \item{width_columns}{(\code{unit})\cr widths for the table columns. If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} -\item{width_forest}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument instead.} +\item{width_forest}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument +instead.} \item{col_symbol_size}{(\code{integer})\cr column index from \code{tbl} containing data to be used to determine relative size for estimator plot symbol. Typically, the symbol size is proportional @@ -62,17 +64,17 @@ By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, o \item{col}{(\code{character})\cr color(s).} -\item{gp}{A \code{"gpar"} object, typically the output - from a call to the function \code{\link[grid]{gpar}}. This is basically - a list of graphical parameter settings.} +\item{gp}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} -\item{draw}{(\code{flag})\cr whether the plot should be drawn.} +\item{draw}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} -\item{newpage}{(\code{flag})\cr whether the plot should be drawn on a new page. -Only considered if \code{draw = TRUE} is used.} +\item{newpage}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} } \value{ -\code{gTree} object containing the forest plot and table. +\code{ggplot} forest plot and table. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} From 5136908e936c07297ce4cdabd73f86f8a0ef36b1 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 16:05:50 -0500 Subject: [PATCH 07/26] Add function to test setup to process ggplot snapshots --- tests/testthat/setup.R | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 80d93d308d..9c74d4d29f 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -20,3 +20,16 @@ skip_if_too_deep <- function(depth) { testthat::skip(paste("testing depth", testing_depth, "is below current testing specification", depth)) } } + +# expect_snapshot_ggplot - set custom plot dimensions +expect_snapshot_ggplot <- function(title, fig, width = NA, height = NA) { + skip_if_not_installed("svglite") + + name <- paste0(title, ".svg") + path <- tempdir() + suppressMessages(ggplot2::ggsave(name, fig, path = path, width = width, height = height)) + path <- file.path(path, name) + + testthat::announce_snapshot_file(name = name) + testthat::expect_snapshot_file(path, name) +} From a9898633f2b5d8cea909a8f79528427bfff14a54 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 16:09:52 -0500 Subject: [PATCH 08/26] Update rtable2gg tests --- .../utils_ggplot/rtable2gg_colsplits.svg | 30 ----------- tests/testthat/test-utils_ggplot.R | 50 +++++-------------- 2 files changed, 12 insertions(+), 68 deletions(-) diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg index f58c5b11a0..6aea311a37 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg @@ -28,11 +28,6 @@ A -A -A -A -A -A @@ -40,11 +35,6 @@ B -B -B -B -B -B @@ -52,11 +42,6 @@ V1 -V1 -V1 -V1 -V1 -V1 @@ -64,11 +49,6 @@ V2 -V2 -V2 -V2 -V2 -V2 @@ -76,11 +56,6 @@ V1 -V1 -V1 -V1 -V1 -V1 @@ -88,11 +63,6 @@ V2 -V2 -V2 -V2 -V2 -V2 diff --git a/tests/testthat/test-utils_ggplot.R b/tests/testthat/test-utils_ggplot.R index 1313062e81..e270fb6266 100644 --- a/tests/testthat/test-utils_ggplot.R +++ b/tests/testthat/test-utils_ggplot.R @@ -1,6 +1,4 @@ -skip_if_not_installed("svglite") - -testthat::test_that("rtables2gg works as expected", { +testthat::test_that("rtable2gg works as expected", { dta <- data.frame( USUBJID = rep(1:6, each = 3), PARAMCD = rep("lab", 6 * 3), @@ -17,43 +15,23 @@ testthat::test_that("rtables2gg works as expected", { tbl <- build_table(lyt, df = dta) # defaults - testthat::expect_snapshot_file( - tbl %>% - rtable2gg() %>% - ggplot2::ggsave(filename = "rtable2gg_default.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_default.svg" - ) + rtable2gg_default <- tbl %>% rtable2gg() + expect_snapshot_ggplot("rtable2gg_default", rtable2gg_default, width = 5) # custom fontsize - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(fontsize = 5) %>% - ggplot2::ggsave(filename = "rtable2gg_fs.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_fs.svg" - ) + rtable2gg_fs <- tbl %>% rtable2gg(fontsize = 5) + expect_snapshot_ggplot("rtable2gg_fs", rtable2gg_fs, width = 5) # custom colwidths - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(colwidths = c(4, 2, 2, 3)) %>% - ggplot2::ggsave(filename = "rtable2gg_cw.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_cw.svg" - ) + rtable2gg_cw <- tbl %>% rtable2gg(colwidths = c(4, 2, 2, 3)) + expect_snapshot_ggplot("rtable2gg_cw", rtable2gg_cw, width = 5) # custom lbl_col_padding - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(lbl_col_padding = -5) %>% - ggplot2::ggsave(filename = "rtable2gg_lblpad.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_lblpad.svg" - ) + rtable2gg_lblpad <- tbl %>% rtable2gg(lbl_col_padding = -5) + expect_snapshot_ggplot("rtable2gg_lblpad", rtable2gg_lblpad, width = 5) }) -testthat::test_that("rtables2gg works with multiple column splits", { +testthat::test_that("rtable2gg works with multiple column splits", { dta2 <- data.frame( USUBJID = rep(1:6, each = 3), PARAMCD = rep("lab", 6 * 3), @@ -71,10 +49,6 @@ testthat::test_that("rtables2gg works with multiple column splits", { tbl <- build_table(lyt, df = dta2) - testthat::expect_snapshot_file( - tbl %>% - rtable2gg() %>% - ggplot2::ggsave(filename = "rtable2gg_colsplits.svg", path = "./_snaps/utils_ggplot", height = 3, width = 10), - "rtable2gg_colsplits.svg" - ) + rtable2gg_colsplits <- tbl %>% rtable2gg() + expect_snapshot_ggplot("rtable2gg_colsplits", rtable2gg_colsplits, width = 10, height = 3) }) From 4c14287ba5cc239c1428ebf7cecf0356d1a4680b Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 16:15:08 -0500 Subject: [PATCH 09/26] Update existing g_forest tests --- .../_snaps/g_forest/g-forest-custom.svg | 50 ------ tests/testthat/_snaps/g_forest/g-forest.svg | 113 ------------- tests/testthat/_snaps/g_forest/g_forest.svg | 160 ++++++++++++++++++ .../_snaps/g_forest/g_forest_custom.svg | 75 ++++++++ tests/testthat/test-g_forest.R | 24 +-- 5 files changed, 247 insertions(+), 175 deletions(-) delete mode 100644 tests/testthat/_snaps/g_forest/g-forest-custom.svg delete mode 100644 tests/testthat/_snaps/g_forest/g-forest.svg create mode 100644 tests/testthat/_snaps/g_forest/g_forest.svg create mode 100644 tests/testthat/_snaps/g_forest/g_forest_custom.svg diff --git a/tests/testthat/_snaps/g_forest/g-forest-custom.svg b/tests/testthat/_snaps/g_forest/g-forest-custom.svg deleted file mode 100644 index 347699fec9..0000000000 --- a/tests/testthat/_snaps/g_forest/g-forest-custom.svg +++ /dev/null @@ -1,50 +0,0 @@ - - - - - - - - - - - - -A - -c1 -c2 -row 1 -1 -0.8, 1.2 -row 2 -1.2 -1.1, 1.4 - -Hello -World - - - - - - -0.5 -1 -2 - - - - - - - - diff --git a/tests/testthat/_snaps/g_forest/g-forest.svg b/tests/testthat/_snaps/g_forest/g-forest.svg deleted file mode 100644 index 3c1e0223ed..0000000000 --- a/tests/testthat/_snaps/g_forest/g-forest.svg +++ /dev/null @@ -1,113 +0,0 @@ - - - - - - - - - - - - - -A: Drug X - -B: Placebo - - -Baseline Risk Factors -Total n -n -Response (%) -n -Response (%) -Odds Ratio -95% CI -All Patients -20 -11 -72.7% -9 -77.8% -1.31 -(0.17, 10.26) -Sex - F -11 -6 -100.0% -5 -80.0% -<0.01 -(0.00, >999.99) - M -9 -5 -40.0% -4 -75.0% -4.50 -(0.25, 80.57) -Stratification Factor 2 - S1 -10 -5 -80.0% -5 -80.0% -1.00 -(0.05, 22.18) - S2 -10 -6 -66.7% -4 -75.0% -1.50 -(0.09, 25.39) - -A: Drug X -Better -B: Placebo -Better - - - - - - -0.1 -1 -10 - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg new file mode 100644 index 0000000000..d6493a659c --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -0,0 +1,160 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +A: Drug X + + + + + + + + +B: Placebo + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +n +11 +6 +5 +5 +6 +Response (%) +72.7% +100.0% +40.0% +80.0% +66.7% +n +9 +5 +4 +5 +4 +Response (%) +77.8% +80.0% +75.0% +80.0% +75.0% +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + + + + + + + + + + + + + + + + + + + + + + + + + +A: Drug X +Better +B: Placebo +Better + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom.svg b/tests/testthat/_snaps/g_forest/g_forest_custom.svg new file mode 100644 index 0000000000..27dfbff66b --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_custom.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + + + + +Hello +World + + + + + +0.5 +1 + + diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index 0da842ce2d..bbb2b312b6 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -19,7 +19,8 @@ testthat::test_that("g_forest default plot works", { tabulate_rsp_subgroups(df) g_forest <- g_forest(tbl) - vdiffr::expect_doppelganger(title = "g_forest", fig = g_forest) + + expect_snapshot_ggplot("g_forest", g_forest, width = 12, height = 3) }) testthat::test_that("g_forest works with custom arguments", { @@ -32,16 +33,15 @@ testthat::test_that("g_forest works with custom arguments", { rrow("row 2", 1.2, c(1.1, 1.4)) ) - g_forest_custom <- - g_forest( - tbl = tbl, - col_x = 1, - col_ci = 2, - xlim = c(0.5, 2), - x_at = c(0.5, 1, 2), - vline = 1, - forest_header = c("Hello", "World") - ) + g_forest_custom <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + xlim = c(0.5, 2), + x_at = c(0.5, 1, 2), + vline = 1, + forest_header = c("Hello", "World") + ) - vdiffr::expect_doppelganger(title = "g_forest_custom", fig = g_forest_custom) + expect_snapshot_ggplot("g_forest_custom", g_forest_custom, width = 4, height = 2) }) From 120029f109acfa8b9f2c3cc5ccecb114c6e43f6a Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 16:50:16 -0500 Subject: [PATCH 10/26] Update documentation --- R/g_forest.R | 56 +++-- man/g_forest.Rd | 50 ++-- tests/testthat/_snaps/g_forest/g_forest.svg | 258 ++++++++++---------- tests/testthat/test-g_forest.R | 2 +- 4 files changed, 191 insertions(+), 175 deletions(-) diff --git a/R/g_forest.R b/R/g_forest.R index ae92fda4af..36196e0006 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -1,34 +1,42 @@ -#' Create a forest plot based on a table +#' Create a forest plot from an `rtable` #' -#' Create a forest plot from any [rtables::rtable()] object that has a -#' column with a single value and a column with 2 values. +#' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 +#' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The +#' table and forest plot are printed side-by-side. #' #' @description `r lifecycle::badge("stable")` #' +#' @inheritParams rtable2gg #' @inheritParams argument_convention -#' @param tbl (`rtable`) +#' @param tbl (`rtable`)\cr table with at least one column with a single value and one column with 2 values. #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from -#' `tbl` attribute `col_x`, otherwise needs to be manually specified. -#' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries -#' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified. -#' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. +#' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded +#' from forest plot. +#' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries to get this from +#' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded +#' from forest plot. +#' @param vline (`numeric`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. -#' If `vline = NULL` then `forest_header` needs to be `NULL` too. -#' By default tries to get this from `tbl` attribute `forest_header`. +#' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute +#' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to +#' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. #' @param xlim (`numeric`)\cr limits for x axis. #' @param logx (`flag`)\cr show the x-values on logarithm scale. -#' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. -#' @param width_row_names (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument -#' instead. -#' @param width_columns (`unit`)\cr widths for the table columns. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' @param width_forest (`unit`)\cr `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument -#' instead. +#' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. +#' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead. +#' @param width_columns (`vector` of `numeric`)\cr a vector of column widths. Each element's position in +#' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated +#' according to maximum number of characters per column. +#' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. +#' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative +#' width of table is then `1 - rel_width_forest`. +#' @param font_size (`numeric`)\cr font size. #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. #' @param col (`character`)\cr color(s). +#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument #' is no longer used. #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument @@ -39,7 +47,6 @@ #' @return `ggplot` forest plot and table. #' #' @examples -#' \donttest{ #' library(dplyr) #' library(forcats) #' library(nestcolor) @@ -145,7 +152,6 @@ #' vline = 1, #' forest_header = c("Hello", "World") #' ) -#' } #' #' @export g_forest <- function(tbl, @@ -206,8 +212,8 @@ g_forest <- function(tbl, checkmate::assert_class(tbl, "VTableTree") checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) - checkmate::assert_number(font_size, lower = 0) checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(font_size, lower = 0) checkmate::assert_character(col, null.ok = TRUE) # Extract info from table @@ -317,7 +323,8 @@ g_forest <- function(tbl, gg_plt <- gg_plt + geom_point( x = x, y = row_num, - aes(size = sym_size, color = col) + color = col, + aes(size = sym_size) ) } @@ -381,11 +388,8 @@ g_forest <- function(tbl, } } - # Apply custom ggtheme to table and plot - if (!is.null(ggtheme)) { - gg_table <- gg_table + ggtheme - gg_plt <- gg_plt + ggtheme - } + # Apply custom ggtheme to plot + if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme cowplot::plot_grid( gg_table, diff --git a/man/g_forest.Rd b/man/g_forest.Rd index 0ce3f33553..bd9fb37b4b 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/g_forest.R \name{g_forest} \alias{g_forest} -\title{Create a forest plot based on a table} +\title{Create a forest plot from an \code{rtable}} \usage{ g_forest( tbl, @@ -28,34 +28,45 @@ g_forest( ) } \arguments{ -\item{tbl}{(\code{rtable})} +\item{tbl}{(\code{rtable})\cr table with at least one column with a single value and one column with 2 values.} \item{col_x}{(\code{integer})\cr column index with estimator. By default tries to get this from -\code{tbl} attribute \code{col_x}, otherwise needs to be manually specified.} +\code{tbl} attribute \code{col_x}, otherwise needs to be manually specified. If \code{NULL}, points will be excluded +from forest plot.} -\item{col_ci}{(\code{integer})\cr column index with confidence intervals. By default tries -to get this from \code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified.} +\item{col_ci}{(\code{integer})\cr column index with confidence intervals. By default tries to get this from +\code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified. If \code{NULL}, lines will be excluded +from forest plot.} -\item{vline}{(\code{number})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted.} +\item{vline}{(\code{numeric})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted.} \item{forest_header}{(\code{character}, length 2)\cr text displayed to the left and right of \code{vline}, respectively. -If \code{vline = NULL} then \code{forest_header} needs to be \code{NULL} too. -By default tries to get this from \code{tbl} attribute \code{forest_header}.} +If \code{vline = NULL} then \code{forest_header} is not printed. By default tries to get this from \code{tbl} attribute +\code{forest_header}. If \code{NULL}, defaults will be extracted from the table if possible, and set to +\code{"Comparison\\nBetter"} and \code{"Treatment\\nBetter"} if not.} \item{xlim}{(\code{numeric})\cr limits for x axis.} \item{logx}{(\code{flag})\cr show the x-values on logarithm scale.} -\item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen.} +\item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL}, \code{x_at} is set to \code{vline} and both \code{xlim} values.} -\item{width_row_names}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument -instead.} +\item{width_row_names}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument instead.} -\item{width_columns}{(\code{unit})\cr widths for the table columns. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_columns}{(\code{vector} of \code{numeric})\cr a vector of column widths. Each element's position in +\code{colwidths} corresponds to the column of \code{tbl} in the same position. If \code{NULL}, column widths are calculated +according to maximum number of characters per column.} -\item{width_forest}{(\code{unit})\cr \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument -instead.} +\item{width_forest}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument instead.} + +\item{lbl_col_padding}{(\code{numeric})\cr additional padding to use when calculating spacing between +the first (label) column and the second column of \code{tbl}. If \code{colwidths} is specified, +the width of the first column becomes \code{colwidths[1] + lbl_col_padding}. Defaults to 0.} + +\item{rel_width_forest}{(\code{proportion})\cr proportion of total width to allocate to the forest plot. Relative +width of table is then \code{1 - rel_width_forest}.} + +\item{font_size}{(\code{numeric})\cr font size.} \item{col_symbol_size}{(\code{integer})\cr column index from \code{tbl} containing data to be used to determine relative size for estimator plot symbol. Typically, the symbol size is proportional @@ -64,6 +75,8 @@ By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, o \item{col}{(\code{character})\cr color(s).} +\item{ggtheme}{(\code{theme})\cr a graphical theme as provided by \code{ggplot2} to control styling of the plot.} + \item{gp}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument is no longer used.} @@ -80,11 +93,11 @@ is no longer used.} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} } \details{ -Create a forest plot from any \code{\link[rtables:rtable]{rtables::rtable()}} object that has a -column with a single value and a column with 2 values. +Given a \code{\link[rtables:rtable]{rtables::rtable()}} object with at least one column with a single value and one column with 2 +values, converts table to a \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object and generates an accompanying forest plot. The +table and forest plot are printed side-by-side. } \examples{ -\donttest{ library(dplyr) library(forcats) library(nestcolor) @@ -190,6 +203,5 @@ g_forest( vline = 1, forest_header = c("Hello", "World") ) -} } diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg index d6493a659c..ed149747a9 100644 --- a/tests/testthat/_snaps/g_forest/g_forest.svg +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -1,5 +1,5 @@ - + + + + + + + + + + + + + + + + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + +0.5 +0.7 +0.9 +1.1 +1.3 +1.5 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg new file mode 100644 index 0000000000..07bcb03534 --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg @@ -0,0 +1,80 @@ + + + + + + + + + + + + + + + + + + + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + + + +c1 +is +better +c2 +is +better + + + + + + +0.5 +1 +2 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_or.svg b/tests/testthat/_snaps/g_forest/g_forest_or.svg new file mode 100644 index 0000000000..10357c35c3 --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_or.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + + + + + + + + + + + + + + + + + + + + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index 585f0fa8b7..a0bcbdb100 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -21,6 +21,18 @@ testthat::test_that("g_forest default plot works", { g_forest <- g_forest(tbl) expect_snapshot_ggplot("g_forest", g_forest, width = 15, height = 3) + + # Odds ratio only + tbl_or <- basic_table() %>% + tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) + + g_forest_or <- g_forest( + tbl_or, + forest_header = c("Comparison\nBetter", "Treatment\nBetter"), + rel_width_forest = 0.4 + ) + + expect_snapshot_ggplot("g_forest_or", g_forest_or, width = 8, height = 3) }) testthat::test_that("g_forest works with custom arguments", { @@ -33,15 +45,43 @@ testthat::test_that("g_forest works with custom arguments", { rrow("row 2", 1.2, c(1.1, 1.4)) ) - g_forest_custom <- g_forest( + g_forest_custom_1 <- g_forest( tbl = tbl, col_x = 1, col_ci = 2, xlim = c(0.5, 2), x_at = c(0.5, 1, 2), - vline = 1, + vline = 0.9, forest_header = c("Hello", "World") ) - expect_snapshot_ggplot("g_forest_custom", g_forest_custom, width = 4, height = 2) + expect_snapshot_ggplot("g_forest_custom_1", g_forest_custom_1, width = 4, height = 2) + + g_forest_custom_2 <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + logx = FALSE, + xlim = c(0.5, 1.5), + x_at = seq(0.5, 1.5, by = 0.2), + lbl_col_padding = -3, + width_columns = c(4, 3, 3) + ) + + expect_snapshot_ggplot("g_forest_custom_2", g_forest_custom_2, width = 10, height = 5) + + g_forest_custom_3 <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + xlim = c(0.5, 2), + x_at = c(0.5, 1, 2), + vline = 0.9, + forest_header = c("c1\nis\nbetter", "c2\nis\nbetter"), + rel_width_forest = 0.6, + font_size = 6, + col = "red" + ) + + expect_snapshot_ggplot("g_forest_custom_3", g_forest_custom_3, width = 10, height = 5) }) From 01cad4174c66e99a802dc19bd8e2ca2af9765a18 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 17:58:54 -0500 Subject: [PATCH 13/26] Clean up aesthetics --- R/g_forest.R | 26 ++++++++++--------- tests/testthat/_snaps/g_forest/g_forest.svg | 10 +++---- .../_snaps/g_forest/g_forest_custom_1.svg | 4 +-- .../_snaps/g_forest/g_forest_custom_2.svg | 8 +++--- .../_snaps/g_forest/g_forest_custom_3.svg | 6 ++--- .../testthat/_snaps/g_forest/g_forest_or.svg | 10 +++---- tests/testthat/test-g_forest.R | 5 ++-- 7 files changed, 36 insertions(+), 33 deletions(-) diff --git a/R/g_forest.R b/R/g_forest.R index 6f61d974f1..cfb373a5ea 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -215,6 +215,7 @@ g_forest <- function(tbl, checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) checkmate::assert_number(font_size, lower = 0) checkmate::assert_character(col, null.ok = TRUE) + checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) # Extract info from table mat <- matrix_form(tbl) @@ -268,6 +269,7 @@ g_forest <- function(tbl, row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) if (is.null(col)) col <- "#343cff" + if (length(col) == 1) col <- rep(col, nrow(tbl_df)) if (is.null(x_at)) x_at <- union(xlim, vline) x_labels <- x_at @@ -322,16 +324,6 @@ g_forest <- function(tbl, ) } - # Add points to plot - if (any(!is.na(x))) { - gg_plt <- gg_plt + geom_point( - x = x, - y = row_num, - color = col, - aes(size = sym_size) - ) - } - if (!is.null(vline)) { # Set default forest header if (is.null(forest_header)) { @@ -361,6 +353,16 @@ g_forest <- function(tbl, ) } + # Add points to plot + if (any(!is.na(x))) { + gg_plt <- gg_plt + geom_point( + x = x, + y = row_num, + color = col, + aes(size = sym_size) + ) + } + for (i in seq_len(nrow(tbl_df))) { # Determine which arrow(s) to add to CI lines which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) @@ -379,7 +381,7 @@ g_forest <- function(tbl, x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], y = row_num[i], yend = row_num[i], - color = col, + color = if (length(col) == 1) col else col[i], arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow) ) } else { @@ -387,7 +389,7 @@ g_forest <- function(tbl, "segment", x = lwr[i], xend = upr[i], y = row_num[i], yend = row_num[i], - color = col + color = if (length(col) == 1) col else col[i], ) } } diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg index 6f7b4739e7..2996fdf64d 100644 --- a/tests/testthat/_snaps/g_forest/g_forest.svg +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -121,11 +121,6 @@ - - - - - @@ -135,6 +130,11 @@ Better B: Placebo Better + + + + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg index 7fdf323431..28af3fce6a 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg @@ -57,12 +57,12 @@ - - Hello World + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg index 89bec07f4e..4b48611a55 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg @@ -57,16 +57,16 @@ - - Comparison Better Treatment Better - - + + + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg index 07bcb03534..98a3e04a58 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg @@ -57,8 +57,6 @@ - - c1 @@ -67,8 +65,10 @@ c2 is better + + - + diff --git a/tests/testthat/_snaps/g_forest/g_forest_or.svg b/tests/testthat/_snaps/g_forest/g_forest_or.svg index 10357c35c3..6afb462d77 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_or.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_or.svg @@ -79,11 +79,6 @@ - - - - - @@ -93,6 +88,11 @@ Better Treatment Better + + + + + diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index a0bcbdb100..fbe5c168a4 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -65,7 +65,8 @@ testthat::test_that("g_forest works with custom arguments", { xlim = c(0.5, 1.5), x_at = seq(0.5, 1.5, by = 0.2), lbl_col_padding = -3, - width_columns = c(4, 3, 3) + width_columns = c(4, 3, 3), + col = "purple" ) expect_snapshot_ggplot("g_forest_custom_2", g_forest_custom_2, width = 10, height = 5) @@ -80,7 +81,7 @@ testthat::test_that("g_forest works with custom arguments", { forest_header = c("c1\nis\nbetter", "c2\nis\nbetter"), rel_width_forest = 0.6, font_size = 6, - col = "red" + col = c("red", "green") ) expect_snapshot_ggplot("g_forest_custom_3", g_forest_custom_3, width = 10, height = 5) From 02c376a84263a178aaa700ce6f3351d28899755f Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 18:00:20 -0500 Subject: [PATCH 14/26] Update NEWS --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index d748281afa..c2af13c753 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # tern 0.9.3.9000 +### New Features +* Refactored `g_forest` to output a `ggplot` object instead of a `grob` object. + # tern 0.9.3 ### New Features From 5e5d0afe17498f7c644152ec8d4129792dc25848 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 18:06:30 -0500 Subject: [PATCH 15/26] Update NEWS --- NEWS.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/NEWS.md b/NEWS.md index c2af13c753..77b6eb0fef 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,12 @@ ### New Features * Refactored `g_forest` to output a `ggplot` object instead of a `grob` object. +### Bug Fixes +* Fixed nested column split label overlay issue in `rtable2gg` to clean up appearance of text labels. + +### Miscellaneous +* Added function `expect_snapshot_ggplot` to test setup file to process plot snapshot tests and allow plot dimensions to be set. + # tern 0.9.3 ### New Features From 1e4e32be57601b28b123d3408a448ef5bd0be568 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Fri, 8 Dec 2023 18:11:27 -0500 Subject: [PATCH 16/26] Make plot background transparent --- R/g_forest.R | 3 ++- tests/testthat/_snaps/g_forest/g_forest.svg | 3 ++- tests/testthat/_snaps/g_forest/g_forest_custom_1.svg | 3 ++- tests/testthat/_snaps/g_forest/g_forest_custom_2.svg | 3 ++- tests/testthat/_snaps/g_forest/g_forest_custom_3.svg | 3 ++- tests/testthat/_snaps/g_forest/g_forest_or.svg | 3 ++- 6 files changed, 12 insertions(+), 6 deletions(-) diff --git a/R/g_forest.R b/R/g_forest.R index cfb373a5ea..b346186c9e 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -288,7 +288,8 @@ g_forest <- function(tbl, # Set up plot area gg_plt <- ggplot(data = tbl_df) + theme( - panel.background = element_blank(), + panel.background = element_rect(fill = "transparent", color = NA_character_), + plot.background = element_rect(fill = "transparent", color = NA_character_), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), axis.title.x = element_blank(), diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg index 2996fdf64d..3ededcaa16 100644 --- a/tests/testthat/_snaps/g_forest/g_forest.svg +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -113,9 +113,10 @@ - + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg index 28af3fce6a..7fa4185738 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg @@ -52,9 +52,10 @@ - + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg index 4b48611a55..addb703e66 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg @@ -52,9 +52,10 @@ - + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg index 98a3e04a58..ae96162d58 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg @@ -52,9 +52,10 @@ - + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_or.svg b/tests/testthat/_snaps/g_forest/g_forest_or.svg index 6afb462d77..103ff9a4eb 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_or.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_or.svg @@ -71,9 +71,10 @@ - + + From 641e18dbbced6e9a530724df0777e00f3911ec96 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 13 Dec 2023 16:06:45 -0500 Subject: [PATCH 17/26] Add as_list arg to store table and plot in a list instead of printing --- R/g_forest.R | 27 +++-- man/g_forest.Rd | 7 +- .../_snaps/g_forest/g_forest_plot_only.svg | 66 +++++++++++ .../_snaps/g_forest/g_forest_table_only.svg | 110 ++++++++++++++++++ tests/testthat/test-g_forest.R | 12 ++ 5 files changed, 213 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/_snaps/g_forest/g_forest_plot_only.svg create mode 100644 tests/testthat/_snaps/g_forest/g_forest_table_only.svg diff --git a/R/g_forest.R b/R/g_forest.R index b346186c9e..c525d743b1 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -29,7 +29,7 @@ #' according to maximum number of characters per column. #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative -#' width of table is then `1 - rel_width_forest`. +#' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. #' @param font_size (`numeric`)\cr font size. #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional @@ -37,6 +37,9 @@ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. #' @param col (`character`)\cr color(s). #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. +#' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list +#' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are +#' printed side-by-side via [cowplot::plot_grid()]. #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument #' is no longer used. #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument @@ -171,6 +174,7 @@ g_forest <- function(tbl, col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], ggtheme = NULL, + as_list = FALSE, gp = lifecycle::deprecated(), draw = lifecycle::deprecated(), newpage = lifecycle::deprecated()) { @@ -398,13 +402,20 @@ g_forest <- function(tbl, # Apply custom ggtheme to plot if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme - cowplot::plot_grid( - gg_table, - gg_plt, - align = "h", - axis = "tblr", - rel_widths = c(1 - rel_width_forest, rel_width_forest) - ) + if (as_list) { + list( + table = gg_table, + plot = gg_plt + ) + } else { + cowplot::plot_grid( + gg_table, + gg_plt, + align = "h", + axis = "tblr", + rel_widths = c(1 - rel_width_forest, rel_width_forest) + ) + } } #' Forest Plot Grob diff --git a/man/g_forest.Rd b/man/g_forest.Rd index bd9fb37b4b..5508b3e7ba 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -22,6 +22,7 @@ g_forest( col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], ggtheme = NULL, + as_list = FALSE, gp = lifecycle::deprecated(), draw = lifecycle::deprecated(), newpage = lifecycle::deprecated() @@ -64,7 +65,7 @@ the first (label) column and the second column of \code{tbl}. If \code{colwidths the width of the first column becomes \code{colwidths[1] + lbl_col_padding}. Defaults to 0.} \item{rel_width_forest}{(\code{proportion})\cr proportion of total width to allocate to the forest plot. Relative -width of table is then \code{1 - rel_width_forest}.} +width of table is then \code{1 - rel_width_forest}. If \code{as_list = TRUE}, this parameter is ignored.} \item{font_size}{(\code{numeric})\cr font size.} @@ -77,6 +78,10 @@ By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, o \item{ggtheme}{(\code{theme})\cr a graphical theme as provided by \code{ggplot2} to control styling of the plot.} +\item{as_list}{(\code{flag})\cr whether the two \code{ggplot} objects should be returned as a list. If \code{TRUE}, a named list +with two elements, \code{table} and \code{plot}, will be returned. If \code{FALSE} (default) the table and forest plot are +printed side-by-side via \code{\link[cowplot:plot_grid]{cowplot::plot_grid()}}.} + \item{gp}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument is no longer used.} diff --git a/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg b/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg new file mode 100644 index 0000000000..b839f18e1e --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + +A: Drug X +Better +B: Placebo +Better + + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_table_only.svg b/tests/testthat/_snaps/g_forest/g_forest_table_only.svg new file mode 100644 index 0000000000..a4eb7e7131 --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_table_only.svg @@ -0,0 +1,110 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + +A: Drug X + + + + + + + + +B: Placebo + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +n +11 +6 +5 +5 +6 +Response (%) +72.7% +100.0% +40.0% +80.0% +66.7% +n +9 +5 +4 +5 +4 +Response (%) +77.8% +80.0% +75.0% +80.0% +75.0% +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index fbe5c168a4..2448229020 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -86,3 +86,15 @@ testthat::test_that("g_forest works with custom arguments", { expect_snapshot_ggplot("g_forest_custom_3", g_forest_custom_3, width = 10, height = 5) }) + +testthat::test_that("g_forest as_list argument works", { + tbl <- basic_table() %>% + tabulate_rsp_subgroups(df) + + f <- g_forest(tbl, as_list = TRUE) + g_forest_table_only <- f$table + g_forest_plot_only <- f$plot + + expect_snapshot_ggplot("g_forest_table_only", g_forest_table_only, width = 9, height = 3) + expect_snapshot_ggplot("g_forest_plot_only", g_forest_plot_only, width = 2, height = 3) +}) From d77d05686ce7da66d21004911c02007486ffbe58 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 13 Dec 2023 16:07:00 -0500 Subject: [PATCH 18/26] Adjust x axis text size --- R/g_forest.R | 1 + tests/testthat/_snaps/g_forest/g_forest.svg | 238 +++++++++--------- .../_snaps/g_forest/g_forest_custom_1.svg | 72 +++--- .../_snaps/g_forest/g_forest_custom_2.svg | 88 +++---- .../_snaps/g_forest/g_forest_custom_3.svg | 80 +++--- .../testthat/_snaps/g_forest/g_forest_or.svg | 154 ++++++------ 6 files changed, 317 insertions(+), 316 deletions(-) diff --git a/R/g_forest.R b/R/g_forest.R index c525d743b1..4a62c82296 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -299,6 +299,7 @@ g_forest <- function(tbl, axis.title.x = element_blank(), axis.title.y = element_blank(), axis.line.x = element_line(), + axis.text = element_text(size = font_size * .pt), legend.position = "none", plot.margin = margin(0, 0.1, 0.05, 0, "npc") ) + diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg index 3ededcaa16..2b79d58c04 100644 --- a/tests/testthat/_snaps/g_forest/g_forest.svg +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -23,87 +23,87 @@ - - + + - - - - - - - - - -A: Drug X - - - - - - - - -B: Placebo - - - - - - - - -Baseline Risk Factors -All Patients -Sex - F - M -Stratification Factor 2 - S1 - S2 -Total n -20 -11 -9 -10 -10 -n -11 -6 -5 -5 -6 -Response (%) -72.7% -100.0% -40.0% -80.0% -66.7% -n -9 -5 -4 -5 -4 -Response (%) -77.8% -80.0% -75.0% -80.0% -75.0% -Odds Ratio -1.31 -<0.01 -4.50 -1.00 -1.50 -95% CI -(0.17, 10.26) -(0.00, >999.99) -(0.25, 80.57) -(0.05, 22.18) -(0.09, 25.39) + + + + + + + + + +A: Drug X + + + + + + + + +B: Placebo + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +n +11 +6 +5 +5 +6 +Response (%) +72.7% +100.0% +40.0% +80.0% +66.7% +n +9 +5 +4 +5 +4 +Response (%) +77.8% +80.0% +75.0% +80.0% +75.0% +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) @@ -116,45 +116,45 @@ - - - - - - - - - - - -A: Drug X -Better -B: Placebo -Better - - - - - - - - - - - - - - - - - - - - - - -0.1 -1 -10 + + + + + + + + + + + +A: Drug X +Better +B: Placebo +Better + + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg index 7fa4185738..84e6674b9f 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg @@ -23,26 +23,26 @@ - - + + - - - - -A - - - -row 1 -row 2 -c1 -1 -1.2 -c2 -0.8, 1.2 -1.1, 1.4 + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 @@ -55,23 +55,23 @@ - - - - - -Hello -World - - - - - - - - -0.5 -1 -2 + + + + + +Hello +World + + + + + + + + +0.5 +1 +2 diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg index addb703e66..91a797af51 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg @@ -23,26 +23,26 @@ - - + + - - - - -A - - - -row 1 -row 2 -c1 -1 -1.2 -c2 -0.8, 1.2 -1.1, 1.4 + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 @@ -55,31 +55,31 @@ - - - - - -Comparison -Better -Treatment -Better - - - - - - - - - - - -0.5 -0.7 -0.9 -1.1 -1.3 -1.5 + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + + + +0.5 +0.7 +0.9 +1.1 +1.3 +1.5 diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg index ae96162d58..81ff63f6fd 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg @@ -23,26 +23,26 @@ - - + + - - - - -A - - - -row 1 -row 2 -c1 -1 -1.2 -c2 -0.8, 1.2 -1.1, 1.4 + + + + +A + + + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 @@ -55,27 +55,27 @@ - - - - - -c1 -is -better -c2 -is -better - - - - - - - - -0.5 -1 -2 + + + + + +c1 +is +better +c2 +is +better + + + + + + + + +0.5 +1 +2 diff --git a/tests/testthat/_snaps/g_forest/g_forest_or.svg b/tests/testthat/_snaps/g_forest/g_forest_or.svg index 103ff9a4eb..c740d6d9b6 100644 --- a/tests/testthat/_snaps/g_forest/g_forest_or.svg +++ b/tests/testthat/_snaps/g_forest/g_forest_or.svg @@ -23,45 +23,45 @@ - - + + - - - - - - - - - -Baseline Risk Factors -All Patients -Sex - F - M -Stratification Factor 2 - S1 - S2 -Total n -20 -11 -9 -10 -10 -Odds Ratio -1.31 -<0.01 -4.50 -1.00 -1.50 -95% CI -(0.17, 10.26) -(0.00, >999.99) -(0.25, 80.57) -(0.05, 22.18) -(0.09, 25.39) + + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) @@ -74,45 +74,45 @@ - - - - - - - - - - - -Comparison -Better -Treatment -Better - - - - - - - - - - - - - - - - - - - - - - -0.1 -1 -10 + + + + + + + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 From 56e1ee6aafa0ce46ced9f0970a46dfefb44ffcad Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 13 Dec 2023 18:20:20 -0500 Subject: [PATCH 19/26] Convert to standard font sizes, remove overlaid segment elements --- R/utils_ggplot.R | 16 +- .../utils_ggplot/rtable2gg_colsplits.svg | 151 +++++++----------- .../_snaps/utils_ggplot/rtable2gg_cw.svg | 133 +++++++-------- .../_snaps/utils_ggplot/rtable2gg_default.svg | 133 +++++++-------- .../_snaps/utils_ggplot/rtable2gg_fs.svg | 133 +++++++-------- .../_snaps/utils_ggplot/rtable2gg_lblpad.svg | 133 +++++++-------- 6 files changed, 303 insertions(+), 396 deletions(-) diff --git a/R/utils_ggplot.R b/R/utils_ggplot.R index 6cb4694f35..aa4c4dbd84 100644 --- a/R/utils_ggplot.R +++ b/R/utils_ggplot.R @@ -32,10 +32,10 @@ #' #' rtable2gg(tbl) #' -#' rtable2gg(tbl, fontsize = 5, colwidths = c(2, 1, 1, 1)) +#' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) #' #' @export -rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) { +rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) { mat <- rtables::matrix_form(tbl) mat_strings <- formatters::mf_strings(mat) mat_aligns <- formatters::mf_aligns(mat) @@ -69,10 +69,11 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) theme_void() + scale_x_continuous(limits = c(0, tot_width)) + scale_y_continuous(limits = c(0, nrow(mat_strings))) + - geom_segment(aes( + annotate( + "segment", x = 0, xend = tot_width, y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 - )) + ) # If header content spans multiple columns, center over these columns if (length(shared_hdr_rows) > 0) { @@ -100,9 +101,10 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) x = mean(line_pos), y = nrow(mat_strings) + 1 - hr, label = cur_lbl, - size = fontsize + size = fontsize / .pt ) + - geom_segment( + annotate( + "segment", x = line_pos[1], xend = line_pos[2], y = nrow(mat_strings) - hr + 0.5, @@ -120,7 +122,7 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) y = rev(seq_len(nrow(tbl_df))), label = tbl_df[, i], hjust = mat_aligns[, i], - size = fontsize + size = fontsize / .pt ) } diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg index 6aea311a37..cc2bf0a6db 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg @@ -22,104 +22,69 @@ - - - - - -A - - - - +A - -B - - - - +B - -V1 - - - +V1 - - -V2 - - - +V2 - - -V1 - - +V1 - - - -V2 - - - - - +V2 -n -Mean (SD) -Median -Min - Max -M -(N=4) -4 -5.0 (3.7) -5.0 -1.0 - 9.0 -F -(N=1) -1 -5.0 (NA) -5.0 -5.0 - 5.0 -M -(N=2) -2 -5.0 (1.4) -5.0 -4.0 - 6.0 -F -(N=2) -2 -5.0 (4.2) -5.0 -2.0 - 8.0 -M -(N=2) -2 -14.0 (1.4) -14.0 -13.0 - 15.0 -F -(N=2) -1 -11.0 (NA) -11.0 -11.0 - 11.0 -M -(N=4) -2 -11.0 (1.4) -11.0 -10.0 - 12.0 -F -(N=1) -1 -14.0 (NA) -14.0 -14.0 - 14.0 +n +Mean (SD) +Median +Min - Max +M +(N=4) +4 +5.0 (3.7) +5.0 +1.0 - 9.0 +F +(N=1) +1 +5.0 (NA) +5.0 +5.0 - 5.0 +M +(N=2) +2 +5.0 (1.4) +5.0 +4.0 - 6.0 +F +(N=2) +2 +5.0 (4.2) +5.0 +2.0 - 8.0 +M +(N=2) +2 +14.0 (1.4) +14.0 +13.0 - 15.0 +F +(N=2) +1 +11.0 (NA) +11.0 +11.0 - 11.0 +M +(N=4) +2 +11.0 (1.4) +11.0 +10.0 - 12.0 +F +(N=1) +1 +14.0 (NA) +14.0 +14.0 - 14.0 diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg index d01fda867d..938219590d 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg @@ -1,5 +1,5 @@ - +