Merge pull request #120 from InstituteforDiseaseModeling/charles/issue24

Confirm that SetGlobalStartEndYears() works as expected

ehep/R/ehep_plot_fertility.R

@@ -152,7 +152,7 @@ PlotFertilityRatesStats <- function(results, se = FALSE, type = "lines", log = T
   }
 
   g <- g + geom_boxplot()
-  g <- g + scale_x_discrete(breaks = c(2020, 2030, 2040))
+  g <- g + scale_x_discrete(breaks = seq(2000, 2100, 5))
   g <- g + theme(legend.position = "none")
 
   if (log){
@@ -187,7 +187,7 @@ PlotFertilityRatesStats <- function(results, se = FALSE, type = "lines", log = T
   g <- g + geom_ribbon(aes(ymin = m - CI, ymax = m + CI, fill = Label), alpha = 0.5)
   g <- g + geom_line(size = .5)
   g <- g + facet_wrap(vars(Label))
-  g <- g + scale_x_discrete(breaks = c(2020, 2030, 2040))
+  g <- g + scale_x_discrete(breaks = seq(2000, 2100, 5))
   g <- g + theme(legend.position = "none")
   g <- g + ylab(ylabel) + xlab("Year")
   g <- g + xlab("Year")
@@ -215,7 +215,7 @@ PlotFertilityRatesStats <- function(results, se = FALSE, type = "lines", log = T
   ))
   g <- g + geom_pointrange(aes(ymin = m - CI, ymax = m + CI), size = 0.5)
   g <- g + facet_wrap(vars(Label))
-  g <- g + scale_x_discrete(breaks = c(2020, 2030, 2040))
+  g <- g + scale_x_discrete(breaks = seq(2000, 2100, 5))
   g <- g + theme(legend.position = "none")
   g <- g + ylab(ylabel) + xlab("Year")
   g <- g + xlab("Year")

ehep/R/ehep_population_config.R

@@ -36,29 +36,6 @@ loadInitialPopulation <- function(sheetName = "TotalPop"){
               total = total))
 }
 
-#' Load Population Change Parameters
-#'
-#' @param sheetName Sheet name from model input Excel file.
-#'
-#' @return List with two \code{PopulationChangeParameters} objects:
-#' \code{initValues} and \code{changeRates}
-#'
-loadPopulationChangeParameters <- function(sheetName = "PopValues"){
-  popValues <- readxl::read_xlsx(GPE$inputExcelFile, sheet = sheetName)
-
-  if (!is.null(popValues)){
-    initValues <- PopulationChangeParameters()
-    changeRates <- PopulationChangeParameters()
-
-    initValues <- setFromVector(initValues, popValues$Value2020)
-    changeRates <- setFromVector(changeRates, popValues$AnnualChange)
-
-    popValues <- list(initValues = initValues, changeRates = changeRates)
-  }
-
-  return(popValues)
-}
-
 .popLabelRawColumns <-
   c("Relevant Population Labels", "Male", "Female", "Starting Age", "Ending Age")
 

ehep/R/ehep_task_time.R

