Merge pull request #165 from idem-lab/fix-age-breaks-160

Working on resolving #160

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),

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)

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`

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,

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)
+    )
 }

inst/WORDLIST

@@ -1,5 +1,6 @@
 Albury
 Auranen
+BGM
 Beutels
 CMD
 COVID