context("Generating contact matrices")
polymod2 <- get_survey(polymod)
polymod3 <- get_survey(polymod)
polymod4 <- get_survey(polymod)
polymod5 <- get_survey(polymod)
polymod6 <- get_survey(polymod)
polymod7 <- get_survey(polymod)
polymod8 <- get_survey(polymod)
polymod9 <- get_survey(polymod)
polymod10 <- get_survey(polymod)
polymod11 <- get_survey(polymod)
polymod2$participants$added_weight <- 0.5
polymod2$contacts$cnt_age <- factor(polymod2$contacts$cnt_age)
polymod2$participants$part_age[1] <- "3-5"
polymod3$participants$dayofweek <- NULL
polymod3$participants$year <- NULL
polymod4$participants$country <- NULL
polymod5$participants$country <- factor("Zamonia")
polymod6$contacts$cnt_age_est_min <- NULL
polymod6$contacts$cnt_age_est_max <- NULL
polymod6$contacts$cnt_age_exact <- NULL
polymod7$participants$country <- NULL
polymod8$contacts$cnt_age_exact <- NA_real_
polymod8$contacts$cnt_age_est_min <- NA_real_
polymod8$contacts$cnt_age_est_max <- NA_real_
polymod8$contacts$cnt_age <- NA_real_
polymod8$contacts[polymod$contacts$part_id == 10, "cnt_age"] <- 10
polymod8$contacts[polymod$contacts$part_id == 20, "cnt_age"] <- 20
polymod9$participants$part_age_est_min <- 1
polymod9$participants$part_age_est_max <- 15
polymod9$participants$part_age <- NULL
polymod9$participants$part_age_est_min <- 1
polymod9$participants$part_age_est_max <- 15
nn <- nrow(polymod9$participants)
polymod9$participants$part_age <- ifelse(runif(nn) > 0.7, 20, NA)
polymod10$participants$added_weight <-
ifelse(polymod10$participants$hh_size > 1, 2, 1)
polymod10$participants$added_weight2 <- 0.3
# to test weights (age and day.of.week)
part_selection <- (polymod11$participants$part_age %in% (1:2) & polymod11$participants$dayofweek %in% 1:6) |
(polymod11$participants$part_age %in% (3) & polymod11$participants$dayofweek %in% 2:3)
polymod11$participants <- polymod11$participants[part_selection, ]
empty_pop <- data.frame(lower.age.limit = c(0, 5), population = NA_real_)
options <-
list(
test1 = list(survey = polymod, countries = "United Kingdom", counts = TRUE, weigh.dayofweek = TRUE, age.limits = seq(0, 80, by = 5), missing.contact.age = "remove"),
test2 = list(survey = polymod2, age.limits = c(0, 5), weights = "added_weight", symmetric = TRUE, sample.participants = TRUE),
test3 = list(survey = polymod, survey.pop = "Australia", countries = "GB", split = TRUE, filter = c(cnt_home = 1), age.limits = c(0, 5, 10), estimated.contact.age = "sample", symmetric = TRUE, missing.contact.age = "remove"),
test4 = list(survey = polymod8, missing.contact.age = "sample", symmetric = TRUE, age.limits = c(0, 5, 15))
)
contacts <- suppressMessages(lapply(options, function(x) {
do.call(contact_matrix, x)
}))
test_that("contact matrix exists and is square", {
expect_true(all(sapply(contacts, function(x) {
length(unique(dim(x[["matrix"]]))) == 1
})))
expect_true(all(sapply(contacts, function(x) {
prod(dim(x[["matrix"]])) > 0
})))
})
test_that("contact matrix is numeric", {
expect_true(all(sapply(contacts, function(x) {
is.numeric(x[["matrix"]])
})))
expect_false(anyNA(sapply(contacts, function(x) {
is.numeric(x[["matrix"]])
})))
expect_type(contacts[[3]]$contacts, "double")
expect_type(contacts[[3]]$normalisation, "double")
})
test_that("demography has been returned", {
expect_gt(nrow(contacts[[3]]$demography), 0)
})
test_that("demography is numeric", {
expect_type(contacts[[3]]$demography$population, "double")
})
test_that("survey argument is validated", {
expect_error(contact_matrix(survey = "bogus"), "survey")
})
test_that("error is thrown if no survey population can be generated", {
expect_error(suppressWarnings(contact_matrix(survey = polymod, countries = "Zamonia"), "No survey data available"))
})
test_that("error is thrown if age limits are non-numeric", {
expect_error(suppressWarnings(contact_matrix(survey = polymod, age.limits = c(0, 5, "fifteen"))), "age.limits")
})
test_that("error is thrown if country is not found", {
expect_error(contact_matrix(survey = polymod, countries = c("Italy", "Zamonia")), "data not found")
})
test_that("warning is thrown if filter column is not found", {
expect_warning(contact_matrix(survey = polymod, filter = c(test = 0)), "column.* not found")
})
test_that("warning is thrown if missing data exist", {
expect_warning(contact_matrix(survey = polymod, missing.contact.age = "keep", symmetric = TRUE), "missing.contact.age")
expect_warning(contact_matrix(survey = polymod, split = TRUE), "age groups")
})
test_that("error is thrown if an unknown argument is passed", {
expect_error(contact_matrix(dummy = "test"), "Unknown argument")
})
test_that("error is thrown if invalid age limits are passed", {
expect_error(contact_matrix(survey = polymod, age.limits = c(13, 11)), "increasing")
})
test_that("error is thrown if there are no participants after selection the country", {
expect_error(contact_matrix(survey = polymod, countries = "Romania"), "No participants left")
})
test_that("warning is thrown if population needed but no 'year' column present", {
expect_warning(contact_matrix(survey = polymod3, symmetric = TRUE), "No 'year' column")
})
test_that("warning is thrown if day of week is asked to be weighed but not present", {
expect_warning(contact_matrix(survey = polymod3, weigh.dayofweek = TRUE), "no 'dayofweek' column")
})
test_that("warning is thrown if country has no survey population", {
expect_error(contact_matrix(survey = polymod5, symmetric = TRUE), "not find population data")
})
test_that("warning is thrown if contact survey has no age information", {
expect_warning(check(x = polymod6), "do not exist")
})
test_that("warning is thrown if participant data has no country", {
expect_warning(check(x = polymod4), "does not exist")
})
test_that("user is informed about removing missing data", {
expect_message(contact_matrix(survey = polymod), "Removing")
})
test_that("check result is reported back", {
expect_message(check(x = polymod2), "Check")
})
test_that("good suggestions are made", {
expect_warning(contact_matrix(survey = polymod8, symmetric = TRUE, age.limits = c(0, 5, 15)), "adjusting the age limits")
expect_warning(contact_matrix(survey = polymod, symmetric = TRUE, age.limits = c(0, 5, 15), missing.participant.age = "keep"), "setting 'missing.participant.age")
expect_warning(contact_matrix(survey = polymod, symmetric = TRUE, age.limits = c(0, 5, 15), missing.participant.age = "keep", missing.contact.age = "keep"), "and 'missing.contact.age")
})
test_that("nonsensical operations are warned about", {
expect_warning(contact_matrix(survey = polymod, counts = TRUE, split = TRUE, age.limits = c(0, 5)), "'split=TRUE' does not make sense with 'counts=TRUE'")
expect_warning(contact_matrix(survey = polymod, counts = TRUE, symmetric = TRUE, age.limits = c(0, 5)), "'symmetric=TRUE' does not make sense with 'counts=TRUE'")
expect_warning(contact_matrix(survey = polymod, split = TRUE, age.limits = c(0, 5, 15), missing.participant.age = "keep"), "does not work with missing data")
})
test_that("warning is thrown if it is assumed that the survey is representative", {
expect_warning(contact_matrix(survey = polymod4, symmetric = TRUE), "Assuming the survey is representative")
})
test_that("Taking mean of estimated contact's age give na when mean is not in an age limit ", {
cm <- contact_matrix(survey = polymod9, age.limits = c(0, 5, 10, 15, 20))
expect_true(is.na(rowSums(cm$matrix)[1]))
expect_false(is.na(rowSums(cm$matrix)[2]))
expect_true(is.na(rowSums(cm$matrix)[3]))
expect_true(is.na(rowSums(cm$matrix)[4]))
expect_false(is.na(rowSums(cm$matrix)[5]))
})
test_that("Taking sample of estimated participant's give na when no overlap with the age limits ", {
cm <- contact_matrix(survey = polymod9, age.limits = c(0, 5, 10, 15, 20), estimated.participant.age = "sample")
expect_false(is.na(rowSums(cm$matrix)[1]))
expect_false(is.na(rowSums(cm$matrix)[2]))
expect_false(is.na(rowSums(cm$matrix)[3]))
expect_true(is.na(rowSums(cm$matrix)[4]))
expect_false(is.na(rowSums(cm$matrix)[5]))
})
test_that("If weights = added_weight, the results are not identical", {
cm_orig <- suppressMessages(
contact_matrix(
survey = polymod10, countries = "United Kingdom",
age.limits = c(0, 18, 60),
return.part.weights = TRUE
)
)
cm_weight <- suppressMessages(contact_matrix(
survey = polymod10, countries = "United Kingdom",
age.limits = c(0, 18, 60),
weights = "added_weight",
return.part.weights = TRUE
))
expect_identical(cm_orig$participants, cm_weight$participants)
expect_false(nrow(cm_orig$participants.weights) == nrow(cm_weight$participants.weights))
expect_false(all(cm_orig$matrix == cm_weight$matrix))
})
test_that("The order in which weights are applied do not change the results", {
expect_identical(
suppressMessages(
contact_matrix(
survey = polymod10, countries = "United Kingdom",
weights = c("added_weight2", "added_weight")
)
),
suppressMessages(
contact_matrix(
survey = polymod10, countries = "United Kingdom",
weights = c("added_weight", "added_weight2")
)
)
)
})
test_that("The day.of.week weight does not affect single-year age groups that reported only during weekdays", {
matrix_unweighted <- suppressMessages(suppressWarnings(
contact_matrix(
polymod11, age.limits = 1:3, weigh.dayofweek = FALSE, symmetric = FALSE
)
))
matrix_weighted <- suppressMessages(suppressWarnings(
contact_matrix(
polymod11, age.limits = 1:3, weigh.dayofweek = TRUE, symmetric = FALSE
)
))
num_contacts_unweighted <- rowSums(matrix_unweighted$matrix)
num_contacts_weighted <- rowSums(matrix_weighted$matrix)
# ages 1 and 2 => impaced by weights
expect_true(rowSums(matrix_unweighted$matrix)[1] != rowSums(matrix_weighted$matrix)[1])
expect_true(rowSums(matrix_unweighted$matrix)[2] != rowSums(matrix_weighted$matrix)[2])
# age 3 => contains only data on weekdays => should not be impacted by weights
expect_equal(num_contacts_unweighted[3], num_contacts_weighted[3], tolerance = 1e-8)
})
test_that("The day.of.week weight does not affect an age group that reported only during weekdays", {
matrix_unweighted <- contact_matrix(polymod11, age.limits = c(0, 3), weigh.dayofweek = FALSE, symmetric = FALSE)
matrix_weighted <- contact_matrix(polymod11, age.limits = c(0, 3), weigh.dayofweek = TRUE, symmetric = FALSE)
num_contacts_unweighted <- rowSums(matrix_unweighted$matrix)
num_contacts_weighted <- rowSums(matrix_weighted$matrix)
# age group 1 => adjusted by weights
expect_true(rowSums(matrix_unweighted$matrix)[1] != rowSums(matrix_weighted$matrix)[1])
# age group 2 => contains only data on weekdays => should not be impacted by weights
expect_equal(num_contacts_unweighted[2], num_contacts_weighted[2], tolerance = 1e-8)
})
test_that("The day.of.week weight should change the result with only one age group", {
matrix_unweighted <- contact_matrix(polymod11, age.limits = 0, weigh.dayofweek = FALSE, symmetric = FALSE)
matrix_weighted <- contact_matrix(polymod11, age.limits = 0, weigh.dayofweek = TRUE, symmetric = FALSE)
expect_false(matrix_unweighted$matrix == matrix_weighted$matrix)
})
test_that("The age-specific weight should change the results for multi-year age groups", {
suppressWarnings({
matrix_unweighted <- contact_matrix(polymod11, age.limits = c(0, 3), weigh.age = FALSE, symmetric = FALSE)
matrix_weighted <- contact_matrix(polymod11, age.limits = c(0, 3), weigh.age = TRUE, symmetric = FALSE)
})
expect_gt(sum(matrix_unweighted$matrix[1, ]), sum(matrix_weighted$matrix[1, ])) # manual calculation
expect_identical(matrix_unweighted$matrix[2, ], matrix_weighted$matrix[2, ])
})
test_that("The age-specific weight should not change the results with single year age groups", {
expect_equal(
suppressWarnings(
contact_matrix(
survey = polymod,
countries = "Poland",
age.limits = 1:110,
weigh.age = FALSE
)$matrix
),
suppressWarnings(
contact_matrix(
survey = polymod,
countries = "Poland",
age.limits = 1:110,
weigh.age = TRUE
)$matrix
),
tolerance = 1e-15
)
})
test_that("The selection of age groups based on the participant data is also used for the reference population", {
# no problems expected
cm <- suppressWarnings(contact_matrix(polymod, age.limits = c(0, 18, 50, 100), symmetric = FALSE))
# problems expected if age.group.breaks of the reference population is not updated according to the participant data
cm <- suppressWarnings(contact_matrix(polymod, age.limits = c(0, 18, 50, 100), symmetric = TRUE))
expect_true(all(cm$demography$age.group == cm$participants$age.group))
})
test_that("The return.demography overrules other parameters", {
suppressWarnings({
# no demography data
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18))$demography)
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), symmetric = FALSE)$demography)
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.age = FALSE)$demography)
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), split = FALSE)$demography)
# default behaviour
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), symmetric = TRUE)$demography, "list")
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.age = TRUE)$demography, "list")
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), split = TRUE)$demography, "list")
# always return demography, irrespectively of other function paramters
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), symmetric = FALSE, return.demography = TRUE)$demography, "list")
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.age = FALSE, return.demography = TRUE)$demography, "list")
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), split = FALSE, return.demography = TRUE)$demography, "list")
# never return demography data, irrespectively of other function paramters
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), symmetric = TRUE, return.demography = FALSE)$demography)
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.age = TRUE, return.demography = FALSE)$demography)
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18), split = TRUE, return.demography = FALSE)$demography)
})
})
test_that("The return.part.weights option", {
suppressWarnings({
# no participant weights data
expect_null(contact_matrix(survey = polymod, age.limits = c(0, 18))$participants.weights)
# with participant weights data
expect_type(contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE)$participants.weights, "list")
# without any weight method activated, weights should be 1
expect_identical(contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE)$participants.weights$weight, c(1, 1))
expect_true(all(contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE)$participants.weights$weight == 1))
# with dayofweek weights activated, we should receive 4 weights, different from 1
expect_length(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.dayofweek = TRUE, return.part.weights = TRUE)$participants.weights$weight, 4)
expect_false(all(contact_matrix(survey = polymod, age.limits = c(0, 18), weigh.dayofweek = TRUE, return.part.weights = TRUE)$participants.weights$weight == 1))
})
})
test_that("The participant weights add up to the sample size", {
suppressWarnings({
weights.uniform <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE)$participants.weights
weights.age <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.dayofweek = TRUE)$participants.weights
weights.dayofweek <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.age = TRUE)$participants.weights
weights.both <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.age = TRUE, weigh.dayofweek = TRUE)$participants.weights
expect_equal(sum(weights.uniform[, weight * proportion]), 1, tolerance = 1e-8)
expect_equal(sum(weights.age[, weight * proportion]), 1, tolerance = 1e-8)
expect_equal(sum(weights.dayofweek[, weight * proportion]), 1, tolerance = 1e-8)
expect_equal(sum(weights.both[, weight * proportion]), 1, tolerance = 1e-8)
})
})
test_that("The weights with threshold", {
suppressWarnings({
# get weights without and with a threshold of 3 and 50
weights.nothreshold <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.age = TRUE, weigh.dayofweek = TRUE, weight.threshold = NA)$participants.weights
weights.threshold3 <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.age = TRUE, weigh.dayofweek = TRUE, weight.threshold = 3)$participants.weights
weights.threshold50 <- contact_matrix(survey = polymod, age.limits = c(0, 18), return.part.weights = TRUE, weigh.age = TRUE, weigh.dayofweek = TRUE, weight.threshold = 50)$participants.weights
# make sure they add up to the sample size
expect_equal(sum(weights.nothreshold[, weight * proportion]), 1, tolerance = 1e-8)
expect_equal(sum(weights.threshold3[, weight * proportion]), 1, tolerance = 1e-8)
expect_equal(sum(weights.threshold50[, weight * proportion]), 1, tolerance = 1e-8)
# check threshold values (include 2.5% margin due to the standardisation)
expect_gt(max(weights.nothreshold$weight), 3 * 1.025)
expect_lt(max(weights.threshold3$weight), 3 * 1.025) #
expect_gt(max(weights.threshold50$weight), 3 * 1.02) # include small margin due to the standardisation
expect_lt(max(weights.threshold50$weight), 50 * 1.025) # include small margin due to the standardisation
})
})
test_that("Country names in Zenodo datasets and the wpp package are aligned (e.g. Viet Nam vs. Vietnam)", {
skip_if_offline("zenodo.org")
skip_on_cran()
vietnam1 <- get_survey("https://doi.org/10.5281/zenodo.1289473")
expect_length(suppressWarnings(contact_matrix(vietnam1, symmetric = FALSE)), 2) # no demography data used
expect_length(suppressWarnings(contact_matrix(vietnam1, symmetric = TRUE)), 3) # country is recognized and demography data found
})
test_that("Participants that report contacts with missing age are removed, sampled, or ignored", {
num.part <- nrow(polymod$participants)
num.part.missing.age <- sum(is.na(polymod$participants$part_age))
# keep missing participant and contact ages ==>> get original sample size
expect_identical(sum(contact_matrix(
survey = polymod, age.limits = 0,
missing.participant.age = "keep",
missing.contact.age = "keep"
)$participants$participants), num.part)
# remove missing participant ages ==>> get original sample size - num.part.missing.age
expect_identical(sum(contact_matrix(
survey = polymod, age.limits = 0,
missing.participant.age = "remove",
missing.contact.age = "keep"
)$participants$participants), num.part - num.part.missing.age)
# remove missing participant ages ==>> get original sample size - num.part.missing.age
expect_lt(sum(contact_matrix(
survey = polymod, age.limits = 0,
missing.participant.age = "remove",
missing.contact.age = "remove"
)$participants$participants), num.part - num.part.missing.age)
# keep missing contact ages ==>> additional column in contact matrix
expect_identical(ncol(contact_matrix(
survey = polymod, age.limits = 0,
missing.contact.age = "remove"
)$matrix), 1L)
expect_identical(ncol(contact_matrix(
survey = polymod, age.limits = 0,
missing.contact.age = "keep"
)$matrix), 2L)
expect_identical(ncol(contact_matrix(
survey = polymod, age.limits = 0,
missing.contact.age = "ignore"
)$matrix), 1L)
expect_identical(ncol(contact_matrix(
survey = polymod, age.limits = 0,
missing.contact.age = "sample"
)$matrix), 1L)
})
test_that("User-defined reference populations with open ended age groups are handled correctly", {
suppressWarnings({
survey.pop <- data.frame(
lower.age.limit = c(0, 4, 15),
population = c(4e6, 1e5, 6e6)
)
# to handle the open ended age group in the survey.pop
expect_identical(nrow(contact_matrix(polymod,
age.limits = c(0, 18, 60),
symmetric = TRUE, # to make sure that demography is returned
survey.pop = survey.pop
)$demography), 3L)
# to check the column names
expect_identical(names(contact_matrix(polymod,
age.limits = c(0, 18, 60),
symmetric = TRUE, # to make sure that demography is returned
survey.pop = survey.pop
)$demography)[1], "age.group")
expect_error(contact_matrix(polymod_nocountry,
age.limits = c(0, 18, 60),
symmetric = TRUE, # to make sure that demography is returned
survey.pop = "dummy"
))
})
})
test_that("The absence of reference population info is going well", {
suppressWarnings({
polymod_nocountry <- polymod
polymod_nocountry$participants$country <- NULL
# no reference population given
expect_identical(nrow(contact_matrix(polymod_nocountry,
age.limits = c(0, 18, 60),
symmetric = TRUE # to make sure that demography is returned
)$demography), 3L)
# to check the column names
expect_identical(names(contact_matrix(polymod_nocountry,
age.limits = c(0, 18, 60),
symmetric = TRUE # to make sure that demography is returned
)$demography)[1], "age.group")
})
})
test_that("Contact matrices per capita can be provided", {
suppressWarnings({
# get contact matrix per capita
expect_type(contact_matrix(polymod,
age.limits = c(0, 18, 60),
per.capita = TRUE
)$matrix.per.capita, "double")
# per capita matrix is not returned when counts=TRUE
expect_null(contact_matrix(polymod,
age.limits = c(0, 18, 60),
per.capita = TRUE,
counts = TRUE
)$matrix.per.capita)
# per capita matrix is not returned when split=TRUE
expect_null(contact_matrix(polymod,
age.limits = c(0, 18, 60),
per.capita = TRUE,
split = TRUE
)$matrix.per.capita)
})
})
test_that("Symmetric contact matrices per capita are actually symmetric", {
suppressWarnings({
# get contact matrix per capita
matrix.per.capita <- contact_matrix(polymod,
age.limits = c(0, 18, 60),
symmetric = TRUE, # to make sure that demography is returned
per.capita = TRUE
)$matrix.per.capita
expect_true(isSymmetric(matrix.per.capita, check.attributes = FALSE))
})
})
test_that("Contact matrices per capita are also generated when bootstrapping", {
suppressWarnings({
# get contact matrix per capita
expect_length(contact_matrix(polymod,
age.limits = c(0, 18, 60),
per.capita = TRUE
), 4)
# get no contact matrix per capita
expect_length(contact_matrix(polymod,
age.limits = c(0, 18, 60),
per.capita = FALSE
), 2)
})
})
test_that("passing a DOI for survey is deprecated", {
lifecycle::expect_deprecated(
contact_matrix(survey = "10.5281/zenodo.1095664") # nolint
)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.