Implement render_grid:

 * Tests for grid counting
 * Output n_inc, n_detect and n for 0-100

R/human_infection.R

@@ -166,7 +166,8 @@ calculate_infections <- function(
     'inc_',
     parameters$incidence_rendering_min_ages,
     parameters$incidence_rendering_max_ages,
-    timestep
+    timestep,
+    parameters$render_grid
   )
 
   infected
@@ -201,7 +202,8 @@ calculate_clinical_infections <- function(
     'inc_clinical_',
     parameters$clinical_incidence_rendering_min_ages,
     parameters$clinical_incidence_rendering_max_ages,
-    timestep
+    timestep,
+    parameters$render_grid
   )
   clinical_infections
 }
@@ -242,7 +244,8 @@ update_severe_disease <- function(
     'inc_severe_',
     parameters$severe_incidence_rendering_min_ages,
     parameters$severe_incidence_rendering_max_ages,
-    timestep
+    timestep,
+    parameters$render_grid
   )
   boost_immunity(
     variables$iva,

R/parameters.R

@@ -207,6 +207,7 @@
 #' * severe_incidence_rendering_min_ages - the minimum ages for severe incidence
 #' outputs; default = turned off
 #' * severe_incidence_rendering_max_ages - the corresponding max ages; default = turned off
+#' * render_grid - whether to render prevalence and incidence values for a grid of year wide age groups between 0 and 100; default = turned off
 #'
 #' miscellaneous:
 #'
@@ -394,6 +395,7 @@ get_parameters <- function(overrides = list()) {
     severe_incidence_rendering_max_ages = numeric(0),
     age_group_rendering_min_ages = numeric(0),
     age_group_rendering_max_ages = numeric(0),
+    render_grid = FALSE,
     # misc
     custom_demography = FALSE,
     human_population = 100,

R/render.R

@@ -55,6 +55,23 @@ create_prevelance_renderer <- function(
         timestep
       )
     }
+
+    if (parameters$render_grid) {
+      grid_renderer(
+        birth,
+        renderer,
+        NULL,
+        'n',
+        timestep
+      )
+      grid_renderer(
+        birth,
+        renderer,
+        detected,
+        'n_detect',
+        timestep
+      )
+    }
   }
 }
 
@@ -82,7 +99,8 @@ incidence_renderer <- function(
   prefix,
   lowers,
   uppers,
-  timestep
+  timestep,
+  render_grid = FALSE
   ) {
   for (i in seq_along(lowers)) {
     lower <- lowers[[i]]
@@ -101,6 +119,16 @@ incidence_renderer <- function(
       timestep
     )
   }
+
+  if (render_grid) {
+    grid_renderer(
+      birth,
+      renderer,
+      target,
+      'n_inc',
+      timestep
+    )
+  }
 }
 
 create_variable_mean_renderer_process <- function(
@@ -172,3 +200,46 @@ create_age_group_renderer <- function(
     }
   }
 }
+
+#' @title Render a grid of statistics
+#'
+#' @description renders incidence (new for this timestep) for year wide age bands between 0 and 100
+#'
+#' @param birth variable for birth of the individual
+#' @param renderer object for model outputs
+#' @param target incidence population
+#' @param prefix for model outputs
+#' @param timestep current target
+#'
+#' @noRd
+grid_renderer <- function(
+  birth,
+  renderer,
+  target,
+  prefix,
+  timestep
+  ) {
+  counts <- grid_count(birth, target, timestep)
+  for (i in seq_along(counts)) {
+    renderer$render(
+      paste0('grid_', prefix, '_', i),
+      counts[[i]],
+      timestep
+    )
+  }
+}
+
+grid_count <- function(birth, selected, timestep) {
+  if (is.null(selected)) {
+    selected_births <- birth$get_values()
+  } else {
+    selected_births <- birth$get_values(selected)
+  }
+  age <- floor(get_age(selected_births, timestep) / 365)
+  age[age < 0] <- NA
+  age[age > 100] <- NA
+  non_zero <- table(age)
+  counts <- rep(0, 101)
+  counts[as.numeric(names(non_zero)) + 1] <- non_zero
+  counts
+}

tests/testthat/test-grid-render.R

@@ -0,0 +1,51 @@
+test_that('grid_count produces all age groups between 0 and 100', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(c(1, 2, 3, 4) * 365)
+  selected <- individual::Bitset$new(4)$not()
+  expect_equal(length(grid_count(birth, selected, timestep)), 101)
+})
+
+test_that('grid_count works without selection', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(c(1, 2, 3, 4) * 365)
+  selected <- NULL
+  expected <- rep(0, 101)
+  expected[seq(4) + 1] <- 1
+  expect_equal(grid_count(birth, selected, timestep), expected)
+})
+
+test_that('grid_count counts internally correctly', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(timestep - c(1, 2, 3, 4) * 365 - 1)
+  selected <- individual::Bitset$new(4)$not()
+  expected <- rep(0, 101)
+  expected[seq(4) + 1] <- 1
+  expect_equal(grid_count(birth, selected, timestep), expected)
+})
+
+test_that('grid_count counts at the boundaries correctly', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(timestep - c(1, 2, 3, 4) * 365)
+  selected <- individual::Bitset$new(4)$not()
+  expected <- rep(0, 101)
+  expected[seq(4) + 1] <- 1
+  expect_equal(grid_count(birth, selected, timestep), expected)
+})
+
+test_that('grid_count can select subset', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(timestep - c(1, 2, 3, 4) * 365 - 1)
+  selected <- individual::Bitset$new(4)$insert(c(2, 4))
+  expected <- rep(0, 101)
+  expected[c(3, 5)] <- 1
+  expect_equal(grid_count(birth, selected, timestep), expected)
+})
+
+test_that('grid_count ignores outside of the grid', {
+  timestep <- 5 * 365
+  birth <- individual::IntegerVariable$new(timestep - c(1, 101, 3, 150) * 365)
+  selected <- individual::Bitset$new(4)$not()
+  expected <- rep(0, 101)
+  expected[c(2, 4)] <- 1
+  expect_equal(grid_count(birth, selected, timestep), expected)
+})