Added the exclude_rows argument to g_forest().

NEWS.md

@@ -1,6 +1,8 @@
 # tern 0.9.11.9000
 
 ### Enhancements
+* 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
   when converting character or logical columns. Supported methods: `"sort_auto"` (default,
   locale-aware, preserves original behavior), `"sort_radix"` (byte-order / ASCII sort), and

R/g_forest.R

@@ -47,6 +47,15 @@
 #'   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.
+#' @param exclude_rows (`integerish` or `NULL`)\cr vector of positive row
+#'   indices specifying rows to exclude from the forest plot. Row indices are
+#'   specified relative to the data frame obtained by applying
+#'   [rtables::as_result_df()] to `tbl`. No elements of `exclude_rows` may be
+#'   missing.
+#'   The specified rows are removed before plotting. This can be used to omit
+#'   rows that should not be displayed in the forest plot, such as rows
+#'   containing non-plottable values. Defaults to `NULL`, meaning that all rows
+#'   are considered for plotting.
 #'
 #' @return `ggplot` forest plot and table.
 #'
@@ -76,7 +85,11 @@
 #'
 #' tbl <- basic_table() |>
 #'   tabulate_rsp_subgroups(df)
+#'
 #' g_forest(tbl)
+#' \donttest{
+#' g_forest(tbl, exclude_rows = 1)
+#' }
 #'
 #' # Odds ratio only table.
 #'
@@ -177,7 +190,8 @@ g_forest <- function(tbl,
                      as_list = FALSE,
                      gp = lifecycle::deprecated(),
                      draw = lifecycle::deprecated(),
-                     newpage = lifecycle::deprecated()) {
+                     newpage = lifecycle::deprecated(),
+                     exclude_rows = NULL) {
   # Deprecated argument warnings
   if (lifecycle::is_present(width_row_names)) {
     lifecycle::deprecate_warn(
@@ -220,6 +234,11 @@ g_forest <- function(tbl,
   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))
+  tbl_df <- as_result_df(tbl)
+  checkmate::assert_integerish(
+    exclude_rows,
+    lower = 1L, upper = nrow(tbl_df), any.missing = FALSE, min.len = 1L, null.ok = TRUE
+  )
 
   # Extract info from table
   mat <- matrix_form(tbl, indent_rownames = TRUE)
@@ -240,7 +259,9 @@ g_forest <- function(tbl,
     arms <- NULL
   }
 
-  tbl_df <- as_result_df(tbl)
+  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)
@@ -252,7 +273,9 @@ g_forest <- function(tbl,
     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 (nrow(tbl_df) >= 1 && 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
@@ -277,18 +300,18 @@ g_forest <- function(tbl,
   if (is.null(x_at)) x_at <- union(xlim, vline)
   x_labels <- x_at
 
-  # Apply log transformation
-  if (logx) {
+  # 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)
-    xlim_t <- log(xlim)
   } else {
     x_t <- x
     lwr_t <- lwr
     upr_t <- upr
-    xlim_t <- xlim
   }
+  xlim_t <- if (logx) log(xlim) else xlim
 
   # Set up plot area
   gg_plt <- ggplot(data = tbl_df) +

inst/WORDLIST

@@ -54,6 +54,7 @@ infimum
 layouting
 le
 pharmacokinetic
+plottable
 pre
 qquad
 responder

tests/testthat/test-g_forest.R

@@ -99,6 +99,55 @@ 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 validates exclude_rows", {
+  tbl <- basic_table() |>
+    tabulate_rsp_subgroups(df)
+
+  testthat::expect_error(
+    g_forest(tbl, exclude_rows = 0)
+  )
+
+  testthat::expect_error(
+    g_forest(tbl, exclude_rows = -1)
+  )
+
+  testthat::expect_error(
+    g_forest(tbl, exclude_rows = NA_integer_)
+  )
+
+  testthat::expect_error(
+    g_forest(tbl, exclude_rows = nrow(as_result_df(tbl)) + 1)
+  )
+
+  testthat::expect_error(
+    g_forest(tbl, exclude_rows = "1")
+  )
+})
+
+testthat::test_that("g_forest exclude_rows works", {
+  tbl <- basic_table() |>
+    tabulate_rsp_subgroups(df)
+
+  testthat::expect_silent(
+    p <- g_forest(tbl, exclude_rows = c(2, 4))
+  )
+
+  expect_snapshot_ggplot("g_forest_exclude_rows", p, width = 15, height = 3)
+})
+
+testthat::test_that("g_forest works when all rows are excluded", {
+  tbl <- basic_table() |>
+    tabulate_rsp_subgroups(df)
+
+  exclude_rows <- seq_len(nrow(as_result_df(tbl)))
+
+  testthat::expect_silent(
+    p <- g_forest(tbl, exclude_rows = exclude_rows)
+  )
+
+  expect_snapshot_ggplot("g_forest_exclude_all_rows", p, width = 15, height = 3)
+})
+
 testthat::test_that("g_forest argument deprecation warnings work", {
   tbl <- basic_table() |>
     tabulate_rsp_subgroups(df)