diff --git a/DESCRIPTION b/DESCRIPTION index 95664d68..3a1b85cf 100644 --- a/DESCRIPTION +++ b/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, diff --git a/NAMESPACE b/NAMESPACE index 997c1c6c..29ee4d2e 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/app_server.R b/R/app_server.R index 96b8a551..4d0b0bcf 100644 --- a/R/app_server.R +++ b/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])) diff --git a/R/app_ui.R b/R/app_ui.R index 775316cf..62e32f1f 100644 --- a/R/app_ui.R +++ b/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")) diff --git a/R/mod_reportsTab.R b/R/mod_reportsTab.R new file mode 100644 index 00000000..3b2176e1 --- /dev/null +++ b/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 + ) + } + ) +} \ No newline at end of file diff --git a/inst/report/safetyGraphicsReport.Rmd b/inst/report/safetyGraphicsReport.Rmd new file mode 100644 index 00000000..466ee5ed --- /dev/null +++ b/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. + diff --git a/man/reportsTab.Rd b/man/reportsTab.Rd new file mode 100644 index 00000000..7d3b60cb --- /dev/null +++ b/man/reportsTab.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_reportsTab.R +\name{reportsTab} +\alias{reportsTab} +\title{Reports tab - server} +\usage{ +reportsTab(input, output, session, charts, data, mapping) +} +\arguments{ +\item{input}{Shiny input object} + +\item{output}{Shiny output object} + +\item{session}{Shiny session object} + +\item{charts}{list containing safetyGraphics chart objects. see custom chart vignette for details.} + +\item{data}{named list of current data sets \link{reactive}.} + +\item{mapping}{tibble capturing the current data mappings \link{reactive}.} +} +\description{ +server for the chart export module +} diff --git a/man/reportsTabUI.Rd b/man/reportsTabUI.Rd new file mode 100644 index 00000000..6702c517 --- /dev/null +++ b/man/reportsTabUI.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_reportsTab.R +\name{reportsTabUI} +\alias{reportsTabUI} +\title{Reports tab} +\usage{ +reportsTabUI(id) +} +\arguments{ +\item{id}{module id} +} +\description{ +Chart export module +}