Merge pull request #236 from InstituteforDiseaseModeling/clean-model_…

…inputs

Update model_inputs.xlsx

tests/testthat/test_ValidateInput.R

@@ -1,5 +1,4 @@
-context("Test ValidateInputExcelFileContent")
-local_edition(3)
+testthat::local_edition(3)
 setwd("../..")
 source("ValidateInput.R")
 
@@ -22,7 +21,7 @@ test_that("Validation capture", {
   # skip_if(.Platform$OS.type != "windows")
   testthat::expect_equal(errCode, ValidateInputExcelFileContent(inputFile = "tests/testthat/sample_config/Test_validation.xlsx",
                                                                 outputDir = logdir,
-                                                                sheetNames = c("SeasonalityCurves")), error=TRUE)
+                                                                sheetNames = c("SeasonalityCurves")))
 
 })
 # test validation success

tests/testthat/test_lean_scenario.R

@@ -1,6 +1,5 @@
-context("Test minimum template")
-local_edition(3)
-packages = c("dplyr","testthat")
+testthat::local_edition(3)
+packages = c("dplyr", "vdiffr", "testthat")
 for(i in packages){
   if(!require(i, character.only = T)){
     install.packages(i)
@@ -11,21 +10,25 @@ for(i in packages){
 library(pacehrh)
 setwd("../..")
 minimum_input_file <- "pacehrh/inst/extdata/model_inputs_template_lean.xlsx"
+source("tests/testthat/test_per_age.R")
 
 # Set up necessary steps for default minimum template
-test_template <- function(){
+test_template <- function(input_file, rounding="", setting="annual"){
     dir.create("tests/results", showWarnings = FALSE)
-    pacehrh::SetInputExcelFile(inputExcelFilePath = minimum_input_file)
+    dir.create("tests/results/regression", showWarnings = FALSE)
+    pacehrh::SetInputExcelFile(inputExcelFilePath = input_file)
     Trace(TRUE)
     InitializePopulation()
     InitializeScenarios()
     InitializeStochasticParameters()
     InitializeSeasonality()
     SetGlobalStartEndYears(start = 2020, end = 2040)
+    if (rounding!=""){pacehrh::SetRoundingLaw(rounding)}
+    pacehrh::SetPerAgeStats(setting)
     withr::defer_parent(unlink("tests/results", recursive = TRUE,  force = TRUE))
 }
 
-test_that("check_template", {
+test_that("check_package_template", {
   # TODO:
   # There is currently warning about
   # tasks in the scenario offsets table are not used in task values sheets
@@ -34,11 +37,53 @@ test_that("check_template", {
 
 })
 
+test_that("check_user_template", {
+  # TODO:
+  # There is currently warning about
+  # tasks in the scenario offsets table are not used in task values sheets
+  # We need to define the validate behavior in lint
+  input_file <- "config/model_inputs.xlsx"
+  expect_true(pacehrh::CheckInputExcelFileFormat(input_file) %in% c(pacehrh:::.Success, pacehrh:::.warnProblemsFound))
+
+})
+
+test_that("model regression annual",{
+  input_file <- "config/model_inputs.xlsx"
+  local({
+    setting = "annual"
+    test_template(input_file, setting = setting)
+    numtrials <- 2
+    scenario <- "ComprehensiveModel"
+    results <- RunExperiments(scenarioName = scenario, trials = numtrials, debug = TRUE)
+    expect_true(all(!is.na(results)))
+    # save results for selected tasks that are representative of seasonality
+    expect_doppelganger("FH.MN.ANC.1",  draw_comparison(results, "FH.MN.ANC.1", numtrials , setting, 1))
+    expect_doppelganger("FH.MN.D.3",  draw_comparison(results, "FH.MN.D.3", numtrials , setting, 1))
+    expect_doppelganger("Record keeping",  draw_comparison(results, "Record keeping", numtrials , setting, 1))
+  })
+})
+
+test_that("model regression monthly",{
+  input_file <- "config/model_inputs.xlsx"
+  local({
+    setting = "monthly"
+    test_template(input_file, setting = setting)
+    numtrials <- 2
+    scenario <- "ComprehensiveModel"
+    results <- RunExperiments(scenarioName = scenario, trials = numtrials, debug = TRUE)
+    expect_true(all(!is.na(results)))
+    # save results for selected tasks that are representative of seasonality
+    expect_doppelganger("FH.MN.ANC.1_monthly",  draw_comparison(results, "FH.MN.ANC.1", numtrials , setting, 1))
+    expect_doppelganger("FH.MN.D.3_monthly",  draw_comparison(results, "FH.MN.D.3", numtrials , setting, 1))
+    expect_doppelganger("Record keeping_monthly",  draw_comparison(results, "Record keeping", numtrials , setting, 1))
+  })
+})
+
 test_that("simple regression", {
   local({
-    test_template()
+    test_template(minimum_input_file)
     numtrials <- 2
-    dir.create("tests/results/regression", showWarnings = FALSE)
+
     # Run through the full scenario list.
     for (i in 1:nrow(pacehrh:::loadScenarios())){
       cat(paste("Starting scenario",i))
@@ -56,15 +101,15 @@ test_that("simple regression", {
       sorted_filename <- gsub("results_", "results_sorted_", filename)
       write.csv(result, sorted_filename)
       # assuming no data change the stochastic randomness, result should be the same using the default seed
-      expect_snapshot_file(sorted_filename)
+      expect_snapshot_file(sorted_filename, compare=testthat::compare_file_text)
       # Check population 
       df <- SaveSuiteDemographics(results)
       df <- df %>%
         dplyr::group_by(Trial, Year, Age) %>%
         dplyr::summarize(Female = sum(Female), Male = sum(Male)) %>%
         dplyr::arrange(Trial, Year, Age)
       write.csv(df, filename_d, row.names = FALSE)
-      expect_snapshot_file(filename_d)
+      expect_snapshot_file(filename_d, compare=testthat::compare_file_text)
     }
   })
 

tests/testthat/test_per_age.R

@@ -0,0 +1,97 @@
+packages = c("tidyverse")
+for(i in packages){
+  if(!require(i, character.only = T)){
+    install.packages(i)
+    library(i, character.only = T)
+  }
+}
+
+draw_comparison <- function(results, taskname, trials, setting, shoulderYears=1){
+
+  # calculate average annual times for all trails
+  xa <-lapply(c(1:trials), 
+              function(x) {y <-data.frame(results[[x]][["AnnualTimes"]][taskname,])
+              colnames(y) <- c("reported_anuual") 
+              y
+              }
+  )
+  reported_annual <- rowMeans(do.call(cbind.data.frame, xa))
+  reported_annual <- reported_annual[1:length(reported_annual)-shoulderYears] # do not compare shoulder years
+  names(reported_annual) <- seq(2020, 2020+length(reported_annual)-1)
+
+  # calculate Per age Results
+  if (setting == "annual"){
+    variable_name <- "AnnualPerAge"
+    interval <- 1
+  } else if (setting == "monthly"){
+    variable_name <- "MonthlyPerAge"
+    interval <- 12
+  }else{
+    stop("Only support per age setting: annual or monthly")
+  }
+
+  x0 <- lapply(c(1:trials), 
+               function(x){
+                 zm <- colSums(results[[x]][[variable_name]][["Times"]][["Male"]][taskname,,], 2)
+                 zf <- colSums(results[[x]][[variable_name]][["Times"]][["Female"]][taskname,,], 2)
+                 total  <-  colSums(as.data.frame(split(zm, ceiling(seq_along(zm)/interval)))) + 
+                   colSums(as.data.frame(split(zf, ceiling(seq_along(zf)/interval))))
+                 total
+               })
+
+  reported_per_age <- rowMeans(do.call(cbind.data.frame, x0))
+  if (variable_name=="AnnualPerAge"){
+    reported_per_age <- reported_per_age[1:length(reported_per_age)-shoulderYears]
+  }
+  names(reported_per_age) <- seq(2020, 2020+length(reported_per_age)-1)
+
+
+  # calculate seasonalityResults if applicable
+  x1 <- lapply(c(1:trials), 
+               function(x){
+                 t <- results[[x]][["SeasonalityResults"]][[taskname]]$Time
+                 # combine to yearly
+                 t <- colSums(as.data.frame(split(t, ceiling(seq_along(t)/12))))
+                 t
+               }
+  )
+  reported_seasonal <-rowMeans(do.call(cbind.data.frame, x1))
+  names(reported_seasonal) <- seq(2020, 2020+length(reported_seasonal)-1)
+
+  data <- data.frame(cbind(reported_annual, reported_per_age, reported_seasonal))
+  year <- rownames(data)
+  data <- cbind(year, data)
+
+  df <- data %>%
+    select(year, reported_annual, reported_per_age, reported_seasonal) %>%
+    gather(key = "variable", value = "value", -year)
+  head(df)
+
+  # Visualization
+  g<- ggplot(df, aes(x = year, y = value, group=year)) +
+    geom_point(aes(color = variable, shape=variable, size=variable)) + 
+    # geom_line(aes(color = variable)) + 
+    labs(x = "Year", y = "Times",  title = taskname) +
+    theme(axis.text.x=element_text(angle = 90, hjust = 1)) +
+    scale_colour_manual(values=(c("blue", "green", "orange"))) +
+    scale_shape_manual(values=c(10,17,19)) +
+    scale_size_manual(values=c(5,3,1))
+  print(g)
+  #ggplot2::ggsave(paste("temp/", taskname, ".png"))
+  #data.frame(data)
+
+}
+
+
+# pick 3 different tasks to check values 
+# FH.MN.ANC.1 (OFFSET)
+# FH.MN.D.3 (No-OFFSET)
+# Record keeping (NO Seasonality)
+# 
+# tasknames <- c("FH.MN.ANC.1", "FH.MN.D.3", "Record keeping")
+# #tasknames <- row.names(results[["1"]][["AnnualTimes"]])
+# dfs <- list()
+# for (taskname in tasknames){
+#   df <- draw_comparison(taskname, trials, setting)
+#   dfs <- append(dfs,list(df))
+# }