Function for setting age-structured outputs for incidence, prevalence…

… and immunity. Discrete age groups are set using a list, where vectors within the list result in contiguous age group rendering.

Also correcting spelling of prevalence in create_prevalence_renderer function.

This is a correction attempting to remove issues around line endings.

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,39 @@
+#' @title Parameterise age grouped output rendering
+#'
+#' @details this function produces discrete and contiguous age groups, inclusive of the lower
+#' age limit and exclusive of the upper age limit: e.g., list(c(0, 10, 100), c(200, 250) will produce
+#' three age groups: 0-9, 10-99 and 200-249 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)
+#' @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
+){
+
+  parent_formals <- names(formals())
+  parent_formals <- parent_formals[which(parent_formals != "parameters")]
+  outputs <- parent_formals[!unlist(lapply(parent_formals, function(x){is.null(get(x))}))]
+
+  for (output in outputs) {
+    if(!is.list(get(output))){stop("Each age input must be a list of vectors")}
+    parameters[[paste0(output, "_rendering_min_ages")]] <- unlist(lapply(get(output), function(x){x[-length(x)]}))
+    parameters[[paste0(output, "_rendering_max_ages")]] <- unlist(lapply(get(output), function(x){x[-1]-1}))
+  }
+
+  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

@@ -14,7 +14,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,
@@ -119,6 +119,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,49 @@
+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 = list(age_limits),
+                                incidence = list(age_limits+1),
+                                clinical_incidence = list(age_limits+2),
+                                severe_incidence = list(age_limits+3),
+                                prevalence = list(age_limits+4),
+                                ica = list(age_limits+5),
+                                icm = list(age_limits+6),
+                                id = list(age_limits+7),
+                                ib = list(age_limits+8),
+                                iva = list(age_limits+9),
+                                ivm = list(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","p_detect",
+                   "ica_mean", "icm_mean","id_mean","ib_mean","iva_mean","ivm_mean"), each = 3),"_",
+             age_limits[-4]+rep(c(0,rep(c(1:4), each = 3),5:10), each = 3),"_",age_limits[-1]-1+rep(c(0,rep(c(1:4), each = 3),5:10), each = 3)
+      ) %in%
+        names(sim)))
+
+})
+
+test_that('Test age parameter multiple sequences function works', {
+  parameters <- get_parameters()
+  age_limits <- c(0,1,2,3)*365
+  parameters <- set_epi_outputs(parameters,
+                                age_group = list(age_limits, age_limits+100))
+
+  sim <- run_simulation(timesteps = 1, parameters)
+
+  expect_true(
+    all(
+      paste0(rep(c("n_age"), each = 3),"_",
+             c(age_limits[-4], age_limits[-4]+100), "_", c(age_limits[-1], age_limits[-1]+100)-1
+      ) %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,
@@ -62,7 +62,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,