Merge pull request #460 from mrc-ide/nm-103

[NM-103] Add function to create datapack download standalone

DESCRIPTION

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

NAMESPACE

@@ -50,6 +50,7 @@ export(hintr_comparison_plot)
 export(hintr_prepare_agyw_download)
 export(hintr_prepare_coarse_age_group_download)
 export(hintr_prepare_comparison_report_download)
+export(hintr_prepare_datapack_download)
 export(hintr_prepare_spectrum_download)
 export(hintr_prepare_summary_report_download)
 export(hintr_run_model)

NEWS.md

@@ -1,3 +1,7 @@
+# naomi 2.10.5
+
+* Add standalone datapack download so that users do not have to download zip and extract this manually.
+
 # naomi 2.10.4
 
 * If users upload multiple quarters in ART programme data, return only the last quarter per year for input comparison data.

R/downloads.R

@@ -130,6 +130,48 @@ hintr_prepare_agyw_download <- function(output, pjnz,
   )
 }
 
+#' Prepare Datapack download
+#'
+#' @param output hintr output object
+#' @param path Path to save output file
+#' @param vmmc_file Optional file object, with path, filename and hash for
+#'   VMMC input
+#' @param ids List of naomi web app queue ids for putting into metadata
+#'
+#' @return Path to output file and metadata for file
+#' @export
+hintr_prepare_datapack_download <- function(output,
+                                            path = tempfile(fileext = ".xlsx"),
+                                            vmmc_file = NULL,
+                                            ids = 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, ids)
+  writexl::write_xlsx(list(data = datapack_output, metadata = datapack_metadata),
+                      path = path)
+  list(
+    path = path,
+    metadata = list(
+      description = build_datapack_description(options),
+      areas = options$area_scope,
+      type = "datapack"
+    )
+  )
+}
+
 build_output_description <- function(options) {
   build_description(t_("DOWNLOAD_OUTPUT_DESCRIPTION"), options)
 }
@@ -146,6 +188,10 @@ build_agyw_tool_description <- function(options) {
   build_description(t_("DOWNLOAD_AGYW_DESCRIPTION"), options)
 }
 
+build_datapack_description <- function(options) {
+  build_description(t_("DOWNLOAD_DATAPACK_DESCRIPTION"), options)
+}
+
 build_description <- function(type_text, options) {
   write_options <- function(name, value) {
     sprintf("%s - %s", name, value)

R/outputs.R

@@ -193,7 +193,7 @@ extract_indicators <- function(naomi_fit, naomi_mf, na.rm = FALSE) {
                          "anc_tested_neg_t4_out" = "anc_tested_neg",
                          "anc_rho_t4_out" = "anc_prevalence",
                          "anc_alpha_t4_out" = "anc_art_coverage")
-  
+
 
   indicator_anc_est_t1 <- Map(get_est, names(indicators_anc_t1), indicators_anc_t1,
                               naomi_mf$calendar_quarter1, list(naomi_mf$mf_anc_out))
@@ -886,6 +886,28 @@ save_output_spectrum <- function(path, naomi_output, notes = NULL,
               export_datapack = TRUE)
 }
 
+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",
+                                             startRow = 2)
+    vmmc_datapack <- transform_dmppt2(vmmc_datapack_raw)
+  } else {
+    vmmc_datapack <- NULL
+  }
+  vmmc_datapack
+}
+
+
 #' Save outputs to zip file
 #'
 #' @param naomi_output Naomi output object
@@ -994,20 +1016,8 @@ save_output <- function(filename, dir,
   }
 
   if (export_datapack) {
-
-    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",
-                                               startRow = 2)
-      vmmc_datapack <- transform_dmppt2(vmmc_datapack_raw)
-    } else {
-      vmmc_datapack <- NULL
-    }
-
-    write_datapack_csv(naomi_output = naomi_output,
-                       path = PEPFAR_DATAPACK_FILENAME,   # global defined in R/pepfar-datapack.R
-                       psnu_level = naomi_output$fit$model_options$psnu_level,
-                       dmppt2_output = vmmc_datapack)
+    # PEPFAR_DATAPACK_FILENAME global defined in R/pepfar-datapack.R
+    save_output_datapack(PEPFAR_DATAPACK_FILENAME, naomi_output, vmmc_path)
   }
 
 

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,43 @@ write_datapack_csv <- function(naomi_output,
       age_sex_rse,
       district_rse
     )
+}
 
-  naomi_write_csv(datapack, path)
+build_datapack_metadata <- function(naomi_output, ids) {
+  cqs <- 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)
+  meta_period <- data.frame(
+    c("Time point", "t1", "t2", "t3", "t4", "t5"), c("Quarter", cqs)
+  )
+
+  info <- attr(naomi_output, "info")
+  inputs <- read.csv(text = info$inputs.csv, header = FALSE)
+
+  version <- data.frame("Naomi Version", utils::packageVersion("naomi"))
+
+  if (!is.null(ids)) {
+    all_data <- list(version, ids, inputs, meta_period)
+  } else {
+    all_data <- list(version, inputs, meta_period)
+  }
 
-  path
+  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)
+  })
+
+  do.call(rbind.data.frame, all_data)
 }
 
 

inst/traduire/en-translation.json

@@ -274,6 +274,7 @@
     "DOWNLOAD_SUMMARY_DESCRIPTION": "Naomi summary report uploaded from Naomi web app",
     "DOWNLOAD_COMPARISON_DESCRIPTION": "Naomi comparison report uploaded from Naomi web app",
     "DOWNLOAD_AGYW_DESCRIPTION": "Naomi AGYW tool uploaded from Naomi web app",
+    "DOWNLOAD_DATAPACK_DESCRIPTION": "Naomi datapack output uploaded from Naomi web app",
     "NUMBER_ON_ART": "Number on ART",
     "NUMBER_ON_ART_DESC": "Number on ART description",
     "POPULATION_PROPORTION": "Population proportion",

inst/traduire/fr-translation.json

@@ -271,6 +271,7 @@
     "DOWNLOAD_OUTPUT_DESCRIPTION": "Paquet Naomi téléchargée depuis l'application web Naomi",
     "DOWNLOAD_SUMMARY_DESCRIPTION": "Rapport de synthèse Naomi téléchargé depuis l'application web Naomi",
     "DOWNLOAD_COMPARISON_DESCRIPTION": "Rapport de comparaison Naomi téléchargé à partir de l'application web Naomi",
+    "DOWNLOAD_DATAPACK_DESCRIPTION": "Sortie du datapack Naomi téléchargée depuis l'application web Naomi",
     "NUMBER_ON_ART": "Nombre de personnes sous TARV",
     "NUMBER_ON_ART_DESC": "Number on ART description",
     "POPULATION_PROPORTION": "Proportion de la population",

inst/traduire/pt-translation.json

@@ -271,6 +271,7 @@
     "DOWNLOAD_OUTPUT_DESCRIPTION": "Pacote Naomi descarregado a partir da aplicação web Naomi",
     "DOWNLOAD_SUMMARY_DESCRIPTION": "Relatório de síntese da Naomi carregado da aplicação web Naomi",
     "DOWNLOAD_COMPARISON_DESCRIPTION": "Relatório de comparação Naomi carregado a partir da aplicação web Naomi",
+    "DOWNLOAD_DATAPACK_DESCRIPTION": "Saída do Naomi datapack carregada a partir da aplicação web Naomi",
     "NUMBER_ON_ART": "Nombre de personnes sous TARV",
     "NUMBER_ON_ART_DESC": "Number on ART description",
     "POPULATION_PROPORTION": "Proporção da população",