Update g_forest() to support col_x and col_ci in the same column.

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

R/g_forest.R

@@ -10,12 +10,14 @@
 #' @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.
 #' @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
@@ -89,6 +91,16 @@
 #' g_forest(tbl)
 #' \donttest{
 #' g_forest(tbl, exclude_rows = 1)
+#'
+#' # 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)
 #' }
 #'
 #' # Odds ratio only table.
@@ -245,7 +257,7 @@ 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]
+  tbl_stats <- make.unique(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) +
@@ -273,8 +285,8 @@ 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 (nrow(tbl_df) >= 1 && 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]]) <= 1) {
+    stop("CI column must have at least two elements (lower and upper limits).")
   }
 
   if (!is.null(col_x)) {
@@ -289,30 +301,38 @@ g_forest <- function(tbl,
     sym_size <- rep(1, nrow(tbl_df))
   }
 
-  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"]])
+  x_ci <- if (nrow(tbl_df) >= 1) {
+    x_ci_df <- tbl_df[, unique(c(x_col, ci_col)), drop = FALSE]
+    x_ci_list <- lapply(x_ci_df, function(col) {
+      byrow <- length(col[[1]]) != 1L
+      matrix(unlist(col), nrow = nrow(tbl_df), byrow = byrow)
+    })
+    do.call(cbind, x_ci_list)
+  } else {
+    NULL
+  }
+  # `x`, `lwr`, and `upr` are NULL when x_ci = NULL.
+  x <- x_ci[, 1]
+  lwr <- x_ci[, 2]
+  upr <- x_ci[, 3]
   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
-
   # 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)
+  x_ci_t <- if (logx && !is.null(x_ci)) {
+    log(x_ci)
   } else {
-    x_t <- x
-    lwr_t <- lwr
-    upr_t <- upr
+    x_ci
   }
+  x_t <- x_ci_t[, 1]
+  lwr_t <- x_ci_t[, 2]
+  upr_t <- x_ci_t[, 3]
   xlim_t <- if (logx) log(xlim) else xlim
 
+  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
+
   # Set up plot area
   gg_plt <- ggplot(data = tbl_df) +
     theme(

tests/testthat/test-g_forest.R

@@ -148,6 +148,20 @@ 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 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.)"))
+  )
+
+  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_the_same_x_ci", p, width = 15, height = 3)
+})
+
 testthat::test_that("g_forest argument deprecation warnings work", {
   tbl <- basic_table() |>
     tabulate_rsp_subgroups(df)