Merge pull request #601 from SafetyGraphics/improveInit

Improve init

Author: jwildfire

NAMESPACE

@@ -19,8 +19,6 @@ export(loadCharts)
 export(loadChartsUI)
 export(loadData)
 export(loadDataUI)
-export(loadDomains)
-export(loadDomainsUI)
 export(makeChartConfig)
 export(makeChartConfigFunctions)
 export(makeChartExport)

R/app_startup.R

@@ -38,6 +38,9 @@ app_startup<-function(domainData=NULL, meta=NULL, charts=NULL, mapping=NULL, aut
         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)]
     }
+
+    chartOrder <- order(charts %>% map_int(~.x$order) %>% unlist())
+    charts <- charts[chartOrder]
 
     #Drop charts if data for required domain(s) is not found
     chart_drops <- charts %>% purrr::keep(~(!all(.x$domain %in% names(domainData))))

R/makeChartConfigFunctions.R

@@ -39,8 +39,9 @@ makeChartConfigFunctions <- function(chart){
         chart$functions$main<-chart$functions[[chart$workflow$main]]
     }else if(chart$type=="table"){
         chart$functions$ui<-DT::dataTableOutput
-        chart$functions$server<-function(expr ){
+        chart$functions$server<-function(expr){
             DT::renderDataTable(
+                expr, 
                 rownames = FALSE,
                 options = list(
                     pageLength = 20,
@@ -50,12 +51,6 @@ makeChartConfigFunctions <- function(chart){
             )
         }
         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") {
@@ -71,8 +66,7 @@ makeChartConfigFunctions <- function(chart){
         chart$functions$server<-renderWidget
         chart$functions$main<-htmlwidgets::createWidget 
         chart$workflow$main <- "htmlwidgets::createWidget"
-
-    }else if (chart$type=="module"){
+    }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]]

R/mod_loadCharts.R

@@ -11,25 +11,14 @@
 
 loadChartsUI <- function(id, charts=makeChartConfig()){ 
     ns <- NS(id)
-    labels <- charts%>%map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
     div(
-        sortable::bucket_list(
-            header = h4("Chart Loader"),
-            group_name = ns("chartList"),
-            orientation = "horizontal",
-            add_rank_list(
-                text = "Active Charts",
-                labels = labels,
-                input_id = ns("active")
-            ),
-            add_rank_list(
-                text = "Inactive Charts",
-                labels = NULL,
-                input_id = ns("inactive")
-            )
-        )
-    )
-
+        h4(
+            "Chart Loader",
+            actionButton(ns("addCharts"), "Select All", class="btn-xs"),
+            actionButton(ns("removeCharts"), "Remove All", class="btn-xs")
+        ),        
+        uiOutput(ns("chartLists"))
+    ) 
 }
 
 #' @title   loadCharts
@@ -42,8 +31,69 @@ loadChartsUI <- function(id, charts=makeChartConfig()){
 
 #' @export
 loadCharts <- function(input, output, session, charts=makeChartConfig()) {
+    ns<-session$ns
+    labels<-charts%>%map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+    rv <- reactiveValues(
+        inactive = charts%>%keep(~.x$order < 1)%>%map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable")),
+        active = charts%>%keep(~.x$order >= 1)%>%map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+    )
+    output$chartLists <- renderUI({
+        div(
+            sortable::bucket_list(
+                header = NULL,
+                group_name = ns("chartList"),
+                orientation = "horizontal",
+                add_rank_list(
+                    text = "Active Charts",
+                    labels = rv$active,
+                    input_id = ns("active")
+                ),
+                add_rank_list(
+                    text = "Inactive Charts",
+                    labels = rv$inactive,
+                    input_id = ns("inactive")
+                )
+            )
+        )
+    })
+
+    # Sync input and reactiveValues
+    observeEvent(input$active,{
+        rv$active <- charts %>% 
+            purrr::keep(~.x$name %in% input$active)%>%
+            map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+        rv$inactive <- charts %>% 
+            purrr::keep(~.x$name %in% input$inactive)%>%
+            map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+    })
+
+    observeEvent(input$inactive,{
+        rv$active <- charts %>% 
+            purrr::keep(~.x$name %in% input$active)%>%
+            map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+        rv$inactive <- charts %>% 
+            purrr::keep(~.x$name %in% input$inactive)%>%
+            map(~makeChartSummary(.x,showLinks=FALSE,class="chart-sortable"))
+
+    })
+
+    # Update reactiveValues/Input on add/remove button clicks
+    observeEvent(input$addCharts,{
+        rv$active <- labels
+        rv$inactive <- NULL
+    })
+
+    observeEvent(input$removeCharts,{
+        rv$active <- NULL
+        rv$inactive <- labels
+    })
     chartsR<-reactive({
-        charts %>% purrr::keep(~.x$name %in% input$active)
+        charts %>% 
+            purrr::keep(~.x$name %in% input$active) %>%
+            map(function(chart){
+                chart$order <- match(chart$name, input$active)
+                return(chart)
+            })
     })
     return(chartsR)
 }

R/mod_loadData.R

@@ -14,22 +14,24 @@ loadDataUI <- function(id, domain=NULL){
     actionButton(ns("load_data"), "Load"),
     hidden(
       actionLink(ns("preview_data"), "Preview")
-    )
-    
+    ),
+    id=ns("wrap")
   )
 }
 
 #' @title   loadDataServer
 #' @description  UI that facilitates the mapping of a column data domain
 #'
