Change SetPerAgeStats from true/false to three levels. Fixes Issue #235.

pacehrh/R/pace_config.R

@@ -283,24 +283,25 @@ SetStochasticity <- function(value = NULL){
 #' @param value Desired value. (Calling \code{SetPerAgeStats()} with
 #' no parameters or value = NULL returns the current state.)
 #'
-#' @return Previous flag value (invisible)
+#' @return Previous value (invisible)
 #' @export
 #'
 #' @examples
 #' \dontrun{
-#' pacehrh::SetPerAgeStats(TRUE) # Turn on per-age statistics
+#' pacehrh::SetPerAgeStats("monthly") # Turn on per-age statistics
 #' pacehrh::SetPerAgeStats() # Return current state
 #' }
 SetPerAgeStats <- function(value = NULL){
-  prevValue <- GPE$stochasticity
+  prevValue <- GPE$perAgeStats
 
   if (!is.null(value)){
-    if (rlang::is_logical(value)){
-      GPE$perAgeStats <- value
+    if (tolower(value) %in% .perAgeLevels){
+      GPE$perAgeStats <- tolower(value)
     } else {
-      traceMessage(paste0(value, " is not an allowed per-age flag value"))
+      traceMessage(paste0(value, " is not an allowed per-age setting"))
     }
   }
-
+  
   return(invisible(prevValue))
 }
+

pacehrh/R/pace_experiment.R

@@ -53,11 +53,15 @@ RunExperiment <- function(debug = FALSE){
   # structures. Results from the next couple of calls are written directly into
   # the temp environment, not passed back from the procedures.
 
-  if (GPE$perAgeStats){
+  if (GPE$perAgeStats != "off"){
     e <- rlang::env()
     ComputePerAgeTaskTimes(e)
-    results$AnnualPerAge <- e$AnnualPerAge
-    results$MonthlyPerAge <- as.list(e)
+
+    if (GPE$perAgeStats == "annual"){
+      results$AnnualPerAge <- e$AnnualPerAge
+    } else {
+      results$MonthlyPerAge <- as.list(e)
+    }
   }
 
   return(results)

pacehrh/R/pace_package_env.R

@@ -21,6 +21,14 @@ EXP <- experimentValuesEnvironment
 
 .defaultRoundingLaw <- .roundingLaws[1] # "early"
 
+.perAgeLevels <- c(
+  "off",
+  "annual",
+  "monthly"
+)
+
+.defaultPerAgeLevel <- .perAgeLevels[1] # "off"
+
 .colorM <- rgb(96,131,180, maxColorValue = 255)
 .colorF <- rgb(210,120,135, maxColorValue = 255)
 
@@ -57,7 +65,7 @@ GPE$scenarios <- NULL
 
 GPE$rngSeed <- 12345
 GPE$roundingLaw <- .defaultRoundingLaw
-GPE$perAgeStats <- FALSE
+GPE$perAgeStats <- .defaultPerAgeLevel
 
 BVE$seasonalityCurves <- NULL
 BVE$seasonalityOffsets <- NULL

pacehrh/R/pace_per_age_compute.R

@@ -35,15 +35,29 @@
 #
 
 ComputePerAgeTaskTimes <- function(e){
+  if (GPE$perAgeStats == "off"){
+    return(invisible(NULL))
+  }
+
   e$AnnualPerAge <- NULL
-
   .computeAnnualTaskTimes(e)
-
-  if (!is.null(e$AnnualPerAge)){
-    .computeMonthlyTaskTimes(e)
+
+  # Stop if user only wants annual stats (much faster to calculate, but not
+  # as accurate since seasonality and seasonality offsets are ignored).
+  if (GPE$perAgeStats == "annual"){
+    return(invisible(NULL))
   }
+
+  # Continue if user wants monthly stats (GPE$perAgeStats == "monthly")
+  if (GPE$perAgeStats == "monthly"){
+    if (!is.null(e$AnnualPerAge)){
+      .computeMonthlyTaskTimes(e)
+    }
 
-  remove(AnnualPerAge, pos = e)
+    remove(AnnualPerAge, pos = e)
+  }
+
+  return(invisible(NULL))
 }
 
 .computeAnnualTaskTimes <- function(e)
@@ -110,9 +124,11 @@ ComputePerAgeTaskTimes <- function(e){
     mmT[,,i] <- mT
   }
 
-  dimnames(mfT) <- list(Tasks = BVE$taskData$Indicator, Ages = GPE$ages, Years = BVE$years)
-  dimnames(mmT) <- list(Tasks = BVE$taskData$Indicator, Ages = GPE$ages, Years = BVE$years)
-
+  dimnames(mfT) <- list(Task = BVE$taskData$Indicator, Age = GPE$ages, Year = BVE$years)
+  dimnames(mmT) <- list(Task = BVE$taskData$Indicator, Age = GPE$ages, Year = BVE$years)
+  dimnames(mfN) <- list(Task = BVE$taskData$Indicator, Age = GPE$ages, Year = BVE$years)
+  dimnames(mmN) <- list(Task = BVE$taskData$Indicator, Age = GPE$ages, Year = BVE$years)
+
   e$AnnualPerAge$Times$Female <- mfT
   e$AnnualPerAge$Times$Male <- mmT
   e$AnnualPerAge$Counts$Female <- mfN

pacehrh/tests/testthat/test-pace_config.R

@@ -70,3 +70,28 @@ test_that("Configuration: SetInputExcelFile", {
   testthat::expect_equal(GPE$inputExcelFile, simpleFile)
   testthat::expect_true(GPE$ignoreGlobalConfigExcelFileSetting)
 })
+
+test_that("Configuration: SetPerAgeStats", {
+  local_vars("perAgeStats", envir = gpe)
+
+  testthat::expect_equal(gpe$perAgeStats, "off")
+
+  # Interrogate current value. Should be "off".
+  value <- pacehrh::SetPerAgeStats()
+  testthat::expect_equal(value, "off")
+
+  # Check that trying to set a bad value doesn't overwrite existing
+  value <- pacehrh::SetPerAgeStats("invalidvalue")
+  testthat::expect_equal(value, "off")
+  testthat::expect_equal(pacehrh::SetPerAgeStats(), "off")
+
+  # Flip to "monthly"
+  value <- pacehrh::SetPerAgeStats("mOnThLy")
+  testthat::expect_equal(value, "off")
+  testthat::expect_equal(pacehrh::SetPerAgeStats(), "monthly")
+
+  # Flip to "annual"
+  value <- pacehrh::SetPerAgeStats("aNnUaL")
+  testthat::expect_equal(value, "monthly")
+  testthat::expect_equal(pacehrh::SetPerAgeStats(), "annual")
+})

pacehrh/tests/testthat/test-pace_per_age_compute.R

@@ -41,7 +41,7 @@ test_that("Per-Age: baseline", {
   pacehrh::SetGlobalStartEndYears(2025, 2055)
   pacehrh::SetStochasticity(FALSE)
   pacehrh::SetRoundingLaw("none")
-  pacehrh::SetPerAgeStats(TRUE)
+  pacehrh::SetPerAgeStats("monthly")
 
   scenario <- "TEST_Simple_2"
   nTrials <- 5
@@ -95,3 +95,73 @@ test_that("Per-Age: baseline", {
 
   testthat::expect_true(all(out))
 })
+
+test_that("Per-Age: annual only", {
+  local_vars("inputExcelFile", envir = gpe)
+  local_vars("ignoreGlobalConfigExcelFileSetting", envir = gpe)
+  local_vars("globalConfigLoaded", envir = gpe)
+  local_vars("perAgeStats", envir = gpe)
+  local_vars("stochasticity", envir = gpe)
+  local_vars("roundingLaw", envir = gpe)
+
+  gpe$globalConfigLoaded <- FALSE
+
+  pacehrh::SetInputExcelFile("./simple_config/super_simple_inputs.xlsx")
+  testthat::expect_true(gpe$ignoreGlobalConfigExcelFileSetting)
+
+  pacehrh::InitializePopulation(popSheet = "Flat_Population")
+  .validateSuperSimpleInitialPopulation(bve$initialPopulation)
+
+  pacehrh::InitializeScenarios()
+  pacehrh::InitializeStochasticParameters()
+  pacehrh::InitializeSeasonality()
+
+  pacehrh::SetGlobalStartEndYears(2025, 2055)
+  pacehrh::SetStochasticity(FALSE)
+  pacehrh::SetRoundingLaw("none")
+  pacehrh::SetPerAgeStats("annual")
+
+  scenario <- "TEST_Simple_2"
+  nTrials <- 5
+
+  results <-
+    pacehrh::RunExperiments(scenarioName = scenario,
+                            trials = nTrials)
+
+  testthat::expect_true(!is.null(results))
+  testthat::expect_equal(length(results), nTrials)
+
+  r <- results[[1]]
+  expectedDataNames <- c("AnnualTimes", "AnnualCounts", "SeasonalityResults", "AnnualPerAge", "Population", "PopulationRates")
+  testthat::expect_true(length(setdiff(names(r), expectedDataNames)) == 0)
+  testthat::expect_true(length(setdiff(expectedDataNames, names(r))) == 0)
+
+  r <- results[[1]]$AnnualPerAge
+  testthat::expect_true(!is.null(r))
+  if (is.null(r)){
+    message("Major failure: results structure did not include AnnualPerAge section")
+    return()
+  }
+
+  # A couple of oddnesses here:
+  #
+  # - The order of sub-sections in the AnnualPerAge section is {$Times, $Counts}, 
+  # but in the MonthlyPerAge section is {$Counts, $Times}. This might be because
+  # the MonthlyPerAge section is stored as an environment - which hashes it's 
+  # contents - before being converted to a list. The as.list() operation picks
+  # up the hashed order of the sub-sections instead of the order of creation.
+  #
+  # - The AnnualPerAge section includes shoulder years. That's because the
+  # shoulder years are needed for the seasonality calculations that would
+  # follow if MonthlyPerAge stats were selected.
+
+  testthat::expect_equal(names(r), c("Times", "Counts"))
+  testthat::expect_equal(names(r$Counts), c("Female", "Male"))
+  testthat::expect_equal(names(r$Times), c("Female", "Male"))
+
+  nTasks <- length(pacehrh:::BVE$taskData$computeMethod)
+  nAges <- length(pacehrh:::GPE$ages)
+  nYears <- length(pacehrh:::BVE$years) # BVE$years includes shoulder years
+
+  testthat::expect_equal(dim(r$Times$Female), c(nTasks, nAges, nYears))
+})