+# Main logic block for estimator-related interactions.
estimators_logic <- function(input, output, react_values) {
# Initialize a data frame to hold estimates.
- react_values$estimates_table <- data.frame(Dataset = character(0))
+ react_values$estimates_table <- data.frame(
+ Estimator = character(0),
+ `Serial interval` = character(0),
+ check.names = FALSE
+
+ )
# Initialize a list to hold added estimators.
react_values$estimators <- list()
# Check whether the new estimator is a duplicate, and warn if so.
for (i in seq_len(num_estimators)) {
if (identical(new_estimator, react_values$estimators[[i]])) {
- showNotification("Error: This estimator has already been added.",
- duration = 3, id = "notify-error"
+ showNotification(
+ "Error: This estimator has already been added.", duration = 3
)
return()
}
# Add the new estimator to the list of estimators.
react_values$estimators[[num_estimators + 1]] <- new_estimator
- showNotification("Estimator added successfully.",
- duration = 3, id = "notify-success"
- )
+ showNotification("Estimator added successfully.", duration = 3)
- # Evaluate all the new estimator on all existing datasets and create a new
- # column in the estimates table.
- update_estimates_col(new_estimator, react_values)
+ # Evaluate the new estimator on all existing datasets and create a new row in
+ # the estimates table.
+ update_estimates_row(new_estimator, react_values)
}
# Ensure serial intervals are specified as positive numbers.
kappa <- trimws(input$kappa)
kappa <- if (kappa == "") 20 else suppressWarnings(as.numeric(kappa))
- if (is.na(kappa) || kappa <= 0) {
+ if (is.na(kappa) || kappa < 1) {
output$kappa_warn <- renderText(
- "The maximum prior must be a positive number."
+ "The maximum prior must be a number greater than or equal to 1."
)
} else if (!is.null(mu)) {
output$kappa_warn <- renderText("")
mu
}
-# Add a column to the estimates table when a new estimator is added.
-update_estimates_col <- function(estimator, react_values) {
+# Add a row to the estimates table when a new estimator is added.
+update_estimates_row <- function(estimator, react_values) {
dataset_rows <- seq_len(nrow(react_values$data_table))
- estimates <- dataset_rows
+ estimates <- c()
- for (row in dataset_rows) {
- estimate <- eval_estimator(estimator, react_values$data_table[row, ])
- estimates[row] <- estimate
+ if (nrow(react_values$data_table) > 0) {
+ estimates <- dataset_rows
+ for (row in dataset_rows) {
+ estimate <- eval_estimator(estimator, react_values$data_table[row, ])
+ estimates[row] <- estimate
+ }
}
- estimates <- data.frame(estimates)
- colnames(estimates) <- estimates_col_name(estimates, estimator)
+ new_row <- data.frame(
+ t(c(estimator_name(estimator), estimator_mu_text(estimator), estimates))
+ )
+ colnames(new_row) <- colnames(react_values$estimates_table)
- react_values$estimates_table <- cbind(
- react_values$estimates_table, estimates
+ react_values$estimates_table <- rbind(
+ react_values$estimates_table, new_row
)
}
eval_estimator <- function(estimator, dataset) {
cases <- as.integer(unlist(strsplit(dataset[, 3], ",")))
- if (estimator$method == "id") {
- mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
- estimate <- round(Rnaught::id(cases, mu), 2)
- } else if (estimator$method == "idea") {
- mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
- estimate <- round(Rnaught::idea(cases, mu), 2)
- } else if (estimator$method == "seq_bayes") {
- mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
- estimate <- round(Rnaught::seq_bayes(cases, mu, estimator$kappa), 2)
- } else if (estimator$method == "wp") {
- if (is.na(estimator$mu)) {
- estimate <- Rnaught::wp(cases, serial = TRUE,
- grid_length = estimator$grid_length,
- max_shape = estimator$max_shape, max_scale = estimator$max_scale
- )
- estimated_mu <- round(sum(estimate$supp * estimate$pmf), 2)
- estimate <- paste0(round(estimate$r0, 2), " (μ = ", estimated_mu,
- " ", tolower(dataset[, 2]), ")"
+ tryCatch(
+ {
+ if (estimator$method == "id") {
+ mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
+ estimate <- round(Rnaught::id(cases, mu), 2)
+ } else if (estimator$method == "idea") {
+ mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
+ estimate <- round(Rnaught::idea(cases, mu), 2)
+ } else if (estimator$method == "seq_bayes") {
+ mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
+ estimate <- round(Rnaught::seq_bayes(cases, mu, estimator$kappa), 2)
+ } else if (estimator$method == "wp") {
+ if (is.na(estimator$mu)) {
+ estimate <- Rnaught::wp(cases, serial = TRUE,
+ grid_length = estimator$grid_length,
+ max_shape = estimator$max_shape, max_scale = estimator$max_scale
+ )
+ estimated_mu <- round(sum(estimate$supp * estimate$pmf), 2)
+ mu_units <- if (dataset[, 2] == "Days") "day(s)" else "week(s)"
+ estimate <- paste0(
+ round(estimate$r0, 2), " (SI = ", estimated_mu, " ", mu_units, ")"
+ )
+ } else {
+ mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
+ estimate <- round(Rnaught::wp(cases, mu), 2)
+ }
+ }
+
+ return(estimate)
+ }, error = function(e) {
+ showNotification(
+ paste0(toString(e),
+ " [Estimator: ", sub(" .*", "", estimator_name(estimator)),
+ ", Dataset: ", dataset[, 1], "]"
+ ), duration = 6
)
- } else {
- mu <- convert_mu_units(dataset[, 2], estimator$mu_units, estimator$mu)
- estimate <- round(Rnaught::wp(cases, mu), 2)
+ return("—")
}
- }
-
- return(estimate)
+ )
}
-# Create the column name of an estimator when it is
-# added to the estimates table.
-estimates_col_name <- function(estimates, estimator) {
+# Create the name of an estimator to be added to the first column of the
+# estimates table.
+estimator_name <- function(estimator) {
if (estimator$method == "id") {
- return(paste0("ID", " (μ = ", estimator$mu, " ",
- tolower(estimator$mu_units), ")"
- ))
+ return("ID")
} else if (estimator$method == "idea") {
- return(paste0("IDEA", " (μ = ", estimator$mu, " ",
- tolower(estimator$mu_units), ")"
- ))
+ return("IDEA")
} else if (estimator$method == "seq_bayes") {
- return(paste0("seqB", " (μ = ", estimator$mu, " ",
- tolower(estimator$mu_units), ", κ = ", estimator$kappa, ")"
- ))
+ return(paste0("seqB", " (κ = ", estimator$kappa, ")"))
} else if (estimator$method == "wp") {
if (is.na(estimator$mu)) {
return(paste0("WP (", estimator$grid_length, ", ",
round(estimator$max_shape, 3), ", ", round(estimator$max_scale, 3), ")"
))
} else {
- return(paste0("WP", " (μ = ", estimator$mu, " ",
- tolower(estimator$mu_units), ")"
- ))
+ return("WP")
}
}
}
+# Create the text to be displayed for the serial interval in the second column
+# of the estimates table.
+estimator_mu_text <- function(estimator) {
+ if (is.na(estimator$mu)) {
+ return("—")
+ }
+ mu_units <- if (estimator$mu_units == "Days") "day(s)" else "week(s)"
+ paste(estimator$mu, mu_units)
+}
+
# Render the estimates table whenever it is updated.
render_estimates <- function(output, react_values) {
observe({
output$estimates_table <- DT::renderDataTable(react_values$estimates_table,
- selection = list(target = "column", selectable = c(0)),
escape = FALSE, rownames = FALSE,
options = list(
columnDefs = list(list(className = "dt-left", targets = "_all"))
})
}
-# Delete columns from the estimates table,
-# as well as the corresponding estimators.
+# Delete rows from the estimates table and the corresponding estimators.
delete_estimators <- function(input, react_values) {
observeEvent(input$estimators_delete, {
- cols_selected <- input$estimates_table_columns_selected
- react_values$estimators <- react_values$estimators[-cols_selected]
- react_values$estimates_table[, cols_selected + 1] <- NULL
+ rows_selected <- input$estimates_table_rows_selected
+ react_values$estimators <- react_values$estimators[-rows_selected]
+ react_values$estimates_table <-
+ react_values$estimates_table[-rows_selected, ]
})
}
# Substitute HTML entity codes with natural names.
sub_entity <- function(obj) {
- obj <- gsub("μ", "mu", obj)
obj <- gsub("κ", "kappa", obj)
obj
}
git.nmode.ca / Rnaught / blobdiff