-#' @param domain List of data domains to be loaded
+#' @param domain data domain to be loaded
 #' @param input Shiny input object
 #' @param output Shiny output object
 #' @param session Shiny session object
 #' 
 #' @export
+
 loadData <- function(input, output, session, domain) {
   ns <- session$ns
+  
   fileSummary <- reactiveVal()
   fileSummary("<No Data Loaded>")
   observeEvent(input$load_data, {
@@ -70,6 +72,6 @@ loadData <- function(input, output, session, domain) {
     )
   })
 
-  return(imported)
+  return(imported$data)
 }
 

R/mod_loadDomains.R

@@ -8,8 +8,10 @@
 #' 
 #' @export
 
-safetyGraphicsInit <- function(charts=makeChartConfig(),delayTime=1000){
+safetyGraphicsInit <- function(charts=makeChartConfig(), delayTime=1000){
   charts_init<-charts
+  all_domains <- charts_init %>% map(~.x$domain) %>% unlist() %>% unique()
+
   app_css <- NULL
   for(lib in .libPaths()){
     if(is.null(app_css)){
@@ -23,19 +25,24 @@ safetyGraphicsInit <- function(charts=makeChartConfig(),delayTime=1000){
     tags$head(tags$style(app_css)),
     div(
       id="init",
-      titlePanel("safetyGraphics Initialization app"),
+      titlePanel("safetyGraphics Initializer"),
       sidebarLayout(
         position="right",
         sidebarPanel(
           h4("Data Loader"),
-          loadDomainsUI("load-data"),
+          all_domains %>% map(~loadDataUI(.x, domain=.x)),
           textOutput("dataSummary"),
           hr(),
           shinyjs::disabled(
             actionButton("runApp","Run App",class = "btn-block")
           )
         ),
         mainPanel(  
+          p(
+            icon("info-circle"),
+            "First, select charts by dragging items between the lists below. Next, load the required data domains using the controls on the right. Finally, click Run App to start the safetyGraphics Shiny App. Reload the webpage to select new charts/data.",
+            class="info"
+          ),
           loadChartsUI("load-charts", charts=charts_init),
         )
       ),
@@ -49,16 +56,33 @@ safetyGraphicsInit <- function(charts=makeChartConfig(),delayTime=1000){
   )
 
   server <- function(input,output,session){ 
-    charts<-callModule(loadCharts, "load-charts",charts=charts_init)
-    domains <- reactive({unique(charts() %>% map(~.x$domain) %>% unlist())})
-    domainDataR <- callModule(loadDomains, "load-data", domains) #this is a reactive list with reactives (?!)
-    domainData <- reactive({domainDataR() %>% map(~.x())})
+    #initialize the chart selection moduls
+    charts<-callModule(loadCharts, "load-charts",charts=charts_init) 
+    domainDataR<-all_domains %>% map(~callModule(loadData,.x,domain=.x))
+    names(domainDataR) <- all_domains
+    domainData<- reactive({domainDataR %>% map(~.x())})
+
+
+    current_domains <- reactive({
+      charts() %>% map(~.x$domain) %>% unlist() %>% unique()
+    })
+
+    observe({
+      for(domain in all_domains){
+        if(domain %in% current_domains()){
+          shinyjs::show(id=paste0(domain,"-wrap"))
+        }else{
+          shinyjs::hide(id=paste0(domain,"-wrap"))
+        }
+      }
+    })
 
     initStatus <- reactive({
+      currentData <- domainData()
       chartCount<-length(charts())
-      domainCount<-length(domainData())
-      loadCount<-sum(domainData() %>% map_lgl(~!is.null(.x)))
-      notAllLoaded <- any(domainData() %>% map_lgl(~is.null(.x)))
+      domainCount<-length(current_domains())
+      loadCount<-sum(currentData %>% map_lgl(~!is.null(.x)))
+      notAllLoaded <- sum(currentData %>% map_lgl(~!is.null(.x))) < domainCount
       ready<-FALSE
       if(domainCount==0){
         status<-paste("No charts selected. Select one or more charts and then load domain data to initilize app.")
@@ -85,20 +109,19 @@ safetyGraphicsInit <- function(charts=makeChartConfig(),delayTime=1000){
       }
     })
 
-
     observeEvent(input$runApp,{
-      print("running the app server now :p")
       shinyjs::hide(id="init")
       shinyjs::show(id="sg-app")
       config<- app_startup(
-        domainData = domainData(),
+        domainData = domainData() %>% keep(~!is.null(.x)),
         meta = safetyGraphics::meta, 
         charts= charts(),
         #mapping=NULL, 
         filterDomain="dm", 
+        autoMapping=TRUE, 
         #chartSettingsPaths = NULL
       )
-    
+          
       output$sg <- renderUI({
         safetyGraphicsUI(
           "sg",
@@ -126,6 +149,5 @@ safetyGraphicsInit <- function(charts=makeChartConfig(),delayTime=1000){
   }
 
   app <- shinyApp(ui = ui, server = server)
-
   runApp(app, launch.browser = TRUE)
 }