diff --git a/NEWS.md b/NEWS.md index a9f4c7a6ab..e78982c4da 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,8 @@ # tern 0.9.11.9000 ### Enhancements +* Updated `g_forest()` to support point estimates and confidence intervals + stored in a single column. (#1499) * Added the `exclude_rows` argument to `g_forest()` to allow excluding selected rows from the forest plot before plotting. (#1498) * Added `factor_level_method` argument to `df_explicit_na()` to control factor level ordering diff --git a/R/g_forest.R b/R/g_forest.R index 0a61ccaea3..943a8107ed 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -10,12 +10,18 @@ #' @inheritParams argument_convention #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2 #' values. -#' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from -#' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded -#' from forest plot. -#' @param col_ci (`integer(1)` or `NULL`)\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 col_x (`integer(1)` or `NULL`)\cr column index with estimator. +#' By default tries to get this from `tbl` attribute `col_x`, otherwise needs +#' to be manually specified. If `NULL`, points will be excluded from forest plot. +#' @param col_ci (`integer(1)` or `NULL`)\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. +#' +#' The estimator and confidence interval can be stored in the same column. +#' In this case, `col_x` and `col_ci` must be the same, and the values in each +#' row of the column indicated by `col_x`/`col_ci` must be ordered as the +#' point estimate, lower confidence interval bound, and upper confidence +#' interval bound, respectively. #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively. #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute @@ -81,25 +87,33 @@ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), #' data = adrs #' ) -#' # Full commonly used response table. #' +#' # Full commonly used response table. #' tbl <- basic_table() |> #' tabulate_rsp_subgroups(df) -#' +#' tbl #' g_forest(tbl) #' \donttest{ #' g_forest(tbl, exclude_rows = 1) #' } -#' #' # Odds ratio only table. -#' #' tbl_or <- basic_table() |> #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) +#' tbl_or #' g_forest( #' tbl_or, #' forest_header = c("Comparison\nBetter", "Treatment\nBetter") #' ) -#' +#' \donttest{ +#' # Estimates and confidence intervals in the same column. +#' tbl <- rtable( +#' header = rheader(rrow("", "point est (CI)")), +#' rrow("row 1", rcell(c(10, 8, 12), format = "xx. (xx. - xx.)")), +#' rrow("row 2", rcell(c(11, 7, 13), format = "xx. (xx. - xx.)")) +#' ) +#' tbl +#' g_forest(tbl, col_x = 1, col_ci = 1, vline = 10, xlim = c(5, 15), logx = FALSE) +#' } #' # Survival forest plot example. #' adtte <- tern_ex_adtte #' # Save variable labels before data processing steps. @@ -228,8 +242,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_int(col_x, lower = 1L, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_int(col_ci, lower = 1L, upper = ncol(tbl), null.ok = TRUE) 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) @@ -245,74 +259,106 @@ g_forest <- function(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) + + 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) { + arms <- if (nlines_hdr == 2) { gg_table$scales$scales[[2]]$expand <- c(0, 0) - arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) + unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) } else { - arms <- NULL + NULL } + # Optionally exclude rows and keep only the data columns in `tbl_df`. if (!is.null(exclude_rows)) { tbl_df <- tbl_df[-exclude_rows, ] } - 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) + row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) + node_class_idx <- match("node_class", names(tbl_df)) + tbl_df <- tbl_df[, -seq_len(node_class_idx), drop = FALSE] + names(tbl_df) <- make.unique(mat_strings[nlines_hdr, -1]) + + # Validate the number of elements in a CI cell. + if (nrow(tbl_df) >= 1L && !is.null(col_ci)) { + ci_len <- length(tbl_df[, col_ci][[1L]]) + # Assert that `tbl_df[, col_ci]` column is homogeneous. + checkmate::assert_true( + all(sapply(tbl_df[, col_ci], length) == ci_len) + ) + if (ci_len < 2L) { + stop("A CI cell must contain at least two elements (lower and upper limits).") + } + if (!is.null(col_x) && col_x == col_ci && ci_len != 3L) { + stop("An x / CI cell must contain three elements (point estimate, lower and upper limits).") + } + } - # Check table data columns - if (!is.null(col_ci)) { - ci_col <- col_ci + 1 + x_ci <- if (nrow(tbl_df) >= 1L) { + tbl_x_ci <- tbl_df[, unique(c(col_x, col_ci)), drop = FALSE] + x_ci_list <- lapply(tbl_x_ci, function(col) { + # Since an `rtables` column is homogeneous, use the first row to determine the fill direction. + byrow <- length(col[[1L]]) != 1L + matrix(unlist(col), nrow = nrow(tbl_df), byrow = byrow) + }) + do.call(cbind, x_ci_list) } else { - tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) - ci_col <- which(names(tbl_df) == "empty_ci") + NULL } - if (nrow(tbl_df) >= 1 && length(tbl_df[, ci_col][[1]]) != 2) { - stop("CI column must have two elements (lower and upper limits).") + + # Optionally apply a log transformation to `x_ci`. + x_ci_t <- if (logx && !is.null(x_ci)) { + log(x_ci) + } else { + x_ci } - if (!is.null(col_x)) { - x_col <- col_x + 1 + # Extract vectors: x, lwr, and upr, and their log transformations. + # + # If `nrow(tbl_df) == 0`, `x_ci` (`x_ci_t`) is `NULL`, so + # `x_ci[, i]` (`x_ci_t[, i]`) is `NULL` for any `i`. + # + # At this point, `x_ci` (`x_ci_t`) has at least one column whenever + # `nrow(tbl_df) >= 1` and `col_x` is not `NULL`. + if (is.null(col_x)) { + x <- x_t <- rep(NA_real_, nrow(tbl_df)) } else { - tbl_df[["empty_x"]] <- NA_real_ - x_col <- which(names(tbl_df) == "empty_x") + x <- x_ci[, 1L] + x_t <- x_ci_t[, 1L] } - if (!is.null(col_symbol_size)) { - sym_size <- unlist(tbl_df[, col_symbol_size + 1]) + # At this point, `x_ci` (`x_ci_t`) has at least two columns whenever + # `nrow(tbl_df) >= 1` and `col_ci` is not `NULL` (see the + # "Validate the number of elements in a CI cell" section above). + if (is.null(col_ci)) { + lwr <- upr <- lwr_t <- upr_t <- rep(NA_real_, nrow(tbl_df)) } else { - sym_size <- rep(1, nrow(tbl_df)) + checkmate::assert_matrix(x_ci, min.cols = 2, null.ok = TRUE) + checkmate::assert_matrix(x_ci_t, min.cols = 2, null.ok = TRUE) + lwr <- x_ci[, ncol(x_ci) - 1L] + upr <- x_ci[, ncol(x_ci)] + lwr_t <- x_ci_t[, ncol(x_ci_t) - 1L] + upr_t <- x_ci_t[, ncol(x_ci_t)] } - 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) + xlim_t <- if (logx) log(xlim) else xlim + + # col_symbol_size + sym_size <- if (!is.null(col_symbol_size)) { + unlist(tbl_df[, col_symbol_size]) + } else { + rep(1L, nrow(tbl_df)) + } 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 - # Apply log transformation. - # When nrow(tbl_df) == 0, x, lwr, and upr are NULL, so log() would fail. - if (logx && nrow(tbl_df) >= 1) { - x_t <- log(x) - lwr_t <- log(lwr) - upr_t <- log(upr) - } else { - x_t <- x - lwr_t <- lwr - upr_t <- upr - } - xlim_t <- if (logx) log(xlim) else xlim - # Set up plot area gg_plt <- ggplot(data = tbl_df) + theme( diff --git a/man/g_forest.Rd b/man/g_forest.Rd index 08f9325e51..b7fd20f391 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -33,13 +33,19 @@ g_forest( \item{tbl}{(\code{VTableTree})\cr \code{rtables} table with at least one column with a single value and one column with 2 values.} -\item{col_x}{(\code{integer(1)} or \code{NULL})\cr column index with estimator. By default tries to get this from -\code{tbl} attribute \code{col_x}, otherwise needs to be manually specified. If \code{NULL}, points will be excluded -from forest plot.} +\item{col_x}{(\code{integer(1)} or \code{NULL})\cr column index with estimator. +By default tries to get this from \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(1)} or \code{NULL})\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{col_ci}{(\code{integer(1)} or \code{NULL})\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. + +The estimator and confidence interval can be stored in the same column. +In this case, \code{col_x} and \code{col_ci} must be the same, and the values in each +row of the column indicated by \code{col_x}/\code{col_ci} must be ordered as the +point estimate, lower confidence interval bound, and upper confidence +interval bound, respectively.} \item{vline}{(\code{numeric(1)} or \code{NULL})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted.} @@ -136,25 +142,33 @@ df <- extract_rsp_subgroups( variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")), data = adrs ) -# Full commonly used response table. +# Full commonly used response table. tbl <- basic_table() |> tabulate_rsp_subgroups(df) - +tbl g_forest(tbl) \donttest{ g_forest(tbl, exclude_rows = 1) } - # Odds ratio only table. - tbl_or <- basic_table() |> tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) +tbl_or g_forest( tbl_or, forest_header = c("Comparison\nBetter", "Treatment\nBetter") ) - +\donttest{ +# Estimates and confidence intervals in the same column. +tbl <- rtable( + header = rheader(rrow("", "point est (CI)")), + rrow("row 1", rcell(c(10, 8, 12), format = "xx. (xx. - xx.)")), + rrow("row 2", rcell(c(11, 7, 13), format = "xx. (xx. - xx.)")) +) +tbl +g_forest(tbl, col_x = 1, col_ci = 1, vline = 10, xlim = c(5, 15), logx = FALSE) +} # Survival forest plot example. adtte <- tern_ex_adtte # Save variable labels before data processing steps. diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index 731f1a32d7..d1207dbd1d 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -99,6 +99,47 @@ testthat::test_that("g_forest as_list argument works", { expect_snapshot_ggplot("g_forest_plot_only", g_forest_plot_only, width = 2, height = 3) }) +testthat::test_that("g_forest handles NULL col_x/col_ci", { + tbl <- rtable( + header = rheader(rrow("", "est", "CI")), + rrow("row 1", rcell(10), rcell(c(8, 12), format = "(xx, xx)")), + rrow("row 2", rcell(11), rcell(c(7, 13), format = "(xx, xx)")) + ) + + # nolint: col_x = NULL + testthat::expect_silent( + p_n2 <- g_forest(tbl, col_x = NULL, col_ci = 2, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_n2_logf <- g_forest(tbl, col_x = NULL, col_ci = 2, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + # nolint: col_ci = NULL + testthat::expect_silent( + p_1n <- g_forest(tbl, col_x = 1, col_ci = NULL, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_1n_logf <- g_forest(tbl, col_x = 1, col_ci = NULL, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + # nolint: col_ci = NULL + testthat::expect_silent( + p_nn <- g_forest(tbl, col_x = NULL, col_ci = NULL, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_nn_logf <- g_forest(tbl, col_x = NULL, col_ci = NULL, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + expect_snapshot_ggplot("g_forest_x_NULL", p_n2, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_x_NULL_logf", p_n2_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_ci_NULL", p_1n, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_ci_NULL_logf", p_1n_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_NULL", p_nn, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_NULL_logf", p_nn_logf, width = 15, height = 3) +}) + testthat::test_that("g_forest validates exclude_rows", { tbl <- basic_table() |> tabulate_rsp_subgroups(df) @@ -148,6 +189,105 @@ testthat::test_that("g_forest works when all rows are excluded", { expect_snapshot_ggplot("g_forest_exclude_all_rows", p, width = 15, height = 3) }) +testthat::test_that("g_forest works for point est. and CI in the same column", { + tbl <- rtable( + header = rheader(rrow("", "point est (CI)")), + rrow("row 1", rcell(c(10, 8, 12), format = "xx. (xx. - xx.)")), + rrow("row 2", rcell(c(11, 7, 13), format = "xx. (xx. - xx.)")) + ) + + testthat::expect_silent( + p <- g_forest(tbl, col_x = 1, col_ci = 1, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + expect_snapshot_ggplot("g_forest_same_x_ci", p, width = 15, height = 3) +}) + +testthat::test_that("g_forest handles NULL col_x/col_ci in same column", { + tbl <- rtable( + header = rheader(rrow("", "point est (CI)")), + rrow("row 1", rcell(c(10, 8, 12), format = "xx. (xx. - xx.)")), + rrow("row 2", rcell(c(11, 7, 13), format = "xx. (xx. - xx.)")) + ) + + # nolint: col_x = NULL + testthat::expect_silent( + p_n1 <- g_forest(tbl, col_x = NULL, col_ci = 1, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_n1_logf <- g_forest(tbl, col_x = NULL, col_ci = 1, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + # nolint: col_ci = NULL + testthat::expect_silent( + p_1n <- g_forest(tbl, col_x = 1, col_ci = NULL, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_1n_logf <- g_forest(tbl, col_x = 1, col_ci = NULL, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + # nolint: col_x, col_ci = NULL + testthat::expect_silent( + p_nn <- g_forest(tbl, col_x = NULL, col_ci = NULL, vline = 10, xlim = c(5, 15)) + ) + testthat::expect_silent( + p_nn_logf <- g_forest(tbl, col_x = NULL, col_ci = NULL, vline = 10, xlim = c(5, 15), logx = FALSE) + ) + + expect_snapshot_ggplot("g_forest_same_x_ci_x_NULL", p_n1, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_x_NULL_logf", p_n1_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_same_x_ci_ci_NULL", p_1n, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_ci_NULL_logf", p_1n_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_same_x_ci_NULL", p_nn, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_NULL_logf", p_nn_logf, width = 15, height = 3) +}) + +testthat::test_that("g_forest handles NULL col_x/col_ci in same column (all rows excluded)", { + tbl <- rtable( + header = rheader(rrow("", "point est (CI)")), + rrow("row 1", rcell(c(10, 8, 12), format = "xx. (xx. - xx.)")), + rrow("row 2", rcell(c(11, 7, 13), format = "xx. (xx. - xx.)")) + ) + + # nolint: col_x = NULL + testthat::expect_silent( + p_n1 <- g_forest(tbl, exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = NULL, col_ci = 1) + ) + testthat::expect_silent( + p_n1_logf <- g_forest(tbl, exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = NULL, col_ci = 1, logx = FALSE) + ) + + # nolint: col_ci = NULL + testthat::expect_silent( + p_1n <- g_forest(tbl, exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = 1, col_ci = NULL) + ) + testthat::expect_silent( + p_1n_logf <- g_forest(tbl, exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = 1, col_ci = NULL, logx = FALSE) + ) + + # nolint: col_x, col_ci = NULL + testthat::expect_silent( + p_nn <- g_forest(tbl, exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = NULL, col_ci = NULL) + ) + testthat::expect_silent( + p_nn_logf <- g_forest( + tbl, + exclude_rows = 1:2, vline = 10, xlim = c(5, 15), col_x = NULL, col_ci = NULL, logx = FALSE + ) + ) + + expect_snapshot_ggplot("g_forest_same_x_ci_excl_x_NULL", p_n1, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_excl_x_NULL_logf", p_n1_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_same_x_ci_excl_ci_NULL", p_1n, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_excl_ci_NULL_logf", p_1n_logf, width = 15, height = 3) + + expect_snapshot_ggplot("g_forest_same_x_ci_excl_NULL", p_nn, width = 15, height = 3) + expect_snapshot_ggplot("g_forest_same_x_ci_excl_NULL_logf", p_nn_logf, width = 15, height = 3) +}) + testthat::test_that("g_forest argument deprecation warnings work", { tbl <- basic_table() |> tabulate_rsp_subgroups(df)