Single implementation for all response strategies

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: daedalus
 Title: Model health, social, and economic costs of a pandemic using
     _DAEDALUS_
-Version: 0.0.16
+Version: 0.0.17
 Authors@R: c(
     person("Pratik", "Gupte", , "p.gupte24@imperial.ac.uk", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-5294-7819")),

NEWS.md

@@ -1,4 +1,12 @@
-# daedalus 0.0.18
+# daedalus 0.0.17
+
+This patch removes dual implementation levels for response strategies. The "elimination" strategy has a "high" implementation level, while all other strategies keep their "light" implementation level.
+
+- The `daedalus()` argument `implementation_level` has been removed.
+
+- Tests and documentation have been updated to remove references to implementation levels.
+
+# daedalus 0.0.16
 
 This patch fixes an issue where vaccination start was tied to the `response_time`; it is now correctly controlled by the vaccine investment level passed to `daedalus()`.
 

R/class_infection.R

@@ -316,7 +316,6 @@ print.daedalus_infection <- function(x, ...) {
 format.daedalus_infection <- function(x, ...) {
   chkDots(...)
 
-  # NOTE: rough implementations, better scaling e.g. to millions could be added
   cli::cli_text("{.cls {class(x)}}")
   divid <- cli::cli_div(theme = list(.val = list(digits = 3)))
   cli::cli_bullets(

R/class_output.R

@@ -28,7 +28,7 @@ validate_daedalus_output <- function(x) {
     "model_data",
     # NOTE: reserving 'parameters' for values fixed before model run
     "country_parameters", "infection_parameters",
-    "response_data" # includes response strategy and implementation level
+    "response_data" # includes response strategy
   )
 
   stopifnot(

R/class_vaccination.R

@@ -190,7 +190,6 @@ print.daedalus_vaccination <- function(x, ...) {
 format.daedalus_vaccination <- function(x, ...) {
   chkDots(...)
 
-  # NOTE: rough implementations, better scaling e.g. to millions could be added
   cli::cli_text("{.cls {class(x)}}")
   cli::cli_text(
     "Advance vaccine investment: {cli::style_bold(x$name)}"

R/closure_data.R

@@ -1,14 +1,13 @@
 #' @title Pandemic response strategy data for DAEDALUS
 #'
 #' @description Coefficients of openness of economic sectors under different
-#' pandemic response strategies.
-#' There are four strategies (including no response), with two levels of
-#' implementation ("heavy" and "light").
+#' pandemic response strategies. There are four strategies (including no
+#' response, identified as `"none"`).
 #'
 #' @format ## `closure_data`
 #' A list with 4 elements, each corresponding to a pandemic response strategy,
-#' and each with 2 elements ("heavy" or "light") giving the coefficients of
-#' sector openness under different levels of implementation.
+#' each a vector `N_ECONOMIC_SECTORS` (45) giving the coefficients of
+#' sector openness.
 #' \describe{
 #'   \item{none}{All economic sectors are fully open and there is no pandemic
 #' response.}

R/daedalus.R

@@ -28,9 +28,6 @@
 #' While the response strategy is active, economic contacts are scaled using the
 #' package data object `daedalus::closure_data`.
 #'
-#' @param implementation_level A string for the level at which the strategy is
-#' implemented; defaults to "light".
-#'
 #' @param response_time A single numeric value for the time in days
 #' at which the selected response is activated. This is ignored if the response
 #' has already been activated by the hospitalisation threshold being reached.
@@ -113,7 +110,6 @@ daedalus <- function(country,
                        "none", "elimination", "economic_closures",
                        "school_closures"
                      ),
-                     implementation_level = c("light", "heavy"),
                      vaccine_investment = c(
                        "none", "low", "medium", "high"
                      ),
@@ -136,7 +132,6 @@ daedalus <- function(country,
   }
 
   response_strategy <- rlang::arg_match(response_strategy)
-  implementation_level <- rlang::arg_match(implementation_level)
 
   is_good_time_end <- checkmate::test_count(time_end, positive = TRUE)
   if (!is_good_time_end) {
@@ -215,9 +210,7 @@ daedalus <- function(country,
   mutables <- prepare_mutable_parameters()
 
   # add the appropriate economic openness vectors to parameters
-  openness <- daedalus::closure_data[[
-    response_strategy
-  ]][[implementation_level]]
+  openness <- daedalus::closure_data[[response_strategy]]
 
   # NOTE: psi (vax waning rate), tau (vax reduction in suscept.), and dims of nu
   # are hard-coded until vaccination scenarios are decided
@@ -351,7 +344,6 @@ daedalus <- function(country,
     infection_parameters = unclass(infection),
     response_data = list(
       response_strategy = response_strategy,
-      implementation_level = implementation_level,
       openness = openness, # easier to include here
       closure_info = get_closure_info(mutables)
     )

data-raw/closure_data.R

@@ -57,4 +57,16 @@ closure_data[["none"]] <- list(
   heavy = rep(1.0, N_ECON_SECTORS)
 )
 
+# JIDEA-132: pick a single implementation level for each response strategy
+# elimination: heavy; all others: light
+levels_to_keep <- c("heavy", rep("light", 3L))
+strategies <- c(strategies, "none")
+
+closure_data <- Map(
+  closure_data[strategies], levels_to_keep,
+  f = function(s, l) {
+    s[[l]]
+  }
+)
+
 usethis::use_data(closure_data, overwrite = TRUE)

tests/testthat/test-closures.R

@@ -3,7 +3,6 @@ response_names <- c(
   "none", "elimination",
   "economic_closures", "school_closures"
 )
-response_level <- c("light", "heavy")
 country_x <- daedalus_country("Thailand")
 
 test_that("Closures: basic expectations: runs without errors", {
@@ -14,106 +13,36 @@ test_that("Closures: basic expectations: runs without errors", {
     })
   })
 
-  # test some combinations of responses and implementation levels
-  expect_no_condition({
-    output_list <- Map(
-      response_names, response_level,
-      f = function(x, y) {
-        daedalus(
-          country_x, "sars_cov_1",
-          response_strategy = x, implementation_level = y
+  # test combinations of responses and some countries
+  invisible({
+    Map(
+      response_names, daedalus::country_names[seq_along(response_names)],
+      f = function(response, country) {
+        expect_no_condition(
+          daedalus(
+            country, "sars_cov_1",
+            response_strategy = response
+          )
         )
       }
     )
   })
 })
 
-# expectation that response strategy 'none' has little to no effect
-test_that("Closures: no response leads to similar epidemic sizes", {
-  # both implementation levels have identical epidemic sizes
-  levels <- c("light", "heavy")
-  output_list <- lapply(levels, function(x) {
-    daedalus(
-      country_x, "sars_cov_1",
-      response_strategy = "none", implementation_level = x
-    )
-  })
-
-  epidemic_sizes <- vapply(
-    output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
-  )
-
-  expect_identical(
-    epidemic_sizes[1], epidemic_sizes[2]
-  )
-
-  # response time has no effect when strategy is 'none'
-  response_times <- c(10, 100)
-  response_threshold <- 1e7 # artificially large
-  output_list <- lapply(response_times, function(x) {
-    daedalus(
-      country_x, "sars_cov_1",
-      response_strategy = "none", response_time = x,
-      response_threshold = response_threshold
-    )
-  })
-
-  epidemic_sizes <- vapply(
-    output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
-  )
-  # NOTE high tolerance as the two have just slightly different final sizes
-  expect_identical(
-    epidemic_sizes[1], epidemic_sizes[2],
-    tolerance = 1L
-  )
-
-  # response threshold has no effect when strategy is 'none'
-  response_thresholds <- c(10, 1000)
-  time_end <- 300
-  response_time <- time_end - 2L # artificially long response time
-  output_list <- lapply(response_thresholds, function(x) {
-    daedalus(
-      country_x, "sars_cov_1",
-      response_strategy = "none", response_time = response_time,
-      response_threshold = x
-    )
-  })
-
-  epidemic_sizes <- vapply(
-    output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
-  )
-
-  # NOTE high tolerance as the two have just slightly different final sizes
-  expect_identical(
-    epidemic_sizes[1], epidemic_sizes[2],
-    tolerance = 1L
-  )
-})
-
 # expect that applying closures reduces epidemic size
 test_that("Closures: basic statistical correctness: reduces epidemic size", {
   output_list <- lapply(response_names, function(x) {
     daedalus(
       country_x, daedalus_infection("sars_cov_1", rho = 0.0),
-      response_strategy = x,
-      implementation_level = "light" # test on light as this differs b/w strats
+      response_strategy = x
     )
   })
 
   epidemic_sizes <- vapply(
     output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
+      get_epidemic_summary(x, "infections")[["value"]]
+    },
+    FUN.VALUE = numeric(1L)
   )
 
   expect_true(
@@ -130,16 +59,15 @@ test_that("Closures: earlier closures reduce epidemic size", {
       country_x, daedalus_infection("sars_cov_1", rho = 0.0),
       response_strategy = "elimination",
       response_time = x,
-      response_threshold = response_threshold,
-      implementation_level = "light"
+      response_threshold = response_threshold
     )
   })
 
   epidemic_sizes <- vapply(
     output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
+      get_epidemic_summary(x, "infections")[["value"]]
+    },
+    FUN.VALUE = numeric(1L)
   )
 
   expect_lt(
@@ -156,17 +84,16 @@ test_that("Closures: lower threshold reduces epidemic size", {
     daedalus(
       country_x, daedalus_infection("sars_cov_1", rho = 0.0),
       response_strategy = "elimination",
-      implementation_level = "heavy",
       response_threshold = x,
       response_time = 200 # artificially high
     )
   })
 
   epidemic_sizes <- vapply(
     output_list, function(x) {
-      x <- get_data(x)
-      sum(x[x$compartment == "recovered" & x$time == max(x$time), ]$value)
-    }, numeric(1)
+      get_epidemic_summary(x, "infections")[["value"]]
+    },
+    FUN.VALUE = numeric(1L)
   )
 
   expect_lt(