diff --git a/R/input-comparison.R b/R/input-comparison.R index c5dc1a97..bb30d6c7 100644 --- a/R/input-comparison.R +++ b/R/input-comparison.R @@ -55,10 +55,9 @@ prepare_art_spectrum_comparison <- function(art, shape, pjnz) { spec_aggreagted <- spec |> dplyr::mutate( value_spectrum_adjusted = art_dec31_attend, - value_spectrum_reallocated = art_dec31_reside - art_dec31_attend, - value_spectrum_adj_factor = value_spectrum_adjusted/ (value_spectrum_reported + value_spectrum_reallocated)) |> + value_spectrum_reallocated = art_dec31_reside - art_dec31_attend ) |> dplyr::select(spectrum_region_code, year, age_group, sex, value_spectrum_reported, - value_spectrum_adjusted, value_spectrum_reallocated, value_spectrum_adjusted, value_spectrum_adj_factor) + value_spectrum_adjusted, value_spectrum_reallocated) # Get spectrum level to select correct area names spectrum_region_code <- unique(shape$spectrum_region_code) @@ -78,12 +77,10 @@ prepare_art_spectrum_comparison <- function(art, shape, pjnz) { dplyr::mutate( indicator = "number_on_art", group = dplyr::if_else(age_group == "Y000_014", - "art_children", paste0("art_adult_", sex)), - difference = value_naomi - value_spectrum_adjusted, - prop_difference = 1 - abs((value_naomi - value_spectrum_adjusted) / value_spectrum_adjusted)) |> - dplyr::select(indicator, area_name, year, group, value_naomi, + "art_children", paste0("art_adult_", sex))) |> + dplyr::select(indicator, area_name, year, group, value_spectrum_reported, value_spectrum_adjusted, - value_spectrum_reallocated, value_spectrum_adjusted, value_spectrum_adj_factor) + value_naomi, value_spectrum_reallocated) } ##' Compare aggregated subnational ART inputs + spectrum totals for comparison table @@ -153,13 +150,10 @@ prepare_anc_spectrum_comparison <- function(anc, shape, pjnz) { ##' @export prepare_spectrum_naomi_comparison <- function(art, anc, shape, pjnz){ - null_df <- setNames(data.frame(matrix(ncol = 7, nrow = 0)), - c("indicator", "area_name", "year", "group","value_spectrum", "value_naomi", "difference")) - if(is.null(art) & is.null(anc) ){ # Empty data frame if no programme data - comparison_df <- null_df + comparison_table <- list(art = NULL, anc = NULL) } else { @@ -175,18 +169,19 @@ prepare_spectrum_naomi_comparison <- function(art, anc, shape, pjnz){ if (!is.null(art)) { art_comparison <- prepare_art_spectrum_comparison(art, shape, pjnz) } else { - art_comparison <- null_df + art_comparison <- NULL } # Create ANC comparison or empty data frame if no ART supplied if (!is.null(anc)) { anc_comparison <- prepare_anc_spectrum_comparison(anc, shape, pjnz) } else { - anc_comparison <- null_df + anc_comparison <- NULL } - comparison_df <- rbind(art_comparison, anc_comparison) + comparison_table <- list(art = art_comparison, + anc = anc_comparison) } - comparison_df + comparison_table } diff --git a/R/run-model.R b/R/run-model.R index 05e791c1..f95553b1 100644 --- a/R/run-model.R +++ b/R/run-model.R @@ -324,14 +324,14 @@ naomi_prepare_data <- function(data, options) { if (!is.null(data$art_number)) { art_number <- read_art_number(data$art_number$path) art_spectrum_comparison <- prepare_art_spectrum_comparison(art_number, area_merged, spec_program_data) - programme_data_warning(art_spectrum_comparison) + art_programme_data_warning(art_spectrum_comparison) } else { art_number <- NULL } if (!is.null(data$anc_testing)) { anc_testing <- read_anc_testing(data$anc_testing$path) anc_spectrum_comparison <- prepare_anc_spectrum_comparison(anc_testing, area_merged, spec_program_data) - programme_data_warning(anc_spectrum_comparison) + anc_programme_data_warning(anc_spectrum_comparison) } else { anc_testing <- NULL } diff --git a/R/warnings.R b/R/warnings.R index 76f996c7..f141bb23 100644 --- a/R/warnings.R +++ b/R/warnings.R @@ -76,14 +76,45 @@ output_naomi_warning <- function(naomi_output, ind, threshold, locations) { ##' ##' @param naomi_spectrum_comparison Comparison table of aggregated subnational ##' Naomi and national Spectrum programme data created by -##' prepare_art_spectrum_comparison() or prepare_anc_spectrum_comparison() +##' prepare_art_spectrum_comparison() +##' +##' @keywords internal +art_programme_data_warning <- function(art_naomi_spectrum_comparison) { + + df <- art_naomi_spectrum_comparison |> + dplyr::group_by(year, indicator) |> + dplyr::summarise( + value_naomi = sum(value_naomi), + value_spectrum_adjusted = sum(value_spectrum_adjusted), .groups = "drop") |> + dplyr::mutate(total_diff = value_naomi - value_spectrum_adjusted) |> + dplyr::filter(total_diff > 0) |> + dplyr::group_by(indicator) |> + dplyr::summarise(years = paste0(year, collapse = ";"), .groups = "drop") |> + dplyr::mutate(text = paste(indicator, years, sep = ": ")) + + + if(nrow(df) > 0) { + msg <- t_("WARNING_PROGRAMME_DATA_NOT_EQUAL_TO_SPECTRUM", list(years = paste(df$text, collapse = "\n"))) + naomi_warning(msg, c("model_calibrate", "review_output")) + } + +} + +##' Warning for aggregated subnational data input snot equal to spectrum totals +##' +##' Generate warning if aggregated subnational totals do not match spectrum totals +##' +##' @param naomi_spectrum_comparison Comparison table of aggregated subnational +##' Naomi and national Spectrum programme data created by +##' prepare_art_spectrum_comparison() ##' ##' @keywords internal -programme_data_warning <- function(naomi_spectrum_comparison) { +anc_programme_data_warning <- function(anc_naomi_spectrum_comparison) { - df <- naomi_spectrum_comparison |> + df <- anc_naomi_spectrum_comparison |> dplyr::group_by(year, indicator) |> - dplyr::summarise(total_diff = sum(abs(difference)), .groups = "drop") |> + dplyr::summarise( + total_diff = sum(abs(difference)), .groups = "drop") |> dplyr::filter(total_diff > 0) |> dplyr::group_by(indicator) |> dplyr::summarise(years = paste0(year, collapse = ";"), .groups = "drop") |> diff --git a/tests/testthat/test-input-comparison.R b/tests/testthat/test-input-comparison.R index 37bb2af1..a329667e 100644 --- a/tests/testthat/test-input-comparison.R +++ b/tests/testthat/test-input-comparison.R @@ -63,7 +63,7 @@ test_that("ANC data is properly aggreagted for Spectrum comparison table", { }) -test_that("Comparisoon wrapper function works with missing programme data", { +test_that("Comparison wrapper function works with missing programme data", { # Test wrapper function with all programme data supplied shape <- a_hintr_data$shape