Merge pull request #233 from InstituteforDiseaseModeling/charles/issu…

…e133

Add per-age processing

pacehrh/DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: pacehrh
 Title: Population-Aware Capacity Estimator for Human Resources for Health
-Version: 1.0.4
+Version: 1.0.5
 Author: Charles Eliot, Brittany Hagedorn
 Maintainer: Charles Eliot <[email protected]>
 Description: This package models the healthcare needs of a given population so you
@@ -63,6 +63,7 @@ Collate:
     'pace_task_manage.R'
     'pace_task_time.R'
     'pace_task_time_stochasticity.R'
+    'pace_per_age_compute.R'
     'pace_experiment.R'
     'pace_experiments.R'
     'pace_scenarios_config.R'

pacehrh/NAMESPACE

@@ -33,7 +33,10 @@ export(SaveResults)
 export(SaveSuiteDemographics)
 export(SaveSuiteResults)
 export(SetGlobalStartEndYears)
+export(SetInputExcelFile)
+export(SetPerAgeStats)
 export(SetRoundingLaw)
+export(SetStochasticity)
 export(Trace)
 export(UpdateScenario)
 import(data.table)

pacehrh/R/pace_config.R

@@ -5,9 +5,6 @@
 # that defines experiment scenarios, baseline population data, task
 # descriptions, etc.
 #
-# Global configuration can be set programmatically with the setGlobalConfig()
-# function.
-#
 # The usual mechanism, however, is for the global configuration to be declared
 # by the user in a file called globalconfig.json in the working directory. This
 # file is read and the global configuration set with the function