@@ -150,7 +150,10 @@ TaskTimesGroup <- function(taskIDs, years, weeksPerYear = 48){
 
 .computeApplicablePopulation <- function(pop, label) {
   # Fail in a big mess if the population labels lookup hasn't been loaded.
-  assertthat::assert_that(!is.null(GPE$populationLabels))
+  if (is.null(GPE$populationLabels)){
+    warning(paste0("Population labels not loaded! Returning 0 for applicable population."))
+    return(0)
+  }
 
   l <- GPE$populationLabels
   i <- which(l$Labels == label)

ehep/tests/testthat/test-ehep_population_config.R

@@ -21,28 +21,6 @@ test_that("Population configuration: confirm cleanup 1", {
   testthat::expect_equal(ehep:::GPE$inputExcelFile, "./config/R Model Inputs.xlsx")
 })
 
-# This test loads and validates a simplified version of the input population data.
-test_that("Population configuration: basic population parameters", {
-  testthat::expect_equal(ehep:::GPE$inputExcelFile, "./config/R Model Inputs.xlsx")
-
-  e <- ehep:::GPE
-  local_vars("inputExcelFile", envir = e)
-
-  e$inputExcelFile <- "./simple_config/Test Inputs.xlsx"
-  popParms <- ehep:::loadPopulationChangeParameters(sheetName = "TEST_PopValues")
-
-  testthat::expect_true(!is.null(popParms))
-  testthat::expect_equal(length(popParms$initValues@values), length(popParms$changeRates@values))
-
-  testDeltas <- replicate(length(popParms$changeRates@values), 0.98)
-  testDeltas[2] <- 30
-  testthat::expect_equal(popParms$changeRates@values, testDeltas)
-})
-
-test_that("Population configuration: confirm cleanup 2", {
-  testthat::expect_equal(ehep:::GPE$inputExcelFile, "./config/R Model Inputs.xlsx")
-})
-
 .validInitPopulation <- function(pop) {
   return(TRUE)
 }

ehep/tests/testthat/test-ehep_population_predict.R

@@ -5,42 +5,6 @@ e <- ehep:::GPE
 local_vars("globalDebug", envir = e)
 GPE$globalDebug <- TRUE
 
-# test_that("explodeMortalityRates: basic", {
-#   refFemale <- c(1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5,
-#                  6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7,
-#                  7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
-#                  9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10,
-#                  10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10)
-#
-#   refMale <- c(1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5,
-#                6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 11, 11, 11, 11, 11,
-#                11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
-#                13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14,
-#                14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14)
-#
-#   results <- ehep:::explodeMortalityRates(c(1,2,3,4,5,6,7,8,9,10,11,12,13,14))
-#
-#   testthat::expect_true(!is.null(results))
-#   testthat::expect_named(results, c("Female", "Male"))
-#   testthat::expect_equal(results$Female, refFemale)
-#   testthat::expect_equal(results$Male, refMale)
-# })
-
-# test_that("explodeFertilityRates: basic", {
-#   refFemale <- c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1,
-#                  2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5,
-#                  6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
-#                  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
-#                  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
-#
-#   results <- ehep:::explodeFertilityRates(c(1,2,3,4,5,6,7))
-#
-#   testthat::expect_true(!is.null(results))
-#   testthat::expect_named(results, c("Female", "Male"))
-#   testthat::expect_equal(results$Female, refFemale)
-#   testthat::expect_true(all(results$Male == 0))
-# })
-
 test_that("computeBirths: basic", {
   testthat::expect_equal(ehep:::GPE$inputExcelFile, "./config/R Model Inputs.xlsx")
 

ehep/tests/testthat/test-ehep_rates_matrix.R

@@ -11,12 +11,9 @@ test_that("Fertility rates matrix: basic", {
   e$inputExcelFile <- "./simple_config/Test Inputs.xlsx"
 
   pars <- ehep:::loadStochasticParameters(sheetName = "TEST_StochasticParms")
-  pcp <- ehep:::loadPopulationChangeParameters(sheetName = "TEST_PopValues")
-  rates <- ehep:::loadPopulationChangeRates(sheetName = "EXP_PopValues")
+  rates <- ehep:::loadPopulationChangeRates(sheetName = "TEST_PopValues")
   years <- ehep:::GPE$years
 
-  testthat::expect_named(pcp, c("initValues", "changeRates"))
-
   # CASE A
 
   rates <- rates[["femaleFertility"]]

ehep/tests/testthat/test-ehep_start_stop.R

@@ -0,0 +1,52 @@
+library(ehep)
+
+withr::local_dir("..")
+
+test_that("Full suite: basic", {
+  ehep::InitializePopulation()
+  ehep::InitializeHealthcareTasks()
+  ehep::InitializeScenarios()
+  ehep::InitializeStochasticParameters()
+  ehep::InitializeSeasonality()
+
+  # Make sure to use a scenario that has seasonality results!
+  scenario <- "MergedModel"
+  nTrials <- 5
+  startYear <- 2025
+  endYear <- 2050
+  nMonths <- 12 * length(startYear:endYear)
+
+  ehep::SetGlobalStartEndYears(startYear, endYear)
+
+  results <-
+    ehep::RunExperiments(scenarioName = scenario,
+                         trials = nTrials)
+
+  # Check that the results structure elements are the correct size and number
+  testthat::expect_true(!is.null(results))
+  testthat::expect_true("SeasonalityResults" %in% names(results[[1]]))
+  testthat::expect_equal(length(results), nTrials)
+  testthat::expect_true(setequal(names(results[[1]]$Population),as.character(startYear:endYear)))
+  testthat::expect_equal(length(results[[1]]$SeasonalityResults[[1]]$Time), nMonths)
+
+  # ---------------------------------
+  ehep::SaveSuiteResults(results, "results.csv", scenario, 1)
+  csvResults <- data.table::fread(file = "results.csv")
+
+  # Test that the saved CSV has the correct number of rows and columns
+  nTasks <- length(results[[1]]$SeasonalityResults)
+  testthat::expect_equal(nrow(csvResults), (nTasks * nMonths * nTrials))
+
+  csvCols <- c("Task_ID",
+               "Scenario_ID",
+               "Trial_num",
+               "Run_num",
+               "Year",
+               "Month",
+               "Num_services",
+               "Service_time",
+               "Health_benefit")
+
+  testthat::expect_true(setequal(names(csvResults), csvCols))
+})
+

tests/testthat/test_lean_scenario.R

@@ -22,6 +22,7 @@ test_template <- function(){
     InitializeScenarios()
     InitializeStochasticParameters()
     InitializeSeasonality()
+    SetGlobalStartEndYears(start = 2020, end = 2040)
     withr::defer_parent(unlink("tests/results", recursive = TRUE,  force = TRUE))
 }