Add chart export module

DESCRIPTION

@@ -23,6 +23,8 @@ Suggests:
     ggplot2,
     knitr,
     plotly,
+    rmarkdown,
+    markdown,
     rstudioapi,
     rprojroot,
     shinydashboard,
@@ -37,6 +39,7 @@ Imports:
     htmlwidgets,
     jsonlite,
     listviewer,
+    magrittr,
     purrr,
     rlang,
     shiny,

NAMESPACE

@@ -31,6 +31,8 @@ export(mappingSelect)
 export(mappingSelectUI)
 export(mappingTab)
 export(mappingTabUI)
+export(reportsTab)
+export(reportsTabUI)
 export(safetyGraphicsApp)
 export(settingsCharts)
 export(settingsChartsUI)
@@ -47,6 +49,7 @@ importFrom(DT,renderDT)
 importFrom(listviewer,jsonedit)
 importFrom(listviewer,jsoneditOutput)
 importFrom(listviewer,renderJsonedit)
+importFrom(magrittr,extract)
 importFrom(purrr,map)
 importFrom(rlang,.data)
 importFrom(shiny,dataTableOutput)

R/app_server.R

@@ -55,6 +55,10 @@ app_server <- function(meta, mapping, domainData, charts){
                 mapping=current_mapping    
             )
         )
+
+        # pass all charts, filtered data, and current mappings to reports/export tab
+        callModule(reportsTab, "reports", charts = charts, data = filtered_data, mapping = current_mapping)
+
 
         #participant count in header
         shinyjs::html("header-count", paste(dim(domainData[["dm"]])[1]))

R/app_ui.R

@@ -48,7 +48,7 @@ app_ui <- function(meta, domainData, mapping, standards){
                 tabPanel("Filtering", icon=icon("filter"), filterTabUI("filter","dm"))
             ),
             navbarMenu('Charts', icon=icon("chart-bar")),
