Fix issue with returning aggregated quarters from input comparison data

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: naomi
 Title: Naomi Model for Subnational HIV Estimates
-Version: 2.10.3
+Version: 2.10.4
 Authors@R:
     person(given = "Jeff",
            family = "Eaton",

NEWS.md

@@ -1,3 +1,8 @@
+# naomi 2.10.4
+
+* If users upload multiple quarters in ART programme data, return only the last quarter per year for input comparison data.
+  This fixes a bug where previously they were being aggregated. issue-3 24/25
+
 # naomi 2.10.3
 
 * Return `anc_already_art`, `anc_status`, `anc_art_among_known` and `anc_total_pos` indicators from ANC input time series data.

R/input-comparison.R

@@ -20,14 +20,23 @@ prepare_art_spectrum_comparison <- function(art, shape, pjnz) {
   if (!inherits(pjnz, "spec_program_data")) {
     pjnz <- extract_pjnz_program_data(pjnz) }
 
+  ## If user has uploaded multiple calendar quarters within a year, we
+  ## only want to return 1 value. The last one within the year.
+  art_single_cq <- art |>
+    dplyr::mutate(year = calendar_quarter_to_year(calendar_quarter)) |>
+    dplyr::group_by(area_id, sex, age_group, year) |>
+    dplyr::mutate(quarter_id = calendar_quarter_to_quarter_id(calendar_quarter)) |>
+    dplyr::filter(quarter_id == max(quarter_id)) |>
+    dplyr::ungroup()
+
   ## Aggregate ART data
-  art_agreggated <- art |>
+  art_agreggated <- art_single_cq |>
     dplyr::mutate(year = calendar_quarter_to_year(calendar_quarter)) |>
     dplyr::left_join(shape, by = "area_id") |>
     dplyr::count(spectrum_region_code, year, sex, age_group,
                  wt = art_current, name = "value_naomi")
 
-  if(identical(unique(art$sex), c("both"))) {
+  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,

tests/testthat/test-input-comparison.R

@@ -99,3 +99,35 @@ test_that("Comparisoon wrapper function works with missing programme data", {
   expect_equal(nrow(x), 0)
 
 })
+
+test_that("art data comparison returns value for only last CQ within each year", {
+  # Create test data with a 2 rows for the same area, sex, and age group
+  # but with a different calendar quarter. We should be returning the latest
+  # quarter of these
+  art <- a_hintr_data$art_number
+  art_dat <- naomi::read_art_number(art)
+  art_dat_row <- art_dat[art_dat$area_id == "MWI_2_1_demo" &
+                                art_dat$sex == "both" &
+                                art_dat$age_group == "Y000_014" &
+                                art_dat$calendar_quarter == "CY2011Q4", ]
+  expected_value <- art_dat_row$art_current
+  art_dat_row$calendar_quarter <- quarter_id_to_calendar_quarter(
+    calendar_quarter_to_quarter_id(art_dat_row$calendar_quarter) - 1)
+  ## We're expecting we don't see this in the aggregated data
+  art_dat_row$art_current <- 10000
+
+  art_test <- dplyr::bind_rows(art_dat, art_dat_row)
+
+  # Test that aggregation works with subnational pjnz and sex disaggreagted adults on ART
+  shape <- a_hintr_data$shape
+  pjnz <- a_hintr_data$pjnz
+
+  x <- prepare_art_spectrum_comparison(art_test, shape, pjnz)
+
+  modified_row <- x[x$indicator == "number_on_art" &
+                      x$year == "2011" &
+                      x$group == "art_children" &
+                      x$area_name == "Northern", ]
+
+  expect_equal(modified_row$value_naomi, expected_value)
+})