update comparison table output structure and warnings

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
 }

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
   }

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") |>

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