Merge pull request #134 from Biogen-Inc/devel

Development branch merge

.github/workflows/R-CMD-check.yaml

@@ -4,7 +4,7 @@ on:
   push:
     branches: [main, master]
   pull_request:
-    branches: [main, master, for_cranny]
+    branches: [main, master, devel]
 
 name: R-CMD-check
 

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: tidyCDISC
 Title: Quick Table Generation & Exploratory Analyses on ADaM-Ish Datasets
-Version: 0.1.0
+Version: 0.1.1
 Authors@R: c(
     person("Aaron", "Clark", , "[email protected]",
       role = c("aut", "cre"), comment = c(ORCID = "0000-0002-0123-0970")),

NAMESPACE

@@ -11,6 +11,8 @@ export(prep_adsl)
 export(prep_bds)
 export(pretty_IDs)
 export(run_app)
+export(std_footnote)
+export(tg_gt)
 export(varN_fctr_reorder)
 import(dplyr)
 import(shiny)

NEWS.md

@@ -1,3 +1,16 @@
+# tidyCDISC 0.1.1
+
+* automated a footnote with **Source** and **Run Date** in table generation
+
+* allowed custom user-defined footnotes
+
+* allowed the selection of 'All' when a time/visit-based statistic is chosen in the table generator
+
+* cleaned up downloadable R Script to replicate table generator output
+
+* fixed bug where `data_from` was erroneously listed as a grouping option in the population explorer
+
+
 # tidyCDISC 0.1.0 (CRAN Release)
 * cleaning up `devtools::check()` & preparing for CRAN release.
 

R/mod_popExp_line.R

@@ -314,9 +314,11 @@ linePlot_srv <- function(input, output, session, data, run) {
     if(!(input$yvar %in% colnames(data())) ){ # yvar paramcd #& input$xvar %in% colnames(data())
       group_dat <- data() %>% 
         dplyr::filter(PARAMCD == input$yvar) %>% 
-        select_if(~!all(is.na(.))) # remove NA cols
+        select_if(~!all(is.na(.))) %>% # remove NA cols
+        select(-data_from)
     } else {
-      group_dat <- data()
+      group_dat <- data() %>%
+        select(-data_from)
     } 
 
     # character and factor columns for coloring or separating

R/mod_popExp_scatter.R

@@ -114,6 +114,8 @@ scatterPlot_srv <- function(input, output, session, data, run) {
       group_dat <- x_cols %>% full_join(y_cols)
     }
 
+    group_dat <- select(group_dat, -data_from)
+
     # character and factor columns for coloring or separating
     char_col <- subset_colclasses(group_dat, is.character)
     fac_col <- subset_colclasses(group_dat, is.factor)

R/mod_tableGen.R

@@ -262,7 +262,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
   # Send any and all AVISITs that exist to javascript side (script.js)
   observe({
     req(AVISIT())
-    session$sendCustomMessage("my_weeks", AVISIT())
+    session$sendCustomMessage("my_weeks", c("ALL", as.vector(AVISIT())))
   })
 
 
@@ -536,8 +536,10 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
         ),
         locations = gt::cells_stub(rows = TRUE)
       )%>%
-      gt::cols_label(Variable = "")
-  }) 
+      gt::cols_label(Variable = "") %>%
+      std_footnote("tidyCDISC app") %>%
+      gt::tab_footnote(input$table_footnote)
+  })
 
   output$all <- gt::render_gt({  gt_table() })
 
@@ -645,18 +647,25 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
       ")}
   })
 
+  footnote_src <- reactive({
+    if(any("CDISCPILOT01" %in% ADSL()$STUDYID)){
+      "'tidyCDISC app'"
+    } else {
+      "study_dir"
+    }
+    })
+
   # If ADAE exists, then prep that data too
   adae_expr <- reactive({
     if("ADAE" %in% names(datafile())){
       glue::glue("
         # Create AE data set
-            pre_adae <- datalist %>%
-                tidyCDISC::prep_adae(pre_adsl$data, '{RECIPE()}')
-            ae_data <- pre_adae$data
+        pre_adae <- datalist %>%
+          tidyCDISC::prep_adae(pre_adsl$data, '{RECIPE()}')
+        ae_data <- pre_adae$data
         "
       )
-    } else {"
-      "}
+    } else {""}
   })
   # capture output of filtering expression
   # input_filter_df <- c("one","mild","Moderate")
