diff --git a/DESCRIPTION b/DESCRIPTION index 0c543a3..6980a56 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -49,7 +49,7 @@ Language: en-US LazyData: true LazyDataCompression: xz Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.0 +RoxygenNote: 7.3.1 Imports: mgcv, dplyr (>= 1.0.9), diff --git a/NAMESPACE b/NAMESPACE index 69c76b9..15d88a4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ S3method(age_breaks,matrix) S3method(age_breaks,ngm_setting_matrix) S3method(age_breaks,numeric) S3method(age_breaks,predicted_contacts) +S3method(age_breaks,setting_contact_model) S3method(age_breaks,setting_data) S3method(age_breaks,setting_vaccination_matrix) S3method(age_breaks,transmission_probability_matrix) @@ -85,6 +86,8 @@ export(get_polymod_setting_data) export(get_setting_transmission_matrices) export(matrix_to_predictions) export(new_age_matrix) +export(new_ngm_setting_matrix) +export(new_setting_data) export(per_capita_household_size) export(polymod) export(population) diff --git a/NEWS.md b/NEWS.md index 1ab6530..410a336 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,3 @@ - # conmat 0.0.2.9000 ## Changes @@ -16,6 +15,9 @@ * extended `add_school_work_participation()`, `add_modelling_features()`, `fit_single_contact_model()`, `fit_setting_contacts()`, `estimate_setting_contacts()` to use different school and work demographics arguments. (#82 and #15, resolved by #153). +* exports `new_ngm_setting_matrix()` and `new_setting_data()` +* Exports new `age_breaks()` method for class `setting_contact_model` (used in `fit_setting_contacts()`). + ## Breaking changes * change `get_per_capita_household_size` to `get_abs_per_capita_household_size` diff --git a/R/constructors.R b/R/constructors.R index 9fa5a5e..f81232e 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -129,6 +129,12 @@ age_breaks.transmission_probability_matrix <- function(x) { attr(x, "age_breaks") } +#' @describeIn age_breaks Get age break information +#' @export +age_breaks.setting_contact_model <- function(x){ + attr(x, "age_breaks") +} + #' @describeIn age_breaks Get age break information #' @export age_breaks.default <- function(x) { @@ -137,6 +143,12 @@ age_breaks.default <- function(x) { ) } +#' Establish new setting data +#' +#' @param list_df list of data frames +#' +#' @return object with additional (primary) class "setting data" and an "age_breaks attribute. +#' @export new_setting_data <- function(list_df) { structure( list_df, @@ -145,6 +157,15 @@ new_setting_data <- function(list_df) { ) } +#' Establish new BGM setting data +#' +#' @param list_matrix list of matrices +#' @param raw_eigenvalue the raw eigenvalue +#' @param scaling scaling factor +#' @param age_breaks vector of age breaks +#' +#' @return object with additional (primary) class "ngm_setting_matrix", and attributes for "age_breaks", "scaling", and "raw_eigenvalue". +#' @export new_ngm_setting_matrix <- function(list_matrix, raw_eigenvalue, scaling, @@ -207,8 +228,13 @@ scaling <- function(list_matrix) { attr(list_matrix, "scaling") } -new_setting_contact_model <- function(list_model) { - add_new_class(list_model, "setting_contact_model") +new_setting_contact_model <- function(list_model, + age_breaks) { + structure( + list_model, + age_breaks = age_breaks, + class = c("setting_contact_model", class(list_model)) + ) } new_setting_vaccination_matrix <- function(list_matrix, diff --git a/R/fit_setting_contacts.R b/R/fit_setting_contacts.R index c96d62e..082ddc0 100644 --- a/R/fit_setting_contacts.R +++ b/R/fit_setting_contacts.R @@ -76,5 +76,8 @@ fit_setting_contacts <- function(contact_data_list, .options = furrr::furrr_options(seed = TRUE) ) - new_setting_contact_model(fitted_setting_contacts) + new_setting_contact_model( + list_model = fitted_setting_contacts, + age_breaks = age_breaks(contact_data_list) + ) } diff --git a/inst/WORDLIST b/inst/WORDLIST index 3bd8209..e710f3b 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,5 +1,6 @@ Albury Auranen +BGM Beutels CMD COVID diff --git a/man/age_breaks.Rd b/man/age_breaks.Rd index ec3b799..b3ebde9 100644 --- a/man/age_breaks.Rd +++ b/man/age_breaks.Rd @@ -12,6 +12,7 @@ \alias{age_breaks.array} \alias{age_breaks.predicted_contacts} \alias{age_breaks.transmission_probability_matrix} +\alias{age_breaks.setting_contact_model} \alias{age_breaks.default} \title{Extract age break attribute information} \usage{ @@ -37,6 +38,8 @@ age_breaks(x) \method{age_breaks}{transmission_probability_matrix}(x) +\method{age_breaks}{setting_contact_model}(x) + \method{age_breaks}{default}(x) } \arguments{ @@ -70,6 +73,8 @@ Extract age break attribute information \item \code{age_breaks(transmission_probability_matrix)}: Get age break information +\item \code{age_breaks(setting_contact_model)}: Get age break information + \item \code{age_breaks(default)}: Get age break information }} diff --git a/man/new_ngm_setting_matrix.Rd b/man/new_ngm_setting_matrix.Rd new file mode 100644 index 0000000..a1c2ee2 --- /dev/null +++ b/man/new_ngm_setting_matrix.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/constructors.R +\name{new_ngm_setting_matrix} +\alias{new_ngm_setting_matrix} +\title{Establish new BGM setting data} +\usage{ +new_ngm_setting_matrix(list_matrix, raw_eigenvalue, scaling, age_breaks) +} +\arguments{ +\item{list_matrix}{list of matrices} + +\item{raw_eigenvalue}{the raw eigenvalue} + +\item{scaling}{scaling factor} + +\item{age_breaks}{vector of age breaks} +} +\value{ +object with additional (primary) class "ngm_setting_matrix", and attributes for "age_breaks", "scaling", and "raw_eigenvalue". +} +\description{ +Establish new BGM setting data +} diff --git a/man/new_setting_data.Rd b/man/new_setting_data.Rd new file mode 100644 index 0000000..ef952bb --- /dev/null +++ b/man/new_setting_data.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/constructors.R +\name{new_setting_data} +\alias{new_setting_data} +\title{Establish new setting data} +\usage{ +new_setting_data(list_df) +} +\arguments{ +\item{list_df}{list of data frames} +} +\value{ +object with additional (primary) class "setting data" and an "age_breaks attribute. +} +\description{ +Establish new setting data +} diff --git a/tests/testthat/_snaps/autoplot/autoplot-all-settinge.svg b/tests/testthat/_snaps/autoplot/autoplot-all-settinge.svg index 282d26f..481d5bd 100644 --- a/tests/testthat/_snaps/autoplot/autoplot-all-settinge.svg +++ b/tests/testthat/_snaps/autoplot/autoplot-all-settinge.svg @@ -89,17 +89,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 1 2 3 -contacts - - - - - - home @@ -153,17 +153,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 2 4 6 -contacts - - - - - - school @@ -217,23 +217,23 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + + + 0.5 1.0 1.5 2.0 2.5 -contacts - - - - - - - - - - work @@ -287,20 +287,20 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + 1 2 3 4 -contacts - - - - - - - - other Setting-specific synthetic contact matrices diff --git a/tests/testthat/_snaps/autoplot/autoplot-ngm.svg b/tests/testthat/_snaps/autoplot/autoplot-ngm.svg index a7e656f..6da1398 100644 --- a/tests/testthat/_snaps/autoplot/autoplot-ngm.svg +++ b/tests/testthat/_snaps/autoplot/autoplot-ngm.svg @@ -89,17 +89,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 0.2 0.4 0.6 -contacts - - - - - - home @@ -153,14 +153,14 @@ [10,15) [15,Inf) age_group_from +contacts + + + + 0.1 0.2 -contacts - - - - school @@ -214,20 +214,20 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + 0.05 0.10 0.15 0.20 -contacts - - - - - - - - work @@ -281,20 +281,20 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + 0.1 0.2 0.3 0.4 -contacts - - - - - - - - The number of newly infected individuals for a specified age group in each setting other Setting-specific NGM matrices diff --git a/tests/testthat/_snaps/autoplot/autoplot-single-setting.svg b/tests/testthat/_snaps/autoplot/autoplot-single-setting.svg index 407e942..822c695 100644 --- a/tests/testthat/_snaps/autoplot/autoplot-single-setting.svg +++ b/tests/testthat/_snaps/autoplot/autoplot-single-setting.svg @@ -70,23 +70,23 @@ [15,Inf) age_group_from age_group_to +contacts + + + + + + + + + + 0.5 1.0 1.5 2.0 2.5 -contacts - - - - - - - - - - Work diff --git a/tests/testthat/_snaps/autoplot/autoplot-vaccination.svg b/tests/testthat/_snaps/autoplot/autoplot-vaccination.svg index 8c20662..985dfe3 100644 --- a/tests/testthat/_snaps/autoplot/autoplot-vaccination.svg +++ b/tests/testthat/_snaps/autoplot/autoplot-vaccination.svg @@ -89,20 +89,20 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + 0.025 0.050 0.075 0.100 -contacts - - - - - - - - home @@ -156,17 +156,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 0.02 0.04 0.06 -contacts - - - - - - school @@ -220,20 +220,20 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + 0.004 0.008 0.012 0.016 -contacts - - - - - - - - work @@ -287,17 +287,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 0.01 0.02 0.03 -contacts - - - - - - Number of newly infected individuals for age groups, adjusted based on proposed age group vaccination rates other Setting-specific vaccination matrices diff --git a/tests/testthat/_snaps/autoplot/autoplot.svg b/tests/testthat/_snaps/autoplot/autoplot.svg index 68cd158..e654bd0 100644 --- a/tests/testthat/_snaps/autoplot/autoplot.svg +++ b/tests/testthat/_snaps/autoplot/autoplot.svg @@ -89,17 +89,17 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + 0.2 0.3 0.4 -contacts - - - - - - home @@ -153,23 +153,23 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + + + 0.050 0.075 0.100 0.125 0.150 -contacts - - - - - - - - - - school @@ -223,23 +223,23 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + + + 0.050 0.075 0.100 0.125 0.150 -contacts - - - - - - - - - - work @@ -293,23 +293,23 @@ [10,15) [15,Inf) age_group_from +contacts + + + + + + + + + + 0.050 0.075 0.100 0.125 0.150 -contacts - - - - - - - - - - Relative probability of individuals in an age group infecting an individual in another age group other Setting-specific transmission probability matrices diff --git a/tests/testthat/_snaps/models-fit-with-furrr.md b/tests/testthat/_snaps/models-fit-with-furrr.md index 061df91..d179470 100644 --- a/tests/testthat/_snaps/models-fit-with-furrr.md +++ b/tests/testthat/_snaps/models-fit-with-furrr.md @@ -1,3 +1,56 @@ +# predict_setting_contact model prints appropriately + + Code + contact_model_pred + Message + + -- Setting Prediction Matrices ------------------------------------------------- + Output + + Message + A list of matrices containing the model predicted contact rate between ages in + each setting. + Output + + Message + There are 5 age breaks, ranging 0-20+ years, with a regular 5 year interval + Output + + Message + * home: a 5x5 + * work: a 5x5 + * school: a 5x5 + * other: a 5x5 + * all: a 5x5 + i Access each with `x$name` + i e.g., `x$home` + +# fit_setting_contact model prints appropriately + + Code + contact_model + Message + + -- Fitted Setting Contact Models ----------------------------------------------- + Output + + Message + A list of fitted models for each setting. Each model predicts the + contact rate between ages, for that setting. + Output + + Message + There are 20 age breaks, ranging 0-20 years, with a regular 1 year interval + Output + + Message + * home: a model (441 obs) + * work: a model (441 obs) + * school: a model (441 obs) + * other: a model (441 obs) + i Access each with `x$name` + i e.g., `x$home` + # list names are kept Code diff --git a/tests/testthat/test-models-fit-with-furrr.R b/tests/testthat/test-models-fit-with-furrr.R index e082e9d..74dc47a 100644 --- a/tests/testthat/test-models-fit-with-furrr.R +++ b/tests/testthat/test-models-fit-with-furrr.R @@ -10,7 +10,8 @@ polymod_setting_short <- map( .f = function(x) { x %>% filter(age_from <= 20, age_to <= 20) } -) +) |> + new_setting_data() polymod_population_short <- polymod_population %>% filter(lower.age.limit <= 20) @@ -18,12 +19,17 @@ contact_model <- fit_setting_contacts( contact_data_list = polymod_setting_short, population = polymod_population_short ) + contact_model_pred <- predict_setting_contacts( population = polymod_population_short, contact_model = contact_model, age_breaks = c(seq(0, 20, by = 5), Inf) ) +test_that("predict_setting_contact model prints appropriately", { + expect_snapshot(contact_model_pred) +}) + # check that you can specify your own population data for school and work demographics contact_model_diff_data <- fit_setting_contacts( contact_data_list = polymod_setting_short, @@ -32,6 +38,10 @@ contact_model_diff_data <- fit_setting_contacts( work_demographics = conmat_original_work_demographics ) +test_that("fit_setting_contact model prints appropriately",{ + expect_snapshot(contact_model) +}) + test_that("list names are kept", { expect_snapshot(names(contact_model)) expect_snapshot(names(contact_model_pred)) diff --git a/vignettes/getting-started.Rmd b/vignettes/getting-started.Rmd index 85c5805..ec7f9aa 100644 --- a/vignettes/getting-started.Rmd +++ b/vignettes/getting-started.Rmd @@ -262,7 +262,8 @@ set.seed(2021 - 09 - 24) polymod_setting_data <- get_polymod_setting_data() polymod_setting_data_small <- polymod_setting_data %>% - lapply(FUN = function(x) x %>% filter(age_from <= 20, age_to <= 20)) + lapply(FUN = function(x) x %>% filter(age_from <= 20, age_to <= 20)) |> + new_setting_data() setting_models <- fit_setting_contacts( contact_data_list = polymod_setting_data_small,