From dff9e07b1f40851fc99433aa9f8bf65942cde08a Mon Sep 17 00:00:00 2001 From: Paul Lietar Date: Tue, 26 Mar 2024 15:31:53 +0000 Subject: [PATCH 1/2] Improve correlation tests. The tests for the correlation parameters were using a tolerance of 1e2 everywhere. Since the tolerance is relative, assertions would effectively succeed for any value within a few orders of magnitude. Setting obviously wrong expected results in the assertions did not produce any errors. This switches the tolerance to 0.1. This was chosen through experimenting, as something that didn't cause false negative even after many runs, while also being reasonably close. When using 0.01 I did get 1 failure in 100 runs of the test suite. Some of the assertions were using incorrected expected values, which flew under the radar because of the huge tolerance. I've also cleared up the tests and bit and made them more consitent with one another. Finally I changed the `CorrelationParameters` constructor to accept only the values it needs (population size and intervention booleans), rather than the full simulation parameters. This makes the test a bit more concise, and will also help with upcoming tests that work at restoring correlation state while adding interventions. The existing public wrapper `get_correlation_parameters` still has the same interface as before. --- R/correlation.R | 18 +++---- tests/testthat/test-correlation.R | 82 ++++++++++++------------------- 2 files changed, 40 insertions(+), 60 deletions(-) diff --git a/R/correlation.R b/R/correlation.R index df5f88f5..458a3015 100644 --- a/R/correlation.R +++ b/R/correlation.R @@ -24,11 +24,11 @@ CorrelationParameters <- R6::R6Class( public = list( #' @description initialise correlation parameters - #' @param parameters model parameters - initialize = function(parameters) { - # Find a list of enabled interventions - enabled <- vlapply(INTS, function(name) parameters[[name]]) - private$interventions <- INTS[enabled] + #' @param population popularion size + #' @param interventions character vector with the name of enabled interventions + initialize = function(population, interventions) { + private$population <- population + private$interventions <- interventions # Initialise a rho matrix for our interventions n_ints <- private$n_ints() @@ -38,9 +38,6 @@ CorrelationParameters <- R6::R6Class( ncol = n_ints, dimnames = list(private$interventions, private$interventions) ) - - # Store population for mvnorm draws - private$population <- parameters$human_population }, #' @description Add rho between rounds @@ -183,7 +180,10 @@ CorrelationParameters <- R6::R6Class( #' #' # You can now pass the correlation parameters to the run_simulation function get_correlation_parameters <- function(parameters) { - CorrelationParameters$new(parameters) + # Find a list of enabled interventions + enabled <- vlapply(INTS, function(name) parameters[[name]]) + + CorrelationParameters$new(parameters$human_population, INTS[enabled]) } #' @title Sample a population to intervene in given the correlation parameters diff --git a/tests/testthat/test-correlation.R b/tests/testthat/test-correlation.R index 880221ba..cd88c16d 100644 --- a/tests/testthat/test-correlation.R +++ b/tests/testthat/test-correlation.R @@ -2,38 +2,30 @@ test_that('1 correlation between rounds gives sensible samples', { pop <- 1e6 target <- seq(pop) vaccine_coverage <- .2 - parameters <- get_parameters(list( - human_population = pop, - pev = TRUE - )) - correlations <- get_correlation_parameters(parameters) + correlations <- CorrelationParameters$new(pop, c('pev')) correlations$inter_round_rho('pev', 1) round_1 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) round_2 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - expect_equal(sum(round_1), pop * .2, tolerance=1e2) - expect_equal(sum(round_2), pop * .2, tolerance=1e2) - expect_equal(sum(round_1 & round_2), pop * .2, tolerance=1e2) + + expect_equal(sum(round_1), pop * .2, tolerance=.1) + expect_equal(sum(round_2), pop * .2, tolerance=.1) + expect_equal(sum(round_1 & round_2), pop * .2, tolerance=.1) + expect_equal(sum(round_1 | round_2), pop * .2, tolerance=.1) }) test_that('0 correlation between rounds gives sensible samples', { pop <- 1e6 target <- seq(pop) vaccine_coverage <- .5 - parameters <- get_parameters(list( - human_population = pop, - pev = TRUE - )) - correlations <- get_correlation_parameters(parameters) + correlations <- CorrelationParameters$new(pop, c('pev')) correlations$inter_round_rho('pev', 0) round_1 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) round_2 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - expect_equal( - length(intersect(which(round_1), which(round_2))), - pop * .5, - tolerance=1e2 - ) - expect_equal(sum(round_1), sum(round_2), tolerance=1e2) - expect_equal(sum(round_1), pop * .5, tolerance=1e2) + + expect_equal(sum(round_1), sum(round_2), tolerance=.1) + expect_equal(sum(round_1), pop * .5, tolerance=.1) + expect_equal(sum(round_1 & round_2), pop * .25, tolerance=.1) + expect_equal(sum(round_1 | round_2), pop * .75, tolerance=.1) }) test_that('1 correlation between interventions gives sensible samples', { @@ -41,21 +33,17 @@ test_that('1 correlation between interventions gives sensible samples', { target <- seq(pop) vaccine_coverage <- .2 mda_coverage <- .2 - parameters <- get_parameters(list( - human_population = pop, - pev = TRUE, - mda = TRUE - )) - correlations <- get_correlation_parameters(parameters) + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', 1) vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal(sum(vaccine_sample), pop * .2, tolerance=1e2) - expect_equal(sum(mda_sample), pop * .2, tolerance=1e2) - expect_equal(sum(vaccine_sample & mda_sample), pop * .2, tolerance=1e2) + expect_equal(sum(vaccine_sample), pop * .2, tolerance=.1) + expect_equal(sum(mda_sample), pop * .2, tolerance=.1) + expect_equal(sum(vaccine_sample & mda_sample), pop * .2, tolerance=.1) + expect_equal(sum(vaccine_sample | mda_sample), pop * .2, tolerance=.1) }) test_that('0 correlation between interventions gives sensible samples', { @@ -63,24 +51,18 @@ test_that('0 correlation between interventions gives sensible samples', { target <- seq(pop) vaccine_coverage <- .2 mda_coverage <- .2 - parameters <- get_parameters(list( - human_population = pop, - pev = TRUE, - mda = TRUE - )) - correlations <- get_correlation_parameters(parameters) + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', 0) + vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal( - length(intersect(which(vaccine_sample), which(mda_sample))), - pop * .5, - tolerance=1e2 - ) - expect_equal(sum(vaccine_sample), sum(mda_sample), tolerance=1e2) - expect_equal(sum(vaccine_sample), pop * .5, tolerance=1e2) + + expect_equal(sum(vaccine_sample), sum(mda_sample), tolerance=.1) + expect_equal(sum(vaccine_sample), pop * .2, tolerance=.1) + expect_equal(sum(vaccine_sample & mda_sample), pop * .04, tolerance=.1) + expect_equal(sum(vaccine_sample | mda_sample), pop * .36, tolerance=.1) }) test_that('-1 correlation between interventions gives sensible samples', { @@ -88,18 +70,16 @@ test_that('-1 correlation between interventions gives sensible samples', { target <- seq(pop) vaccine_coverage <- .2 mda_coverage <- .2 - parameters <- get_parameters(list( - human_population = pop, - pev = TRUE, - mda = TRUE - )) - correlations <- get_correlation_parameters(parameters) + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', -1) + vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal(length(intersect(which(vaccine_sample), which(mda_sample))), 0) - expect_equal(sum(vaccine_sample), .2 * pop, tolerance=1e2) - expect_equal(sum(mda_sample), .2 * pop, tolerance=1e2) + + expect_equal(sum(vaccine_sample), .2 * pop, tolerance=.1) + expect_equal(sum(mda_sample), .2 * pop, tolerance=.1) + expect_equal(sum(vaccine_sample & mda_sample), 0, tolerance=.1) + expect_equal(sum(vaccine_sample | mda_sample), pop * .4, tolerance=.1) }) From 2aca8d5340b6e60732a6676fc323a8703798a245 Mon Sep 17 00:00:00 2001 From: Paul Lietar Date: Wed, 27 Mar 2024 14:58:56 +0000 Subject: [PATCH 2/2] Use explicit probability formulas --- tests/testthat/test-correlation.R | 121 +++++++++++++++++++++--------- 1 file changed, 86 insertions(+), 35 deletions(-) diff --git a/tests/testthat/test-correlation.R b/tests/testthat/test-correlation.R index cd88c16d..882831f8 100644 --- a/tests/testthat/test-correlation.R +++ b/tests/testthat/test-correlation.R @@ -1,85 +1,136 @@ test_that('1 correlation between rounds gives sensible samples', { pop <- 1e6 target <- seq(pop) - vaccine_coverage <- .2 + + coverage_1 <- .2 + coverage_2 <- .4 + correlations <- CorrelationParameters$new(pop, c('pev')) correlations$inter_round_rho('pev', 1) - round_1 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - round_2 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - expect_equal(sum(round_1), pop * .2, tolerance=.1) - expect_equal(sum(round_2), pop * .2, tolerance=.1) - expect_equal(sum(round_1 & round_2), pop * .2, tolerance=.1) - expect_equal(sum(round_1 | round_2), pop * .2, tolerance=.1) + round_1 <- sample_intervention(target, 'pev', coverage_1, correlations) + round_2 <- sample_intervention(target, 'pev', coverage_2, correlations) + + expect_equal(sum(round_1), pop * coverage_1, tolerance=.1) + expect_equal(sum(round_2), pop * coverage_2, tolerance=.1) + + expect_equal( + sum(round_1 & round_2), + pop * min(coverage_1, coverage_2), + tolerance=.1) + + expect_equal( + sum(round_1 | round_2), + pop * max(coverage_1, coverage_2), + tolerance=.1) }) test_that('0 correlation between rounds gives sensible samples', { pop <- 1e6 target <- seq(pop) - vaccine_coverage <- .5 + + coverage_1 <- .2 + coverage_2 <- .4 + correlations <- CorrelationParameters$new(pop, c('pev')) correlations$inter_round_rho('pev', 0) - round_1 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - round_2 <- sample_intervention(target, 'pev', vaccine_coverage, correlations) - expect_equal(sum(round_1), sum(round_2), tolerance=.1) - expect_equal(sum(round_1), pop * .5, tolerance=.1) - expect_equal(sum(round_1 & round_2), pop * .25, tolerance=.1) - expect_equal(sum(round_1 | round_2), pop * .75, tolerance=.1) + round_1 <- sample_intervention(target, 'pev', coverage_1, correlations) + round_2 <- sample_intervention(target, 'pev', coverage_2, correlations) + + expect_equal(sum(round_1), pop * coverage_1, tolerance=.1) + expect_equal(sum(round_2), pop * coverage_2, tolerance=.1) + + expect_equal( + sum(round_1 & round_2), + pop * coverage_1 * coverage_2, + tolerance=.1) + + expect_equal( + sum(round_1 | round_2), + pop * (coverage_1 + coverage_2 - (coverage_1 * coverage_2)), + tolerance=.1) }) test_that('1 correlation between interventions gives sensible samples', { pop <- 1e6 target <- seq(pop) - vaccine_coverage <- .2 - mda_coverage <- .2 + + pev_coverage <- .2 + mda_coverage <- .4 + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', 1) - vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) + + pev_sample <- sample_intervention(target, 'pev', pev_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal(sum(vaccine_sample), pop * .2, tolerance=.1) - expect_equal(sum(mda_sample), pop * .2, tolerance=.1) - expect_equal(sum(vaccine_sample & mda_sample), pop * .2, tolerance=.1) - expect_equal(sum(vaccine_sample | mda_sample), pop * .2, tolerance=.1) + expect_equal(sum(pev_sample), pop * pev_coverage, tolerance=.1) + expect_equal(sum(mda_sample), pop * mda_coverage, tolerance=.1) + + expect_equal( + sum(pev_sample & mda_sample), + pop * min(pev_coverage, mda_coverage), + tolerance=.1) + + expect_equal( + sum(pev_sample | mda_sample), + pop * max(pev_coverage, mda_coverage), + tolerance=.1) }) test_that('0 correlation between interventions gives sensible samples', { pop <- 1e6 target <- seq(pop) - vaccine_coverage <- .2 - mda_coverage <- .2 + + pev_coverage <- .2 + mda_coverage <- .4 + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', 0) - vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) + pev_sample <- sample_intervention(target, 'pev', pev_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal(sum(vaccine_sample), sum(mda_sample), tolerance=.1) - expect_equal(sum(vaccine_sample), pop * .2, tolerance=.1) - expect_equal(sum(vaccine_sample & mda_sample), pop * .04, tolerance=.1) - expect_equal(sum(vaccine_sample | mda_sample), pop * .36, tolerance=.1) + expect_equal(sum(pev_sample), pop * pev_coverage, tolerance=.1) + expect_equal(sum(mda_sample), pop * mda_coverage, tolerance=.1) + + expect_equal( + sum(pev_sample & mda_sample), + pop * pev_coverage * mda_coverage, + tolerance=.1) + + expect_equal( + sum(pev_sample | mda_sample), + pop * (pev_coverage + mda_coverage - (pev_coverage * mda_coverage)), + tolerance=.1) }) test_that('-1 correlation between interventions gives sensible samples', { pop <- 1e6 target <- seq(pop) - vaccine_coverage <- .2 - mda_coverage <- .2 + + pev_coverage <- .2 + mda_coverage <- .4 + correlations <- CorrelationParameters$new(pop, c('pev', 'mda')) correlations$inter_round_rho('pev', 1) correlations$inter_round_rho('mda', 1) correlations$inter_intervention_rho('pev', 'mda', -1) - vaccine_sample <- sample_intervention(target, 'pev', vaccine_coverage, correlations) + pev_sample <- sample_intervention(target, 'pev', pev_coverage, correlations) mda_sample <- sample_intervention(target, 'mda', mda_coverage, correlations) - expect_equal(sum(vaccine_sample), .2 * pop, tolerance=.1) - expect_equal(sum(mda_sample), .2 * pop, tolerance=.1) - expect_equal(sum(vaccine_sample & mda_sample), 0, tolerance=.1) - expect_equal(sum(vaccine_sample | mda_sample), pop * .4, tolerance=.1) + expect_equal(sum(pev_sample), pop * pev_coverage, tolerance=.1) + expect_equal(sum(mda_sample), pop * mda_coverage, tolerance=.1) + + expect_equal(sum(pev_sample & mda_sample), 0, tolerance=.1) + expect_equal( + sum(pev_sample | mda_sample), + pop * (pev_coverage + mda_coverage), + tolerance=.1) })