Update Shiny app

- Refactor data upload and sample data - Create custom data upload button - Create script.js - Change Shiny notification colour - Bug fix: ensure the case counts in bulk data that have only one row are treated as a data frame, by wrapping them in 'data.frame' before passing to 'apply'
author: Naeem Model <me@nmode.ca> 2024-05-26 02:38:19 +0000
committer: Naeem Model <me@nmode.ca> 2024-05-26 02:38:19 +0000
commit: 9cf25e707fbd49d357cf295ad62f83d805c59c2c (patch)
tree: 30154c5e964dbe7f8975527e48a1e1a5d042107e /inst
parent: bd2bfa90dc7bb75cc6cbe8c6b674b7bcf486b519 (diff)
7 files changed, 195 insertions, 78 deletions
diff --git a/inst/app/index.html b/inst/app/index.html
index b0f1245..504918d 100644
--- a/inst/app/index.html
+++ b/inst/app/index.html
@@ -5,12 +5,7 @@
     {{ headContent() }}
     <title>Rnaught Web</title>
     <link rel="stylesheet" type="text/css" href="styles.css">
-    <!-- Enable tooltips. -->
-    <script>
-      $(document).ready(function(){
-        $('[data-bs-toggle="tooltip"]').tooltip();
-      });
-    </script>
+    <script src="script.js"></script>
   </head>
   <body class="d-flex flex-column h-100">
     <noscript>
diff --git a/inst/app/scripts/data.R b/inst/app/scripts/data.R
index eebd14f..02b57c5 100644
--- a/inst/app/scripts/data.R
+++ b/inst/app/scripts/data.R
@@ -10,7 +10,9 @@ data_logic <- function(input, output, react_values) {
 
   render_plot(input, output)
   single_entry(input, output, react_values)
-  bulk_entry(input, output, react_values)
+  manual_bulk_entry(input, output, react_values)
+  upload_data(input, output, react_values)
+  load_samples(input, output, react_values)
   render_data(output, react_values)
   delete_data(input, react_values)
   export_data(output, react_values)
@@ -93,80 +95,143 @@ single_entry <- function(input, output, react_values) {
   })
 }
 
