diff --git a/NEWS.md b/NEWS.md index 69d1779f..efdbfee5 100644 --- 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 index d856bc37..9b3511f5 100644 --- 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 index 8cb1089e..ef52aeb5 100644 --- 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 index f80d0bcc..6ef10e97 100644 --- 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 index f413ae38..e96f421c 100644 --- 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 index f439f6cf..7f46686f 100644 --- 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 index a0b215bf..d1620b6a 100644 --- 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,8 +70,8 @@ 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 @@ -79,7 +79,7 @@ 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("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 index 52e060a9..24192b91 100644 --- 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 index d0d844f8..51ceda8e 100644 --- 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.") })