Merge pull request #462 from mrc-ide/Apply-spectrum-ART-adjustments

Apply Spectrum ART adjustments
mrc-ide · Dec 11, 2024 · 63d20ad · 63d20ad
2 parents 3f88595 + 9bffe8f
commit 63d20ad
Show file tree

Hide file tree

Showing 19 changed files with 419 additions and 182 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: naomi
 Title: Naomi Model for Subnational HIV Estimates
-Version: 2.10.5
+Version: 2.10.6
 Authors@R:
     person(given = "Jeff",
            family = "Eaton",

diff --git a/NAMESPACE b/NAMESPACE
@@ -54,7 +54,8 @@ export(hintr_prepare_datapack_download)
 export(hintr_prepare_spectrum_download)
 export(hintr_prepare_summary_report_download)
 export(hintr_run_model)
-export(hintr_validate_programme_data)
+export(hintr_validate_anc_programme_data)
+export(hintr_validate_art_programme_data)
 export(interpolate_population_agesex)
 export(log_linear_interp)
 export(map_outputs)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,9 @@
+# naomi 2.10.6
+
+* Update `read_dp_art_dec31()` with new .DP file flags to ensure ART adjustment factor and ART patient reallocation counts are applied to number on ART extracted from Spectrum.
+* Ensure adjusted Spectrum number on ART is used in Spectrum-Naomi comparison table.
+* Add ART adjustment factor and ART patient reallocation counts to Spectrum-Naomi comparison table.
+
 # naomi 2.10.5
 
 * Add standalone datapack download so that users do not have to download zip and extract this manually.

diff --git a/R/input-comparison.R b/R/input-comparison.R
@@ -38,18 +38,27 @@ prepare_art_spectrum_comparison <- function(art, shape, pjnz) {
 
   if(identical(unique(art_single_cq$sex), c("both"))) {
     # If no sex aggregated data present in ART data, aggregate Spectrum by age
-    spec_aggreagted <- pjnz$art_dec31 |>
-      dplyr::count(spectrum_region_code, year, age_group,
-                   wt = art_dec31, name = "value_spectrum") |>
+    spec <- pjnz$art_dec31 |>
+      dplyr::group_by(spectrum_region_code, year, age_group) |>
+      dplyr::summarise(
+        value_spectrum_reported = round(sum(art_dec31_reported)),
+        art_dec31_attend = round(sum(art_dec31_attend)),
+        art_dec31_reside = round(sum(art_dec31_reside)),
+        .groups = "drop") |>
       dplyr::mutate(sex = "both")
-
   } else {
     # If sex aggregated data present in ART data, aggregate Spectrum by age and sex
-    spec_aggreagted <- pjnz$art_dec31 |>
-      dplyr::count(spectrum_region_code, year, sex, age_group,
-                   wt = art_dec31, name = "value_spectrum")
+    spec <- pjnz$art_dec31 |>
+      dplyr::select(value_spectrum_reported = art_dec31_reported, dplyr::everything())
   }
 
+  spec_aggreagted <- spec |>
+    dplyr::mutate(
+      value_spectrum_adjusted = art_dec31_attend,
+      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)
+
   # Get spectrum level to select correct area names
   spectrum_region_code <- unique(shape$spectrum_region_code)
 
@@ -68,10 +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_spectrum - value_naomi) |>
+                             "art_children", paste0("art_adult_", sex))) |>
     dplyr::select(indicator, area_name, year, group,
-                  value_spectrum, value_naomi, difference)
+                  value_spectrum_reported, value_spectrum_adjusted,
+                  value_naomi, value_spectrum_reallocated)
 }
 
 ##' Compare aggregated subnational ART inputs + spectrum totals for comparison table
@@ -125,10 +134,9 @@ prepare_anc_spectrum_comparison <- function(anc, shape, pjnz) {
   dat |>
     dplyr::mutate(
       sex = "female", age_group = "Y015_049",
-      group = "anc_adult_female",
-      difference = value_spectrum - value_naomi) |>
+      group = "anc_adult_female") |>
     dplyr::select(indicator, area_name, year, group,
-                  value_spectrum, value_naomi, difference)
+                  value_spectrum, value_naomi)
 
 }
 
