Return datapack download as an xlsx file

R/downloads.R

@@ -140,16 +140,28 @@ hintr_prepare_agyw_download <- function(output, pjnz,
 #' @return Path to output file and metadata for file
 #' @export
 hintr_prepare_datapack_download <- function(output,
-                                            path = tempfile(fileext = ".csv"),
+                                            path = tempfile(fileext = ".xlsx"),
                                             vmmc_file = NULL) {
   assert_model_output_version(output)
   progress <- new_simple_progress()
   progress$update_progress("PROGRESS_DOWNLOAD_SPECTRUM")
+
+  if (!grepl("\\.xlsx$", path, ignore.case = TRUE)) {
+    path <- paste0(path, ".xlsx")
+  }
+
   model_output <- read_hintr_output(output$model_output_path)
   options <- yaml::read_yaml(text = model_output$info$options.yml)
+  vmmc_datapack <- datapack_read_vmmc(vmmc_file$path)
+  datapack_output <- build_datapack_output(
+    model_output$output_package,
+    model_output$output_package$fit$model_options$psnu_level,
+    vmmc_datapack)
+  datapack_metadata <- build_datapack_metadata(model_output$output_package)
+  writexl::write_xlsx(list(data = datapack_output, metadata = datapack_metadata),
+                      path = path)
   list(
-    path = save_output_datapack(path, model_output$output_package,
-                                vmmc_file$path),
+    path = path,
     metadata = list(
       description = build_datapack_description(options),
       areas = options$area_scope,

R/outputs.R

@@ -887,6 +887,15 @@ save_output_spectrum <- function(path, naomi_output, notes = NULL,
 }
 
 save_output_datapack <- function(path, naomi_output, vmmc_path = NULL) {
+  vmmc_datapack <- datapack_read_vmmc(vmmc_path)
+
+  write_datapack_csv(naomi_output = naomi_output,
+                     path = path,
+                     psnu_level = naomi_output$fit$model_options$psnu_level,
+                     dmppt2_output = vmmc_datapack)
+}
+
+datapack_read_vmmc <- function(vmmc_path) {
   if (!is.null(vmmc_path)) {
     ## Skip the first row, the file has two rows of headers
     vmmc_datapack_raw <- openxlsx::read.xlsx(vmmc_path, sheet = "Datapack inputs",
@@ -895,11 +904,7 @@ save_output_datapack <- function(path, naomi_output, vmmc_path = NULL) {
   } else {
     vmmc_datapack <- NULL
   }
-
-  write_datapack_csv(naomi_output = naomi_output,
-                     path = path,
-                     psnu_level = naomi_output$fit$model_options$psnu_level,
-                     dmppt2_output = vmmc_datapack)
+  vmmc_datapack
 }
 
 

R/pepfar-datapack.R

@@ -31,12 +31,19 @@ write_datapack_csv <- function(naomi_output,
                                psnu_level = NULL,
                                dmppt2_output = NULL) {
 
-  stopifnot(inherits(naomi_output, "naomi_output"))
-
   if (!grepl("\\.csv$", path, ignore.case = TRUE)) {
     path <- paste0(path, ".csv")
   }
 
+  datapack <- build_datapack_output(naomi_output, psnu_level, dmppt2_output)
+  naomi_write_csv(datapack, path)
+
+  path
+}
+
+build_datapack_output <- function(naomi_output, psnu_level, dmppt2_output) {
+  stopifnot(inherits(naomi_output, "naomi_output"))
+
   datapack_indicator_map <- naomi_read_csv(system_file("datapack", "datapack_indicator_mapping.csv"))
   datapack_age_group_map <- naomi_read_csv(system_file("datapack", "datapack_age_group_mapping.csv"))
   datapack_sex_map <- naomi_read_csv(system_file("datapack", "datapack_sex_mapping.csv"))
@@ -73,7 +80,7 @@ write_datapack_csv <- function(naomi_output,
     dplyr::rename(
       indicator_code = datapack_indicator_code,
       dataelement_uid = datapack_indicator_id,
-      ) %>%
+    ) %>%
     dplyr::select(indicator, indicator_code, dataelement_uid, is_integer, calendar_quarter)
 
 
@@ -128,10 +135,10 @@ write_datapack_csv <- function(naomi_output,
       by = c("indicator", "calendar_quarter")
     ) %>%
     dplyr::filter(
-    (sex_naomi %in% datapack_sex_map$sex_naomi &
-       age_group %in% datapack_age_group_map$age_group |
-       sex_naomi == "both" & age_group == "Y000_999" & !anc_indicator |
-       sex_naomi == "female" & age_group == "Y015_049" & anc_indicator )
+      (sex_naomi %in% datapack_sex_map$sex_naomi &
+         age_group %in% datapack_age_group_map$age_group |
+         sex_naomi == "both" & age_group == "Y000_999" & !anc_indicator |
+         sex_naomi == "female" & age_group == "Y015_049" & anc_indicator )
     ) %>%
     dplyr::transmute(
       area_id,
@@ -176,7 +183,7 @@ write_datapack_csv <- function(naomi_output,
   dat <- dplyr::left_join(dat, psnu_map, by = "area_id")
   dat$psnu <- ifelse(is.na(dat$map_name), dat$area_name, dat$map_name)
 
-  datapack <- dat %>%
+  dat %>%
     dplyr::select(
       psnu,
       psnu_uid,
@@ -192,10 +199,35 @@ write_datapack_csv <- function(naomi_output,
       age_sex_rse,
       district_rse
     )
+}
 
-  naomi_write_csv(datapack, path)
+build_datapack_metadata <- function(naomi_output) {
+  meta_period <- get_period_metadata(
+    c(naomi_output$fit$model_options$calendar_quarter_t1,
+      naomi_output$fit$model_options$calendar_quarter_t2,
+      naomi_output$fit$model_options$calendar_quarter_t3,
+      naomi_output$fit$model_options$calendar_quarter_t4,
+      naomi_output$fit$model_options$calendar_quarter_t5))
+  info <- attr(naomi_output, "info")
+  inputs <- read.csv(text = info$inputs.csv, header = FALSE)
+
+  version <- data.frame("version", utils::packageVersion("naomi"))
+  all_data <- list(version, inputs)
+
+  max_cols <- max(vapply(all_data, ncol, numeric(1)))
+  col_names <- vapply(seq_len(max_cols), function(i) paste0("V", i), character(1))
+  empty_row <- data.frame(matrix("", ncol = max_cols, nrow = 1))
+  colnames(empty_row) <- col_names
+  all_data <- lapply(all_data, function(df) {
+    colnames(df) <- col_names[seq(1, ncol(df))]
+    if (ncol(df) < max_cols) {
+      df[, col_names[seq(ncol(df) + 1, max_cols)]] <- ""
+    }
+    df[] <- lapply(df, as.character)
+    rbind.data.frame(df, empty_row)
+  })
 
-  path
+  do.call(rbind.data.frame, all_data)
 }
 
 

tests/testthat/test-downloads.R

@@ -312,12 +312,17 @@ test_that("datapack download can be created", {
   expect_length(out$metadata$description, 1)
   expect_equal(out$metadata$areas, "MWI")
 
-  datapack <- utils::read.csv(out$path)
+  datapack <- readxl::read_xlsx(out$path, "data")
 
   expect_true("psnu_uid" %in% colnames(datapack))
   expect_true(!any(is.na(datapack)))
   ## Simple smoke test that we have some indicator code
   expect_true("HIV_PREV.T_1" %in% datapack$indicator_code)
+
+  metadata <- readxl::read_xlsx(out$path, "metadata")
+
+  expect_true(nrow(metadata) > 0)
+  expect_equal(as.character(metadata[1, 1]), "version")
 })
 
 test_that("datapack download can include vmmc data", {
@@ -334,10 +339,15 @@ test_that("datapack download can include vmmc data", {
   )
   expect_true(file.exists(out$path))
 
-  datapack <- utils::read.csv(out$path)
+  datapack <- readxl::read_xlsx(out$path, "data")
 
   expect_true("psnu_uid" %in% colnames(datapack))
   expect_true(!any(is.na(datapack)))
   expect_true(all(c("VMMC_CIRC_SUBNAT.T_1", "VMMC_TOTALCIRC_SUBNAT.T_1") %in%
                     datapack$indicator_code))
+
+  metadata <- readxl::read_xlsx(out$path, "metadata")
+
+  expect_true(nrow(metadata) > 0)
+  expect_equal(as.character(metadata[1, 1]), "version")
 })