-            tabPanel("Reports", icon=icon("file-alt")),
+            tabPanel("Reports", icon=icon("file-alt"), reportsTabUI("reports")),
             navbarMenu('',icon=icon("cog"),
                 tabPanel(title = "Metadata", settingsMappingUI("metaSettings")),
                 tabPanel(title = "Charts", settingsChartsUI("chartSettings"))

R/mod_reportsTab.R

@@ -0,0 +1,96 @@
+#' @title Reports tab
+#' @description Chart export module
+#' 
+#' @param id module id
+#' 
+#' @export
+
+reportsTabUI <- function(id){
+  ns <- NS(id)
+
+
+  fluidPage(
+    fluidRow(
+      column(10,
+        wellPanel(
+          class="reportPanel",
+          h3("Export Charts"),
+          span("Note: AE Timelines, Hepatic Explorer and Shift plot export is temporarily disabled, but will be included in v2.0. Charts implemented using shiny modules are not currently able to be exported, but may be added at a later date."),
+          hr(),
+          uiOutput(ns("checkboxes")),
+          downloadButton(ns("reportDL"), "Export Chart(s)")
+        )    
+      )
+    )
+  )
+
+}
+
+#' @title  Reports tab - server
+#' @description server for the chart export module
+#' 
+#' @param input Shiny input object
+#' @param output  Shiny output object
+#' @param session Shiny session object
+#' @param charts list containing safetyGraphics chart objects. see custom chart vignette for details.  
+#' @param data named list of current data sets [reactive]. 
+#' @param mapping tibble capturing the current data mappings [reactive].
+#' 
+#' @importFrom magrittr extract
+#' 
+#' @export
+
+reportsTab <- function(input, output, session, charts, data, mapping){
+
+  ns <- session$ns 
+
+  # create checkbox for selecting charts of interest
+  output$checkboxes <- renderUI({
+    # no support for modules or broken widgets yet
+    noExport <- c("aeTimelines","hepexplorer","safetyShiftPlot","tplyr_shift")
+    chart_type <- charts %>% map(., ~.$type) %>% unlist 
+    chart_name <- charts %>% map(., ~.$name) %>% unlist 
+    charts_keep <- ((! chart_type == "module") & (! chart_name %in% noExport))
+
+    charts_labels <- charts %>% map(., ~ .$label) %>% unlist
+    charts_vec <- names(charts)[charts_keep]
+
+    names(charts_vec) <- charts_labels[charts_keep]
+    checkboxGroupInput(
+      ns('chk'), 
+      choices = charts_vec, 
+      selected = charts_vec, 
+      label = "Select Charts for Export"
+    )
+  })
+
+
+  # subset charts based on checkbox selections
+  charts_keep <- reactive({
+    charts %>% magrittr::extract(input$chk)
+  })
+
+
+  # Set up report generation on download button click
+  output$reportDL <- downloadHandler(
+    filename = "safetyGraphicsReport.html",
+    content = function(file) {
+      # Copy the report file to a temporary directory before processing it, in case we don't
+      # have write permissions to the current working dir (which can happen when deployed).
+      templateReport <- system.file("report","safetyGraphicsReport.Rmd", package = "safetyGraphics")
+      tempReport <- file.path(tempdir(), "report.Rmd")
+      file.copy(templateReport, tempReport, overwrite = TRUE)
+      params <- list(
+        data = data(), 
+        mapping = mapping(), 
+        charts=charts_keep()
+      )
+
+      rmarkdown::render(tempReport,
+                        output_file = file,
+                        params = params,  ## pass in params
+                        envir = new.env(parent = globalenv())  ## eval in child of global env
+      )
+    }
+  )
+}

inst/report/safetyGraphicsReport.Rmd

@@ -0,0 +1,117 @@
+---
+output:
+  html_document
+
+params:
+  data: NA
+  mapping: NA
+  charts: NA
+
+
+---
+
+## Customized Interactive Safety Graphics {.tabset .tabset-fade} 
+
+```{r echo = FALSE}
+
+# Function to create chart-level params
+create_chart_params <- function(data, chart, mapping){
+  settingsList <-  safetyGraphics::generateMappingList(mapping, domain=chart$domain)
+  #subset data to specific domain (if specified)
+  if(chart$domain=="multiple"){
+    domainData <- data
+  }else{
+    domainData<- data[[chart$domain]]
+  }
+  params <- list(data=domainData, settings=settingsList)
+
+  #customize initial the parameters if desired - otherwise pass through domain level data and mapping)
+  if(utils::hasName(chart,"functions")){
+    if(utils::hasName(chart$workflow,"init")){
+      message(chart$name, " has an init.")
+      params <- do.call(chart$functions[[chart$workflow$init]], params)
+    }
+  }
+  return(params)
+}
+
+# Function to create chart
+create_chart <- function(chart, params){
+  if (chart$type=="htmlwidget"){
+    ###Html widget code
+    widgetParams <- function(params, settingsToJSON = TRUE){
+      widgetParams<-params
+      if(settingsToJSON){
+        widgetParams$settings <- jsonlite::toJSON(
+          widgetParams$settings,
+          auto_unbox = TRUE,
+          null = "null",  
+        )
+      }
+      widgetParams$ns <-chart$name  #Still not working quite right. May need to refactor widgets a bit to, since some use this parameter to select the location of the wrapper div. there's no easy way to set this to the random widget value (e.g. "htmlwidget-638ca0176b34007fbdf9")
+      return(widgetParams)
+    }
+
+    # shiny render function for the widget 
+    htmlwidgets::createWidget(
+      name = chart$name,
+      widgetParams(params),
+      package = chart$package,
+      sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress=TRUE, browser.external = TRUE),     
+    )  
+  } else {
+    ### static code
+    chartFunction <- chart$functions[[chart$workflow$main]]
+    do.call(chartFunction, chart_params)  
+  }  
+}
+```
+
+
+```{r results='asis', echo = FALSE, message=FALSE, warning = FALSE}
+library(safetyGraphics)
+library(knitr)
+
+
+create_chunk_title <- function(chart) {
+  sub_chunk <- paste0("### ",chart,"\n")
+  cat(sub_chunk)
+}
+
+create_chunk_chart <- function(chart, params, fig_height=7, fig_width=9) {
+  g_deparsed <- paste0(deparse(
+    function() {create_chart(chart, params)}
+  ), collapse = '')
+
+  sub_chunk <- paste0("
+  `","``{r sub_chunk_", floor(runif(1) * 10000), ", fig.height=",
+   fig_height, ", fig.width=", fig_width, ", echo=FALSE, message=FALSE, warning=FALSE}",
+  "\n(",
+    g_deparsed
+    , ")()",
+  "\n`","``
+  ",'\n')
+
+  cat(knitr::knit(text = knitr::knit_expand(text = sub_chunk), quiet = TRUE))
+}
+
+mapping <- params$mapping
+data <- params$data
+for (i in seq_along(names(params$charts))){
+  chart <- params$charts[[i]]
+  chart_params <- create_chart_params(data, chart, mapping)
+  create_chunk_title(chart$label)
+  create_chunk_chart(chart, chart_params)
+}
+
+```
+
+
+
+### Info
+
+#### Background
+The safetyGraphics package provides a framework for evaluation of clinical trial safety in R. Examples and additional documentation are available [here](https://github.com/ASA-DIA-InteractiveSafetyGraphics/safetyGraphics).
+
+safetyGraphics is an open source project built using standard web technology and will run in any modern web browser. The displays created are all dynamically linked to raw safety data which allows the tool to work with data from any safety system. The tool was originally created using Javascript/D3, but has been extended to an R tool as well using HTML Widgets.   
+