Add stats and risk difference parameters to forest plot modules

NEWS.md

@@ -5,6 +5,8 @@
 * Introduced `ylim` parameter for `tm_g_km` module that controls width of y-axis.
 * Added functionality to `tm_t_events_patyear` to split columns by multiple (nested) variables via the `arm_var` argument.
 * Added arguments `arm_var_labels` to `template_summary` and `show_arm_var_labels` to `tm_t_summary` to allow user to display arm variable (`arm_var`) labels in table header.
+* Added argument `stats` to modules `tm_g_forest_rsp` and `tm_g_forest_tte` to allow users to specify statistics to include in the table.
+* Added argument `riskdiff` to modules `tm_g_forest_rsp` and `tm_g_forest_tte` to allow users to add a risk difference table column.
 
 ### Miscellaneous
 * Removed `Show Warnings` modals from modules.

R/tm_g_forest_rsp.R

@@ -4,6 +4,17 @@
 #'
 #' @inheritParams tern::g_forest
 #' @inheritParams template_arguments
+#' @param stats (`character`)\cr the names of statistics to be reported among:
+#'   * `n`: Total number of observations per group.
+#'   * `n_rsp`: Number of responders per group.
+#'   * `prop`: Proportion of responders.
+#'   * `n_tot`: Total number of observations.
+#'   * `or`: Odds ratio.
+#'   * `ci` : Confidence interval of odds ratio.
+#'   * `pval`: p-value of the effect.
+#'   Note, the statistics `n_tot`, `or`, and `ci` are required.
+#' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply
+#'   within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added.
 #' @param obj_var_name (`character`)\cr additional text to append to the table title.
 #' @param responders (`character`)\cr values of `aval_var` that are considered to be responders.
 #' @param col_symbol_size (`integer` or `NULL`)\cr column index to be used to determine relative size for