-# Add multiple datasets to the existing table.
-bulk_entry <- function(input, output, react_values) {
+manual_bulk_entry <- function(input, output, react_values) {
   observeEvent(input$data_bulk, {
-    tryCatch(
-      {
-        datasets <- read.csv(text = input$data_area, header = FALSE, sep = ",")
+    validate_bulk_data(input, output, react_values, "data_area")
+  })
+}
 
-        names <- trimws(datasets[, 1])
-        units <- trimws(datasets[, 2])
-        counts <- apply(datasets[, 3:ncol(datasets)], 1,
-          function(row) {
-            row <- suppressWarnings(as.integer(row))
-            toString(row[!is.na(row) & row >= 0])
-          }
-        )
+upload_data <- function(input, output, react_values) {
+  observeEvent(input$data_upload, {
+    validate_bulk_data(input, output, react_values, "data_upload")
+  })
+}
 
-        warning_text <- ""
+validate_bulk_data <- function(input, output, react_values, data_source) {
+  tryCatch(
+    {
+      if (data_source == "data_area") {
+        datasets <- read.csv(text = input$data_area, header = FALSE, sep = ",")
+      } else if (data_source == "data_upload") {
+        datasets <- read.csv(
+          file = input$data_upload$datapath, header = FALSE, sep = ","
+        )
+      }
 
-        # Ensure the dataset names are neither blank nor duplicates.
-        if (anyNA(names) || any(names == "")) {
-          warning_text <- paste0(warning_text, sep = "<br>",
-            "Each row must begin with a non-blank dataset name."
-          )
-        } else {
-          if (length(unique(names)) != length(names)) {
-            warning_text <- paste0(warning_text, sep = "<br>",
-              "The rows contain duplicate dataset names."
-            )
-          }
-          if (any(names %in% react_values$data_table[, 1])) {
-            warning_text <- paste0(warning_text, sep = "<br>",
-              "The rows contain dataset names which already exist."
-            )
-          }
+      names <- trimws(datasets[, 1])
+      units <- trimws(datasets[, 2])
+      counts <- apply(data.frame(datasets[, 3:ncol(datasets)]), 1,
+        function(row) {
+          row <- suppressWarnings(as.integer(row))
+          toString(row[!is.na(row) & row >= 0])
         }
+      )
 
-        # Ensure the second entry in each row is a time unit equal to
-        # "Days" or "Weeks".
-        if (!all(units %in% c("Days", "Weeks"))) {
-          warning_text <- paste0(warning_text, sep = "<br>",
-            "The second entry in each row must be either 'Days' or 'Weeks'."
+      warning_text <- ""
+
+      # Ensure the dataset names are neither blank nor duplicates.
+      if (anyNA(names) || any(names == "")) {
+        warning_text <- paste0(warning_text,
+          "Each row must begin with a non-blank dataset name.<br>"
+        )
+      } else {
+        if (length(unique(names)) != length(names)) {
+          warning_text <- paste0(warning_text,
+            "The rows contain duplicate dataset names.<br>"
           )
         }
-
-        # Ensure the counts in each row have at least one non-negative integer.
-        if (any(counts == "")) {
-          warning_text <- paste0(warning_text, sep = "<br>",
-            "Each row must contain at least one non-negative integer."
+        if (any(names %in% react_values$data_table[, 1])) {
+          warning_text <- paste0(warning_text,
+            "The rows contain dataset names which already exist.<br>"
           )
         }
+      }
 
-        output$data_area_warn <- renderUI(HTML(warning_text))
+      # Ensure the second entry in each row is a time unit equal to
+      # "Days" or "Weeks".
+      if (!all(units %in% c("Days", "Weeks"))) {
+        warning_text <- paste0(warning_text,
+          "The second entry in each row must be either 'Days' or 'Weeks'.<br>"
+        )
+      }
 
-        if (warning_text == "") {
-          # Add the new datasets to the data table.
-          new_rows <- data.frame(names, units, counts)
-          colnames(new_rows) <- c("Name", "Time units", "Case counts")
-          react_values$data_table <- rbind(react_values$data_table, new_rows)
+      # Ensure the counts in each row have at least one non-negative integer.
+      if (any(counts == "")) {
+        warning_text <- paste0(warning_text,
+          "Each row must contain at least one non-negative integer.<br>"
+        )
+      }
 
-          # Evaluate all existing estimators on the new dataset and update the
-          # corresponding row in the estimates table.
-          update_estimates_rows(new_rows, react_values)
+      output[[paste0(data_source, "_warn")]] <- renderUI(HTML(warning_text))
 
-          showNotification("Datasets added successfully.",
-            duration = 3, id = "notify-success"
-          )
-        }
-      },
-      error = function(e) {
-        output$data_area_warn <- renderText(
-          "The input does not match the required format."
+      if (warning_text == "") {
+        # Add the new datasets to the data table.
+        new_rows <- data.frame(names, units, counts)
+        colnames(new_rows) <- c("Name", "Time units", "Case counts")
+        react_values$data_table <- rbind(react_values$data_table, new_rows)
+
+        # Evaluate all existing estimators on the new datasets and update the
+        # corresponding rows in the estimates table.
+        update_estimates_rows(new_rows, react_values)
+
+        showNotification("Datasets added successfully.",
+          duration = 3, id = "notify-success"
         )
       }
-    )
+    },
+    error = function(e) {
+      output[[paste0(data_source, "_warn")]] <- renderText(
+        "The input does not match the required format."
+      )
+    }
+  )
+}
+
+# Load sample datasets.
+load_samples <- function(input, output, react_values) {
+  observeEvent(input$data_samples, {
+    names <- c()
+    units <- c()
+    counts <- c()
+
+    # COVID-19 Canada, March 2020 (weekly).
+    if (input$covid_canada) {
+      names <- c(names, "COVID-19 Canada 2020/03/03 - 2020/03/31")
+      units <- c(units, "Weeks")
+      counts <- c(counts, toString(Rnaught::COVIDCanada[seq(41, 69, 7), 2]))
+    }
+    # COVID-19 Ontario, March 2020 (weekly).
+    if (input$covid_ontario) {
+      names <- c(names, "COVID-19 Ontario 2020/03/03 - 2020/03/31")
+      units <- c(units, "Weeks")
+      counts <- c(counts,
+        toString(Rnaught::COVIDCanadaPT[seq(10176, 10204, 7), 3])
+      )
+    }
+
+    if (length(names) == 0) {
+      output$data_samples_warn <- renderText(
+        "At least one sample dataset must be selected."
+      )
+    } else if (any(names %in% react_values$data_table[, 1])) {
+      output$data_samples_warn <- renderText(
+        "At least one of the selected dataset names already exist."
+      )
+    } else {
+      output$data_samples_warn <- renderText("")
+
+      new_rows <- data.frame(names, units, counts)
+      colnames(new_rows) <- c("Name", "Time units", "Case counts")
+      react_values$data_table <- rbind(react_values$data_table, new_rows)
+
+      # Evaluate all existing estimators on the sample datasets and update the
+      # corresponding rows in the estimates table.
+      update_estimates_rows(new_rows, react_values)
+
+      showNotification("Datasets added successfully.",
+        duration = 3, id = "notify-success"
+      )
+    }
   })
 }
 
diff --git a/inst/app/templates/content/data/enter-data.html b/inst/app/templates/content/data/enter-data.html
index 621c785..f4d5e75 100644
--- a/inst/app/templates/content/data/enter-data.html
+++ b/inst/app/templates/content/data/enter-data.html
@@ -8,6 +8,10 @@
   </div>
 </div>
 <hr>
-<form>
+<form class="mb-5">
   {{ htmlTemplate("templates/content/data/enter-data/bulk-entry.html") }}
 </form>
+<hr>
+<form>
+  {{ htmlTemplate("templates/content/data/enter-data/load-samples.html") }}
+</form>
diff --git a/inst/app/templates/content/data/enter-data/bulk-entry.html b/inst/app/templates/content/data/enter-data/bulk-entry.html
index 82a3ccf..30fab06 100644
--- a/inst/app/templates/content/data/enter-data/bulk-entry.html
+++ b/inst/app/templates/content/data/enter-data/bulk-entry.html
@@ -1,13 +1,11 @@
 <h4 class="mb-3">Bulk entry</h4>
 <!-- Button to toggle help text. -->
 <button type="button" class="btn btn-outline-primary btn-sm" id="bulk-help-toggle"
-        data-bs-toggle="collapse" data-bs-target="#bulk-help">
-    Show required format
-</button>
+        data-bs-toggle="collapse" data-bs-target="#bulk-help">Show required format</button>
 <!-- Help text for bulk input format. -->
 <div class="collapse mt-2" id="bulk-help">
   <div class="card card-body border-primary">
-    <p>Enter one or more rows in the following format:</p>
+    <p>Manually enter rows or upload a CSV file in the following format:</p>
     <p class="overflow-x-scroll text-nowrap font-monospace">
       <u>Dataset name</u>,<u>Time units</u>,<u>Case counts</u>
     </p>
@@ -27,11 +25,24 @@
   </div>
 </div>
 <!-- Data input area. -->
-<div>
-  <textarea id="data_area" class="form-control shiny-input-textarea my-3" rows="3" wrap="off"></textarea>
-  <small id="data_area_warn" class="form-text text-primary shiny-html-output"></small>
+<div class="my-4">
+  <label class="form-label" for="data_area">Enter manually</label>
+  <textarea id="data_area" class="form-control" rows="3" wrap="off"></textarea>
+  <div>
+    <small id="data_area_warn" class="form-text text-primary shiny-html-output"></small>
+  </div>
+  <button id="data_bulk" type="button" class="btn btn-outline-primary btn-sm action-button mt-3">
+    <span class="glyphicon glyphicon-plus"></span> Add
+  </button>
+</div>
+<!-- File input for data upload (hidden). -->
+<input class="form-control" type="file" id="data_upload" accept="text/csv,text/comma-separated-values,text/plain,.csv">
+<!-- Custom button to trigger file selector for data upload (visible). -->
+<label class="form-label" for="data-upload-select">Upload a CSV file</label>
+<div class="input-group">
+  <button id="data-upload-select" type="button" class="btn btn-outline-primary btn-sm">
+    <span class="glyphicon glyphicon-file"></span> Select file
+  </button>
+  <input type="text" id="data-upload-name" class="form-control" placeholder="No file selected" disabled>
 </div>
-<!-- Submit data. -->
-<button id="data_bulk" type="button" class="btn btn-outline-primary btn-sm action-button">
-  <span class="glyphicon glyphicon-plus"></span> Add
-</button>
+<small id="data_upload_warn" class="form-text text-primary shiny-html-output"></small>
diff --git a/inst/app/templates/content/data/enter-data/load-samples.html b/inst/app/templates/content/data/enter-data/load-samples.html
new file mode 100644
index 0000000..a42a8c8
--- /dev/null
+++ b/inst/app/templates/content/data/enter-data/load-samples.html
@@ -0,0 +1,17 @@
+<h4 class="mb-3">Load samples</h4>
+{{
+  checkboxInput(inputId = "covid_canada", label = "COVID-19 Canada, 2020/03/03 - 2020/03/31 (Weekly)",
+    value = FALSE, width = "100%"
+  )
+}}
+{{
+  checkboxInput(inputId = "covid_ontario", label = "COVID-19 Ontario, 2020/03/03 - 2020/03/31 (Weekly)",
+    value = FALSE, width = "100%"
+  )
+}}
+<div>
+  <small id="data_samples_warn" class="form-text text-primary shiny-text-output"></small>
+</div>
+<button id="data_samples" type="button" class="btn btn-outline-primary btn-sm action-button mt-3">
+  <span class="glyphicon glyphicon-plus"></span> Add
+</button>
diff --git a/inst/app/www/script.js b/inst/app/www/script.js
new file mode 100644
index 0000000..c31584f
--- /dev/null
+++ b/inst/app/www/script.js
@@ -0,0 +1,21 @@
+$(document).ready(() => {
+  // Enable tooltips.
+  $('[data-bs-toggle="tooltip"]').tooltip();
+
+  // Toggle the text in the bulk data help button.
+  $('#bulk-help-toggle').on('click', event => {
+    btn = $(event.target);
+    show_format = 'Show required format';
+    btn.text(btn.text() === show_format ? 'Hide required format' : show_format);
+  });
+
+  // Trigger the file selector via a custom button.
+  $('#data-upload-select').on('click', () => {
+    $('#data_upload').trigger('click');
+  });
+
+  // Display the name of the uploaded file.
+  $('#data_upload').on('change', event => {
+    $('#data-upload-name').attr('placeholder', event.target.files[0].name);
+  });
+});
diff --git a/inst/app/www/styles.css b/inst/app/www/styles.css
index f6c4407..d53a387 100644
--- a/inst/app/www/styles.css
+++ b/inst/app/www/styles.css
@@ -20,7 +20,11 @@ noscript {
   margin-top: -0.5rem;
 }
 
-td.selected {
+td.selected, .shiny-notification {
   background-color: black;
   color: white;
 }
+
+#data_upload {
+  display: none;
+}
author	Naeem Model <me@nmode.ca>	2024-05-26 02:38:19 +0000
committer	Naeem Model <me@nmode.ca>	2024-05-26 02:38:19 +0000
commit	9cf25e707fbd49d357cf295ad62f83d805c59c2c (patch)
tree	30154c5e964dbe7f8975527e48a1e1a5d042107e /inst
parent	bd2bfa90dc7bb75cc6cbe8c6b674b7bcf486b519 (diff)