update test options and patch tests

mrc-ide · Nov 18, 2024 · 032b27d · 032b27d
1 parent 1283c8c
commit 032b27d
Show file tree

Hide file tree

Showing 9 changed files with 73 additions and 61 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -13,6 +13,8 @@
 	  
   - Update vignettes with new datasets and default options.
 
+* Update Navigator checklist calendar quarter for 2025 estimates to
+  2024Q4 and 2025Q3 for current period and projection.
 
 # naomi 2.9.29
 

diff --git a/inst/metadata/navigator_validation.yml b/inst/metadata/navigator_validation.yml
@@ -1,2 +1,2 @@
-calendar_quarter_t2: CY2021Q4
-calendar_quarter_t3: CY2022Q3
+calendar_quarter_t2: CY2024Q4
+calendar_quarter_t3: CY2025Q3
diff --git a/tests/testthat/setup-run-model.R b/tests/testthat/setup-run-model.R
@@ -3,7 +3,7 @@
 ## for every test.
 
 a_hintr_data <- list(
-  pjnz = system_file("extdata/demo-subnational-pjnz/demo_mwi2019_region-pjnz.zip"),
+  pjnz = system_file("extdata/demo-subnational-pjnz/demo_mwi2024_region-pjnz.zip"),
   population = system_file("extdata/demo-subnational-pjnz/demo_population_zone.csv"),
   shape = system_file("extdata/demo-subnational-pjnz/demo_areas_region-pjnz.geojson"),
   survey = system_file("extdata/demo_survey_hiv_indicators.csv"),
@@ -14,22 +14,22 @@ a_hintr_data <- list(
 a_hintr_options <- list(
   area_scope = "MWI",
   area_level = "2",
-  calendar_quarter_t1 = "CY2016Q1",
-  calendar_quarter_t2 = "CY2018Q4",
-  calendar_quarter_t3 = "CY2019Q2",
-  calendar_quarter_t4 = "CY2022Q3",
-  calendar_quarter_t5 = "CY2023Q3",  
-  survey_prevalence = c("DEMO2016PHIA", "DEMO2015DHS"),
-  survey_art_coverage = "DEMO2016PHIA",
-  survey_recently_infected = "DEMO2016PHIA",
+  calendar_quarter_t1 = "CY2020Q3",
+  calendar_quarter_t2 = "CY2023Q4",
+  calendar_quarter_t3 = "CY2024Q3",
+  calendar_quarter_t4 = "CY2025Q3",
+  calendar_quarter_t5 = "CY2026Q3",  
+  survey_prevalence = "DEMO2020PHIA",
+  survey_art_coverage = "DEMO2020PHIA",
+  survey_recently_infected = "DEMO2020PHIA",
   include_art_t1 = "true",
   include_art_t2 = "true",
-  anc_clients_year2 = 2018,
-  anc_clients_year2_num_months = "9",
-  anc_prevalence_year1 = 2016,
-  anc_prevalence_year2 = 2018,
-  anc_art_coverage_year1 = 2016,
-  anc_art_coverage_year2 = 2018,
+  anc_clients_year2 = 2023,
+  anc_clients_year2_num_months = "12",
+  anc_prevalence_year1 = 2020,
+  anc_prevalence_year2 = 2023,
+  anc_art_coverage_year1 = 2020,
+  anc_art_coverage_year2 = 2023,
   spectrum_population_calibration = "national",
   artattend = "true",
   artattend_t2 = "false",

diff --git a/tests/testthat/test-01-run-model.R b/tests/testthat/test-01-run-model.R
@@ -325,7 +325,11 @@ test_that("model run can be calibrated", {
 
   expect_file_different(calibrated_output$model_output_path,
                         a_hintr_output$model_output_path)
-  expect_length(calibrated_output$warnings, 0)
+  ## expect_length(calibrated_output$warnings, 0)
+
+  expect_match(calibrated_output$warnings[[1]]$text,
+               "^ART coverage is higher than 100%")
+
 
   output <- read_hintr_output(calibrated_output$model_output_path)
   expect_equal(names(output),
@@ -451,8 +455,8 @@ test_that("Model can be run without .shiny90 file", {
 
   ## Remove .shiny90 from PJNZ and set 'output_aware_plhiv = FALSE'
   temp_pjnz <- tempfile(fileext = ".pjnz")
-  file.copy(system_file("extdata/demo_mwi2019.PJNZ"), temp_pjnz)
-  utils::zip(temp_pjnz, "malawi.zip.shiny90", flags="-d", extras = "-q")
+  file.copy(system_file("extdata/demo_mwi2024_v6.36.PJNZ"), temp_pjnz)
+  utils::zip(temp_pjnz, "Malawi.zip.shiny90", flags="-d", extras = "-q")
   expect_false(assert_pjnz_shiny90(temp_pjnz))
 
   data <- a_hintr_data

diff --git a/tests/testthat/test-02-model-options.R b/tests/testthat/test-02-model-options.R
@@ -168,6 +168,9 @@ test_that("use_survey_aggregate option affects selected data", {
   a_hintr_options <- format_options(a_hintr_options)
   options_aggregate <- a_hintr_options
   options_aggregate$use_survey_aggregate <- "true"
+  options_aggregate$survey_prevalence <- c("DEMO2016PHIA", "DEMO2015DHS")
+  options_aggregate$survey_art_coverage <- "DEMO2016PHIA"
+  options_aggregate$survey_recently_infected <- "DEMO2016PHIA"
 
   aggregate_survey <- dplyr::filter(demo_survey_hiv_indicators,
                                     age_group %in% c("Y000_014", "Y015_049"),
@@ -195,7 +198,7 @@ test_that("use_survey_aggregate option affects selected data", {
   ## Aggregate data with standard model options -- returns no data and an error.
   expect_error(
     naomi_prepare_data(input_data_aggregate, a_hintr_options),
-    "No prevalence survey data found for survey: DEMO2016PHIA, DEMO2015DHS. Prevalence data are required for Naomi. Check your selections."
+    "No prevalence survey data found for survey: DEMO2020PHIA. Prevalence data are required for Naomi. Check your selections."
   )
 
 })

diff --git a/tests/testthat/test-downloads.R b/tests/testthat/test-downloads.R
@@ -153,7 +153,7 @@ test_that("summary report download can be created", {
   expect_equal(out$metadata$areas, "MWI")
 
   expect_true(file.size(out$path) > 2000)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS",
+  expect_true(any(grepl("DEMO2020PHIA",
                         brio::readLines(out$path))))
   expect_true(any(grepl(basename(a_hintr_data$pjnz),
                         brio::readLines(out$path))))
@@ -181,8 +181,8 @@ test_that("comparison report download can be created", {
 
   expect_true(file.size(out$path) > 2000)
   content <- brio::readLines(out$path)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("Naomi estimate CY2016Q1", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("Naomi estimate CY2020Q3", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
   expect_true(any(grepl("Central", content)))
 

diff --git a/tests/testthat/test-input-comparison.R b/tests/testthat/test-input-comparison.R
@@ -41,7 +41,7 @@ test_that("ANC data is properly aggreagted for Spectrum comparison table", {
 
   x <- prepare_anc_spectrum_comparison(anc, shape, pjnz)
 
-  expect_equal(unique(x$indicator), c("anc_already_art", "anc_clients",
+  expect_equal(unique(x$indicator), c("anc_already_art", "anc_clients", "anc_known_neg",
                                       "anc_known_pos", "anc_tested" , "anc_tested_pos"))
   expect_equal(unique(x$group), c("anc_adult_female"))
   expect_equal(unique(x$area_name), c("Northern", "Central", "Southern"))
@@ -70,16 +70,16 @@ test_that("Comparisoon wrapper function works with missing programme data", {
 
   x <- prepare_spectrum_naomi_comparison(art, anc, shape, pjnz)
 
-  expect_equal(unique(x$indicator), c("number_on_art","anc_already_art", "anc_clients",
-                                      "anc_known_pos", "anc_tested" , "anc_tested_pos"))
+  expect_equal(unique(x$indicator), c("number_on_art", "anc_already_art", "anc_clients",
+                                      "anc_known_neg", "anc_known_pos", "anc_tested" , "anc_tested_pos"))
   expect_equal(unique(x$group), c("art_children", "art_adult_both", "anc_adult_female"))
 
   # Test wrapper function with no ART
   art <- NULL
 
   x <- prepare_spectrum_naomi_comparison(art, anc, shape, pjnz)
 
-  expect_equal(unique(x$indicator), c("anc_already_art", "anc_clients",
+  expect_equal(unique(x$indicator), c("anc_already_art", "anc_clients", "anc_known_neg",
                                       "anc_known_pos", "anc_tested" , "anc_tested_pos"))
   expect_equal(unique(x$group), c("anc_adult_female"))
 

diff --git a/tests/testthat/test-outputs.R b/tests/testthat/test-outputs.R
@@ -132,7 +132,7 @@ test_that("subset_output_package() saves expected output package", {
   area_id_sub <- c("MWI_1_2_demo", "MWI_2_2_demo")
   sex_sub <- "both"
   age_group_sub <- c("Y000_014", "Y015_024", "Y050_999")
-  calendar_quarter_sub <- c("CY2018Q4", "CY2019Q2")
+  calendar_quarter_sub <- c("CY2023Q4", "CY2024Q3")
   indicator_sub <- c("prevalence", "plhiv")
 
   sub_keep_file <- tempfile(fileext = ".zip")
@@ -191,8 +191,8 @@ test_that("can generate summary report from a qs file", {
                                  quiet = TRUE)
   expect_true(file.size(t) > 2000)
   content <- brio::readLines(t)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("demo_mwi2019_region-pjnz.zip", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("demo_mwi2024_region-pjnz.zip", content)))
   expect_true(any(grepl("Central", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
 })
@@ -203,8 +203,8 @@ test_that("can generate summary report from zip file", {
   generate_output_summary_report(t, zip$path, quiet = TRUE)
   expect_true(file.size(t) > 2000)
   content <- brio::readLines(t)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("demo_mwi2019_region-pjnz.zip", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("demo_mwi2024_region-pjnz.zip", content)))
   expect_true(any(grepl("Central", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
 })
@@ -293,7 +293,7 @@ test_that("navigator checklist returns expected results", {
                           "Opt_future_proj_qtr"        = FALSE,
                           "Opt_area_ID_selected"       = TRUE,
                           "Opt_calendar_survey_match"  = TRUE,
-                          "Opt_recent_survey_only"     = FALSE,
+                          "Opt_recent_survey_only"     = TRUE,
                           "Opt_ART_coverage"           = TRUE,
                           "Opt_ANC_data"               = TRUE,
                           "Opt_ART_data"               = TRUE,
@@ -317,12 +317,12 @@ test_that("navigator checklist returns expected results", {
 
   adj_output <- model_output$output_package
 
-  adj_output$fit$model_options$calendar_quarter_t2 <- "CY2021Q4"
-  adj_output$fit$model_options$calendar_quarter_t3 <- "CY2022Q3"
+  adj_output$fit$model_options$calendar_quarter_t2 <- "CY2024Q4"
+  adj_output$fit$model_options$calendar_quarter_t3 <- "CY2025Q3"
   adj_output$fit$model_options$artattend_t2 <- TRUE
 
-  adj_output$fit$data_options$prev_survey_ids <- "DEMO2016PHIA"
-  adj_output$fit$data_options$prev_survey_quarters <- "CY2016Q1"
+  adj_output$fit$data_options$prev_survey_ids <- "DEMO2020PHIA"
+  adj_output$fit$data_options$prev_survey_quarters <- "CY2020Q3"
   adj_output$fit$data_options$art_number_spectrum_aligned <- TRUE
   adj_output$fit$data_options$anc_testing_spectrum_aligned <- TRUE
 
@@ -392,7 +392,7 @@ test_that("navigator checklist returns results if options lists missing", {
                                    "Opt_future_proj_qtr"        = NA,
                                    "Opt_area_ID_selected"       = NA,
                                    "Opt_calendar_survey_match"  = NA,
-                                   "Opt_recent_survey_only"     = FALSE,
+                                   "Opt_recent_survey_only"     = TRUE,
                                    "Opt_ART_coverage"           = TRUE,
                                    "Opt_ANC_data"               = TRUE,
                                    "Opt_ART_data"               = TRUE,
@@ -426,7 +426,7 @@ test_that("navigator checklist returns results if options lists missing", {
                                    "Opt_future_proj_qtr"        = FALSE,
                                    "Opt_area_ID_selected"       = TRUE,
                                    "Opt_calendar_survey_match"  = TRUE,
-                                   "Opt_recent_survey_only"     = FALSE,
+                                   "Opt_recent_survey_only"     = TRUE,
                                    "Opt_ART_coverage"           = TRUE,
                                    "Opt_ANC_data"               = TRUE,
                                    "Opt_ART_data"               = TRUE,
@@ -491,7 +491,7 @@ test_that("navigator checklist returns results for uncalibrated model output", {
                           "Opt_future_proj_qtr"        = FALSE,
                           "Opt_area_ID_selected"       = TRUE,
                           "Opt_calendar_survey_match"  = TRUE,
-                          "Opt_recent_survey_only"     = FALSE,
+                          "Opt_recent_survey_only"     = TRUE,
                           "Opt_ART_coverage"           = TRUE,
                           "Opt_ANC_data"               = TRUE,
                           "Opt_ART_data"               = TRUE,
@@ -579,12 +579,12 @@ test_that("writing output package translates labels", {
   ## area_level_label comes from input data (not translated)
   expect_true("Prévalence du VIH" %in% read$indicators$indicator_label)
   expect_setequal(read$indicators$quarter_label,
-                  c("Mars 2016", "Décembre 2018", "Juin 2019", "Septembre 2022", "Septembre 2023"))
+                  c("Septembre 2020", "Décembre 2023", "Septembre 2024", "Septembre 2025", "Septembre 2026"))
   ## age group label currently doesn't have translations
   expect_true("all ages" %in% read$indicators$age_group_label)
 
   expect_setequal(read$art_attendance$quarter_label,
-                  c("Mars 2016", "Décembre 2018"))
+                  c("Septembre 2020", "Décembre 2023"))
   expect_true("all ages" %in% read$art_attendance$age_group_label)
 })
 
@@ -611,8 +611,8 @@ test_that("can generate comparison report from a qs file", {
                              quiet = TRUE)
   expect_true(file.size(t) > 2000)
   content <- brio::readLines(t)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("Naomi estimate CY2016Q1", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("Naomi estimate CY2020Q3", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
 })
 
@@ -622,8 +622,8 @@ test_that("can generate summary report from zip file", {
   generate_comparison_report(t, zip$path, quiet = TRUE)
   expect_true(file.size(t) > 2000)
   content <- brio::readLines(t)
-  expect_true(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("Naomi estimate CY2016Q1", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("Naomi estimate CY2020Q3", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
 })
 
@@ -641,9 +641,8 @@ test_that("can generate comparison report with only 1 survey chosen", {
   generate_comparison_report(t, out, quiet = TRUE)
   expect_true(file.size(t) > 2000)
   content <- brio::readLines(t)
-  expect_false(any(grepl("DEMO2016PHIA, DEMO2015DHS", content)))
-  expect_true(any(grepl("DEMO2016PHIA", content)))
-  expect_true(any(grepl("Naomi estimate CY2016Q1", content)))
+  expect_true(any(grepl("DEMO2020PHIA", content)))
+  expect_true(any(grepl("Naomi estimate CY2020Q3", content)))
   expect_true(any(grepl("class=\"logo-naomi\"", content)))
 })
 
@@ -662,7 +661,7 @@ test_that("can generate comparison report without survey ART coverage", {
   html <- rvest::read_html(t, encoding = "UTF-8")
   expect_length(rvest::html_element(html, ".prevalence-barchart"), 2)
   expect_length(rvest::html_element(html, ".prevalence-scatter1"), 2)
-  expect_length(rvest::html_element(html, ".prevalence-scatter1B"), 2)
+  expect_length(rvest::html_element(html, ".prevalence-scatter1B"), 0) ## Only 1 survey now; this plot is not shown
   expect_length(rvest::html_element(html, ".prevalence-plotly"), 2)
   expect_length(rvest::html_element(html, ".art-barchart"), 0)
   expect_length(rvest::html_element(html, ".art-scatter"), 0)
@@ -699,7 +698,7 @@ test_that("prevalence survey plots not drawn when using aggregate survey", {
   output$output_package$inputs_outputs <-
     output$output_package$inputs_outputs %>%
     dplyr::mutate(calendar_quarter = dplyr::case_when(
-      indicator == "art_coverage" & calendar_quarter == "CY2016Q1" ~ "CY2015Q1",
+      indicator == "art_coverage" & calendar_quarter == "CY2020Q3" ~ "CY2019Q3",
       TRUE ~ calendar_quarter))
 
   out <- tempfile(fileext = ".qs")
@@ -712,7 +711,7 @@ test_that("prevalence survey plots not drawn when using aggregate survey", {
   html <- rvest::read_html(t, encoding = "UTF-8")
   expect_length(rvest::html_element(html, ".prevalence-barchart"), 2)
   expect_length(rvest::html_element(html, ".prevalence-scatter1"), 2)
-  expect_length(rvest::html_element(html, ".prevalence-scatter1B"), 2)
+  expect_length(rvest::html_element(html, ".prevalence-scatter1B"), 0)
   expect_length(rvest::html_element(html, ".prevalence-plotly"), 2)
   expect_length(rvest::html_element(html, ".art-barchart"), 0)
   expect_length(rvest::html_element(html, ".art-scatter"), 0)

diff --git a/tests/testthat/test-warning.R b/tests/testthat/test-warning.R
@@ -50,19 +50,23 @@ test_that("warning raised after false convergence", {
   a_fit_bad$convergence <- 1
   a_fit_bad$message <- "false convergence (8)"
 
-  with_mock(
-    fit_tmb = mockery::mock(a_fit_bad),
-    sample_tmb = mockery::mock(a_fit_sample),
-    output_package = mockery::mock(a_output), {
-      out <- hintr_run_model(a_hintr_data, a_hintr_options, validate = FALSE)
-    }
+  a_fit_sample_bad <- a_fit_sample
+  a_fit_sample_bad$convergence <- 1
+  a_fit_sample_bad$message <- "false convergence (8)"
+
+  with_mocked_bindings(
+  {
+    out <- hintr_run_model(a_hintr_data, a_hintr_options, validate = FALSE)
+  },
+  fit_tmb = mockery::mock(a_fit_bad),
+  output_package = mockery::mock(a_output)
   )
-
+  
   expect_length(out$warnings, 3)
   expect_match(out$warnings[[1]]$text,
                "Naomi subnational data not equal to Spectrum national data. Check table on review inputs tab for: \nnumber_on_art: 2011;2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023")
   expect_match(out$warnings[[2]]$text,
-               "Naomi subnational data not equal to Spectrum national data. Check table on review inputs tab for: \nanc_already_art: 2011;2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_clients: 2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_known_pos: 2012;2013;2014;2015;2016;2017;2018\nanc_tested: 2012;2013;2014;2015;2016;2017;2018\nanc_tested_pos: 2012;2013;2014;2015;2016;2017;2018")
+               "Naomi subnational data not equal to Spectrum national data. Check table on review inputs tab for: \nanc_already_art: 2011;2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_clients: 2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_known_neg: 2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_known_pos: 2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023\nanc_tested: 2012;2013;2014;2015;2016;2017;2018;2019;2020;2021;2022;2023")
   expect_equal(out$warnings[[3]]$text,
                "Model fitting to input data has not fully converged. Please review estimates of HIV prevalence and ART coverage across districts and the national distribution of key indicators by age and sex.")
 })