@@ -748,6 +757,11 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
     pkgs_req <- c('tidyCDISC', 'purrr', 'haven', 'dplyr', 'stringr', 'tidyr', 'gt')
     {install_text}
     
+    if (utils::compareVersion(as.character(utils::packageVersion('tidyCDISC')), '{packageVersion('tidyCDISC')}') < 0) {{
+      install.packages('remotes')
+      remotes::install_github('Biogen-Inc/tidyCDISC')
+    }}
+    
     library(tidyCDISC)
     library(purrr)
     library(haven)
@@ -765,7 +779,7 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
         
     # get drop zone area from tidyCDISC
     # and create table using data
-    blockData <- {paste0(capture.output(dput(blocks_and_functions())), collapse = '\n')}
+    blockData <- {prep_blocks(blocks_and_functions())}
     
     {df_empty_expr()}
     "
@@ -820,20 +834,9 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
       # Calculate totals for population set
       {total_for_code()}
       
+      tg_datalist <- list({ifelse(adae_expr() == '', '', 'ADAE = ae_data, ')}ADSL = bds_data, POPDAT = {Rscript_use_preferred_pop_data()})
       
-      tg_table <- purrr::pmap(list(
-                  blockData$agg,
-                  blockData$S3,
-                  blockData$dropdown,
-                  blockData$dataset), 
-          function(x,y,z,d) tidyCDISC::app_methods(x,y,z,
-                       group = {column() %quote% 'NULL'}, 
-                       data = tidyCDISC::data_to_use_str(d, ae_data, bds_data),
-                       totals = total_df)) %>%
-      map(setNames, tidyCDISC::common_rownames({Rscript_use_preferred_pop_data()}, {column() %quote% 'NULL'})) %>%
-      setNames(paste(blockData$gt_group)) %>%
-      bind_rows(.id = 'ID') %>%
-      mutate(ID = tidyCDISC::pretty_IDs(ID))
+      tg_table <- tidyCDISC::tg_gt(tg_datalist, blockData, total_df, {column() %quote% 'NULL'})
       
       # get the column names for the table
       col_names <- names(tg_table)[-c(1:2)]
@@ -856,7 +859,9 @@ mod_tableGen_server <- function(input, output, session, datafile = reactive(NULL
           style = cell_text(weight = 'bold'),
           locations = cells_row_groups()
           ) %>%
-          cols_label(Variable = '')
+          cols_label(Variable = '') %>%
+          tidyCDISC::std_footnote({footnote_src()}) %>%
+          tab_footnote('{input$table_footnote}')
       "
     )
   })

R/mod_tableGen_fct_methods.R

