From b9b38075f8be1f389a321b1dfe402687de109fab Mon Sep 17 00:00:00 2001 From: pratikunterwegs Date: Mon, 12 Feb 2024 16:18:50 +0000 Subject: [PATCH] Add tests for vectorised input, WIP #166, WIP #167 --- .../testthat/test-model_func_vectorisation.R | 255 ++++++++++++++++++ 1 file changed, 255 insertions(+) create mode 100644 tests/testthat/test-model_func_vectorisation.R diff --git a/tests/testthat/test-model_func_vectorisation.R b/tests/testthat/test-model_func_vectorisation.R new file mode 100644 index 00000000..c7c02433 --- /dev/null +++ b/tests/testthat/test-model_func_vectorisation.R @@ -0,0 +1,255 @@ +#### Tests checking the output of multiple parameter sets #### +# Prepare contact matrix and demography vector +polymod <- socialmixr::polymod +contact_data <- socialmixr::contact_matrix( + polymod, + countries = "United Kingdom", + age.limits = c(0, 20, 40), + symmetric = TRUE +) +contact_matrix <- t(contact_data$matrix) +demography_vector <- contact_data$demography$population + +# Prepare some initial objects +uk_population <- population( + name = "UK population", + contact_matrix = contact_matrix, + demography_vector = demography_vector, + initial_conditions = matrix( + c(0.9999, 0, 0.0001, 0, 0), + nrow = nrow(contact_matrix), ncol = 5L, + byrow = TRUE + ) +) + +# pass multiple parameter sets +beta <- rnorm(10, 1.3 / 7, sd = 0.01) +sigma <- rnorm(10, 0.5, sd = 0.01) +gamma <- rnorm(10, 1 / 7, sd = 0.01) + +test_that("Vectorised inputs: default model, parameter sets", { + ## Parameter uncertainty, single intervention scenario (none) ## + expect_no_condition( + model_default_cpp( + population = uk_population, + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma + ) + ) + + output <- model_default_cpp( + population = uk_population, + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma + ) + + expect_s3_class(output, "data.frame") + + expect_identical( + nrow(output), length(beta) + ) + expect_identical( + output$transmissibility, beta + ) + + # expect parameter set column has different values + # but scenario has single value + expect_identical( + output$param_set, seq_along(beta) + ) + expect_identical( + unique(output$scenario), 1L + ) +}) + +test_that("Vectorised inputs: default model, intervention sets", { + ## Multiple intervention scenarios ## + # create scenarios + school_closure <- intervention( + "school_closure", "contacts", + time_begin = 30, time_end = 60, reduction = c(0.2, 0, 0) + ) + work_closure <- intervention( + "work_closure", "contacts", + time_begin = 50, time_end = 80, reduction = c(0, 0.5, 0.1) + ) + + # intervention scenario list + intervention_scenarios <- list( + scenario_01 = list(contacts = school_closure), + scenario_02 = list(contacts = c(school_closure, work_closure)), + scenario_03 = list(contacts = work_closure) + ) + + expect_no_condition( + model_default_cpp( + population = uk_population, + intervention = intervention_scenarios + ) + ) + + output <- model_default_cpp( + population = uk_population, + intervention = intervention_scenarios + ) + + expect_s3_class(output, "data.frame") + + expect_identical( + nrow(output), length(intervention_scenarios) + ) + expect_equal( + output$intervention, intervention_scenarios, + ignore_attr = TRUE # ignore names + ) + + # expect parameter set column has has single value + # but scenario has multiple values + expect_identical( + output$scenario, seq_along(intervention_scenarios) + ) + expect_identical( + unique(output$param_set), 1L + ) +}) + +test_that("Vectorised inputs: default model, param and intervention sets", { + ## Multiple intervention scenarios and multiple parameter sets ## + # create scenarios + school_closure <- intervention( + "school_closure", "contacts", + time_begin = 30, time_end = 60, reduction = c(0.2, 0, 0) + ) + work_closure <- intervention( + "work_closure", "contacts", + time_begin = 50, time_end = 80, reduction = c(0, 0.5, 0.1) + ) + + # intervention scenario list + intervention_scenarios <- list( + scenario_01 = list(contacts = school_closure), + scenario_02 = list(contacts = c(school_closure, work_closure)), + scenario_03 = list(contacts = work_closure) + ) + + expect_no_condition( + model_default_cpp( + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma, + population = uk_population, + intervention = intervention_scenarios + ) + ) + output <- model_default_cpp( + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma, + population = uk_population, + intervention = intervention_scenarios + ) + + expect_s3_class(output, "data.frame") + + expect_identical( + nrow(output), length(intervention_scenarios) * length(beta) + ) + + # expect parameter set and scenario column have multiple values + expect_identical( + output$scenario, + rep(seq_along(intervention_scenarios), length(beta)) + ) + expect_identical( + output$param_set, + rep(seq_along(beta), each = length(intervention_scenarios)) + ) +}) + +## Tests for multi parameter, multi interventions with vaccinations ## +test_that("Vectorised inputs: default model multi-param-NPI with vaccination", { + # create alternative vaccination regimes + vax_regime_01 <- vaccination( + time_begin = matrix(20, nrow(contact_matrix)), + time_end = matrix(100, nrow(contact_matrix)), + nu = matrix(0.01, nrow(contact_matrix)) + ) + vax_regime_02 <- vaccination( + time_begin = matrix(10, nrow(contact_matrix)), + time_end = matrix(40, nrow(contact_matrix)), + nu = matrix(0.03, nrow(contact_matrix)) + ) + + # create scenarios + school_closure <- intervention( + "school_closure", "contacts", + time_begin = 30, time_end = 60, reduction = c(0.2, 0, 0) + ) + work_closure <- intervention( + "work_closure", "contacts", + time_begin = 50, time_end = 80, reduction = c(0, 0.5, 0.1) + ) + + # intervention scenario list + intervention_scenarios <- list( + scenario_00 = NULL, # no response scenario + scenario_01 = list(contacts = school_closure), + scenario_02 = list(contacts = c(school_closure, work_closure)), + scenario_03 = list(contacts = work_closure) + ) + + # vaccination scenarios list + vaccination_scenarios <- list( + scenario_00 = NULL, + scenario_01 = vax_regime_01, + scenario_02 = vax_regime_02 + ) + + expect_no_condition( + model_default_cpp( + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma, + population = uk_population, + intervention = intervention_scenarios, + vaccination = vaccination_scenarios + ) + ) + + output <- model_default_cpp( + transmissibility = beta, + infectiousness_rate = sigma, + recovery_rate = gamma, + population = uk_population, + intervention = intervention_scenarios, + vaccination = vaccination_scenarios + ) + + expect_s3_class(output, "data.frame") + + expect_identical( + nrow(output), + length(intervention_scenarios) * length(beta) * + length(vaccination_scenarios) + ) + + # do not expect names + expect_equal( + unique(output$vaccination), vaccination_scenarios, + ignore_attr = TRUE + ) + + # expect parameter set and scenario column have multiple values + n_unique_scenarios <- length(intervention_scenarios) * + length(vaccination_scenarios) + expect_identical( + output$scenario, + rep(seq_len(n_unique_scenarios), length(beta)) + ) + expect_identical( + output$param_set, + rep(seq_along(beta), each = n_unique_scenarios) + ) +})