@@ -33,6 +44,8 @@ template_forest_rsp <- function(dataname = "ANL",
                                 responders = c("CR", "PR"),
                                 subgroup_var,
                                 strata_var = NULL,
+                                stats = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
+                                riskdiff = NULL,
                                 conf_level = 0.95,
                                 col_symbol_size = NULL,
                                 rel_width_forest = 0.25,
@@ -44,6 +57,9 @@ template_forest_rsp <- function(dataname = "ANL",
   checkmate::assert_string(aval_var)
   checkmate::assert_string(obj_var_name)
   checkmate::assert_character(subgroup_var, null.ok = TRUE)
+  checkmate::assert_character(stats, min.len = 3)
+  checkmate::assert_true(all(c("n_tot", "or", "ci") %in% stats))
+  checkmate::assert_list(riskdiff, null.ok = TRUE)
   checkmate::assert_number(rel_width_forest, lower = 0, upper = 1)
   checkmate::assert_number(font_size)
 
@@ -155,9 +171,10 @@ template_forest_rsp <- function(dataname = "ANL",
   y$summary <- bracket_expr(summary_list)
 
   # Table output.
-  y$table <- quote(
-    result <- rtables::basic_table() %>%
-      tabulate_rsp_subgroups(df, vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci"))
+  y$table <- substitute(
+    expr = result <- rtables::basic_table() %>%
+      tabulate_rsp_subgroups(df, vars = stats, riskdiff = riskdiff),
+    env = list(stats = stats, riskdiff = riskdiff)
   )
 
   all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
@@ -325,6 +342,8 @@ tm_g_forest_rsp <- function(label,
                             ),
                             subgroup_var,
                             strata_var,
+                            stats = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
+                            riskdiff = NULL,
                             fixed_symbol_size = TRUE,
                             conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE),
                             default_responses = c("CR", "PR", "Y", "Complete Response (CR)", "Partial Response (PR)"),
@@ -346,6 +365,9 @@ tm_g_forest_rsp <- function(label,
   checkmate::assert_class(subgroup_var, "choices_selected")
   checkmate::assert_class(strata_var, "choices_selected")
   checkmate::assert_class(conf_level, "choices_selected")
+  checkmate::assert_character(stats, min.len = 3)
+  checkmate::assert_true(all(c("n_tot", "or", "ci") %in% stats))
+  checkmate::assert_list(riskdiff, null.ok = TRUE)
   checkmate::assert_multi_class(default_responses, c("list", "character", "numeric"), null.ok = TRUE)
   checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
   checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
@@ -380,6 +402,8 @@ tm_g_forest_rsp <- function(label,
         parentname = parentname,
         arm_ref_comp = arm_ref_comp,
         label = label,
+        stats = stats,
+        riskdiff = riskdiff,
         default_responses = default_responses,
         plot_height = plot_height,
         plot_width = plot_width,
@@ -497,6 +521,8 @@ srv_g_forest_rsp <- function(id,
                              aval_var,
                              subgroup_var,
                              strata_var,
+                             stats,
+                             riskdiff,
                              plot_height,
                              plot_width,
                              label,
@@ -721,6 +747,8 @@ srv_g_forest_rsp <- function(id,
         responders = input$responders,
         subgroup_var = if (length(subgroup_var) != 0) subgroup_var else NULL,
         strata_var = if (length(strata_var) != 0) strata_var else NULL,
+        stats = stats,
+        riskdiff = riskdiff,
         conf_level = as.numeric(input$conf_level),
         col_symbol_size = `if`(input$fixed_symbol_size, NULL, 1),
         rel_width_forest = input$rel_width_forest / 100,

R/tm_g_forest_tte.R

@@ -4,6 +4,17 @@
 #'
 #' @inheritParams template_arguments
 #' @inheritParams template_forest_rsp
+#' @param stats (`character`)\cr the names of statistics to be reported among:
+#'   * `n_tot_events`: Total number of events per group.
+#'   * `n_events`: Number of events per group.
+#'   * `n_tot`: Total number of observations per group.
+#'   * `n`: Number of observations per group.
+#'   * `median`: Median survival time.
+#'   * `hr`: Hazard ratio.
+#'   * `ci`: Confidence interval of hazard ratio.
+#'   * `pval`: p-value of the effect.
+#'   Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`
+#'   are required.
 #'
 #' @inherit template_arguments return
 #'
@@ -20,6 +31,8 @@ template_forest_tte <- function(dataname = "ANL",
                                 cnsr_var = "CNSR",
                                 subgroup_var,
                                 strata_var = NULL,
+                                stats = c("n_tot_events", "n_events", "median", "hr", "ci"),
+                                riskdiff = NULL,
                                 conf_level = 0.95,
                                 col_symbol_size = NULL,
                                 time_unit_var = "AVALU",
@@ -30,6 +43,10 @@ template_forest_tte <- function(dataname = "ANL",
   checkmate::assert_string(arm_var)
   checkmate::assert_string(obj_var_name)
   checkmate::assert_character(subgroup_var, null.ok = TRUE)
+  checkmate::assert_character(stats, min.len = 3)
+  checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% stats))
+  checkmate::assert_true(all(c("hr", "ci") %in% stats))
+  checkmate::assert_list(riskdiff, null.ok = TRUE)
   checkmate::assert_number(rel_width_forest, lower = 0, upper = 1)
   checkmate::assert_number(font_size)
 
@@ -147,11 +164,12 @@ template_forest_tte <- function(dataname = "ANL",
       result <- rtables::basic_table() %>%
         tabulate_survival_subgroups(
           df,
-          vars = c("n_tot", "n_tot_events", "n", "n_events", "median", "hr", "ci"),
-          time_unit = as.character(anl$time_unit_var[1])
+          vars = stats,
+          time_unit = as.character(anl$time_unit_var[1]),
+          riskdiff = riskdiff
         )
     },
-    env = list(time_unit_var = as.name(time_unit_var))
+    env = list(stats = stats, time_unit_var = as.name(time_unit_var), riskdiff = riskdiff)
   )
 
   all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
@@ -302,6 +320,8 @@ tm_g_forest_tte <- function(label,
                               teal.transform::variable_choices(dataname, "CNSR"), "CNSR",
                               fixed = TRUE
                             ),
+                            stats = c("n_tot_events", "n_events", "median", "hr", "ci"),
+                            riskdiff = NULL,
                             conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE),
                             time_unit_var = teal.transform::choices_selected(
                               teal.transform::variable_choices(dataname, "AVALU"), "AVALU",
@@ -327,6 +347,10 @@ tm_g_forest_tte <- function(label,
   checkmate::assert_class(cnsr_var, "choices_selected")
   checkmate::assert_class(conf_level, "choices_selected")
   checkmate::assert_class(time_unit_var, "choices_selected")
+  checkmate::assert_character(stats, min.len = 3)
+  checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% stats))
+  checkmate::assert_true(all(c("hr", "ci") %in% stats))
+  checkmate::assert_list(riskdiff, null.ok = TRUE)
   checkmate::assert_flag(fixed_symbol_size)
   checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
   checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
@@ -362,6 +386,8 @@ tm_g_forest_tte <- function(label,
         dataname = dataname,
         arm_ref_comp = arm_ref_comp,
         parentname = parentname,
+        stats = stats,
+        riskdiff = riskdiff,
         plot_height = plot_height,
         plot_width = plot_width,
         ggplot2_args = ggplot2_args
@@ -493,6 +519,8 @@ srv_g_forest_tte <- function(id,
                              aval_var,
                              cnsr_var,
                              time_unit_var,
+                             stats,
+                             riskdiff,
                              plot_height,
                              plot_width,
                              ggplot2_args) {
@@ -645,6 +673,8 @@ srv_g_forest_tte <- function(id,
         cnsr_var = as.vector(anl_m$columns_source$cnsr_var),
         subgroup_var = if (length(subgroup_var) != 0) subgroup_var else NULL,
         strata_var = if (length(strata_var) != 0) strata_var else NULL,
+        stats = stats,
+        riskdiff = riskdiff,
         conf_level = as.numeric(input$conf_level),
         col_symbol_size = if (!input$fixed_symbol_size) 1,
         time_unit_var = as.vector(anl_m$columns_source$time_unit_var),

tests/testthat/_snaps/tm_g_forest_rsp.md

@@ -27,7 +27,52 @@
 
       $table
       result <- rtables::basic_table() %>% tabulate_rsp_subgroups(df, 
-          vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci"))
+          vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci"), riskdiff = NULL)
+
+      $plot
+      $plot[[1]]
+      f <- g_forest(tbl = result, col_symbol_size = NULL, font_size = 15, 
+          as_list = TRUE)
+
+      $plot[[2]]
+      p <- cowplot::plot_grid(f[["table"]] + ggplot2::labs(title = "Forest Plot of Best Overall Response for "), 
+          f[["plot"]] + ggplot2::labs(caption = ""), align = "h", axis = "tblr", 
+          rel_widths = c(1 - 0.25, 0.25))
+
+
+
+# template_forest_rsp works with risk difference column added
+
+    Code
+      res
+    Output
+      $data
+      {
+          adrs <- adrs %>% dplyr::filter(ARMCD %in% c("ARM A", "ARM B", 
+              "ARM C")) %>% dplyr::mutate(ARMCD = stats::relevel(ARMCD, 
+              ref = "ARM A")) %>% dplyr::mutate(ARMCD = droplevels(ARMCD)) %>% 
+              dplyr::mutate(is_rsp = AVALC %in% c("CR", "PR")) %>% 
+              dplyr::mutate(ARMCD = combine_levels(ARMCD, levels = c("ARM B", 
+                  "ARM C")))
+          parent <- adsl %>% dplyr::filter(ARMCD %in% c("ARM A", "ARM B", 
+              "ARM C")) %>% dplyr::mutate(ARMCD = stats::relevel(ARMCD, 
+              ref = "ARM A")) %>% dplyr::mutate(ARMCD = droplevels(ARMCD)) %>% 
+              dplyr::mutate(ARMCD = combine_levels(ARMCD, levels = c("ARM B", 
+                  "ARM C")))
+      }
+
+      $summary
+      {
+          df <- extract_rsp_subgroups(variables = list(rsp = "is_rsp", 
+              arm = "ARMCD", subgroups = c("SEX", "STRATA2"), strata = NULL), 
+              data = adrs, conf_level = 0.95)
+      }
+
+      $table
+      result <- rtables::basic_table() %>% tabulate_rsp_subgroups(df, 
+          vars = c("n_tot", "or", "ci"), riskdiff = list(arm_x = NULL, 
+              arm_y = NULL, format = "xx.x (xx.x - xx.x)", col_label = "Prop. Diff", 
+              pct = TRUE))
 
       $plot
       $plot[[1]]