Merge pull request #51 from Merck/soc_pr

Add display SOC button

DESCRIPTION

@@ -34,7 +34,8 @@ Imports:
     reactable,
     reactR,
     rlang,
-    ggplot2
+    ggplot2,
+    uuid
 Suggests:
     covr,
     dplyr,

R/ae_forestly.R

@@ -19,6 +19,7 @@
 #' Display interactive forest plot
 #'
 #' @param outdata An `outdata` object created by [format_ae_forestly()].
+#' @param display_soc_toggle A boolean value to display SOC toggle button.
 #' @param filter A character value of the filter variable.
 #' @param width A numeric value of width of the table in pixels.
 #'
@@ -38,7 +39,10 @@
 #'     format_ae_forestly() |>
 #'     ae_forestly()
 #' }
-ae_forestly <- function(outdata, filter = c("prop", "n"), width = 1400) {
+ae_forestly <- function(outdata,
+                        display_soc_toggle = TRUE,
+                        filter = c("prop", "n"),
+                        width = 1400) {
   filter <- match.arg(filter)
   filter_range <- c(0, 100)
 
@@ -73,7 +77,7 @@ ae_forestly <- function(outdata, filter = c("prop", "n"), width = 1400) {
   # Set default to be the first item
   default_param <- as.character(unique(outdata$tbl$parameter)[1])
 
-  random_id <- paste0("filter_ae_", sample(1:9999, 1), "|", default_param)
+  random_id <- paste0("filter_ae_", uuid::UUIDgenerate(), "|", default_param)
   filter_ae <- crosstalk::filter_select(
     id = random_id,
     label = "AE Criteria",
@@ -121,6 +125,8 @@ ae_forestly <- function(outdata, filter = c("prop", "n"), width = 1400) {
     tbl,
     columns = outdata$reactable_columns,
     columnGroups = outdata$reactable_columns_group,
+    hidden_item = paste0("'", outdata$hidden_column, "'", collapse = ", "),
+    soc_toggle = display_soc_toggle,
     width = width,
     details = function(index) {
       t_row <- outdata$tbl$name[index]

R/format_ae_forestly.R

@@ -105,6 +105,7 @@ format_ae_forestly <- function(
   tbl <- data.frame(
     parameter = outdata$parameter_order,
     name = outdata$name,
+    soc_name = outdata$soc_name,
     prop_fig = NA,
     diff_fig = NA,
     outdata$n[, 1:m_group],
@@ -224,6 +225,11 @@ format_ae_forestly <- function(
     name = reactable::colDef(
       header = "Adverse Events",
       minWidth = width_term, align = "right"
+    ),
+    soc_name = reactable::colDef(
+      header = "SOC Name",
+      minWidth = width_term, align = "right",
+      show = FALSE
     )
   )
 
@@ -314,13 +320,24 @@ format_ae_forestly <- function(
     col_prop_fig, col_diff_fig
   )
 
+  # column hidden
+  columns <- lapply(columns, function (x) {
+    if (!"show" %in% names(x)) {
+      x$show <- TRUE
+    }
+    return(x)
+  })
+
+  hidden_item <- names(columns)[(!names(columns) %in% "soc_name") & (sapply(columns, function(x) {return(!x$show)}))]
+
   # Create outdata
   outdata$tbl <- tbl
   outdata$reactable_columns <- columns
   outdata$reactable_columns_group <- columnGroups
   outdata$display <- display
   outdata$fig_prop_color <- fig_prop_color
   outdata$fig_diff_color <- fig_diff_color
+  outdata$hidden_column <- hidden_item
 
   outdata
 }

R/prepare_ae_forestly.R

@@ -101,7 +101,7 @@ prepare_ae_forestly <- function(
     metalite.ae::prepare_ae_specific(meta,
       population = population, observation = observation,
       parameter = x,
-      components = "par",
+      components = c("soc", "par"),
       reference_group = reference_group
     ) |>
       metalite.ae::extend_ae_specific_inference() |>
@@ -142,7 +142,7 @@ prepare_ae_forestly <- function(
     tmp
   }
 
-  name <- c("order", "name")
+  name <- name <- c("order", "name", "soc_name")
   info <- lapply(name, foo)
   names(info) <- name
   parameter_order <- unlist(Map(rep, x = parameters, each = attributes(info$order)$n))
@@ -174,6 +174,7 @@ prepare_ae_forestly <- function(
     diff = values$diff,
     n_pop = res[[1]]$n_pop,
     name = info$name,
+    soc_name = info$soc_name,
     ci_lower = values$ci_lower,
     ci_upper = values$ci_upper,
     p = values$p,

R/reactable2.R

@@ -47,6 +47,8 @@
 #' @param col_def An alternative argument for `defaultColDef`.
 #' @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 hidden_item Vector for hidden columns.
 #' @param ... Additional arguments passed to [reactable::reactable()].
 #' @inheritParams reactable::reactable
 #'
@@ -73,6 +75,8 @@ reactable2 <- function(
     wrap = FALSE,
     download = TRUE,
     col_def = NULL,
+    soc_toggle = TRUE,
+    hidden_item = NULL,
     ...) {
   # Display variable label as hover text
   if (label & is.null(col_def)) {
@@ -106,6 +110,27 @@ reactable2 <- function(
     ...
   )
 
+  if (soc_toggle) {
+    on_click2 <- paste0("function control_column(hidden_columns) {",
+                        "  if (hidden_columns.includes('soc_name')) {",
+                        "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
+                             return prevColumns.length === 0 ? ['soc_name']:[", hidden_item ,"]})",
+                        "  } else {",
+                        "    Reactable.setHiddenColumns('", element_id, "', prevColumns => {
+                             return prevColumns.length === 0 ? [ ]: ['soc_name',",  hidden_item, "]})",
+                        "  }",
+                        "}",
+                        "control_column(Reactable.getState('", element_id, "').hiddenColumns);")
+
+    tbl <- htmltools::tagList(
+      htmltools::tags$button(
+        "Show/Hide SOC column",
+        onclick = on_click2
+      ),
+      tbl
+    )
+  }
+
   if (download) {
     on_click <- paste0("Reactable.downloadDataCSV('", element_id, "')")