Function for setting age-structured outputs.

NAMESPACE

@@ -24,6 +24,7 @@ export(set_carrying_capacity)
 export(set_clinical_treatment)
 export(set_demography)
 export(set_drugs)
+export(set_epi_outputs)
 export(set_equilibrium)
 export(set_mass_pev)
 export(set_mda)

R/output_parameters.R

@@ -0,0 +1,59 @@
+#' @title Parameterise age grouped output rendering
+#'
+#' @details this function produces contiguous age groups, inclusive of the lower
+#' age limit and exclusive of the upper age limit: e.g., c(0, 10, 100) will produce
+#' two age groups: 0-9 and 10-99 in days.
+#' @param parameters the model parameters
+#' @param age_group age breaks for population size outputs; default = NULL
+#' @param incidence age breaks for incidence outputs (D+Tr+A); default = NULL
+#' @param clinical_incidence age breaks for clinical incidence outputs (symptomatic); default = c(0, 1825)
+#' @param severe_incidence age breaks for severe incidence outputs; default = NULL
+#' @param prevalence age breaks for clinical prevalence outputs (pcr and lm detectable infections); default = c(730, 3650)
+#' @param ica age breaks for average acquired clinical immunity; default = NULL
+#' @param icm age breaks for average maternal clinical immunity; default = NULL
+#' @param iva age breaks for average acquired severe immunity; default = NULL
+#' @param ivm age breaks for average maternal severe immunity; default = NULL
+#' @param id age breaks for average immunity to detectability; default = NULL
+#' @param ib age breaks for average blood immunity; default = NULL
+#' @export
+#'
+set_epi_outputs <- function(parameters,
+                            age_group = NULL,
+                            incidence = NULL,
+                            clinical_incidence = NULL,
+                            severe_incidence = NULL,
+                            prevalence = NULL,
+                            ica = NULL,
+                            icm = NULL,
+                            iva = NULL,
+                            ivm = NULL,
+                            id = NULL,
+                            ib = NULL
+){
+
+  input <- list(
+    age_group = age_group,
+    incidence = incidence,
+    clinical_incidence = clinical_incidence,
+    severe_incidence = severe_incidence,
+    prevalence = prevalence,
+    ica = ica,
+    icm = icm,
+    iva = iva,
+    ivm = ivm,
+    id = id,
+    ib = ib
+  )
+  input <- input[!sapply(input, is.null)]
+
+  for(i in seq_along(input)){
+    name <- names(input)[i]
+    ages <- input[[i]]
+    min_ages <- ages[-length(ages)]
+    max_ages <- ages[-1] - 1
+    parameters[[paste0(name, "_rendering_min_ages")]] <- min_ages
+    parameters[[paste0(name, "_rendering_max_ages")]] <- max_ages
+  }
+
+  return(parameters)
+}

R/processes.R

@@ -181,6 +181,9 @@ create_processes <- function(
   # =========
   # Rendering
   # =========
+
+  imm_var_names <- c('ica', 'icm', 'id', 'ib', 'iva', 'ivm')
+
   processes <- c(
     processes,
     individual::categorical_count_renderer_process(
@@ -190,10 +193,10 @@ create_processes <- function(
     ),
     create_variable_mean_renderer_process(
       renderer,
-      c('ica', 'icm', 'ib', 'id', 'iva', 'ivm'),
-      variables[c('ica', 'icm', 'ib', 'id', 'iva', 'ivm')]
+      imm_var_names,
+      variables[imm_var_names]
     ),
-    create_prevelance_renderer(
+    create_prevalence_renderer(
       variables$state,
       variables$birth,
       variables$id,
@@ -205,6 +208,13 @@ create_processes <- function(
       parameters,
       renderer
     ),
+    create_age_variable_mean_renderer_process(
+      imm_var_names[paste0(imm_var_names,"_rendering_min_ages") %in% names(parameters)],
+      variables[imm_var_names[paste0(imm_var_names,"_rendering_min_ages") %in% names(parameters)]],
+      variables$birth,
+      parameters,
+      renderer
+    ),
     create_compartmental_rendering_process(renderer, solvers, parameters)
   )
 

R/render.R

@@ -17,7 +17,7 @@ in_age_range <- function(birth, timestep, lower, upper) {
 #' @param renderer model renderer
 #' 
 #' @noRd
-create_prevelance_renderer <- function(
+create_prevalence_renderer <- function(
   state,
   birth,
   immunity,
@@ -128,6 +128,30 @@ create_variable_mean_renderer_process <- function(
   }
 }
 
+create_age_variable_mean_renderer_process <- function(
+    names,
+    variables,
+    birth,
+    parameters,
+    renderer
+) {
+  function(timestep) {
+    for (i in seq_along(variables)) {
+      for (j in seq_along(parameters[[paste0(names[[i]],"_rendering_min_ages")]])) {
+        lower <- parameters[[paste0(names[[i]],"_rendering_min_ages")]][[j]]
+        upper <- parameters[[paste0(names[[i]],"_rendering_max_ages")]][[j]]
+        in_age <- in_age_range(birth, timestep, lower, upper)
+        renderer$render(paste0('n_', lower, '_', upper), in_age$size(), timestep)
+        renderer$render(
+          paste0(names[[i]], '_mean_', lower, '_', upper),
+          mean(variables[[i]]$get_values(index = in_age)),
+          timestep
+        )
+      }
+    }
+  }
+}
+
 create_vector_count_renderer_individual <- function(
   mosquito_state,
   species,

tests/testthat/test-output.R

@@ -0,0 +1,33 @@
+test_that('Test age parameter function works', {
+  parameters <- get_parameters()
+  age_limits <- c(0,1,2,3)*365
+  parameters <- set_epi_outputs(parameters,
+                                age_group = age_limits,
+                                incidence = age_limits+1,
+                                clinical_incidence = age_limits+2,
+                                severe_incidence = age_limits+3,
+                                prevalence = age_limits+4,
+                                ica = age_limits+5,
+                                icm = age_limits+6,
+                                id = age_limits+7,
+                                ib = age_limits+8,
+                                iva = age_limits+9,
+                                ivm = age_limits+10
+  )
+
+  sim <- run_simulation(timesteps = 1, parameters)
+
+  expect_true(
+    all(
+      paste0(rep(c("n_age",
+                   "n", "n_inc", "p_inc",
+                   "n","n_inc_clinical","p_inc_clinical",
+                   "n","n_inc_severe","p_inc_severe",
+                   "n","n_detect_lm","p_detect_lm","n_detect_pcr",
+                   "ica_mean", "icm_mean","id_mean","ib_mean","iva_mean","ivm_mean"), each = 3),"_",
+             age_limits[-4]+rep(c(0,rep(c(1:3), each = 3), rep(4, 4), 5:10), each = 3),"_",age_limits[-1]-1+rep(c(0,rep(c(1:3), each = 3), rep(4, 4), 5:10), each = 3)
+      ) %in%
+        names(sim)))
+
+})
+

tests/testthat/test-render.R

@@ -11,7 +11,7 @@ test_that('that default rendering works', {
   immunity <- individual::DoubleVariable$new(rep(1, 4))
 
   renderer <- mock_render(1)
-  process <- create_prevelance_renderer(
+  process <- create_prevalence_renderer(
     state,
     birth,
     immunity,
@@ -70,7 +70,7 @@ test_that('that default rendering works when no one is in the age range', {
   immunity <- individual::DoubleVariable$new(rep(1, 4))
 
   renderer <- mock_render(1)
-  process <- create_prevelance_renderer(
+  process <- create_prevalence_renderer(
     state,
     birth,
     immunity,