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

…e133

WIP PR on the way to the final #133 PR

pacehrh/DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: pacehrh
 Title: Population-Aware Capacity Estimator for Human Resources for Health
-Version: 1.0.2
+Version: 1.0.3
 Author: Charles Eliot, Brittany Hagedorn
 Maintainer: Charles Eliot <[email protected]>
 Description: This package models the healthcare needs of a given population so you
@@ -17,6 +17,7 @@ Imports:
     magrittr,
     methods,
     readxl,
+    rlang,
     scales,
     tibble,
     tidyr,
@@ -44,12 +45,6 @@ Collate:
     'pace_utils.R'
     'pace_lint.R'
     'pace_trace.R'
-    'pace_pop_pyramid_class.R'
-    'pace_task_params_class.R'
-    'pace_add_method.R'
-    'pace_getValue_method.R'
-    'pace_setFromVector_method.R'
-    'pace_setValue_method.R'
     'pace_config.R'
     'pace_pop_rates_config.R'
     'pace_exp_control.R'

pacehrh/NAMESPACE

@@ -25,7 +25,6 @@ export(PlotPyramids)
 export(PlotResultsFertilityRates)
 export(PlotResultsMortalityRates)
 export(PlotResultsPopulationCurve)
-export(PopulationPyramid)
 export(ReadAndCollateSuiteResults)
 export(ReadScenario)
 export(RunExperiments)
@@ -35,11 +34,8 @@ export(SaveSuiteDemographics)
 export(SaveSuiteResults)
 export(SetGlobalStartEndYears)
 export(SetRoundingLaw)
-export(TaskParameters)
 export(Trace)
 export(UpdateScenario)
-exportClasses(PopulationPyramid)
-exportClasses(TaskParameters)
 import(data.table)
 importFrom(dplyr,group_by)
 importFrom(dplyr,summarize)

pacehrh/R/pace_config.R

