Skip to content

Commit

Permalink
Add validation for bednet s + r + d = 1
Browse files Browse the repository at this point in the history 
 * Improve testing on prob_survive_bednets
 * Add validation to set_bednets
  • Loading branch information
@giovannic
giovannic committed Feb 14, 2025
1 parent 395e25f commit 711087e
Show file tree
Hide file tree
Showing 3 changed files with 70 additions and 81 deletions.
6 changes: 6 additions & 0 deletions R/vector_control_parameters.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,12 @@ set_bednets <- function(
stop('death and repelling probabilities columns need to align with timesteps')
}
}
if (!all((dn0 + rn) < 1)) {
stop('all death and repelling probabilities must sum to less than 1')
}
if (!all(rnm < rn)) {
stop('rnm must be less than rn')
}
parameters$bednets <- TRUE
parameters$bednet_timesteps <- timesteps
parameters$bednet_coverages <- coverages
Expand Down
4 changes: 2 additions & 2 deletions tests/testthat/test-resume.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -160,8 +160,8 @@ test_that("Bednets intervention can be added when resuming", {
timesteps = timesteps,
coverages = rep(0.5, n),
retention = 25,
dn0 = matrix(rep(0.533, n), ncol=1),
rn = matrix(rep(0.56, n), ncol=1),
dn0 = matrix(rep(0.5, n), ncol=1),
rn = matrix(rep(0.4, n), ncol=1),
rnm = matrix(rep(0.24, n), ncol=1),
gamman = rep(2.64 * 365, n))
}
Expand Down
141 changes: 62 additions & 79 deletions tests/testthat/test-vector-control.R
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,34 @@

test_that('set_bednets validates death and repelling parameters', {
parameters <- get_parameters()
# check that dn0 + rn < 1
expect_error(
set_bednets(
parameters,
timesteps = 5,
coverages = .5,
retention = 40,
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.5, .5), nrow=2, ncol=1),
rnm = matrix(c(.25, .25), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
)
# check that rnm < rn
expect_error(
set_bednets(
parameters,
timesteps = 5,
coverages = .5,
retention = 40,
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.15, .15), nrow=2, ncol=1),
rnm = matrix(c(.25, .25), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
)
})