@@ -141,13 +149,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 {
 
@@ -163,18 +168,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/inputs-spectrum.R b/R/inputs-spectrum.R
@@ -195,7 +195,6 @@ read_dp_art_dec31 <- function(dp) {
   art15plus_need <- rbind(male_15plus_needart, female_15plus_needart)
   dimnames(art15plus_need) <- list(sex = c("male", "female"), year = proj.years)
 
-
   if (any(art15plus_num[art15plus_isperc == 1] < 0 |
           art15plus_num[art15plus_isperc == 1] > 100)) {
     stop("Invalid percentage on ART entered for adult ART")
@@ -208,27 +207,80 @@ read_dp_art_dec31 <- function(dp) {
   ## * Enabled / disabled by checkbox flag ("<AdultARTAdjFactorFlag>")
   ## * Scaling factor only applies to number inputs, not percentages (John Stover email, 20 Feb 2023)
   ##   -> Even if scaling factor specified in a year with percentage input, ignore it.
+  ## ** UPDATE Spectrum 6.37 beta 18 **
+  ##
+  ## Two changes to the adult ART adjustment were implemented in Spectrum 6.37 beta 18:
+  ##
+  ## * ART adjustments were moved the main Spectrum editor and the flag variable
+  ##   "<AdultARTAdjFactorFlag>" was removed from the .DP file.
+  ## * New tag "<AdultPatsAllocToFromOtherRegion>" was added allowing for input
+  ##   of absolute count adjustment
+  ##
+  ## New logic to account for these changes:
+  ## * Initialise values to defaults 1.0 for relative adjustment and 0.0
+  ##   for absolute adjustment.
+  ## * Only check flag variable if it exists. If adjustment variable exists
+  ##   but flag variable does not exist, use the adjustment.
 
-  if (exists_dptag("<AdultARTAdjFactorFlag>") &&
-        dpsub("<AdultARTAdjFactorFlag>", 2, 4) == 1) {
+  ## Initialise
+  adult_artadj_factor <- array(1.0, dim(art15plus_num))
+  dimnames(adult_artadj_factor) <- list(sex = c("male", "female"), year = proj.years)
+
+  adult_artadj_absolute <- array(0.0, dim(art15plus_num))
+  dimnames(adult_artadj_absolute) <- list(sex = c("male", "female"), year = proj.years)
+
+  ## Flag to use adjustment
+  use_artadj <- exists_dptag("<AdultARTAdjFactor>") &&
+    (!exists_dptag("<AdultARTAdjFactorFlag>") ||
+       (exists_dptag("<AdultARTAdjFactorFlag>") &&
+          dpsub("<AdultARTAdjFactorFlag>", 2, 4) == 1))
+
+  if (use_artadj) {
 
     adult_artadj_factor <- sapply(dpsub("<AdultARTAdjFactor>", 3:4, timedat.idx), as.numeric)
 
+    if(exists_dptag("<AdultPatsAllocToFromOtherRegion>")) {
+      adult_artadj_absolute <- sapply(dpsub("<AdultPatsAllocToFromOtherRegion>", 3:4, timedat.idx), as.numeric)
+    }
+
     ## Only apply if is number (! is percentage)
     adult_artadj_factor <- adult_artadj_factor ^ as.numeric(!art15plus_isperc)
-
-    art15plus_num <- art15plus_num * adult_artadj_factor
+    adult_artadj_absolute <- adult_artadj_absolute * as.numeric(!art15plus_isperc)
   }
 
+  ## First add absolute adjustment, then apply scalar adjustment (Spectrum procedure)
+  art15plus_attend <- art15plus_num + adult_artadj_absolute
+  art15plus_attend <- art15plus_attend * adult_artadj_factor
+  art15plus_reside <- art15plus_attend + adult_artadj_absolute
+
+  # Covert percentage coverage to absolute numbers on ART
   art15plus_num[art15plus_isperc == 1] <- art15plus_need[art15plus_isperc == 1] * art15plus_num[art15plus_isperc == 1] / 100
+  art15plus_attend[art15plus_isperc == 1] <- art15plus_need[art15plus_isperc == 1] * art15plus_attend[art15plus_isperc == 1] / 100
+  art15plus_reside[art15plus_isperc == 1] <- art15plus_need[art15plus_isperc == 1] * art15plus_reside[art15plus_isperc == 1] / 100
+
+  # Reported number on ART
+  art_dec31_reported <- as.data.frame.table(art15plus_num,
+                                   responseName = "art_dec31_reported",
+                                   stringsAsFactors = FALSE)
 
-  art15plus <- as.data.frame.table(art15plus_num,
-                                   responseName = "art_dec31",
+  # Adjusted number on ART (attending)
+  art_dec31_attend <- as.data.frame.table(art15plus_attend,
+                                   responseName = "art_dec31_attend",
                                    stringsAsFactors = FALSE)
+
+  # Adjusted number on ART (residing)
+  art_dec31_reside <- as.data.frame.table(art15plus_reside,
+                                             responseName = "art_dec31_reside",
+                                             stringsAsFactors = FALSE)
+
+  art15plus <- purrr::reduce(list(art_dec31_reported,
+                                  art_dec31_attend,
+                                  art_dec31_reside), dplyr::left_join,
+                             by = dplyr::join_by(sex, year))
+
   art15plus$age_group <- "Y015_999"
   art15plus$year <- utils::type.convert(art15plus$year, as.is = TRUE)
 
-
   ## # Child number on ART
   ##
   ## - If age-stratified entered, use sum of three age categories
@@ -280,32 +332,53 @@ read_dp_art_dec31 <- function(dp) {
                                 child_art_isperc == 1 ~ child_art_need * child_art_0to14 / 100)
   names(child_art) <- proj.years
 
+  if (any(is.na(child_art))) {
+    stop("Something has gone wrong extracting child ART inputs; please seek troubleshooting.")
+  }
+
+
   ## # Child on ART adjustment factor
   ##
   ## * Implemented same as adult adjustment factor above
 
-  if (exists_dptag("<ChildARTAdjFactorFlag>") &&
-        dpsub("<ChildARTAdjFactorFlag>", 2, 4) == 1) {
+  ## Initialise
+  child_artadj_factor <- rep(1.0, length(child_art))
+  child_artadj_absolute <- rep(0.0, length(child_art))
+
+  ## Flag to use adjustment
+  use_child_artadj <- exists_dptag("<ChildARTAdjFactor MV>") &&
+    (!exists_dptag("<ChildARTAdjFactorFlag>") ||
+       (exists_dptag("<ChildARTAdjFactorFlag>") &&
+          dpsub("<ChildARTAdjFactorFlag>", 2, 4) == 1))
+
+  if (use_child_artadj) {
 
     child_artadj_factor <- as.numeric(dpsub("<ChildARTAdjFactor MV>", 2, timedat.idx))
 
+    if(exists_dptag("<ChildPatsAllocToFromOtherRegion MV>")) {
+      child_artadj_absolute <- as.numeric(dpsub("<ChildPatsAllocToFromOtherRegion MV>", 2, timedat.idx))
+    }
+
     ## Only apply if is number (! is percentage)
     child_artadj_factor <- child_artadj_factor ^ !child_art_isperc
-
-    child_art <- child_art * child_artadj_factor
+    child_artadj_absolute <- child_artadj_absolute ^ !child_art_isperc
   }
 
-
-  if (any(is.na(child_art))) {
-    stop("Something has gone wrong extracting child ART inputs; please seek troubleshooting.")
-  }
+  ## First add absolute adjustment, then apply scalar adjustment (Spectrum procedure)
+  child_art_attend <- child_art + child_artadj_absolute
+  child_art_attend <- child_art_attend * child_artadj_factor
+  child_art_reside <- child_art_attend + child_artadj_absolute
 
   child_art <- data.frame(sex = "both",
                           age_group = "Y000_014",
                           year = proj.years,
-                          art_dec31 = child_art)
+                          art_dec31_reported = child_art,
+                          art_dec31_attend = child_art_attend,
+                          art_dec31_reside = child_art_reside)
 
-  art_dec31 <- rbind(child_art, art15plus)
+  art_dec31 <- rbind(child_art, art15plus) |>
+    dplyr::mutate(dplyr::across(where(is.numeric), ~ round(., 0)),
+                  art_dec31 = art_dec31_attend)
 
   art_dec31
 }

diff --git a/R/model.R b/R/model.R
@@ -570,7 +570,7 @@ naomi_model_frame <- function(area_merged,
                       spec_unaware_untreated_prop_t4 = unaware_untreated_prop,
                       asfr_t4 = asfr,
                       frr_plhiv_t4 = frr_plhiv,
-                      frr_already_art_t4 = frr_already_art                      
+                      frr_already_art_t4 = frr_already_art
                     ),
              by = c("spectrum_region_code", "sex", "age_group")
            ) %>%
@@ -881,65 +881,6 @@ select_naomi_data <- function(
 
   stopifnot(methods::is(naomi_mf, "naomi_mf"))
 
-  ## Check anc_testing and art_number against Spectrum inputs.
-  ## Return NA if spec_program_data not provided
-  anc_testing_spectrum_aligned <- NA
-  art_number_spectrum_aligned <- NA
-
-  if (!is.null(spec_program_data)) {
-    stopifnot(methods::is(spec_program_data, "spec_program_data"))
-
-    if (!is.null(anc_testing)) {
-
-      anc_merged <- anc_testing %>%
-        dplyr::left_join(
-          dplyr::select(naomi_mf$mf_areas, area_id, spectrum_region_code),
-          by = "area_id"
-        ) %>%
-        tidyr::pivot_longer(dplyr::starts_with("anc"),
-                            names_to = "indicator",
-                            values_to = "value_naomi") %>%
-        dplyr::count(spectrum_region_code, year, indicator,
-                     wt = value_naomi, name = "value_naomi") %>%
-        dplyr::inner_join(
-          spec_program_data$anc_testing %>%
-          dplyr::rename("value_spectrum" = "value"),
-          by = c("spectrum_region_code", "indicator", "year")
-        )
-
-      anc_testing_spectrum_aligned <- all(anc_merged$value_naomi == anc_merged$value_spectrum)
-
-    } else {
-      ## If no ANC testing data, return TRUE
-      anc_testing_spectrum_aligned <- TRUE
-    }
-
-    if (!is.null(art_number)) {
-
-      art_merged <- art_number %>%
-        dplyr::left_join(
-          dplyr::select(naomi_mf$mf_areas, area_id, spectrum_region_code),
-          by = "area_id"
-        ) %>%
-        dplyr::count(spectrum_region_code, sex, age_group, calendar_quarter,
-                     wt = art_current, name = "art_current_naomi") %>%
-        dplyr::inner_join(
-          spec_program_data$art_dec31 %>%
-          dplyr::mutate(
-            calendar_quarter = paste0("CY", year, "Q4"),
-            year = NULL
-          ),
-          by = c("spectrum_region_code", "sex", "age_group", "calendar_quarter")
-        )
-
-      art_number_spectrum_aligned <- all(art_merged$art_current_naomi == art_merged$art_dec31)
-
-    } else {
-      ## If no ANC testing data, return TRUE
-      art_number_spectrum_aligned <- TRUE
-    }
-  }
-
   common_surveys <- intersect(artcov_survey_ids, vls_survey_ids)
   if (length(common_surveys)) {
     stop(t_("ART_COV_AND_VLS_SAME_SURVEY",
@@ -1101,9 +1042,7 @@ select_naomi_data <- function(
                        artnum_calendar_quarter_t1 = artnum_calendar_quarter_t1,
                        artnum_calendar_quarter_t2 = artnum_calendar_quarter_t2,
                        anc_prev_year_t1 = anc_artcov_year_t1,
-                       anc_prev_year_t2 = anc_artcov_year_t2,
-                       art_number_spectrum_aligned = art_number_spectrum_aligned,
-                       anc_testing_spectrum_aligned = anc_testing_spectrum_aligned)
+                       anc_prev_year_t2 = anc_artcov_year_t2)
 
   naomi_mf$data_options <- data_options
 

diff --git 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
   }