Merge pull request #114 from Merck/113-toggle-button-to-showhide-risk-difference-column

add new feature for toggle risk difference columns

Author: LittleBeannie

DESCRIPTION

@@ -50,4 +50,4 @@ Suggests:
 VignetteBuilder: knitr
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.3.3

R/ae_forestly.R

@@ -20,6 +20,7 @@
 #'
 #' @param outdata An `outdata` object created by [format_ae_forestly()].
 #' @param display_soc_toggle A boolean value to display SOC toggle button.
+#' @param display_diff_toggle A boolean value to display risk difference toggle button.
 #' @param filter A character value of the filter variable.
 #' @param filter_label A character value of the label for slider bar.
 #' @param filter_range A numeric vector of length 2 for the range of the slider bar.
@@ -48,6 +49,7 @@
 #' }
 ae_forestly <- function(outdata,
                         display_soc_toggle = TRUE,
+                        display_diff_toggle = FALSE,
                         filter = c("prop", "n"),
                         filter_label = NULL,
                         filter_range = NULL,
@@ -186,12 +188,29 @@ ae_forestly <- function(outdata,
   filter_subject$children[[2]]$attribs$`data-to` <- filter_range[2]
   filter_subject$children[[2]]$attribs$`data-max` <- filter_range[2]
 
+  diff_cols <- c(
+    names(outdata$diff)
+  )
+
+  all_diff_cols <- c(diff_cols, "diff_fig")
+  displayed_diff_cols <- intersect(all_diff_cols, c(
+    if ("diff" %in% outdata$display) diff_cols else NULL,
+    if ("fig_diff" %in% outdata$display) "diff_fig" else NULL
+  ))
+
+  hidden_cols <- outdata$hidden_column
+  if (display_diff_toggle) {
+    hidden_cols <- setdiff(hidden_cols, displayed_diff_cols)
+  }
+
   p_reactable <- reactable2(
     tbl,
     columns = outdata$reactable_columns,
     columnGroups = outdata$reactable_columns_group,
-    hidden_item = paste0("'", outdata$hidden_column, "'", collapse = ", "),
+    hidden_item = paste0("'", hidden_cols, "'", collapse = ", "),
     soc_toggle = display_soc_toggle,
+    diff_toggle = display_diff_toggle,
+    diff_columns = displayed_diff_cols,
     width = width,
     download = dowload_button,
     searchable = FALSE,

R/format_ae_forestly.R

@@ -38,12 +38,14 @@
 #'   for risk difference figure.
 #' @param color A vector of colors for analysis groups.
 #'   Default value supports up to 4 groups.
+#' @param ae_col_header Column header for adverse events item columns.
+#'   If NULL (default) and "par" specified in `components` from `prepare_ae_forestly()`, uses "Adverse Event".
+#'   If NULL and "soc" specified in `components` from `prepare_ae_forestly()`, uses "System Organ Class" for "soc".
 #' @param diff_label x-axis label for risk difference.
-#' @param col_header Column header for risk difference table columns.
+#' @param diff_col_header Column header for risk difference table columns.
 #'   If NULL (default), uses "Risk Difference (%) <br> vs. Reference Group".
-#' @param fig_header Column header for risk difference figure.
+#' @param diff_fig_header Column header for risk difference figure.
 #'   If NULL (default), uses "Risk Difference (%) + 95% CI <br> vs. Reference Group".
-#' @param show_ae_parameter A boolean value to display AE parameter column.
 #'
 #' @return An `outdata` object.
 #'
@@ -71,10 +73,10 @@ format_ae_forestly <- function(
     prop_range = NULL,
     diff_range = NULL,
     color = NULL,
+    ae_col_header = NULL,
     diff_label = "Treatment <- Favor -> Placebo",
-    col_header = NULL,
-    fig_header = NULL,
-    show_ae_parameter = FALSE) {
+    diff_col_header = NULL,
+    diff_fig_header = NULL) {
   display <- tolower(display)
 
   display <- match.arg(
@@ -105,12 +107,20 @@ format_ae_forestly <- function(
   reference_name <- outdata$group[index_reference]
 
   # Set default headers if not provided
-  if (is.null(col_header)) {
-    col_header <- paste0("Risk Difference (%) <br> vs. ", reference_name)
+  if (is.null(ae_col_header)) {
+    if ("par" %in% outdata$components) {
+      ae_col_header <- "Adverse Event"
+    } else if ("soc" %in% outdata$components) {
+      ae_col_header <- "System Organ Class"
+    }
+  }
+
+  if (is.null(diff_col_header)) {
+    diff_col_header <- paste0("Risk Difference (%) <br> vs. ", reference_name)
   }
 
-  if (is.null(fig_header)) {
-    fig_header <- paste0("Risk Difference (%) + 95% CI <br> vs. ", reference_name)
+  if (is.null(diff_fig_header)) {
+    diff_fig_header <- paste0("Risk Difference (%) + 95% CI <br> vs. ", reference_name)
   }
 
   # Input checking
@@ -143,8 +153,6 @@ format_ae_forestly <- function(
     hide_n = apply(outdata$n[, 1:n_group], 1, max, na.rm = TRUE)
   )
 
-  if (!show_ae_parameter) tbl <- tbl[, c(2:ncol(tbl), 1)]
-
   rownames(tbl) <- NULL
 
   # JavaScript for plotly figures ----
@@ -251,7 +259,7 @@ format_ae_forestly <- function(
     )
   }
   columnGroups[[m_group + 1]] <- reactable::colGroup(
-    name = col_header,
+    name = diff_col_header,
     html = TRUE,
     columns = names(outdata$diff)
   )
@@ -262,10 +270,10 @@ format_ae_forestly <- function(
   col_var <- list(
     parameter = reactable::colDef(
       header = "Type",
-      show = show_ae_parameter
+      show = FALSE
     ),
     name = reactable::colDef(
-      header = "Adverse Events",
+      header = ae_col_header,
       minWidth = width_term, align = "right"
     ),
     soc_name = reactable::colDef(
@@ -342,7 +350,7 @@ format_ae_forestly <- function(
 
   # difference format
   col_diff_fig <- list(diff_fig = reactable::colDef(
-    header = fig_header,
+    header = diff_fig_header,
     defaultSortOrder = "desc",
     width = ifelse("fig_diff" %in% display, width_fig, 0),
     align = "center",

R/prepare_ae_forestly.R

@@ -170,6 +170,7 @@ prepare_ae_forestly <- function(
     order = info$order,
     parameter_order = parameter_order,
     group = res[[1]]$group,
+    components = components,
     reference_group = res[[1]]$reference_group,
     prop = values$prop,
     diff = values$diff,

R/reactable2.R

@@ -48,7 +48,9 @@
 #' @param label A logical value to display label as a hover text.
 #' @param download A logical value to display download button.
 #' @param soc_toggle A logical value to display SOC toggle button.
+#' @param diff_toggle A logical value to display risk difference toggle button.
 #' @param hidden_item Vector for hidden columns.
+#' @param diff_columns Character vector of risk difference column names.
 #' @param ... Additional arguments passed to [reactable::reactable()].
 #' @inheritParams reactable::reactable
 #'
@@ -76,7 +78,9 @@ reactable2 <- function(
     download = TRUE,
     col_def = NULL,
     soc_toggle = TRUE,
+    diff_toggle = FALSE,
     hidden_item = NULL,
+    diff_columns = NULL,
     ...) {
   # Display variable label as hover text
   if (label & is.null(col_def)) {
@@ -110,25 +114,60 @@ reactable2 <- function(
     ...
   )
 
+  buttons <- list()
+
   if (soc_toggle) {
-    on_click2 <- paste0(
-      "function control_column(hidden_columns) {",
+    on_click_soc <- paste0(
+      "function control_soc(hidden_columns) {",
       "  if (hidden_columns.includes('soc_name')) {",
       "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
-                             return prevColumns.length === 0 ? ['soc_name']:[", hidden_item, "]})",
+                             return prevColumns.filter(col => col !== 'soc_name')})",
       "  } else {",
       "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
-                             return prevColumns.length === 0 ? [ ]: ['soc_name',", hidden_item, "]})",
+                             return [...prevColumns, 'soc_name']})",
       "  }",
       "}",
-      "control_column(Reactable.getState('", element_id, "').hiddenColumns);"
+      "control_soc(Reactable.getState('", element_id, "').hiddenColumns);"
     )
 
-    tbl <- htmltools::tagList(
+    buttons <- c(buttons, list(
       htmltools::tags$button(
         "Show/Hide SOC column",
-        onclick = on_click2
-      ),
+        onclick = on_click_soc
+      )
+    ))
+  }
+
+  if (diff_toggle && !is.null(diff_columns) && length(diff_columns) > 0) {
+    diff_cols_js <- paste0("['", paste(diff_columns, collapse = "', '"), "']")
+    on_click_diff <- paste0(
+      "function control_diff(hidden_columns) {",
+      "  const diffCols = ", diff_cols_js, ";",
+      "  const allDiffHidden = diffCols.every(col => hidden_columns.includes(col));",
+      "  if (allDiffHidden) {",
+      "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
+                             return prevColumns.filter(col => !diffCols.includes(col))})",
+      "  } else {",
+      "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
+                             return [...new Set([...prevColumns, ...diffCols])]})",
+      "  }",
+      "}",
+      "control_diff(Reactable.getState('", element_id, "').hiddenColumns);"
+    )
+
+    buttons <- c(buttons, list(
+      htmltools::tags$button(
+        "Show/Hide Risk Difference",
+        onclick = on_click_diff
+      )
+    ))
+  }
+
+
+
+  if (length(buttons) > 0) {
+    tbl <- htmltools::tagList(
+      buttons,
       tbl
     )
   }

_pkgdown.yml

@@ -37,6 +37,7 @@ articles:
   - customize-color
   - customize-ae-specific-columns
   - customize-diff-label
+  - customize-toggle-buttons
   - customize-xlimit
   - customize-width
   - customize-display-only-soc

man/ae_forestly.Rd

@@ -17,3 +17,34 @@ test_that("ae_forestly(): test filter and width option", {
   expect_true(grepl("width:1500px", html$children[[1]], fixed = TRUE))
   expect_true(grepl("Number of AE in One or More Treatment Groups", html$children[[1]], fixed = TRUE))
 })
+
+test_that("ae_forestly(): toggle risk difference button is hidden by default", {
+  outdata <- metalite.ae::meta_ae_example() |>
+    prepare_ae_forestly(
+      population = "apat",
+      observation = "wk12",
+      parameter = "any;rel;ser"
+    ) |>
+    format_ae_forestly(display = c("n", "prop", "fig_prop", "fig_diff", "diff"))
+
+  html <- outdata |> ae_forestly(display_diff_toggle = FALSE)
+  html_text <- as.character(html)
+
+  expect_false(grepl("Show/Hide Risk Difference", html_text, fixed = TRUE))
+})
+
+test_that("ae_forestly(): toggle risk difference button can be enabled", {
+  outdata <- metalite.ae::meta_ae_example() |>
+    prepare_ae_forestly(
+      population = "apat",
+      observation = "wk12",
+      parameter = "any;rel;ser"
+    ) |>
+    format_ae_forestly(display = c("n", "prop", "fig_prop", "fig_diff", "diff"))
+
+  html <- outdata |> ae_forestly(display_diff_toggle = TRUE)
+  html_text <- as.character(html)
+
+  expect_true(grepl("Show/Hide Risk Difference", html_text, fixed = TRUE))
+  expect_true(grepl("control_diff", html_text, fixed = TRUE))
+})