@@ -111,47 +111,62 @@ custom_class <- function(x, df) {
 #' @importFrom purrr map_chr
 #' @importFrom stringr str_trim
 #' 
-#' @param agg the aggregate statistic block 
+#' @param aggs the aggregate statistic block 
 #' to apply to the column
 #' @param blocks the block corresponding 
 #' to the column name to apply statistic on
 #' 
 #' @family tableGen Functions
 #' @noRd
 #' 
-convertTGOutput <- function(agg, blocks) {
+convertTGOutput <- function(aggs, blocks) {
 
-  agg <- unlist(agg, recursive = FALSE)
+  aggs <- unlist(aggs, recursive = FALSE)
   blocks <- unlist(blocks, recursive = FALSE)
-
-  # why does it work if I assign it outside the tibble???
-  test <- purrr::map_chr(agg, "val", .default = NA_character_) %>% unname()
-
-  if (length(agg) > length(blocks)) {
+
+  if (length(aggs) > length(blocks)) {
     stop("Need addional variable block")
-  } else if (length(agg) < length(blocks)) {
+  } else if (length(aggs) < length(blocks)) {
     stop("Need additional statistics block")
   } else {
 
-    tidyr::tibble(
-      agg = purrr::map_chr(agg, "txt") %>% unname() %>% str_trim(),
-      block = purrr::map_chr(blocks, "txt") %>% unname() %>% str_trim(),
-      dataset = purrr::map_chr(blocks, "df") %>% unname() %>% str_trim(),
-      # why is this NA in the tibble, but not NA pri
-      # dropdown = map_chr(agg, "val", .default = NA_character_) %>% unname()
-      dropdown = test,
-      S3 = map2(block, dataset, ~ custom_class(.x, .y)),
-      gt_group =
-        case_when(
-          dropdown == "NONE" ~ glue("{agg} of {block}"),
-          is.na(dropdown) ~ glue("{agg} of {block}"),
-          tolower(substr(dropdown, 1, 4)) %in% c("week","base","scree","end ") ~ glue("{agg} of {block} at {dropdown}"),
-          TRUE ~ glue("{agg} of {block} and {dropdown}") # "and" instead of "at"
-        )#, # will need to feed these datasets through to this function? Or create a new funct?
-            # that get's called "blocks_and_functions" that adds the labels?
-      # label = purrr::map(blockData$block, function(x) attr(data_to_use(dataset)[[x]], 'label')) %>% 
-      #   unname() %>% str_trim()
-    )
+    purrr::map2_df(aggs, blocks, function(aggs, blocks) {
+      if (!is.null(aggs$val) && aggs$val == "ALL") {
+        purrr::map_df(aggs$lst, function(dropdown) {
+          tidyr::tibble(
+            agg = aggs$txt %>% unname() %>% str_trim(),
+            block = blocks$txt %>% unname() %>% str_trim(),
+            dataset = blocks$df %>% unname() %>% str_trim(),
+            dropdown = dropdown %>% unname() %>% str_trim(),
+            S3 = map2(block, dataset, ~ custom_class(.x, .y)),
+            gt_group =
+              case_when(
+                dropdown == "NONE" ~ glue("{agg} of {block}"),
+                is.na(dropdown) ~ glue("{agg} of {block}"),
+                tolower(substr(dropdown, 1, 4)) %in% c("week","base","scree","end ") ~ glue("{agg} of {block} at {dropdown}"),
+                TRUE ~ glue("{agg} of {block} and {dropdown}") # "and" instead of "at"
+              )
+          )
+        })
+      } else {
+        tidyr::tibble(
+          agg = aggs$txt %>% unname() %>% str_trim(),
+          block = blocks$txt %>% unname() %>% str_trim(),
+          dataset = blocks$df %>% unname() %>% str_trim(),
+          dropdown = ifelse(is.null(aggs$val), NA_character_, aggs$val %>% unname() %>% str_trim()),
+          S3 = map2(block, dataset, ~ custom_class(.x, .y)),
+          gt_group =
+            case_when(
+              dropdown == "NONE" ~ glue("{agg} of {block}"),
+              is.na(dropdown) ~ glue("{agg} of {block}"),
+              tolower(substr(dropdown, 1, 4)) %in% c("week","base","scree","end ") ~ glue("{agg} of {block} at {dropdown}"),
+              TRUE ~ glue("{agg} of {block} and {dropdown}") # "and" instead of "at"
+            )
+        )
+      }
+
+
+    })
 
   }
 }

R/mod_tableGen_ui.R

@@ -110,6 +110,8 @@ mod_tableGen_ui <- function(id){
            wellPanel(
              fluidRow(column(width = 12,
                 div(id = "table_title", textInput(ns("table_title"), "Table Title", "Table Title", width = '100%')))),
+             fluidRow(column(width = 12,
+                div(id = "table_footnote", textInput(ns("table_footnote"), "Table Footnote", placeholder = "Add footnote here", width = '100%')))),
              fluidRow(column(width = 12,
                              div(id = "download_table", fluidRow(
                                column(6, downloadButton(ns("download_gt"), "Download Table")),

R/mod_tableGen_utils.R

@@ -445,6 +445,63 @@ pretty_IDs <- function(ID) {
   )
 }
 
+#' Prep Block Data for TG Tables
+#' 
+#' @param blockData The `blockData` object from the application
+#' 
+#' @noRd
+prep_blocks <- function(blockData) {
+  dput(blockData) %>%
+    capture.output() %>%
+    paste0(collapse = "") %>%
+    str_replace_all("\\s{2,}", " ") %>%
+    str_replace_all("(\\),)", "\\1\n")
+}
+
+#' Create Standard Footnotes for TG Table
+#' 
+#' Creates a footnote with a source on the left and date run on the right.
+#' 
+#' @param data The `gt` table object to append the footnote
+#' @param source The source of the data in the table
+#' 
+#' @export
+#' @keywords tabGen_repro
+std_footnote <- function(data, source) {
+  gt::tab_footnote(data, 
+                   tags$div(HTML("<b>Source:</b>", source), 
+                            shiny::tags$span(shiny::HTML("<b> Run Date:</b>", toupper(format(Sys.Date(), "%d%b%Y"))),
+                                             style="float:right"),
+                            style="text-align:left"))
+}
+
+#' Create the gt table object for TG
+#' 
+#' A wrapper for other functions to create the `gt` object from the data
+#' 
+#' @param tg_datalist A list containing the data frames used to create the table
+#' @param blockData The data for the construction of the blocks in the table
+#' @param total_df A data frame containing the totals by grouping variable
+#' @param group A character denoting the grouping variable
+#' 
+#' @export
+#' @keywords tabGen_repro
+tg_gt <- function(tg_datalist, blockData, total_df, group) {
+  purrr::pmap(list(
+    blockData$agg,
+    blockData$S3,
+    blockData$dropdown,
+    blockData$dataset), 
+    function(x,y,z,d) tidyCDISC::app_methods(x,y,z,
+                                             group = group, 
+                                             data = tidyCDISC::data_to_use_str(d, tg_datalist$ADAE, tg_datalist$ADSL),
+                                             totals = total_df)) %>%
+    purrr::map(setNames, tidyCDISC::common_rownames(tg_datalist$POPDAT, group)) %>%
+    setNames(paste(blockData$gt_group)) %>%
+    dplyr::bind_rows(.id = 'ID') %>%
+    dplyr::mutate(ID = tidyCDISC::pretty_IDs(ID))
+}
+
 #' Table Generator Cicerone R6 Object 
 #' 
 #' This object is used within the table generator module

dev/02_dev.R

@@ -175,7 +175,7 @@ usethis::use_vignette("dev03_Indv_Expl")
 
 
 # Before submitting a PR, run this code & update NEWS.md
-usethis::use_version("patch") #choices: "dev", "patch", "minor", "major"
+usethis::use_version("dev") #choices: "dev", "patch", "minor", "major"
 
 # Build pkg, including vignettes. Do this before updating documentation.
 devtools::build() # calls pkgbuld::build()     # X.X MB

inst/app/www/script.js

@@ -35,8 +35,14 @@ $( document ).ready(function() {
       txt = $(this).text()
       df = $(this).attr("class").split(" ")[1]  
       val = $(this).parent().find("select").children("option:selected").val()
+      lst = [];
+      if (val === "ALL") {
+      for (let i = 2; i < $(this).parent().find("select").children().length; i++) {
+        lst.push($(this).parent().find("select").children()[i].text);
+      }
+      }
       str += `${df}*${txt.replace(" ", "")}*${val} + `.replace(/\r?\n|\r/g, "")
-      obj.numbers.push({txt,df,val})
+      obj.numbers.push({txt,df,val,lst})
     })
   // currently return a string seperated by +
     // and blocks must be one word - this is very fragile!