# Setup for testing -------------------------------------------------------
futile.logger::flog.threshold("FATAL")
reported_cases <- EpiNow2::example_confirmed[1:30]
default_estimate_infections <- function(..., add_stan = list(), gt = TRUE,
delay = TRUE) {
futile.logger::flog.threshold("FATAL")
def_stan <- list(
chains = 2, warmup = 50, samples = 50,
control = list(adapt_delta = 0.8)
)
def_stan <- modifyList(def_stan, add_stan)
stan_args <- do.call(stan_opts, def_stan)
suppressWarnings(estimate_infections(...,
generation_time = ifelse(gt, list(gt_opts(example_generation_time)), list(gt_opts()))[[1]],
delays = ifelse(delay, list(delay_opts(example_reporting_delay)), list(delay_opts()))[[1]],
stan = stan_args, verbose = FALSE
))
}
test_estimate_infections <- function(...) {
out <- default_estimate_infections(...)
expect_equal(names(out), c("samples", "summarised", "fit", "args", "observations"))
expect_true(nrow(out$samples) > 0)
expect_true(nrow(out$summarised) > 0)
expect_true(nrow(out$observations) > 0)
invisible(out)
}
# Test functionality ------------------------------------------------------
test_that("estimate_infections successfully returns estimates using default settings", {
skip_on_cran()
test_estimate_infections(reported_cases)
})
test_that("estimate_infections successfully returns estimates when passed NA values", {
skip_on_cran()
reported_cases_na <- data.table::copy(reported_cases)
reported_cases_na[sample(1:30, 5), confirm := NA]
test_estimate_infections(reported_cases_na)
})
test_that("estimate_infections successfully returns estimates when accumulating to weekly", {
skip_on_cran()
reported_cases_weekly <- data.table::copy(reported_cases)
reported_cases_weekly[, confirm := frollsum(confirm, 7)]
reported_cases_weekly <-
reported_cases_weekly[seq(7, nrow(reported_cases_weekly), 7)]
test_estimate_infections(reported_cases_weekly, obs = obs_opts(na = "accumulate"))
})
test_that("estimate_infections successfully returns estimates using no delays", {
skip_on_cran()
test_estimate_infections(reported_cases, delay = FALSE)
})
test_that("estimate_infections successfully returns estimates using the poisson observation model", {
skip_on_cran()
test_estimate_infections(reported_cases, obs = obs_opts(family = "poisson"))
})
test_that("estimate_infections successfully returns estimates using backcalculation", {
skip_on_cran()
test_estimate_infections(reported_cases, rt = NULL)
})
test_that("estimate_infections successfully returns estimates using a fixed Rt", {
skip_on_cran()
test_estimate_infections(reported_cases, gp = NULL)
})
test_that("estimate_infections successfully returns estimates using only mean shifted reported cases", {
skip_on_cran()
test_estimate_infections(reported_cases, gp = NULL, rt = NULL)
})
test_that("estimate_infections successfully returns estimates using a single breakpoint", {
skip_on_cran()
test_estimate_infections(data.table::copy(reported_cases)[, breakpoint := ifelse(date == "2020-03-10", 1, 0)],
gp = NULL
)
})
test_that("estimate_infections successfully returns estimates using a random walk", {
skip_on_cran()
test_estimate_infections(reported_cases, gp = NULL, rt = rt_opts(rw = 7))
})
test_that("estimate_infections works without setting a generation time", {
skip_on_cran()
df <- test_estimate_infections(reported_cases, gt = FALSE, delay = FALSE)
## check exp(r) == R
growth_rate <- df$samples[variable == "growth_rate"][,
list(date, sample, growth_rate = value)
]
R <- df$samples[variable == "R"][,
list(date, sample, R = value)
]
combined <- merge(growth_rate, R, by = c("date", "sample"), all = FALSE)
expect_equal(exp(combined$growth_rate), combined$R)
})
test_that("estimate_infections works with different kernels", {
skip_on_cran()
test_estimate_infections(reported_cases, gp = gp_opts(kernel = "se"))
test_estimate_infections(reported_cases, gp = gp_opts(kernel = "ou"))
test_estimate_infections(reported_cases, gp = gp_opts(matern_order = 5 / 2))
expect_error(gp_opts(matern_order = 4))
})
test_that("estimate_infections fails as expected when given a very short timeout", {
skip_on_cran()
expect_error(output <- capture.output(suppressMessages(
out <- default_estimate_infections(
reported_cases,
add_stan = list(future = TRUE, max_execution_time = 1, samples = 2000)
))), "all chains failed")
expect_error(output <- capture.output(suppressMessages(
out <- default_estimate_infections(
reported_cases,
add_stan = list(future = FALSE, max_execution_time = 1, samples = 2000)
))), "timed out")
})
test_that("estimate_infections works as expected with failing chains", {
skip_on_cran()
test_estimate_infections(reported_cases,
add_stan = list(
chains = 4,
stuck_chains = 2, future = TRUE,
control = list(adapt_delta = 0.8)
)
)
expect_error(default_estimate_infections(reported_cases,
add_stan = list(chains = 4, stuck_chains = 1)
))
expect_error(default_estimate_infections(reported_cases,
add_stan = list(
chains = 4,
stuck_chains = 3,
future = TRUE
)
))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.