Apply Spectrum ART adjustments

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

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.

R/input-comparison.R

@@ -39,15 +39,26 @@ 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") |>
-      dplyr::mutate(sex = "both")
-
+      dplyr::mutate(calendar_quarter = paste0("CY", year, "Q4")) |>
+      dplyr::group_by(spectrum_region_code, calendar_quarter, year, age_group) |>
+      dplyr::summarise(
+        value_spectrum = sum(art_dec31),
+        artadj_factor = sum(artadj_factor),
+        artadj_absolute = sum(artadj_absolute),
+        .groups = "drop") |>
+      dplyr::mutate(
+        value_spectrum_adjusted = (value_spectrum + artadj_absolute) * artadj_factor,
+        artadj_factor = dplyr::if_else(age_group == "Y000_014",artadj_factor, artadj_factor/2),
+        sex = "both") |>
+      dplyr::select(spectrum_region_code, calendar_quarter, year, age_group, sex, value_spectrum,
+                    value_spectrum_adjusted, artadj_absolute, artadj_factor)
   } 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")
+      dplyr::mutate(calendar_quarter = paste0("CY", year, "Q4"),
+                    value_spectrum_adjusted = (art_dec31 + artadj_absolute) * artadj_factor) |>
+      dplyr::select(spectrum_region_code, calendar_quarter,year, age_group, sex,
+                    value_spectrum = art_dec31, value_spectrum_adjusted, artadj_absolute, artadj_factor)
   }
 
   # Get spectrum level to select correct area names
@@ -69,9 +80,11 @@ prepare_art_spectrum_comparison <- function(art, shape, pjnz) {
       indicator = "number_on_art",
       group = dplyr::if_else(age_group == "Y000_014",
                              "art_children", paste0("art_adult_", sex)),
-      difference = value_spectrum - value_naomi) |>
+      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_spectrum, value_naomi, difference)
+                  value_spectrum = value_spectrum_adjusted, artadj_factor,
+                  artadj_absolute, value_naomi, difference, prop_difference)
 }
 
 ##' Compare aggregated subnational ART inputs + spectrum totals for comparison table

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,73 @@ 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.
+
+  ## Initialise
+  adult_artadj_factor <- array(1.0, dim(art15plus_num))
+  dimnames(adult_artadj_factor) <- list(sex = c("male", "female"), year = proj.years)
 
-  if (exists_dptag("<AdultARTAdjFactorFlag>") &&
-        dpsub("<AdultARTAdjFactorFlag>", 2, 4) == 1) {
+  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)
+    adult_artadj_absolute <- adult_artadj_absolute * as.numeric(!art15plus_isperc)
+
+    ## First add absolute adjustment, then apply scalar adjustment (Spectrum procedure)
+    art15plus_num_adj <- art15plus_num + adult_artadj_absolute
+    art15plus_num_adj <- art15plus_num * adult_artadj_factor
 
-    art15plus_num <- art15plus_num * adult_artadj_factor
   }
 
+  # Covert percentage coverage to absolute numbers on ART
   art15plus_num[art15plus_isperc == 1] <- art15plus_need[art15plus_isperc == 1] * art15plus_num[art15plus_isperc == 1] / 100
 
+  # Adjusted number on ART
   art15plus <- as.data.frame.table(art15plus_num,
                                    responseName = "art_dec31",
                                    stringsAsFactors = FALSE)
+  # ART adjustment factor
+  art15plus_adjfactor <- as.data.frame.table(adult_artadj_factor,
+                                   responseName = "artadj_factor",
+                                   stringsAsFactors = FALSE)
+  # ART reallocation
+  art15plus_adjabsolute <- as.data.frame.table(adult_artadj_absolute,
+                                             responseName = "artadj_absolute",
+                                             stringsAsFactors = FALSE)
+
+  art15plus$artadj_factor <- art15plus_adjfactor$artadj_factor
+  art15plus$artadj_absolute <- art15plus_adjabsolute$artadj_absolute
   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
@@ -284,26 +329,43 @@ read_dp_art_dec31 <- function(dp) {
   ##
   ## * 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_artadj_absolute <- child_artadj_absolute ^ !child_art_isperc
 
+    ## First add absolute adjustment, then apply scalar adjustment (Spectrum procedure)
+    child_art <- child_art + child_artadj_absolute
     child_art <- child_art * child_artadj_factor
   }
 
-
   if (any(is.na(child_art))) {
     stop("Something has gone wrong extracting child ART inputs; please seek troubleshooting.")
   }
 
   child_art <- data.frame(sex = "both",
                           age_group = "Y000_014",
                           year = proj.years,
-                          art_dec31 = child_art)
+                          art_dec31 = child_art,
+                          artadj_factor = child_artadj_factor,
+                          artadj_absolute = child_artadj_absolute)
 
   art_dec31 <- rbind(child_art, art15plus)