Merge pull request #59 from InstituteforDiseaseModeling/mewu/ui_fix

remaining issues

R/archive/validate_module.R

@@ -0,0 +1,56 @@
+
+ValidateUI <- function(id, title="Validation report"){
+  ns <- NS(id)
+  tabPanel(title,
+           fluidRow(
+             column(12, actionButton(ns("run_validation_report_now"), "Run Advanced Validation Report"))
+           ),
+           fluidRow(
+             column(
+               4,
+               uiOutput(ns("download_validation_report"))
+             )
+           ),
+           fluidRow(
+             style = "margin: 0 5px;",
+             htmlOutput(ns("validate_result_html"))
+           )
+  )
+}
+
+ValidateServer <- function(id, input_file){
+  moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+    logdir <- tempdir()
+    outfilename <- basename(sub("\\.xlsx$", ".html", input_file))
+
+    observeEvent(input$run_validation_report_now, {
+      print("Button clicked!")  # Debugging line
+      rmarkdown::render(input = "validation_report.Rmd",
+                        output_format = "html_document",
+                        output_file = outfilename, 
+                        output_dir = logdir,
+                        params = list(inputFile = input_file, outputDir = logdir))
+
+      report <- file.path(logdir, outfilename)
+      if (file.exists(report)){
+        output$validate_result_html <- renderUI({
+          includeHTML(report)
+        })
+        output$download_validation_report <- renderUI({
+          downloadButton(ns("downloadData"),
+                         "Download Validation Report",
+                         icon = icon("download"))
+        })
+        output$downloadData <- downloadHandler(
+          filename = function() {
+            paste("validation_report.html")
+          },
+          content = function(file) {
+            file.copy(report, file)
+          }
+        ) 
+      }
+    })
+  })
+}

R/run_simulation.R