@@ -201,7 +201,7 @@ SetRoundingLaw <- function(value = NULL){
 
   if (!is.null(value)){
     if (tolower(value) %in% .roundingLaws){
-      GPE$roundingLaw <- value
+      GPE$roundingLaw <- tolower(value)
     } else {
       traceMessage(paste0(value, " is not an allowed rounding law value"))
     }

pacehrh/R/pace_exp_control.R

@@ -89,7 +89,7 @@ SaveBaseSettings <- function(scenarioName = ""){
     BVE$taskDataDims <- dim(BVE$taskData)
     BVE$stochasticTasks <- which(BVE$taskData$applyStochasticity)
     m <- .convertTaskDfToMatrix(BVE$taskData)
-    BVE$taskParameters <- TaskParameters(values = m)
+    BVE$taskParameters <- m
 
     # Add a task data column pointing into the population range mask tables
     # associated with each RelevantPop range

pacehrh/R/pace_experiment.R

@@ -104,7 +104,7 @@ RunExperiment <- function(debug = FALSE){
   })
 
   rm <- lapply(populations, function(pop){
-    t(t(popRanges$Female) * pop$Female)
+    t(t(popRanges$Male) * pop$Male)
   })
 
   return(list(

pacehrh/R/pace_plot.R

@@ -333,7 +333,7 @@ PlotPyramid <- function(df, year){
         yend = Percent
       ),
       color = .colorF,
-      size = 1.5
+      linewidth = 1.5
     )
   g <-
     g + geom_segment(
@@ -345,7 +345,7 @@ PlotPyramid <- function(df, year){
         yend = (-1 * Percent)
       ),
       color = .colorM,
-      size = 1.5
+      linewidth = 1.5
     )
   g <- g + scale_y_continuous(limits = limits, breaks = breaks, labels = labels)
   g <- g + xlab("Age") + ylab("Percent of Population")
@@ -409,7 +409,7 @@ PlotPyramids <- function(df) {
         yend = Percent
       ),
       color = .colorF,
-      size = 1
+      linewidth = 1
     )
   g <-
     g + geom_segment(
@@ -421,7 +421,7 @@ PlotPyramids <- function(df) {
         yend = (-1 * Percent)
       ),
       color = .colorM,
-      size = 1
+      linewidth = 1
     )
   g <- g + scale_y_continuous(limits = limits, breaks = breaks, labels = labels)
   g <- g + xlab("Age") + ylab("Percent of Population")

pacehrh/R/pace_population_config.R

@@ -6,34 +6,64 @@
 #'
 #' @param sheetName Sheet name from the model input Excel file
 #'
-#' @return List with three \code{PopulationPyramid} objects:
-#' \code{female}, \code{male} and \code{total}
+#' @return Tibble with three population pyramid fields:
+#' \code{Female}, \code{Male} and \code{Total}
 #'
 loadInitialPopulation <- function(sheetName = "TotalPop"){
   popData <- readxl::read_xlsx(GPE$inputExcelFile, sheet = sheetName)
 
-  assertthat::has_name(popData, "Age")
-  assertthat::has_name(popData, "Male")
-  assertthat::has_name(popData, "Female")
+  namesFound <- names(popData)
+  namesExpected <- c("Age", "Male", "Female")
 
-  # For consistency we use the integer range 0:100 to label age buckets.
-  assertthat::assert_that(length(popData$Male) == length(popData$Female))
-  assertthat::assert_that(length(popData$Male) == length(popData$Age))
-  assertthat::assert_that(length(popData$Age) == length(GPE$ages))
+  if (length(setdiff(namesExpected, namesFound)) != 0){
+    warning(paste0("Incorrect columns in ", sheetName, ". Could not load initial population."))
+    return(NULL)
+  }
 
-  male <- PopulationPyramid()
-  female <- PopulationPyramid()
-  total <- PopulationPyramid()
+  return(.createPopulationTreeDf(GPE$ages, popData$Female, popData$Male))
+}
 
-  male <- setFromVector(male, round(popData$Male, 0))
-  female <- setFromVector(female, round(popData$Female, 0))
-  total <- setFromVector(total,
-                         round(popData$Male, 0) + round(popData$Female, 0))
+.createPopulationTreeDf <- function(ages = 0:100L,
+                                    femalePop = rep_len(0.0, length(ages)),
+                                    malePop = rep_len(0.0, length(ages))) {
+  if (!.validPopTreeParams(ages, femalePop, malePop)) {
+    warning("Invalid parameters passed to .createPopulationTreeDf")
+    return(NULL)
+  }
+
+  if (GPE$roundingLaw != "none"){
+    femalePop <- round(femalePop, 0)
+    malePop <- round(malePop, 0)
+  }
+
+  return(
+    tibble::tibble(
+      Age = ages,
+      Female = femalePop,
+      Male = malePop,
+      Total = femalePop + malePop
+    )
+  )
+}
+
+.validPopTreeParams <- function(...) {
+  params <- rlang::dots_list(..., .named = TRUE)
+
+  if (any(sapply(params, is.null))) {
+    return(FALSE)
+  }
+
+  if (any(sapply(params, length) == 0)) {
+    return(FALSE)
+  }
+
+  reflen <- length(params$ages)
+
+  if (any(sapply(params, length) != reflen)) {
+    return(FALSE)
+  }
 
-  return(list(age = GPE$ages,
-              female = female,
-              male = male,
-              total = total))
+  return(TRUE)
 }
 
 .popLabelRawColumns <-

pacehrh/R/pace_population_predict.R

@@ -53,18 +53,18 @@
 }
 
 .normalizePopulationEx <- function(pop, normalizedTotal){
-  total <- sum(pop$female@values) + sum(pop$male@values)
+  total <- sum(pop$Female) + sum(pop$Male)
   normFactor <- normalizedTotal / total
 
   if (GPE$roundingLaw == "none"){
-    pop$male@values <- pop$male@values * normFactor
-    pop$female@values <- pop$female@values * normFactor
+    pop$Male <- pop$Male * normFactor
+    pop$Female <- pop$Female * normFactor
   } else {
-    pop$male@values <- round(pop$male@values * normFactor, 0)
-    pop$female@values <- round(pop$female@values * normFactor, 0)
+    pop$Male <- round(pop$Male * normFactor, 0)
+    pop$Female <- round(pop$Female * normFactor, 0)
   }
 
-  pop$total@values <- pop$male@values + pop$female@values
+  pop$Total <- pop$Male + pop$Female
 
   return(pop)
 }
@@ -127,27 +127,23 @@ ComputePopulationProjection <- function(initialPopulation,
   }
 
   initialPopulationTotal <-
-    sum(initialPopulation$female@values) + sum(initialPopulation$male@values)
+    sum(initialPopulation$Female) + sum(initialPopulation$Male)
 
   previousPyramid <- NULL
 
-  assertthat::has_name(initialPopulation, "age")
-  range <- initialPopulation$age
+  range <- initialPopulation$Age
 
   projection <- lapply(years, function(currentYear){
     # Special case: the first element of the projection is just the population
     # pyramid for the starting year.
 
     if (is.null(previousPyramid)){
-      out <- data.frame(Range = range, Female = initialPopulation$female@values, Male = initialPopulation$male@values)
+      out <- data.frame(Range = range, Female = initialPopulation$Female, Male = initialPopulation$Male)
     } else {
       previousYear <- currentYear - 1
 
       rates <- .explodeRates(populationChangeRates, currentYear)
 
-      # currentYearFertilityRates <- explodeFertilityRates(fertilityRates[, as.character(currentYear)])
-      # currentYearMortalityRates <- explodeMortalityRates(mortalityRates[, as.character(currentYear)])
-
       # Shuffle the end-of-year snapshots from the previous year to the next
       # population bucket
       f <- c(0, previousPyramid$Female)[1:length(GPE$ages)]