test_that('set_bednets validates coverages', {
parameters <- get_parameters()
expect_error(
Expand All @@ -6,8 +37,8 @@ test_that('set_bednets validates coverages', {
timesteps = c(5, 50),
coverages = c(.5),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
Expand All @@ -19,8 +50,8 @@ test_that('set_bednets validates coverages', {
timesteps = c(5, 50),
coverages = c(-1, 0.5),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
), "all(coverages >= 0) && all(coverages <= 1) is not TRUE",
Expand All @@ -33,8 +64,8 @@ test_that('set_bednets validates coverages', {
timesteps = c(5, 50),
coverages = c(0.5, 1.5),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
), "all(coverages >= 0) && all(coverages <= 1) is not TRUE",
Expand All @@ -51,8 +82,8 @@ test_that('set_bednets validates matrices', {
timesteps = c(5, 50),
coverages = c(.5, .9),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
Expand All @@ -66,8 +97,8 @@ test_that('set_bednets sets parameters', {
timesteps = c(5, 50),
coverages = c(.5, .9),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
Expand Down Expand Up @@ -120,8 +151,8 @@ test_that('distribute_bednets process sets net_time correctly', {
timesteps = c(5, 50),
coverages = c(.5, .9),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
Expand Down Expand Up @@ -167,8 +198,8 @@ test_that('throw_away_bednets process resets net_time correctly', {
timesteps = c(5, 50),
coverages = c(.5, .9),
retention = 40,
dn0 = matrix(c(.533, .533), nrow=2, ncol=1),
rn = matrix(c(.56, .56), nrow=2, ncol=1),
dn0 = matrix(c(.5, .5), nrow=2, ncol=1),
rn = matrix(c(.4, .4), nrow=2, ncol=1),
rnm = matrix(c(.24, .24), nrow=2, ncol=1),
gamman = c(963.6, 963.6)
)
Expand Down Expand Up @@ -241,34 +272,29 @@ test_that('prob_bitten defaults to 1 with no protection', {
)
})

test_that('prob_bitten correctly calculates net only probabilities', {
timestep <- 100
test_that('prob_survives_bednets correctly calculates net only probabilities on the same day of distribution', {
parameters <- get_parameters()
parameters <- set_bednets(
parameters,
timesteps = c(5, 50, 100),
coverages = c(.5, .9, .2),
timesteps = 100,
coverages = .5,
retention = 40,
dn0 = matrix(rep(.533, 3), nrow=3, ncol=1),
rn = matrix(rep(.56, 3), nrow=3, ncol=1),
rnm = matrix(rep(.24, 3), nrow=3, ncol=1),
gamman = rep(25, 3)
)
variables <- create_variables(parameters)
variables$net_time <- individual::DoubleVariable$new(
c(-1, 5, 50, 100)
dn0 = matrix(.5, nrow=1, ncol=1),
rn = matrix(.4, nrow=1, ncol=1),
rnm = matrix(.24, nrow=1, ncol=1),
gamman = 25
)
variables$spray_time <- individual::DoubleVariable$new(rep(-1, 4))

expect_equal(
prob_bitten(timestep, variables, 1, parameters),
list(
prob_bitten_survives = c(1, 0.7797801, 0.6978752, 0.0709500),
prob_bitten = c(1, 0.7797801, 0.6978752, 0.0709500),
prob_repelled = c(0, 0.2100848, 0.2408112, 0.4760000)
),
tolerance = 1e-5

since_net <- 0
matches <- 1
sn <- prob_survives_bednets(
.4,
matches,
since_net,
1,
parameters
)
expect_equal(sn, .1)
})

test_that('prob_bitten correctly calculates spraying only probabilities', {
Expand Down Expand Up @@ -303,49 +329,6 @@ test_that('prob_bitten correctly calculates spraying only probabilities', {
)
})

test_that('prob_bitten correctly combines spraying and net probabilities', {
timestep <- 100
parameters <- get_parameters(list(human_population = 4))
parameters <- set_bednets(
parameters,
timesteps = c(5, 50, 100),
coverages = c(.5, .9, .2),
retention = 40,
dn0 = matrix(rep(.533, 3), nrow=3, ncol=1),
rn = matrix(rep(.56, 3), nrow=3, ncol=1),
rnm = matrix(rep(.24, 3), nrow=3, ncol=1),
gamman = rep(25, 3)
)
parameters <- set_spraying(
parameters,
timesteps = c(5, 50, 100),
coverages = c(.5, .9, .2),
ls_theta = matrix(rep(2.025, 3), nrow=3, ncol=1),
ls_gamma = matrix(rep(-0.009, 3), nrow=3, ncol=1),
ks_theta = matrix(rep(-2.222, 3), nrow=3, ncol=1),
ks_gamma = matrix(rep(0.008, 3), nrow=3, ncol=1),
ms_theta = matrix(rep(-1.232, 3), nrow=3, ncol=1),
ms_gamma = matrix(rep(-0.009, 3), nrow=3, ncol=1)
)
variables <- create_variables(parameters)
variables$net_time <- individual::IntegerVariable$new(
c(100, 50, 5, -1)
)
variables$spray_time <- individual::IntegerVariable$new(
c(-1, 5, 50, 100)
)

expect_equal(
prob_bitten(timestep, variables, 1, parameters),
list(
prob_bitten_survives = c(0.0709500, 0.1808229, 0.1629512, 0.1506359),
prob_bitten = c(0.0709500, 0.5828278, 0.6363754, 0.7688352),
prob_repelled = c(0.4760000, 0.3676569, 0.3556276, 0.2311648)
),
tolerance=1e-4
)
})

test_that('usage renderer outputs correct values', {
timestep <- 150

Expand Down

0 comments on commit 711087e

Please sign in to comment.