@@ -53,6 +53,21 @@ sim_tabs <- function(ns){
            fluidRow(
              column(12, HTML(gsub("\n", "<br>", validation_intro_str)))
            ),
+           fluidRow(
+             column(12, actionButton(ns("run_validation_report_now"), "Run Advanced Validation Report"))
+           ),
+           fluidRow(
+             column(12,  HTML("<br>"))
+           ),
+           fluidRow(
+             div(id = ns("wait_msg"), "Validating your configuration, this may take awhile...", div(class = "spinner"), style = "display: none;"),
+           ),
+           fluidRow(
+             column(
+               4,
+               uiOutput(ns("download_validation_report"))
+             )
+           ),
            tabsetPanel(
              id ="validation",
              tabPanel("Population Pyramid", simpleplotUI(ns("population-tab"))),
@@ -103,7 +118,9 @@ runSimulationUI <- function(id) {
       fluidRow(
         column(12, div(sim_tabs(ns = ns)), class='sim_row'),
       ),
-
+      fluidRow(
+        column(12, HTML("<br>"))
+      ),
       fluidRow(
         column(2, hidden(div(id = ns("prevDiv"), 
                              actionButton(ns("prevBtn"), "Previous"), align="center"))),
@@ -135,6 +152,53 @@ runSimulationServer <- function(id, return_event, rv, store = NULL) {
       shinyjs::runjs(gsub("\n", "", js_code))
     }
 
+    # handle Validation Report generation
+    observeEvent(input$run_validation_report_now, {
+      shinyjs::show(ns("wait_msg"), asis=TRUE)
+      report <- ValidateConfig(rv$input_file)
+      if (!is.null(report)){
+        # report may contain error
+        if (!file.exists(report)){
+          output$validate_result_html <- renderUI({
+            HTML(report)
+          })
+        }
+        else{
+          output$download_validation_report <- renderUI({
+            downloadButton(ns("downloadValidationData"),
+                           "Download Validation Report",
+                           icon = icon("download"),
+                           onclick = sprintf('Shiny.setInputValue("%s", true);', ns("download_report_clicked"))
+            )
+          })
+          output$downloadValidationData <- downloadHandler(
+            filename = function() {
+              paste("validation_report.html")
+            },
+            content = function(file) {
+              file.copy(report, file)
+            }
+          ) 
+        }
+      }
+      else{
+        output$download_validation_report <- renderUI({
+          HTML("Generating validation report failed.")
+        })
+      }
+      shinyjs::hide(ns("wait_msg"), asis=TRUE)
+      shinyjs::show(ns("download_validation_report"), asis = TRUE)
+    })
+
+    observeEvent(input$download_report_clicked, {
+      # Hide the validation report download button after it's clicked
+      if (input$download_report_clicked){
+        print("report downloaded. remove the link...")
+        shinyjs::runjs(sprintf('Shiny.setInputValue("%s", false);', ns("download_report_clicked")))
+        shinyjs::hide(ns("download_validation_report"), asis = TRUE)
+      }
+    })
+
     # Set sheet data based on input scenario
     observe({
       if (!is.null(rv$uid)) {
@@ -195,21 +259,20 @@ runSimulationServer <- function(id, return_event, rv, store = NULL) {
         isolate(updateSelectInput(session, "region", selected=rv$current_region))
       }
     })
-
-
+
     ### handle conditional button appearance
     observe({
-      hide("prevDiv")
-      hide("nextDiv")
-      show("skipAll")
+      shinyjs::hide("prevDiv")
+      shinyjs::hide("nextDiv")
+      shinyjs::show("skipAll")
       if(rv$page > 1){
-        show("prevDiv")
+        shinyjs::show("prevDiv")
       }
       if(rv$page <= length(sim_pages)){
-        show("nextDiv")
+        shinyjs::show("nextDiv")
       }
       if(rv$page >= which(sim_pages == "Run Simulation")){
-        hide("skipAll")
+        shinyjs::hide("skipAll")
         updateActionButton(session, "nextBtn", label = "Go To Results")
         shinyjs::runjs(sprintf('document.getElementById("%s").classList.remove("green-button");', ns("nextBtn")))
         shinyjs::runjs(sprintf('document.getElementById("%s").classList.add("green-button");', ns("run_simBtn")))
@@ -444,9 +507,11 @@ runSimulationServer <- function(id, return_event, rv, store = NULL) {
     observe({
 
       rv$trial_num <- ifelse(is.null(input$num_trials), 0, input$num_trials)
+      rv$num_tasks <- nrow(rv$task_input)
+      rv$num_years <- rv$end_year - rv$start_year
 
       output$run_estimate <- renderText({
-        get_estimated_run_stats(rv$trial_num)
+        get_estimated_run_stats(rv$trial_num, rv$num_tasks, rv$num_years)
       })
 
     })
@@ -479,6 +544,7 @@ runSimulationServer <- function(id, return_event, rv, store = NULL) {
         removeModal()
         output$errorRunName <- renderText({""})
         # Update config again if anything changed before running sim
+        shinyjs::html(id="log-display", "", asis=TRUE)
         shinyjs::show(id="sim_logger_area", asis=TRUE)
         rv$sim_triggered <- TRUE 
         trigger_file_saving(ns)

R/simulationFunctions.R

@@ -1,17 +1,39 @@
 # Function to estimate runtime statistics based on iterations
 # TODO: determine the logic to estimate file size and run time
-get_estimated_run_stats <- function (iteration){
+get_estimated_run_stats <- function (iterations, num_tasks, num_years){
 
-  if (iteration >0 ){
-    runtime <- iteration* 10
-    expected_size <-  iteration
+  #Function to generate scaling ratio
+  run_benchmark = function(n=200){
+
+    reference <- 0.09344006 # Time in seconds that a fast computer takes to run this benchmark 
+
+    #Start timing
+    start <- Sys.time() 
+    matrix_a <- matrix(rnorm(n*1000),nrow=n, ncol=1000)
+    # Perform the big computation 
+    result <- t(matrix_a) %*% matrix_a
+    timeelapsed <- Sys.time() - start # Stop timing
+
+    ratio <- as.numeric(timeelapsed) / reference
+
+    return(ratio)
   }
 
+  scalingratio <- run_benchmark() * 1.10
+
+  runtime= -18.51 + .03955 * iterations + .9659 * num_years + .2366 * num_tasks
+  runtime = runtime * scalingratio
+  runtime = max(round(runtime / 60), 1)
+
+  expected_size = -12740 + 18.29 *iterations + 390.5 * num_years + 296.7 * num_tasks
+  expected_size = max(round(expected_size), 3) 
+
+
   runtime <- ifelse(runtime >0 , runtime, "--:--:--")
   expected_size <- ifelse(expected_size >0 , expected_size, "--.--")
 
-  result_text <- sprintf("Given your number of replications, This model will take %s seconds to run, 
-                             The detailed result files, if you choose to download them, will be approximately %s mb.", runtime, expected_size)
+  result_text <- sprintf("Given your number of replications, This run time may take up to %s minutes to complete, 
+                             The detailed result files, if you choose to download them, will be approximately %s KB.", runtime, expected_size)
   result_text
 }
 
@@ -179,3 +201,25 @@ run_pacehrh_simulation <- function(rv, input_file){
   })
   return(new_rv)
 }
+
+# Run validation config
+ValidateConfig <- function(input_file){
+  logdir <- tempdir()
+  outfilename <- basename(sub("\\.xlsx$", ".html", input_file))
+  report <- NULL
+  tryCatch(
+    {
+      rmarkdown::render(input = "validation_report.Rmd",
+                        output_format = "html_document",
+                        output_file = outfilename, 
+                        output_dir = logdir,
+                        params = list(inputFile = input_file, outputDir = logdir))
+
+      report <- file.path(logdir, outfilename)
+    }, error = function(e){
+      report <- paste0("An error occurred: ", e$message)
+      print(e$message)
+    }
+  )
+  report
+}