nmode's Git Repositories - Rnaught/blob - R/server.R

   1 #' @importFrom methods is
   2 #' @importFrom utils read.csv write.csv
   3 server <- function(input, output) {
   4   reactive <- shiny::reactiveValues(
   5     data_table = data.frame(Name = character(0),
   6                             `Reporting Frequency` = character(0),
   7                             `Case Counts` = numeric(0), check.names = FALSE),
   8     est_table = data.frame(Dataset = character(0)),
   9     estimators = list()
  10   )
  11
  12   # Validate and add datasets when button is clicked.
  13   # Also evaluate the new datasets on existing estimators.
  14   shiny::observeEvent(input$addData, {
  15     # Option 1: Manual entry.
  16     if (input$dataInputMethod == 1) {
  17       checks_passed <- TRUE
  18
  19       # Ensure the dataset name is not blank.
  20       if (grepl("^\\s*$", input$dataName)) {
  21         output$dataNameWarn <- shiny::renderText(
  22           "Error: The dataset name cannot be blank.")
  23         checks_passed <- FALSE
  24       }
  25       # Ensure the dataset name is not a duplicate.
  26       else if (input$dataName %in% reactive$data_table[,1]) {
  27         output$dataNameWarn <- shiny::renderText(
  28           "Error: There is already a dataset with the specified name.")
  29         checks_passed <- FALSE
  30       }
  31       else
  32         output$dataNameWarn <- shiny::renderText("")
  33
  34       # Ensure the case counts consist only of positive integers, separated by
  35       # commas.
  36       counts <- as.numeric(unlist(strsplit(input$dataCounts, split = ",")))
  37       if (any(is.na(counts)) || any(counts <= 0) || any(counts %% 1 != 0)) {
  38         output$dataCountsWarn <- shiny::renderText("Error: The list of case
  39           counts should only contain positive integers, separated by commas.")
  40         checks_passed <- FALSE
  41       }
  42       # Ensure the case counts contain at least two entries.
  43       else if (length(counts) < 2) {
  44         output$dataCountsWarn <- shiny::renderText(
  45           "Error: The list of case counts should contain at least two entries.")
  46         checks_passed <- FALSE
  47       }
  48       else
  49         output$dataCountsWarn <- shiny::renderText("")
  50
  51       if (checks_passed)
  52         d <- data.frame(input$dataName, input$dataUnits, t(counts))
  53     }
  54
  55     else {
  56       checks_passed <- FALSE
  57
  58       # Option 2: Upload .csv
  59       if (input$dataInputMethod == 2)
  60         d <- try(read.csv(input$dataUpload$datapath, header = FALSE))
  61       # Option 3: Paste .csv
  62       else
  63         d <- try(read.csv(text = input$dataPaste, header = FALSE))
  64
  65       if (is(d, "try-error"))
  66         output$dataCSVWarn <- shiny::renderText("Error reading file.")
  67       else if (ncol(d) < 4 || anyNA(d[,1]) || anyNA(sapply(d[,3:4], as.numeric))
  68                || !all(trimws(d[,2]) %in% c("Daily", "Weekly")))
  69         output$dataCSVWarn <- shiny::renderText(
  70           "Error: The provided .csv file does not match the required format.")
  71       else if (length(intersect(reactive$data_table[,1], d[,1])) > 0)
  72         output$dataCSVWarn <- shiny::renderText("Error: The provided .csv file
  73           contains dataset names which already exist.")
  74       else if (length(unique(d[,1])) != length(d[,1]))
  75         output$dataCSVWarn <- shiny::renderText(
  76           "Error: The provided .csv file contains duplicate dataset names.")
  77       else {
  78         output$dataCSVWarn <- shiny::renderText("")
  79         checks_passed <- TRUE
  80       }
  81     }
  82
  83     if (checks_passed) {
  84       d[,3:ncol(d)] <- apply(d[,3:ncol(d)], 2, as.numeric)
  85       d[,3] <- data.frame(I(lapply(split(d[,3:ncol(d)], 1:nrow(d)),
  86                                    function(x) x[!is.na(x)])))
  87       d <- d[,1:3]
  88       d[,2] <- trimws(d[,2])
  89       colnames(d) <- c("Name", "Reporting Frequency", "Case Counts")
  90       reactive$data_table <- rbind(reactive$data_table, d)
  91       reactive$est_table <- update_est_row(input, output, d,
  92         reactive$estimators, reactive$est_table)
  93     }
  94   })
  95
  96   output$dataTable <- shiny::renderDataTable(reactive$data_table,
  97                                              escape = FALSE)
  98   output$estTable <- shiny::renderDataTable(reactive$est_table,
  99                                             escape = FALSE)
 100
 101   # Download table of estimates as a .csv file.
 102   output$downloadEst <- shiny::downloadHandler(
 103     filename = function() { paste0("Rnaught-", Sys.Date(), ".csv") },
 104     content = function(file) { write.csv(reactive$est_table, file) }
 105   )
 106
 107   shiny::observeEvent(input$addWP, {
 108     if (input$serialWPKnown == 1) {
 109       serial <- validate_serial(input, output, "serialWPInput", "serialWPWarn")
 110       if (!is.na(serial)) {
 111         reactive$estimators[[length(reactive$estimators) + 1]] <- list(
 112           method = "WP", mu = serial, mu_units = input$serialWPUnits,
 113           grid_length = 100, max_shape = 10, max_scale = 10)
 114         reactive$est_table <- update_est_col(input, output, reactive$data_table,
 115           reactive$estimators[[length(reactive$estimators)]],
 116           reactive$est_table)
 117       }
 118     }
 119     else {
 120       checks_passed <- TRUE
 121
 122       grid_length <- as.numeric(input$gridLengthInput)
 123       max_shape <- as.numeric(input$gridShapeInput)
 124       max_scale <- as.numeric(input$gridScaleInput)
 125
 126       if (is.na(grid_length) || grid_length <= 0 || grid_length %% 1 != 0) {
 127         output$gridLengthWarn <- shiny::renderText(
 128           "Error: The grid size must be a positive integer.")
 129         output$gridShapeWarn <- shiny::renderText("")
 130         output$gridScaleWarn <- shiny::renderText("")
 131         checks_passed <- FALSE
 132       }
 133       else {
 134         output$gridLengthWarn <- shiny::renderText("")
 135
 136         if (is.na(max_shape) || max_shape < 1 / grid_length) {
 137           output$gridShapeWarn <- shiny::renderText("Error: The maximum shape
 138             must be at least the reciprocal of the grid length.")
 139           checks_passed <- FALSE
 140         }
 141         else
 142           output$gridShapeWarn <- shiny::renderText("")
 143
 144         if (is.na(max_scale) || max_scale < 1 / grid_length) {
 145           output$gridScaleWarn <- shiny::renderText("Error: The maximum scale
 146             must be at least the reciprocal of the grid length.")
 147           checks_passed <- FALSE
 148         }
 149         else
 150           output$gridScaleWarn <- shiny::renderText("")
 151       }
 152
 153       if (checks_passed) {
 154         reactive$estimators[[length(reactive$estimators) + 1]] <- list(
 155           method = "WP", mu = NA, mu_units = input$serialWPUnits,
 156           grid_length = grid_length, max_shape = max_shape, max_scale = max_scale)
 157         reactive$est_table <- update_est_col(input, output, reactive$data_table,
 158           reactive$estimators[[length(reactive$estimators)]],
 159           reactive$est_table)
 160       }
 161     }
 162   })
 163
 164   shiny::observeEvent(input$addseqB, {
 165     serial <- validate_serial(input, output, "serialseqBInput",
 166                               "serialseqBWarn")
 167     checks_passed <- !is.na(serial)
 168
 169     kappa <- as.numeric(input$kappaInput)
 170     if (is.na(kappa) || kappa <= 0) {
 171       output$kappaWarn <- shiny::renderText(
 172         "Error: The maximum value must be a positive number.")
 173       checks_passed <- FALSE
 174     }
 175     else
 176       output$kappaWarn <- shiny::renderText("")
 177
 178     if (checks_passed) {
 179       reactive$estimators[[length(reactive$estimators) + 1]] <- list(
 180         method="seqB", mu = serial, kappa = kappa,
 181         mu_units = input$serialseqBUnits)
 182       reactive$est_table <- update_est_col(input, output, reactive$data_table,
 183         reactive$estimators[[length(reactive$estimators)]], reactive$est_table)
 184     }
 185   })
 186
 187   shiny::observeEvent(input$addID, {
 188     serial <- validate_serial(input, output, "serialIDInput", "serialIDWarn")
 189     if (!is.na(serial)) {
 190       reactive$estimators[[length(reactive$estimators) + 1]] <- list(
 191         method = "ID", mu = serial, mu_units = input$serialIDUnits)
 192       reactive$est_table <- update_est_col(input, output, reactive$data_table,
 193         reactive$estimators[[length(reactive$estimators)]], reactive$est_table)
 194     }
 195   })
 196
 197   shiny::observeEvent(input$addIDEA, {
 198     serial <- validate_serial(input, output, "serialIDEAInput",
 199                               "serialIDEAWarn")
 200     if (!is.na(serial)) {
 201       reactive$estimators[[length(reactive$estimators) + 1]] <- list(
 202         method = "IDEA", mu = serial, mu_units = input$serialIDEAUnits)
 203       reactive$est_table <- update_est_col(input, output, reactive$data_table,
 204         reactive$estimators[[length(reactive$estimators)]], reactive$est_table)
 205     }
 206   })
 207 }
 208
 209 validate_serial <- function(input, output, serialInputId, serialWarnId) {
 210   serial <- as.numeric(input[[serialInputId]])
 211   if (is.na(serial) || serial <= 0) {
 212     output[[serialWarnId]] <- shiny::renderText(
 213       "Error: The mean serial interval should be a positive number.")
 214     serial <- NA
 215   }
 216   else
 217     output[[serialWarnId]] <- shiny::renderText("") # Clear warning text.
 218
 219   return(serial)
 220 }
 221
 222 # Create a new column in the estimator table when a new estimator is added.
 223 update_est_col <- function(input, output, datasets, estimator, est_table) {
 224   if (nrow(datasets) == 0)
 225     new_est_table <- data.frame(matrix(nrow = 0, ncol = ncol(est_table) + 1))
 226   else {
 227     estimates <- rep(NA, nrow(datasets))
 228
 229     for (row in 1:nrow(datasets))
 230       estimates[row] <- eval_estimator(input, output, estimator, datasets[row,])
 231
 232       if (nrow(est_table) == 0)
 233         new_est_table <- cbind(datasets[,1], estimates)
 234       else
 235         new_est_table <- cbind(est_table, estimates)
 236   }
 237
 238   colnames(new_est_table) <- c(colnames(est_table), shiny::HTML(
 239     paste0(estimator$method, "<br/>(&mu; = ", estimator$mu, " ",
 240            tolower(estimator$mu_units), ")")))
 241
 242   return(new_est_table)
 243 }
 244
 245 # Create a new row in the estimator table when new datasets are added.
 246 update_est_row <- function(input, output, datasets, estimators, est_table) {
 247   if (length(estimators) == 0) {
 248     if (nrow(est_table) == 0)
 249       new_est_table <- data.frame(datasets[,1])
 250     else
 251       new_est_table <- data.frame(c(est_table[,1], datasets[,1]))
 252
 253     colnames(new_est_table) <- colnames(est_table)
 254   }
 255   else {
 256     new_est_table <- data.frame(matrix(nrow = nrow(datasets),
 257                                        ncol = length(estimators)))
 258
 259     for (row in 1:nrow(datasets))
 260       for (col in 1:length(estimators))
 261         new_est_table[row, col] <- eval_estimator(input, output,
 262           estimators[[col]], datasets[row,])
 263
 264     new_est_table <- cbind(datasets[,1], new_est_table)
 265     colnames(new_est_table) <- colnames(est_table)
 266     new_est_table <- rbind(est_table, new_est_table)
 267   }
 268
 269   return(new_est_table)
 270 }
 271
 272 # Evaluate an estimator on a given dataset.
 273 eval_estimator <- function(input, output, estimator, dataset) {
 274   # Adjust serial interval to match time unit of case counts.
 275   serial <- estimator$mu
 276   if (estimator$mu_units == "Days" && dataset[2] == "Weekly")
 277     serial <- serial / 7
 278   else if (estimator$mu_units == "Weeks" && dataset[2] == "Daily")
 279     serial <- serial * 7
 280
 281   # White and Pagano
 282   if (estimator$method == "WP") {
 283     estimate <- wp(unlist(dataset[3]), mu = serial, serial = TRUE,
 284                    grid_length = estimator$grid_length,
 285                    max_shape = estimator$max_shape,
 286                    max_scale = estimator$max_scale)
 287
 288     if (!is.na(estimator$mu))
 289       estimate <- round(estimate$r0, 2)
 290     # Display the estimated mean of the serial distribution if mu was not
 291     # specified.
 292     else {
 293       if (dataset[2] == "Daily")
 294         mu_units <- "days"
 295       else
 296         mu_units <- "weeks"
 297       MSI <- sum(estimate$supp * estimate$pmf)
 298       estimate <- shiny::HTML(paste0(round(estimate$r0, 2), "<br/>(&mu; = ",
 299                                      round(MSI, 2), " ", mu_units, ")"))
 300     }
 301   }
 302   # Sequential Bayes
 303   else if (estimator$method == "seqB")
 304     estimate <- round(seq_bayes(unlist(dataset[3]), mu = serial,
 305                            kappa = estimator$kappa), 2)
 306   # Incidence Decay
 307   else if (estimator$method == "ID")
 308     estimate <- round(id(unlist(dataset[3]), mu = serial), 2)
 309   # Incidence Decay with Exponential Adjustement
 310   else if (estimator$method == "IDEA")
 311     estimate <- round(idea(unlist(dataset[3]), mu = serial), 2)
 312
 313   return(estimate)
 314 }