@@ -36,17 +33,21 @@ loadGlobalConfig <- function(path = "./globalconfig.json"){
       {
         configInfo <- jsonlite::read_json(path)
 
-        if (!is.null(configInfo$configDirectoryLocation)){
-          configDirPath <- configInfo$configDirectoryLocation
-        } else {
-          configDirPath <- "."
-        }
+        # Check whether to use the Excel file name from the global config file
+        if (!GPE$ignoreGlobalConfigExcelFileSetting){
 
-        if (!is.null(configInfo$inputExcelFile)){
-          GPE$inputExcelFile <-
-            paste(configDirPath,
-                  configInfo$inputExcelFile,
-                  sep = "/")
+          if (!is.null(configInfo$configDirectoryLocation)){
+            configDirPath <- configInfo$configDirectoryLocation
+          } else {
+            configDirPath <- "."
+          }
+
+          if (!is.null(configInfo$inputExcelFile)){
+            GPE$inputExcelFile <-
+              paste(configDirPath,
+                    configInfo$inputExcelFile,
+                    sep = "/")
+          }
         }
 
         if (!is.null(configInfo$suiteRngSeed)){
@@ -97,16 +98,6 @@ loadGlobalConfig <- function(path = "./globalconfig.json"){
   invisible(NULL)
 }
 
-# Note: this function does not check that the file path is valid.
-# This function is intended to support unit tests to force the system to
-# initialize based on a different configuration than is in globalconfig.json.
-setGlobalConfig <- function(inputExcelFilePath = "./config/model_inputs.xlsx"){
-  if (!is.blank(inputExcelFilePath)){
-    GPE$inputExcelFile <- inputExcelFilePath
-    GPE$globalConfigLoaded <- TRUE
-  }
-}
-
 # Internal function used by the various InitializeXXXXX() functions to auto-
 # magically load the global configuration.
 
@@ -118,7 +109,51 @@ setGlobalConfig <- function(inputExcelFilePath = "./config/model_inputs.xlsx"){
     loadGlobalConfig()
     GPE$globalConfigLoaded <- TRUE
   }
-  invisible(NULL)
+  return(invisible(NULL))
+}
+
+.validInputFile <- function(filepath){
+  if (is.null(filepath)){
+    return(FALSE)
+  }
+
+  if (is.blank(filepath)){
+    return(FALSE)
+  }
+
+  if (!file.exists(filepath)){
+    return(FALSE)
+  }
+
+  return(TRUE)
+}
+
+#' Set Input Excel File
+#'
+#' Declare the Excel file to be used for reading configuration information. The
+#' function over-writes whatever is supplied in the globalconfig.json file. The
+#' function returns a warning if the user supplies a bad file path.
+#'
+#' @param inputExcelFilePath Path to Excel file (default =
+#'   "./config/model_inputs.xlsx")
+#'
+#' @return NULL (invisible)
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' pacehrh::SetInputExcelFile(inputExcelFilePath = "config_file.xlsx")
+#' }
+SetInputExcelFile <- function(inputExcelFilePath = "./config/model_inputs.xlsx"){
+  if (!.validInputFile(inputExcelFilePath)){
+    warning(paste0("Input file <", inputExcelFilePath, "> not found."))
+  } else {
+    GPE$inputExcelFile <- inputExcelFilePath
+    GPE$ignoreGlobalConfigExcelFileSetting <- TRUE
+  }
+
+  return(invisible(NULL))
 }
 
 #' Set Global Start And End Year Parameters
@@ -189,7 +224,7 @@ SetGlobalStartEndYears <- function(start = 2020, end = 2040, shoulderYears = 1)
 #'
 #' @param value Rounding law. Allowed values are "early", "late", "none" and NULL
 #'
-#' @return Previous rounding law value
+#' @return Previous rounding law value (invisible)
 #' @export
 #'
 #' @examples
@@ -209,3 +244,64 @@ SetRoundingLaw <- function(value = NULL){
 
   return(invisible(prevValue))
 }
+
+#' Turn Stochasticity On/Off
+#'
+#' Debugging function to turn off all Monte Carlo variation. With stochasticity
+#' off, every experiment based on the same configuration produces the
+#' same output.
+
+#' By default the system is set up with stochasticity on.
+#'
+#' @param value Desired stochasticity. (Calling \code{SetStochasiticity()} with
+#' no parameters or value = NULL returns the current state.)
+#'
+#' @return Previous stochasticity flag value (invisible)
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' pacehrh::SetStochasticity(FALSE) # Turn off stochasticity
+#' pacehrh::SetStochasticity() # Return current stochasticity state
+#' }
+SetStochasticity <- function(value = NULL){
+  prevValue <- GPE$stochasticity
+
+  if (!is.null(value)){
+    if (rlang::is_logical(value)){
+      GPE$stochasticity <- value
+    } else {
+      traceMessage(paste0(value, " is not an allowed stochasticity flag value"))
+    }
+  }
+
+  return(invisible(prevValue))
+}
+
+#' Turn Per-Age Statistics On/Off
+#'
+#' @param value Desired value. (Calling \code{SetPerAgeStats()} with
+#' no parameters or value = NULL returns the current state.)
+#'
+#' @return Previous value (invisible)
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' pacehrh::SetPerAgeStats("monthly") # Turn on per-age statistics
+#' pacehrh::SetPerAgeStats() # Return current state
+#' }
+SetPerAgeStats <- function(value = NULL){
+  prevValue <- GPE$perAgeStats
+
+  if (!is.null(value)){
+    if (tolower(value) %in% .perAgeLevels){
+      GPE$perAgeStats <- tolower(value)
+    } else {
+      traceMessage(paste0(value, " is not an allowed per-age setting"))
+    }
+  }
+
+  return(invisible(prevValue))
+}
+

pacehrh/R/pace_exp_control.R

@@ -26,9 +26,6 @@
 #' result <- pacehrh::SaveBaseSettings(scenario)
 #' }
 SaveBaseSettings <- function(scenarioName = ""){
-  # GPE = globalPackageEnvironment = source environment
-  # BVE = baseValuesEnvironment = destination environment
-
   .zeroExpBaseVariables()
 
   BVE$scenario <- .getScenarioConfig(scenarioName)
@@ -98,15 +95,40 @@ SaveBaseSettings <- function(scenarioName = ""){
     })
 
     BVE$taskData$popRangeMaskPtr <- as.vector(index)
+
+    # Generate a list of tasks affected by seasonality
+    tpIds <- dimnames(BVE$taskParameters)[[1]]
+    soIds <- BVE$seasonalityOffsets$Task
+    BVE$seasonalTasks <- intersect(soIds, tpIds)
   }
 
   # Set the year range for trials, which is just the specified year range
-  # extended by a year to correct for seasonality edge effects.
+  # extended by a GPE$shoulderYears years to correct for seasonality edge effects.
   .setTrialYears()
 
+  # Merge seasonality curves into the seasonality offsets table
+  .mergeSeasonalityCurves()
+
   return(BVE$scenario)
 }
 
+# Extend the SeasonalityOffsets table with the seasonality curve values from the
+# SeasonalityCurves table. This facilitates easier lookups later on.
+.mergeSeasonalityCurves <- function(){
+  seasonalityCurvesTable <- BVE$seasonalityCurves
+  curveCols <- 2:length(seasonalityCurvesTable)
+  monthNames <- seasonalityCurvesTable$Month
+  curveNames <- names(seasonalityCurvesTable)[curveCols]
+
+  # Convert [months x curves] table to [curves x months] table
+  tsc <- t(seasonalityCurvesTable[curveCols])
+  colnames(tsc) <- monthNames
+  tsc <- tibble::as_tibble(tsc)
+  tsc$Type <- curveNames
+
+  BVE$seasonalityOffsetsEx <- merge(BVE$seasonalityOffsets, tsc, by.x = "Curve", by.y = "Type")
+}
+
 .setTrialYears <- function(){
   BVE$startYear <- GPE$startYear
   BVE$endYear <- GPE$endYear + GPE$shoulderYears
@@ -223,7 +245,6 @@ ConfigureExperimentValues <- function(){
 #' initPop <- pacehrh:::loadInitialPopulation(sheetName = "Flat_Population")
 #' pcr <- pacehrh:::loadPopulationChangeRates(sheetName = "Flat_Rates")
 #' pars <- pacehrh:::loadStochasticParameters(sheetName = "Flat_StochasticParms")
-#' # Turn off stochasticity and generate several years of rates
 #' years <- 2020:2040
 #' pcr <- pacehrh:::addRatesMatricesToPopulationChangeRates(pcr, years, NULL)
 #' }

pacehrh/R/pace_experiment.R

@@ -40,14 +40,30 @@ RunExperiment <- function(debug = FALSE){
 
   # COMPUTE ANNUAL TIMES FOR TASKS
   t <- TaskTimes()
-
   results$AnnualTimes <- t$Time
   results$AnnualCounts <- t$N
 
   # USE ANNUAL TIMES TO COMPUTE SEASONALLY ADJUSTED MONTHLY TIMES
   seasonalityResults <- runSeasonalityExperiment(results)
   results$SeasonalityResults <- seasonalityResults
 
+  # COMPUTE PER-AGE ANNUAL TIMES FOR TASKS
+
+  # Note: Environments are passed by reference, reducing the need to copy large
+  # structures. Results from the next couple of calls are written directly into
+  # the temp environment, not passed back from the procedures.
+
+  if (GPE$perAgeStats != "off"){
+    e <- rlang::env()
+    ComputePerAgeTaskTimes(e)
+
+    if (GPE$perAgeStats == "annual"){
+      results$AnnualPerAge <- e$AnnualPerAge
+    } else {
+      results$MonthlyPerAge <- as.list(e)
+    }
+  }
+
   return(results)
 }
 
@@ -66,14 +82,6 @@ RunExperiment <- function(debug = FALSE){
   return(retVal)
 }
 
-
-# ---------------------------------------
-#
-# TODO: Remove this testing-only function
-#
-# ---------------------------------------
-
-
 #' Compute Population Range Sizes Based On Population Predictions
 #'
 #' @param populations Population predictions as returned by [ComputePopulationProjection()]

pacehrh/R/pace_package_env.R

@@ -21,8 +21,18 @@ EXP <- experimentValuesEnvironment
 
 .defaultRoundingLaw <- .roundingLaws[1] # "early"
 
-.colorM = rgb(96,131,180, maxColorValue = 255)
-.colorF = rgb(210,120,135, maxColorValue = 255)
+.perAgeLevels <- c(
+  "off",
+  "annual",
+  "monthly"
+)
+
+.defaultPerAgeLevel <- .perAgeLevels[1] # "off"
+
+.colorM <- rgb(96,131,180, maxColorValue = 255)
+.colorF <- rgb(210,120,135, maxColorValue = 255)
+
+.defaultPopSheet <- "TotalPop"
 
 # GLOBAL VARIABLES
 
@@ -31,6 +41,7 @@ GPE$globalDebug <- FALSE
 
 GPE$traceState <- FALSE
 GPE$inputExcelFile <- "./config/model_inputs.xlsx"
+GPE$ignoreGlobalConfigExcelFileSetting <- FALSE
 
 GPE$startYear <- 2020
 GPE$endYear <- 2040
@@ -39,6 +50,8 @@ GPE$years <- seq(from = GPE$startYear,
                  by = 1)
 GPE$shoulderYears <- 1
 
+GPE$stochasticity <- TRUE
+
 GPE$ageMin <- 0
 GPE$ageMax <- 100
 GPE$ages <- seq(from = GPE$ageMin,
@@ -52,6 +65,7 @@ GPE$scenarios <- NULL
 
 GPE$rngSeed <- 12345
 GPE$roundingLaw <- .defaultRoundingLaw
+GPE$perAgeStats <- .defaultPerAgeLevel
 
 BVE$seasonalityCurves <- NULL
 BVE$seasonalityOffsets <- NULL