diff --git a/tests/testthat/test-closures.R b/tests/testthat/test-closures.R index e35cfb6..5f7756a 100644 --- a/tests/testthat/test-closures.R +++ b/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,7 +84,6 @@ 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 ) @@ -164,9 +91,9 @@ test_that("Closures: lower threshold reduces epidemic size", { 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(