diff --git a/NAMESPACE b/NAMESPACE index a29c2a15..afff64e0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,12 +4,6 @@ export(add_chart) export(app_startup) export(chart_template) export(chartsNav) -export(chartsRenderModule) -export(chartsRenderModuleUI) -export(chartsRenderStatic) -export(chartsRenderStaticUI) -export(chartsRenderWidget) -export(chartsRenderWidgetUI) export(chartsTab) export(chartsTabUI) export(create_new_safetyGraphics_app) @@ -28,6 +22,9 @@ export(loadDataUI) export(loadDomains) export(loadDomainsUI) export(makeChartConfig) +export(makeChartConfigFunctions) +export(makeChartExport) +export(makeChartParams) export(makeChartSummary) export(makeMapping) export(mappingColumn) @@ -38,8 +35,6 @@ export(mappingSelect) export(mappingSelectUI) export(mappingTab) export(mappingTabUI) -export(reportsTab) -export(reportsTabUI) export(safetyGraphicsApp) export(safetyGraphicsInit) export(safetyGraphicsServer) @@ -66,8 +61,6 @@ importFrom(DT,renderDT) importFrom(listviewer,jsonedit) importFrom(listviewer,jsoneditOutput) importFrom(listviewer,renderJsonedit) -importFrom(magrittr,extract) -importFrom(pharmaRTF,write_rtf) importFrom(purrr,keep) importFrom(purrr,map) importFrom(purrr,map2) @@ -93,5 +86,6 @@ importFrom(stringr,str_detect) importFrom(stringr,str_split) importFrom(stringr,str_to_title) importFrom(stringr,str_to_upper) +importFrom(utils,hasName) importFrom(utils,zip) importFrom(yaml,write_yaml) diff --git a/R/app_startup.R b/R/app_startup.R index 8fb80b4a..bcbd8910 100644 --- a/R/app_startup.R +++ b/R/app_startup.R @@ -31,6 +31,14 @@ app_startup<-function(domainData=NULL, meta=NULL, charts=NULL, mapping=NULL, aut } } + # Drop charts where order is negative + orderDrops <- charts[purrr::map_lgl(charts, function(chart) chart$order < 0)] + if(length(orderDrops)>0){ + message("Dropped ", length(orderDrops), " charts: ",paste(names(orderDrops),collapse=", ")) + message("To display these charts, set the `order` parameter in the chart object or yaml file to a positive number.") + charts <- charts[purrr::map_lgl(charts, function(chart) chart$order >= 0)] + } + #Drop charts if data for required domain(s) is not found chart_drops <- charts %>% purrr::keep(~(!all(.x$domain %in% names(domainData)))) if(length(chart_drops)>0){ diff --git a/R/generateMappingList.R b/R/generateMappingList.R index 416047aa..97c13abe 100644 --- a/R/generateMappingList.R +++ b/R/generateMappingList.R @@ -25,6 +25,8 @@ generateMappingList <- function(settingsDF, domain=NULL, pull=FALSE){ if(is.null(domain)){ return(settingsList) + }else if(length(domain)>1){ + return(settingsList) }else{ return(settingsList[[domain]]) } diff --git a/R/makeChartConfig.R b/R/makeChartConfig.R index b5b97e1c..66ee593e 100644 --- a/R/makeChartConfig.R +++ b/R/makeChartConfig.R @@ -112,51 +112,12 @@ makeChartConfig <- function(dirs, packages="safetyCharts", packageLocation="conf message("`env` paramter missing or not set to 'safetyGraphics'") charts <- charts[purrr::map_lgl(charts, function(chart) chart$envValid)] } - - # Drop charts where order is negative - orderDrops <- charts[purrr::map_lgl(charts, function(chart) chart$order < 0)] - if(length(orderDrops)>0){ - message("Dropped ", length(orderDrops), " charts: ",paste(names(orderDrops),collapse=", ")) - message("To display these charts, set the `order` parameter in the chart object or yaml file to a positive number.") - charts <- charts[purrr::map_lgl(charts, function(chart) chart$order >= 0)] - } # sort charts based on order charts <- charts[order(purrr::map_dbl(charts, function(chart) chart$order))] message("Loaded ", length(charts), " charts: ",paste(names(charts),collapse=", ")) # Bind workflow functions to chart object - all_functions <- as.character(utils::lsf.str(".GlobalEnv")) - message("Global Functions: ",all_functions) - charts <- lapply(charts, - function(chart){ - if(utils::hasName(chart, "package")){ - package_functions <- as.character(utils::lsf.str(paste0("package:",chart$package))) - all_functions<-c(all_functions,package_functions) - } - - #search functions that include the charts name or the workflow function names - chart_function_names <- c() - for(query in c(chart$name, unlist(chart$workflow)) ){ - matches<-all_functions[str_detect(query, all_functions)] - chart_function_names <- c(chart_function_names, matches) - } - - chart$functions <- lapply(chart_function_names, match.fun) - names(chart$functions) <- chart_function_names - - # check that functions exist for specified workflows - workflow_found <- sum(unlist(chart$workflow) %in% chart_function_names) - workflow_total <- length(unlist(chart$workflow)[names(unlist(chart$workflow))!="widget"]) - message<-paste0(chart$name,": Found ", workflow_found, " of ",workflow_total, " workflow functions, and ", length(chart$functions)-workflow_found ," other functions.") - if(workflow_found == workflow_total){ - message("+ ",message) - }else{ - message("x ", message) - } - - return(chart) - } - ) + charts <- lapply(charts, makeChartConfigFunctions) return(charts) } diff --git a/R/makeChartConfigFunctions.R b/R/makeChartConfigFunctions.R new file mode 100644 index 00000000..8502fe10 --- /dev/null +++ b/R/makeChartConfigFunctions.R @@ -0,0 +1,92 @@ +#' Make Chart Config Functions +#' +#' Binds needed functions to a chart object based on chart type. +#' +#' @param chart chart object like the one generated by makeChartConfig(). +#' +#' @import purrr +#' +#' @return returns the chart object with a new functions object added. +#' +#' @export + +makeChartConfigFunctions <- function(chart){ + all_functions <- as.character(utils::lsf.str(".GlobalEnv")) + + if(utils::hasName(chart, "package")){ + package_functions <- as.character(utils::lsf.str(paste0("package:",chart$package))) + all_functions<-c(all_functions,package_functions) + } + + #search functions that include the charts name or the workflow function names + chart_function_names <- c() + for(query in c(chart$name, unlist(chart$workflow)) ){ + matches<-all_functions[str_detect(query, all_functions)] + chart_function_names <- c(chart_function_names, matches) + } + + chart$functions <- lapply(chart_function_names, match.fun) + names(chart$functions) <- chart_function_names + + # Define UI function unless one is provided + if(chart$type=="plot"){ + chart$functions$ui<-plotOutput + chart$functions$server<-renderPlot + chart$functions$main<-chart$functions[[chart$workflow$main]] + }else if(chart$type=="html"){ + chart$functions$ui<-htmlOutput + chart$functions$server<-renderText + chart$functions$main<-chart$functions[[chart$workflow$main]] + }else if(chart$type=="table"){ + chart$functions$ui<-DT::dataTableOutput + chart$functions$server<-function(expr ){ + DT::renderDataTable( + rownames = FALSE, + options = list( + pageLength = 20, + ordering = FALSE, + searching = FALSE + ) + ) + } + chart$functions$main<-chart$functions[[chart$workflow$main]] + #} + # }else if(chart$type=="rtf"){ + # chart$functions$ui<-div( + # downloadButton(ns("downloadRTF"), "Download RTF"), + # DT::dataTableOutput(ns("chart-wrap")) + # ) + }else if(chart$type=="htmlwidget"){ + # Helper functions for html widget render + widgetOutput <- function(outputId, width = "100%", height = "400px") { + htmlwidgets::shinyWidgetOutput(outputId, chart$workflow$widget, width, height, package=chart$package) + } + + renderWidget <- function(expr, env = parent.frame(), quoted = FALSE) { + if (!quoted) { expr <- substitute(expr) } # force quoted + htmlwidgets::shinyRenderWidget(expr, widgetOutput, env, quoted = TRUE) + } + + chart$functions$ui<-widgetOutput + chart$functions$server<-renderWidget + chart$functions$main<-htmlwidgets::createWidget + chart$workflow$main <- "htmlwidgets::createWidget" + + }else if (chart$type=="module"){ + chart$functions$ui<-chart$functions[[chart$workflow$ui]] + chart$functions$server<-callModule + chart$functions$main <- chart$functions[[chart$workflow$server]] + } + + # check that functions exist for specified workflows + workflow_found <- sum(unlist(chart$workflow) %in% chart_function_names) + workflow_total <- length(unlist(chart$workflow)[names(unlist(chart$workflow))!="widget"]) + message<-paste0(chart$name,": Found ", workflow_found, " of ",workflow_total, " workflow functions, and ", length(chart$functions)-workflow_found ," other functions.") + if(workflow_found == workflow_total){ + message("+ ",message) + }else{ + message("x ", message) + } + + return(chart) +} \ No newline at end of file diff --git a/R/makeChartExport.R b/R/makeChartExport.R new file mode 100644 index 00000000..4c1a1fb3 --- /dev/null +++ b/R/makeChartExport.R @@ -0,0 +1,112 @@ +#' Make Chart Config Functions +#' +#' Binds needed functions to a chart object based on chart type. +#' +#' @param chart chart object like the one generated by makeChartConfig(). +#' @param mapping mapping object like the one generatedf by makeMapping(). +#' +#' @import purrr +#' @importFrom utils hasName +#' +#' @return returns the chart object with an export script added. +#' +#' @export + +makeChartExport <- function(chart, mapping){ + # Load packages + packageScript<-c( + "library(yaml)", + paste0("library(",chart$package,")"), + "", + paste0("### Reproducible Code for ",chart$label, " (",chart$type,") ###"), + "" + ) + + # TODO: src custom functions identified in workflow. Probably not a big deal for v2.0 + + # Load data + demodata <- list( + labs="safetyData::adam_adlbc", + aes="safetyData::adam_adae", + dm="safetyData::adam_adsl" + ) + if(length(chart$domain)==1){ + dataLoad <- paste0("data<-",demodata[[chart$domain]]) + }else{ + + dataLoad<-c( + "data <- list(", + chart$domain %>% map_chr(~paste0(" ",.x, "=",demodata[[.x]])) %>% paste(collapse=",\n"), + ")" + ) + } + + dataScript <- c( + "#Load Data", + "#NOTE: Correct data names should be updated by user", + dataLoad, + "" + ) + + # Load mapping + mappingScript<-c( + "#Load mapping", + "#NOTE: mapping can also be saved as a .yaml and used for multiple charts.", + paste0('mapping_yaml<-"',as.yaml(mapping),'"'), + "mapping <- read_yaml(text=mapping_yaml)", + "" + ) + + # make parameters + if(utils::hasName(chart$workflow, "init")){ + paramScript <- c( + "# Create parameter list using custom initialization function", + paste0("params<-",chart$workflow$init,"(data,mapping)"), + "" + ) + }else{ + paramScript<-c( + "# Create Parameter list", + "params<-list(data=data, settings=mapping)", + "" + ) + } + + # format for widget (if needed) + if(chart$type =="htmlwidget"){ + paramScript <- c( + paramScript, + "widgetParams <- list(", + paste0(" name='",chart$workflow$widget,"',"), + paste0(" package='",chart$package,"',"), + " sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress=TRUE, browser.external = TRUE),", + " x=list()", + ")", + "widgetParams$x$data <- params$data", + "widgetParams$x$rSettings <- params$settings", + "widgetParams$x$settings <- jsonlite::toJSON(", + " params$settings,", + " auto_unbox = TRUE,", + ' null = "null"', + ")", + "params <- widgetParams", + "" + ) + } + + # Initialize the chart + initScript<-c( + "# Run the chart", + paste0("do.call(",chart$workflow$main,",params)") + ) + + fullScript<- c( + packageScript, + dataScript, + mappingScript, + paramScript, + initScript + ) + + return(fullScript) +} \ No newline at end of file diff --git a/R/makeChartParams.R b/R/makeChartParams.R new file mode 100644 index 00000000..ce76c55d --- /dev/null +++ b/R/makeChartParams.R @@ -0,0 +1,48 @@ +#' @title Make Chart Parameters +#' @description Updates raw data and mapping for use with a specific chart +#' +#' @param data list of domain-level data +#' @param chart list containing chart specifications +#' @param mapping data frame with current mapping +#' +#' @export + +makeChartParams <- function(data, chart, mapping){ + settingsList <- safetyGraphics::generateMappingList(mapping, domain=chart$domain) + + #subset data to specific domain (if specified) + if(length(chart$domain)>1){ + 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) + } + } + + # format parameters for htmlwidget + if(chart$type == "htmlwidget"){ + widgetParams <- list( + name=chart$workflow$widget, + package=chart$package, + sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress=TRUE, browser.external = TRUE), + x=list() + ) + widgetParams$x$data <- params$data + widgetParams$x$rSettings <- params$settings + widgetParams$x$settings <- jsonlite::toJSON( + params$settings, + auto_unbox = TRUE, + null = "null", + ) + params <- widgetParams + } + + return(params) +} \ No newline at end of file diff --git a/R/makeChartSummary.R b/R/makeChartSummary.R index a2040bdf..450b30f9 100644 --- a/R/makeChartSummary.R +++ b/R/makeChartSummary.R @@ -19,7 +19,7 @@ makeChartSummary<- function(chart, showLinks=TRUE, class="chart-header"){ target='_blank' ) ) - links<-div(tags$small("Links"), links, class="pull-right") + links<-div(tags$small("Links"), links) }else{ links<-NULL } diff --git a/R/mod_chartsNav.R b/R/mod_chartsNav.R index 6a5762bb..2641fe1e 100644 --- a/R/mod_chartsNav.R +++ b/R/mod_chartsNav.R @@ -7,6 +7,7 @@ #' chartsNav <- function(chart,ns){ + print(chart$name) appendTab( inputId = "safetyGraphicsApp", menuName = "Charts", diff --git a/R/mod_chartsRenderModule.R b/R/mod_chartsRenderModule.R deleted file mode 100644 index 97c3c964..00000000 --- a/R/mod_chartsRenderModule.R +++ /dev/null @@ -1,28 +0,0 @@ -#' @title Charts Module - render module chart UI -#' @description Charts Module - sub module for rendering a static chart -#' -#' @param id module id -#' @param customModUI UI function for chart module -#' -#' @export - -chartsRenderModuleUI <- function(id, customModUI){ - ns <- NS(id) - customModUI(ns("customModUI")) -} - -#' @title Charts Module - render static chart server -#' @description server for the display of the loaded data -#' -#' @param input Shiny input object -#' @param output Shiny output object -#' @param session Shiny session object -#' @param serverFunction server function for the module -#' @param params parameters to be passed to the widget (Reactive) -#' -#' @export - -chartsRenderModule <- function(input, output, session, serverFunction, params){ - ns <- session$ns - callModule(serverFunction, "customModUI", params) -} diff --git a/R/mod_chartsRenderStatic.R b/R/mod_chartsRenderStatic.R deleted file mode 100644 index 9b93ccc6..00000000 --- a/R/mod_chartsRenderStatic.R +++ /dev/null @@ -1,64 +0,0 @@ -#' @title Charts Module - render static chart UI -#' @description Charts Module - sub module for rendering a static chart -#' -#' @param id module id -#' @param type output type for the chart. Valid options are "plot", "html" and "table" -#' @export - -chartsRenderStaticUI <- function(id, type){ - ns <- NS(id) - if(type=="plot"){ - plotOutput(ns("staticPlot")) - } else if(type=="html"){ - htmlOutput(ns("staticHTML")) - } else if(type=="table"){ - DT::dataTableOutput(ns("staticTable")) - } else if(type == "rtf") { - div( - downloadButton(ns("downloadRTF"), "Download RTF"), - DT::dataTableOutput(ns("rtfTable")) - ) - - } - -} - -#' @title Charts Module - render static chart server -#' @description server for the display of the loaded data -#' -#' @param input Shiny input object -#' @param output Shiny output object -#' @param session Shiny session object -#' @param chartFunction function to generate the chart. -#' @param params parameters to be passed to the widget (Reactive) -#' @param type output type for the chart. Valid options are "plot", "html" and "table" -#' -#' @importFrom pharmaRTF write_rtf -#' -#' @export - -chartsRenderStatic <- function(input, output, session, chartFunction, params, type){ - ns <- session$ns - if(type=="plot"){ - output[["staticPlot"]] <- renderPlot(do.call(chartFunction,params())) - }else if(type=="html"){ - output[["staticHTML"]] <- renderText(do.call(chartFunction,params())) - }else if(type=="table"){ - output[["staticTable"]] <- DT::renderDataTable(do.call(chartFunction,params()), rownames = FALSE, - options = list(pageLength = 20, - ordering = FALSE, - searching = FALSE)) - } else if(type == "rtf") { - output[["rtfTable"]] <- DT::renderDataTable(do.call(chartFunction,params())$table, rownames = FALSE, - options = list(pageLength = 20, - ordering = FALSE, - searching = FALSE)) - - output[["downloadRTF"]] <- downloadHandler( - filename = "SafetyGraphics.rtf", - content = function(file) { - pharmaRTF::write_rtf(do.call(chartFunction,params()), file = file) - } - ) - } -} diff --git a/R/mod_chartsRenderWidget.R b/R/mod_chartsRenderWidget.R deleted file mode 100644 index 37628085..00000000 --- a/R/mod_chartsRenderWidget.R +++ /dev/null @@ -1,78 +0,0 @@ -#' @title Charts Module - render static chart UI -#' @description Charts Module - sub module for rendering a static chart -#' -#' @param id module id -#' @param chart chart name - must match the name of a widget in the specified pacakge -#' @param package pacakge containing the widget -#' -#' @export - -chartsRenderWidgetUI <- function(id, chart, package){ - # shiny output binding for a widget - widgetOutput <- function(outputId, width = "100%", height = "400px") { - htmlwidgets::shinyWidgetOutput(outputId, chart, width, height, package=package) - } - ns <- NS(id) - widgetOutput(ns("widgetChart")) -} - -#' @title Charts Module - render static chart server -#' @description server for the display of the loaded data -#' -#' @param input Shiny input object -#' @param output Shiny output object -#' @param session Shiny session object -#' @param chart chart name - must match the name of a widget in the specified pacakge -#' @param package package containing the widget. Note that package name is required for htmlwidgets. -#' @param params parameters to be passed to the widget (Reactive) -#' @param settingsToJSON convert param$settings to json? Default = TRUE -#' -#' @export - -chartsRenderWidget <- function( - input, - output, - session, - chart, - package, - params, - settingsToJSON=TRUE -){ - ns <- session$ns - message("chartRenderWidget() starting for ", chart) - # shiny output binding - widgetOutput <- function(outputId, width = "100%", height = "400px") { - htmlwidgets::shinyWidgetOutput(outputId, chart, width, height, package=package) - } - - # shiny render function for a widget - renderWidget <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - htmlwidgets::shinyRenderWidget(expr, widgetOutput, env, quoted = TRUE) - } - - widgetParams <- reactive({ - print("Getting widget params") - widgetParams<-params() - if(settingsToJSON){ - widgetParams$settings <- jsonlite::toJSON( - widgetParams$settings, - auto_unbox = TRUE, - null = "null", - ) - } - widgetParams$ns <- ns("widgetChart") - return(widgetParams) - }) - - # shiny render function for the widget - output[["widgetChart"]] <- renderWidget({ - message("Rendering Widget") - htmlwidgets::createWidget( - name = chart, - widgetParams(), - package = package, - sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress=TRUE, browser.external = TRUE), - ) - }) -} diff --git a/R/mod_chartsTab.R b/R/mod_chartsTab.R index 0add7e9b..aeaacde6 100644 --- a/R/mod_chartsTab.R +++ b/R/mod_chartsTab.R @@ -10,22 +10,11 @@ #' @export chartsTabUI <- function(id, chart){ - ns <- NS(id) - # Chart header with description and links - header<-makeChartSummary(chart) - chartWrap <- NULL - if(tolower(chart$type=="module")){ - #render the module UI - chartWrap <- chartsRenderModuleUI(id=ns("wrap"), chart$functions[[chart$workflow$ui]]) - }else if(tolower(chart$type=="htmlwidget")){ - #render the widget - chartWrap<-chartsRenderWidgetUI(id=ns("wrap"),chart=chart$workflow$widget, package=chart$package) - }else{ - #create the static or plotly chart - chartWrap<-chartsRenderStaticUI(id=ns("wrap"), type=chart$type) - } - - return(list(header, chartWrap)) + ns <- shiny::NS(id) + header<-div(class=ns("header"), makeChartSummary(chart)) + chartWrap<-chart$functions$ui(ns("chart-wrap")) + + return(list(header, chartWrap)) } #' @title home tab - server @@ -40,64 +29,81 @@ chartsTabUI <- function(id, chart){ #' #' @export -#chartsTab <- function(input, output, session, chart, type, package, chartFunction, initFunction, domain, data, mapping){ -chartsTab <- function(input, output, session, chart, data, mapping){ - - ns <- session$ns - message("chartsTab() starting for ",chart$name) - - params <- reactive({ - #convert settings from data frame to list and subset to specified domain (if any) - settingsList <- safetyGraphics::generateMappingList(mapping(), domain=chart$domain) +chartsTab <- function(input, output, session, chart, data, mapping){ + ns <- session$ns + message("chartsTab() starting for ",chart$name) - #subset data to specific domain (if specified) - if(length(chart$domain)>1){ - domainData <- data() - }else{ - domainData<- data()[[chart$domain]] - } - params <- list(data=domainData, settings=settingsList) + print(chart$label) + # Initialize chart-specific parameters + params <- reactive({ + makeChartParams( + data = data(), + mapping = mapping(), + chart = chart + ) + }) - #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.") - print(chart$functions[chart$workflow$init]) - params <- do.call(chart$functions[[chart$workflow$init]], params) - } - } - return(params) + # Draw the chart + if(chart$type=="module"){ + callModule(chart$functions$main, "chart-wrap", params) + }else{ + output[["chart-wrap"]] <- chart$functions$server( + do.call( + chart$functions$main, + params() + ) + ) + + # Downolad R script + insertUI( + paste0(".",ns("header"), " .chart-header"), + where="beforeEnd", + ui=downloadButton(ns("scriptDL"), "R script", class="pull-right btn-xs dl-btn") + ) + + mapping_list<-reactive({ + mapping_list <- generateMappingList(mapping() %>% filter(.data$domain %in% chart$domain)) + if(length(mapping_list)==1){ + mapping_list <- mapping_list[[1]] + } + return(mapping_list) }) - if(tolower(chart$type=="module")){ - #render the module UI - message("chartsTab() is initializing a module at ", ns("wrap")) - serverFunction <- chart$functions[[chart$workflow$server]] - callModule( - module=chartsRenderModule, - id="wrap", - serverFunction=serverFunction, - params=params - ) - }else if(tolower(chart$type=="htmlwidget")){ - message("chartsTab() is initializing a widget at ", ns("wrap")) - message("chart is ", chart$workflow$widget, "; package is ", chart$package) - callModule( - module=chartsRenderWidget, - id="wrap", - chart=chart$workflow$widget, - package=chart$package, - params=params + output$scriptDL <- downloadHandler( + filename = paste0("sg-",chart$name,".R"), + content = function(file) { + writeLines(makeChartExport(chart, mapping_list()), file) + } + ) + + # Set up chart export button + insertUI( + paste0(".",ns("header"), " .chart-header"), + where="beforeEnd", + ui=downloadButton(ns("reportDL"), "html report", class="pull-right btn-primary btn-xs") + ) + + output$reportDL <- downloadHandler( + filename = paste0("sg-",chart$name,".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) + report_params <- list( + data = data(), + mapping = mapping(), + chart = chart ) - }else{ - #create the static or plotly chart - chartFunction <- chart$functions[[chart$workflow$main]] - callModule( - module=chartsRenderStatic, - id="wrap", - chartFunction=chartFunction, - params=params, - type=chart$type + + rmarkdown::render( + tempReport, + output_file = file, + params = report_params, ## pass in params + envir = new.env(parent = globalenv()) ## eval in child of global env ) - } + } + ) + } } diff --git a/R/mod_reportsTab.R b/R/mod_reportsTab.R deleted file mode 100644 index 3d4f5aae..00000000 --- a/R/mod_reportsTab.R +++ /dev/null @@ -1,94 +0,0 @@ -#' @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"), - 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 - chart_type <- charts %>% map(., ~.$type) %>% unlist - chart_export <- charts %>% map(., ~.$export) %>% unlist - charts_keep <- ((! chart_type == "module") & (chart_export)) - - 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/R/mod_safetyGraphicsServer.R b/R/mod_safetyGraphicsServer.R index 2eb5a414..cfa78086 100644 --- a/R/mod_safetyGraphicsServer.R +++ b/R/mod_safetyGraphicsServer.R @@ -31,7 +31,6 @@ safetyGraphicsServer <- function(input, output, session, meta, mapping, domainDa current_mapping=current_mapping ) - callModule(homeTab, "home") #Initialize Chart UI - Adds subtabs to chart menu - this initializes initializes chart UIs @@ -48,11 +47,8 @@ safetyGraphicsServer <- function(input, output, session, meta, mapping, domainDa 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) + #Setting tab callModule(settingsTab, "settings", domains = domainData, metadata=meta, mapping=current_mapping, charts = charts) - } diff --git a/R/mod_safetyGraphicsUI.R b/R/mod_safetyGraphicsUI.R index 8842f147..665c1a1a 100644 --- a/R/mod_safetyGraphicsUI.R +++ b/R/mod_safetyGraphicsUI.R @@ -47,7 +47,6 @@ safetyGraphicsUI <- function(id, meta, domainData, mapping, standards){ tabPanel("Mapping", icon=icon("map"), mappingTabUI(ns("mapping"), meta, domainData, mapping, standards)), tabPanel("Filtering", icon=icon("filter"), filterTabUI(ns("filter"))), navbarMenu('Charts', icon=icon("chart-bar")), - tabPanel("Reports", icon=icon("file-alt"), reportsTabUI(ns("reports"))), tabPanel('',icon=icon("cog"), settingsTabUI(ns("settings"))) ), participant_badge diff --git a/inst/report/safetyGraphicsReport.Rmd b/inst/report/safetyGraphicsReport.Rmd index 39977c01..83c5f44b 100644 --- a/inst/report/safetyGraphicsReport.Rmd +++ b/inst/report/safetyGraphicsReport.Rmd @@ -1,116 +1,83 @@ --- output: html_document - params: data: NA mapping: NA - charts: NA - - + chart: NA +title: "{safetyGraphics}: `r params$chart$label` report" --- -## 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(length(chart$domain)>1){ - 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", - ) - } - return(widgetParams) - } - - # shiny render function for the widget - htmlwidgets::createWidget( - name = chart$workflow$widget, - 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) - } -} -``` +```{css, echo=FALSE} +.chart-md{ + padding: 0.5em 0.5em 0.2em 0.5em; + background: #e7e7e7; + margin-right: -15px; + margin-left: -15px; + margin-bottom: 15px; + border: 1px solid #bbb; +} -```{r results='asis', echo = FALSE, message=FALSE, warning = FALSE} -library(safetyGraphics) -library(knitr) +.chart-md *{ + display:inline-block; + padding-left:0.4em; +} +.chart-md strong{ + font-size:1.2em; +} -create_chunk_title <- function(chart) { - sub_chunk <- paste0("### ",chart,"\n") - cat(sub_chunk) +.chart-md small{ + font-size:0.8em; + color:#999; } -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)) +.chart-md .chart-link{ + padding-right:0.5em; } +``` + +```{r results='asis', echo = FALSE, message=FALSE, warning = FALSE} +library(safetyGraphics) +library(yaml) 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) +chart<-params$chart + +header <- makeChartSummary(chart, class="chart-md") +chart_params <- makeChartParams(data, chart, mapping) + +mapping_list<-generateMappingList(mapping %>% filter(domain %in% chart$domain)) +if(length(mapping_list)==1){ + mapping_list <- mapping_list[[1]] } ``` +## {.tabset .tabset-fade} +### `r params$chart$label` +`r header` +```{r fig.height=7, fig.width=9, echo=FALSE, message=FALSE, warning=FALSE} + do.call(chart$functions$main, chart_params) +``` -### Info +### Details #### 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. +This chart was generated using the safetyGraphics shiny app. 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). + +#### Chart Code + +This chart can be re-run using the code below after updating to load your data. + +``` +`r paste(makeChartExport(chart, mapping_list),collapse="\n")` +``` + + diff --git a/inst/www/index.css b/inst/www/index.css index f3522266..efdc5f3c 100644 --- a/inst/www/index.css +++ b/inst/www/index.css @@ -71,6 +71,7 @@ table.metatable.dataTable tr > td:last-of-type, table.metatable.trdataTable tr > /* Formatting for charts metadata on chart page headers */ .chart-header{ + height:35px; background: #e7e7e7; padding: 0.5em 0.5em 0.2em 0.5em; margin-top:-20px; @@ -98,6 +99,10 @@ table.metatable.dataTable tr > td:last-of-type, table.metatable.trdataTable tr > padding-right:0.5em; } +.chart-header .btn{ + margin-right:0.5em; +} + /* Formatting for charts items in init item sorter */ .chart-sortable{ font-size:0.8em; @@ -142,3 +147,5 @@ table.metatable.dataTable tr > td:last-of-type, table.metatable.trdataTable tr > background-color: #d1ecf1; border:1px solid #bee5eb; } + + diff --git a/inst/www/index_old.css b/inst/www/index_old.css deleted file mode 100644 index 46b5b5b7..00000000 --- a/inst/www/index_old.css +++ /dev/null @@ -1,25 +0,0 @@ -.selectize-input.not-full{ - border-color:red; -} - -.selectize-input.full{ - border-color:green; -} - - -.field-wrap{ - padding-left:1em; -} - -.mapping-domain{ -padding:0.5em; -border:1px solid black; -border-radius:0.2em; -margin-bottom:1em; -max-width:45%; -} - -table.dataTable tr > td:last-of-type, table.dataTable tr > th:last-of-type { - border-left:2px solid black; - background:#d0d1e6; -} diff --git a/man/chartsRenderModule.Rd b/man/chartsRenderModule.Rd deleted file mode 100644 index 7e966588..00000000 --- a/man/chartsRenderModule.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderModule.R -\name{chartsRenderModule} -\alias{chartsRenderModule} -\title{Charts Module - render static chart server} -\usage{ -chartsRenderModule(input, output, session, serverFunction, params) -} -\arguments{ -\item{input}{Shiny input object} - -\item{output}{Shiny output object} - -\item{session}{Shiny session object} - -\item{serverFunction}{server function for the module} - -\item{params}{parameters to be passed to the widget (Reactive)} -} -\description{ -server for the display of the loaded data -} diff --git a/man/chartsRenderModuleUI.Rd b/man/chartsRenderModuleUI.Rd deleted file mode 100644 index be311933..00000000 --- a/man/chartsRenderModuleUI.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderModule.R -\name{chartsRenderModuleUI} -\alias{chartsRenderModuleUI} -\title{Charts Module - render module chart UI} -\usage{ -chartsRenderModuleUI(id, customModUI) -} -\arguments{ -\item{id}{module id} - -\item{customModUI}{UI function for chart module} -} -\description{ -Charts Module - sub module for rendering a static chart -} diff --git a/man/chartsRenderStatic.Rd b/man/chartsRenderStatic.Rd deleted file mode 100644 index 0643bd90..00000000 --- a/man/chartsRenderStatic.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderStatic.R -\name{chartsRenderStatic} -\alias{chartsRenderStatic} -\title{Charts Module - render static chart server} -\usage{ -chartsRenderStatic(input, output, session, chartFunction, params, type) -} -\arguments{ -\item{input}{Shiny input object} - -\item{output}{Shiny output object} - -\item{session}{Shiny session object} - -\item{chartFunction}{function to generate the chart.} - -\item{params}{parameters to be passed to the widget (Reactive)} - -\item{type}{output type for the chart. Valid options are "plot", "html" and "table"} -} -\description{ -server for the display of the loaded data -} diff --git a/man/chartsRenderStaticUI.Rd b/man/chartsRenderStaticUI.Rd deleted file mode 100644 index 85308dfe..00000000 --- a/man/chartsRenderStaticUI.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderStatic.R -\name{chartsRenderStaticUI} -\alias{chartsRenderStaticUI} -\title{Charts Module - render static chart UI} -\usage{ -chartsRenderStaticUI(id, type) -} -\arguments{ -\item{id}{module id} - -\item{type}{output type for the chart. Valid options are "plot", "html" and "table"} -} -\description{ -Charts Module - sub module for rendering a static chart -} diff --git a/man/chartsRenderWidget.Rd b/man/chartsRenderWidget.Rd deleted file mode 100644 index 70c657a8..00000000 --- a/man/chartsRenderWidget.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderWidget.R -\name{chartsRenderWidget} -\alias{chartsRenderWidget} -\title{Charts Module - render static chart server} -\usage{ -chartsRenderWidget( - input, - output, - session, - chart, - package, - params, - settingsToJSON = TRUE -) -} -\arguments{ -\item{input}{Shiny input object} - -\item{output}{Shiny output object} - -\item{session}{Shiny session object} - -\item{chart}{chart name - must match the name of a widget in the specified pacakge} - -\item{package}{package containing the widget. Note that package name is required for htmlwidgets.} - -\item{params}{parameters to be passed to the widget (Reactive)} - -\item{settingsToJSON}{convert param$settings to json? Default = TRUE} -} -\description{ -server for the display of the loaded data -} diff --git a/man/chartsRenderWidgetUI.Rd b/man/chartsRenderWidgetUI.Rd deleted file mode 100644 index 6d93363a..00000000 --- a/man/chartsRenderWidgetUI.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mod_chartsRenderWidget.R -\name{chartsRenderWidgetUI} -\alias{chartsRenderWidgetUI} -\title{Charts Module - render static chart UI} -\usage{ -chartsRenderWidgetUI(id, chart, package) -} -\arguments{ -\item{id}{module id} - -\item{chart}{chart name - must match the name of a widget in the specified pacakge} - -\item{package}{pacakge containing the widget} -} -\description{ -Charts Module - sub module for rendering a static chart -} diff --git a/man/makeChartConfigFunctions.Rd b/man/makeChartConfigFunctions.Rd new file mode 100644 index 00000000..b581ab70 --- /dev/null +++ b/man/makeChartConfigFunctions.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeChartConfigFunctions.R +\name{makeChartConfigFunctions} +\alias{makeChartConfigFunctions} +\title{Make Chart Config Functions} +\usage{ +makeChartConfigFunctions(chart) +} +\arguments{ +\item{chart}{chart object like the one generated by makeChartConfig().} +} +\value{ +returns the chart object with a new functions object added. +} +\description{ +Binds needed functions to a chart object based on chart type. +} diff --git a/man/makeChartExport.Rd b/man/makeChartExport.Rd new file mode 100644 index 00000000..2d22998d --- /dev/null +++ b/man/makeChartExport.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeChartExport.R +\name{makeChartExport} +\alias{makeChartExport} +\title{Make Chart Config Functions} +\usage{ +makeChartExport(chart, mapping) +} +\arguments{ +\item{chart}{chart object like the one generated by makeChartConfig().} + +\item{mapping}{mapping object like the one generatedf by makeMapping().} +} +\value{ +returns the chart object with an export script added. +} +\description{ +Binds needed functions to a chart object based on chart type. +} diff --git a/man/makeChartParams.Rd b/man/makeChartParams.Rd new file mode 100644 index 00000000..09b47c83 --- /dev/null +++ b/man/makeChartParams.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeChartParams.R +\name{makeChartParams} +\alias{makeChartParams} +\title{Make Chart Parameters} +\usage{ +makeChartParams(data, chart, mapping) +} +\arguments{ +\item{data}{list of domain-level data} + +\item{chart}{list containing chart specifications} + +\item{mapping}{data frame with current mapping} +} +\description{ +Updates raw data and mapping for use with a specific chart +} diff --git a/man/reportsTab.Rd b/man/reportsTab.Rd deleted file mode 100644 index 7d3b60cb..00000000 --- a/man/reportsTab.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% 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 deleted file mode 100644 index 6702c517..00000000 --- a/man/reportsTabUI.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% 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 -} diff --git a/tests/testthat/module_examples/chartsRenderStatic/app.R b/tests/testthat/module_examples/chartsRenderStatic/app.R deleted file mode 100644 index 17d6b394..00000000 --- a/tests/testthat/module_examples/chartsRenderStatic/app.R +++ /dev/null @@ -1,99 +0,0 @@ -library(shiny) -library(safetyGraphics) -library(ggplot2) -library(dplyr) - -data <- list(labs=safetyData::adam_adlbc, aes=safetyData::adam_adae) -mapping <- list(measure_col="PARAM", value_col="AVAL") -params<- reactive({list(data=data,settings=mapping)}) - -# Test app code -ui <- tagList( - tags$head( - tags$link( - rel = "stylesheet", - type = "text/css", - href = "index.css" - ) - ), - fluidPage( - h2("Example 1: Basic Chart - Hello world"), - chartsRenderStaticUI("HelloWorld", type="plot"), - h2("Example 2: Boxplot using data and settings"), - chartsRenderStaticUI("BoxPlot",type="plot"), - h2("Example 3: Boxplot using custom init"), - chartsRenderStaticUI("BoxPlot2",type="plot"), - ) -) - -server <- function(input,output,session){ - - #Example 1 - helloWorld <- function(data,settings){ - plot(-1:1, -1:1) - text(runif(20, -1,1),runif(20, -1,1),"Hello World") - } - - callModule( - chartsRenderStatic, - "HelloWorld", - chartFunction=helloWorld, - params=reactive({list()}), - type="plot" - ) - - #Example 2 - boxPlot <- function(data,settings){ - mapped_data <- data[['labs']] %>% - select(CustomValue = settings[["value_col"]], CustomMeasure = settings[["measure_col"]])%>% - filter(!is.na(CustomValue)) - ggplot(data = mapped_data, aes(x = CustomMeasure, y = CustomValue)) + - geom_boxplot() + - scale_y_log10() + - theme_bw() + - theme( - axis.text.x = element_text(angle = 25, hjust = 1), - axis.text = element_text(size = 12), - axis.title = element_text(size = 12) - ) - } - - callModule( - chartsRenderStatic, - "BoxPlot", - chartFunction=boxPlot, - params=params, - type="plot" - ) - - #Example 3 - dataInit <- function(data,settings){ - mapped_data <- data[['labs']] %>% - select(Value = settings[["value_col"]], Measure = settings[["measure_col"]])%>% - filter(!is.na(Value)) - settings$boxcolor="blue" - return(list(data=mapped_data,settings=settings)) - } - - boxPlot2 <- function(data,settings){ - ggplot(data = data, aes(x = Measure, y = Value)) + - geom_boxplot(fill = settings[["boxcolor"]]) + - scale_y_log10() + - theme_bw() + - theme( - axis.text.x = element_text(angle = 25, hjust = 1), - axis.text = element_text(size = 12), - axis.title = element_text(size = 12) - ) - } - - callModule( - chartsRenderStatic, - "BoxPlot2", - chartFunction=boxPlot2, - params=reactive({dataInit(data=data,settings=mapping)}), - type="plot" - ) -} - -shinyApp(ui, server) \ No newline at end of file diff --git a/tests/testthat/module_examples/chartsRenderStatic/www/index.css b/tests/testthat/module_examples/chartsRenderStatic/www/index.css deleted file mode 100644 index 0625ad68..00000000 --- a/tests/testthat/module_examples/chartsRenderStatic/www/index.css +++ /dev/null @@ -1,5 +0,0 @@ -table.dataTable tr > td:last-of-type, table.dataTable tr > th:last-of-type { - border-left:2px solid black; - background:#d0d1e6; -} - diff --git a/tests/testthat/module_examples/chartsRenderWidget/app.R b/tests/testthat/module_examples/chartsRenderWidget/app.R deleted file mode 100644 index e2c33f04..00000000 --- a/tests/testthat/module_examples/chartsRenderWidget/app.R +++ /dev/null @@ -1,113 +0,0 @@ -library(shiny) -library(safetyGraphics) -library(ggplot2) -library(dplyr) -library(htmlwidgets) -library(shinydashboard) - -domainData <- list(labs=safetyData::adam_adlbc, aes=safetyData::adam_adae) -standards <- names(domainData) %>% lapply(function(domain){ - return(detectStandard(domain=domain, data = domainData[[domain]], meta=meta)) -}) -names(standards)<-names(domainData) -mapping_list <- standards %>% lapply(function(standard){ - return(standard[["mapping"]]) -}) -mapping<-bind_rows(mapping_list, .id = "domain") -mappingLabs <- generateMappingList(mapping,domain="labs", pull=TRUE) -mappingAEs <- generateMappingList(mapping,domain="aes", pull=TRUE) - -# Test app code - -header <- dashboardHeader(title = span("chartRendererWidget module Test page")) -body<-dashboardBody( - tabItems( - # tabItem( - # tabName="ex1-tab", - # { - # h2("Example 1 - hepexplorer - called directly from safetyCharts hepexplorer") - # chartsRenderWidgetUI("ex1",chart="hepexplorer",package="safetyCharts") - # } - - # ), - tabItem( - tabName="ex2-tab", - { - h2("Example 2 - AE Explorer - called from safetyCharts using custom init function") - chartsRenderWidgetUI("ex2",chart="aeExplorer",package="safetyCharts") - } - ), - tabItem( - tabName="ex3-tab", - { - h2("Example 3 - Results over time - called from safetyCharts") - chartsRenderWidgetUI("ex3",chart="safetyResultsOverTime",package="safetyCharts") - } - ) - ) -) - -sidebar <- shinydashboard::dashboardSidebar( - shinydashboard::sidebarMenu( - id = "sidebar_tabs", - # menuItem(text = 'Ex1: Hepatic explorer', tabName = 'ex1-tab', icon = icon('angle-right')), - menuItem(text = 'Ex2: AE Explorer', tabName = 'ex2-tab', icon = icon('angle-right')), - menuItem(text = 'Ex3: Safety Results Over Time', tabName = 'ex3-tab', icon = icon('angle-right')) - ) -) - - -ui <- tagList( - tags$head( - tags$link( - rel = "stylesheet", - type = "text/css", - href = "index.css" - ) - ), - dashboardPage(header=header, sidebar=sidebar, body=body) -) - -server <- function(input,output,session){ - paramsLabs <- reactive({list(data=domainData[["labs"]],settings=mappingLabs)}) - # Example 1 - hep explorer - # callModule( - # chartsRenderWidget, - # "ex1", - # chart="hepexplorer", - # package="safetyCharts", - # params=paramsLabs - # ) - - # Example 2 - AE Explorer - initAEE <- function(data, settings){ - settings$variables=list( - major=settings[["bodsys_col"]], - minor=settings[["term_col"]], - group="STUDYID", - id=settings[["id_col"]], - filters=list(), - details=list() - ) - return(list(data=data,settings=settings)) - } - paramsAEs <- reactive({initAEE(data=domainData[["aes"]],settings=mappingAEs)}) - callModule( - chartsRenderWidget, - "ex2", - chart="aeExplorer", - package="safetyCharts", - params=paramsAEs - ) - - #Example 3 - results over time - callModule( - chartsRenderWidget, - "ex3", - chart="safetyResultsOverTime", - package="safetyCharts", - params=paramsLabs - ) -} - -shinyApp(ui, server) \ No newline at end of file diff --git a/tests/testthat/module_examples/chartsRenderWidget/www/index.css b/tests/testthat/module_examples/chartsRenderWidget/www/index.css deleted file mode 100644 index 0625ad68..00000000 --- a/tests/testthat/module_examples/chartsRenderWidget/www/index.css +++ /dev/null @@ -1,5 +0,0 @@ -table.dataTable tr > td:last-of-type, table.dataTable tr > th:last-of-type { - border-left:2px solid black; - background:#d0d1e6; -} - diff --git a/tests/testthat/module_examples/chartsTab/app.R b/tests/testthat/module_examples/chartsTab/app.R index d5dfb663..013bc3f6 100644 --- a/tests/testthat/module_examples/chartsTab/app.R +++ b/tests/testthat/module_examples/chartsTab/app.R @@ -7,17 +7,92 @@ library(shinydashboard) library(safetyexploreR) -domainData <- list(labs=safetyData::adam_adlbc, aes=safetyData::adam_adae) -standards <- names(domainData) %>% lapply(function(domain){ - return(detectStandard(domain=domain, data = domainData[[domain]], meta=meta)) -}) -names(standards)<-names(domainData) -mapping_list <- standards %>% lapply(function(standard){ - return(standard[["mapping"]]) -}) -mapping<-bind_rows(mapping_list, .id = "domain") +# Prep sample mapping and data objects +domainData <- list( + labs=safetyData::adam_adlbc, + aes=safetyData::adam_adae, + dm=safetyData::adam_adsl +) + +mapping <- makeMapping(domainData, meta=safetyGraphics::meta, autoMapping=TRUE, customMapping=NULL) dataR<-reactive({domainData}) -mappingR<-reactive({mapping}) +mappingR<-reactive({mapping$mapping}) + +# Import safetyCharts chart objects and activate a module and static graphic +charts <- makeChartConfig() + +# Custom charts +# Example 4 - hello world +helloWorld <- function(data,settings){ + plot(-1:1, -1:1) + text(runif(20, -1,1),runif(20, -1,1),"Hello World") +} + +helloworld_chart<-list( + name="HelloWorld", + label="Hello World!", + type="plot", + domain="aes", + workflow=list( + main="helloWorld" + ) +) +helloworld_chart <- makeChartConfigFunctions(helloworld_chart) + +# Example 5 - box plot +boxPlot <- function(data,settings){ + mapped_data <- data %>% + select(CustomValue = settings$value_col, CustomMeasure = settings$measure_col)%>% + filter(!is.na(CustomValue)) + ggplot(data = mapped_data, aes(x = CustomMeasure, y = CustomValue)) + + geom_boxplot() + + scale_y_log10() + + theme_bw() + + theme(axis.text.x = element_text(angle = 25, hjust = 1), + axis.text = element_text(size = 12), + axis.title = element_text(size = 12)) +} + +box1_chart<-list( + name="Box1", + label="Standard Box plot", + type="plot", + domain="labs", + workflow=list( + main="boxPlot" + ) +) +box1_chart <- makeChartConfigFunctions(box1_chart) + +# Example 6 - custom boxplot +dataInit <- function(data,settings){ + mapped_data <- data %>% + select(Value = settings[["value_col"]], Measure = settings[["measure_col"]])%>% + filter(!is.na(Value)) + settings$boxcolor="blue" + return(list(data=mapped_data,settings=settings)) +} + +boxPlot2 <- function(data,settings){ + ggplot(data = data, aes(x = Measure, y = Value)) + + geom_boxplot(fill = settings[["boxcolor"]]) + + scale_y_log10() + + theme_bw() + + theme(axis.text.x = element_text(angle = 25, hjust = 1), + axis.text = element_text(size = 12), + axis.title = element_text(size = 12)) +} +box2_chart<-list( + name="Box2", + label="Custom Box plot", + type="plot", + domain="labs", + workflow=list( + main="boxPlot2", + init="dataInit" + ) +) +box2_chart <- makeChartConfigFunctions(box2_chart) # Test app code header <- dashboardHeader(title = span("chartRendererWidget module Test page")) @@ -26,44 +101,43 @@ body<-dashboardBody( tabItem( tabName="ex1-tab", { - h2("Example 1 - hepexplorer- called directly from safetyGraphics hepexplorer") - chartsTabUI("ex1",name="hepexplorer",package="safetyCharts",label="Hepatic Explorer",type="htmlwidget") + h2("Example 1 - hepexplorer- called directly from safetyCharts") + chartsTabUI("ex1",chart=charts[["hepExplorer"]]) } - - ), + ), tabItem( tabName="ex2-tab", { - h2("Example 2 - AE Explorer - called from safetyexploreR using custom init function") - chartsTabUI("ex2",name="aeExplorer",package="safetyexploreR",label="AE Explorer",type="htmlwidget") + h2("Example 2 - AE Explorer - called from safetyCharts with custom init") + chartsTabUI("ex2",chart=charts[["aeExplorer"]]) } ), tabItem( tabName="ex3-tab", { - h2("Example 3 - Results over time - called from safetyexploreR") - chartsTabUI("ex3",name="safetyResultsOverTime",label="Lab Results Over Time", package="safetyexploreR",type="htmlwidget") + h2("Example 3 - Results over time - called from safetyCharts") + chartsTabUI("ex3",chart=charts[["safetyResultsOverTime"]]) } ), tabItem( tabName="ex4-tab", { h2("Example 4 - Helloworld static chart") - chartsTabUI("ex4",name="HelloWorld",label="Hello World",type="plot") + chartsTabUI("ex4",chart=helloworld_chart) } ), tabItem( tabName="ex5-tab", { h2("Example 5 - Box plot") - chartsTabUI("ex5",name="Boxplot1",label="Box Plot 1",type="plot") + chartsTabUI("ex5",chart=box1_chart) } ), tabItem( tabName="ex6-tab", { h2("Example 6 - Custom Box plot") - chartsTabUI("ex6",name="Boxplot2",label="Custom Box Plot",type="plot") + chartsTabUI("ex6",chart=box2_chart) } ) ) @@ -82,7 +156,6 @@ sidebar <- shinydashboard::dashboardSidebar( ) ) - ui <- tagList( tags$head( tags$link( @@ -96,138 +169,58 @@ ui <- tagList( server <- function(input,output,session){ # Example 1 - hep explorer - charts<-MakeChartConfig(paste(.libPaths(),'safetygraphics','config', "charts", sep="/")) - paramsLabs <- reactive({list(data=domainData[["labs"]],settings=mappingLabs)}) callModule( chartsTab, "ex1", - chart=charts$hepexplorer, + chart=charts[["hepExplorer"]], data=dataR, mapping=mappingR -) + ) - # Example 2 - AE Explorer - initAEE <- function(data, settings){ - print("intiAEEE") - data<-data$aes - settings$variables=list( - major=settings[["bodsys_col"]], - minor=settings[["term_col"]], - group="STUDYID", - id=settings[["id_col"]], - filters=list(), - details=list() - ) - return(list(data=data,settings=settings)) - } - - charts$aeExplorer$functions$init <- initAEE - callModule( - chartsTab, - "ex2", - chart=charts$aeExplorer, - mapping=mappingR, - data=dataR - ) - - #Example 3 - results over time - callModule( - chartsTab, - "ex3", - chart=charts$safetyResultsOverTime, - data=dataR, - mapping=mappingR - ) - - #Example 4 - hello world - helloWorld <- function(data,settings){ - plot(-1:1, -1:1) - text(runif(20, -1,1),runif(20, -1,1),"Hello World") - } - - helloworld_chart<-list( - name="HelloWorld", - type="plot", - domain="aes", - functions=list( - main=helloWorld - ) - ) - - callModule( - chartsTab, - "ex4", - chart=helloworld_chart, - data=dataR, - mapping=mappingR - ) - - #Example 5 - boxPlot <- function(data,settings){ - mapped_data <- data %>% - select(CustomValue = settings$value_col, CustomMeasure = settings$measure_col)%>% - filter(!is.na(CustomValue)) - ggplot(data = mapped_data, aes(x = CustomMeasure, y = CustomValue)) + - geom_boxplot() + - scale_y_log10() + - theme_bw() + - theme(axis.text.x = element_text(angle = 25, hjust = 1), - axis.text = element_text(size = 12), - axis.title = element_text(size = 12)) - } - - box1_chart<-list( - name="Box1", - type="plot", - domain="labs", - functions=list( - main=boxPlot - ) - ) - - callModule( - chartsTab, - "ex5", - chart=box1_chart, - data=dataR, - mapping=mappingR - ) - - #Example 3 - dataInit <- function(data,settings){ - mapped_data <- data %>% - select(Value = settings[["value_col"]], Measure = settings[["measure_col"]])%>% - filter(!is.na(Value)) - settings$boxcolor="blue" - return(list(data=mapped_data,settings=settings)) - } + # Example 2 - AE Explorer + callModule( + chartsTab, + "ex2", + chart=charts$aeExplorer, + mapping=mappingR, + data=dataR + ) - boxPlot2 <- function(data,settings){ - ggplot(data = data, aes(x = Measure, y = Value)) + - geom_boxplot(fill = settings[["boxcolor"]]) + - scale_y_log10() + - theme_bw() + - theme(axis.text.x = element_text(angle = 25, hjust = 1), - axis.text = element_text(size = 12), - axis.title = element_text(size = 12)) - } - box2_chart<-list( - name="Box2", - type="plot", - domain="labs", - functions=list( - main=boxPlot2, - init=dataInit - ) - ) - - callModule( - chartsTab, - "ex6", - chart=box2_chart, - data=dataR, - mapping=mappingR - ) + #Example 3 - results over time + callModule( + chartsTab, + "ex3", + chart=charts$safetyResultsOverTime, + data=dataR, + mapping=mappingR + ) + + #Example 4 - hello world + callModule( + chartsTab, + "ex4", + chart=helloworld_chart, + data=dataR, + mapping=mappingR + ) + + #Example 5 + callModule( + chartsTab, + "ex5", + chart=box1_chart, + data=dataR, + mapping=mappingR + ) + + #Example 6 + callModule( + chartsTab, + "ex6", + chart=box2_chart, + data=dataR, + mapping=mappingR + ) } -shinyApp(ui, server) \ No newline at end of file +shinyApp(ui, server) diff --git a/tests/testthat/test_mod_chartsRenderStatic.R b/tests/testthat/test_mod_chartsRenderStatic.R deleted file mode 100644 index a048f110..00000000 --- a/tests/testthat/test_mod_chartsRenderStatic.R +++ /dev/null @@ -1,25 +0,0 @@ -context("Tests for the renderStatic R module") -library(safetyGraphics) -library(shiny) -library(shinytest) -library(testthat) -library(dplyr) - - -app <- ShinyDriver$new("./module_examples/chartsRenderStatic") -initial<-app$getAllValues() - -test_that("All 3 charts are drawn and have correct axes",{ - expect_equal(substring(initial$output$`HelloWorld-staticPlot`$src,1,14), "data:image/png") - - expect_equal(substring(initial$output$`BoxPlot-staticPlot`$src,1,14), "data:image/png") - expect_equal(initial$output$`BoxPlot-staticPlot`$coordmap$panels[[1]]$mapping$x, "CustomMeasure") - expect_equal(initial$output$`BoxPlot-staticPlot`$coordmap$panels[[1]]$mapping$y, "CustomValue") - - expect_equal(substring(initial$output$`BoxPlot2-staticPlot`$src,1,14), "data:image/png") - expect_equal(initial$output$`BoxPlot2-staticPlot`$coordmap$panels[[1]]$mapping$x, "Measure") - expect_equal(initial$output$`BoxPlot2-staticPlot`$coordmap$panels[[1]]$mapping$y, "Value") -}) - -app$stop() - diff --git a/tests/testthat/test_mod_chartsRenderWidget.R b/tests/testthat/test_mod_chartsRenderWidget.R deleted file mode 100644 index db97d11f..00000000 --- a/tests/testthat/test_mod_chartsRenderWidget.R +++ /dev/null @@ -1,40 +0,0 @@ -context("Tests for the renderWidget R module") -library(safetyGraphics) -library(htmlwidgets) -library(shiny) -library(shinytest) -library(testthat) -library(dplyr) - -#setwd('tests/testthat') -app <- ShinyDriver$new("./module_examples/chartsRenderWidget") - -## Not working in ShinyDriver for some reason :( - maybe reimplement later -# test_that("the first widget renderers when clicked",{ -# app$setInputs(sidebar_tabs = "ex1-tab") -# Sys.sleep(1) -# outputs1<-app$getAllValues()[["output"]] -# expect_length(outputs1, 2) -# expect_named(outputs1, "ex2-widgetChart","ex1-widgetChart") -# chart1<-jsonlite::fromJSON(outputs1[["ex1-widgetChart"]]) -# expect_named(chart1,c("x","evals","jsHooks","deps" )) # names for htmlwidget shiny output -# }) - -test_that("2nd widget renderers by default",{ - skip_on_ci() - outputs2<-app$getAllValues()[["output"]] - expect_named(outputs2, c("ex2-widgetChart")) - chart2<-jsonlite::fromJSON(outputs2[["ex2-widgetChart"]]) - expect_named(chart2,c("x","evals","jsHooks","deps" )) # names for htmlwidget shiny output -}) - -test_that("3rd widget renderers when sidebar is clicked",{ - skip_on_ci() - app$setInputs(sidebar_tabs = "ex3-tab") - outputs3<-app$getAllValues()[["output"]] - expect_named(outputs3, c("ex2-widgetChart","ex3-widgetChart")) - chart3<-jsonlite::fromJSON(outputs3[["ex3-widgetChart"]]) - expect_named(chart3,c("x","evals","jsHooks","deps" )) # names for htmlwidget shiny output -}) -app$stop() -