diff --git a/DESCRIPTION b/DESCRIPTION index 2bfcb9f2..4299d4c5 100644 --- a/DESCRIPTION +++ b/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", diff --git a/NAMESPACE b/NAMESPACE index 2bd06c28..a5e29c55 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 424d65fb..3a3f3839 100644 --- a/NEWS.md +++ b/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. diff --git a/R/downloads.R b/R/downloads.R index 6216af85..2f3ee899 100644 --- a/R/downloads.R +++ b/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) diff --git a/R/outputs.R b/R/outputs.R index 8e04f485..e81bfddf 100644 --- a/R/outputs.R +++ b/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) } diff --git a/R/pepfar-datapack.R b/R/pepfar-datapack.R index d808b69a..dd051d29 100644 --- a/R/pepfar-datapack.R +++ b/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) } diff --git a/inst/traduire/en-translation.json b/inst/traduire/en-translation.json index 8d65b654..78f07efd 100644 --- a/inst/traduire/en-translation.json +++ b/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", diff --git a/inst/traduire/fr-translation.json b/inst/traduire/fr-translation.json index 6d785c48..60c7d9e2 100644 --- a/inst/traduire/fr-translation.json +++ b/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", diff --git a/inst/traduire/pt-translation.json b/inst/traduire/pt-translation.json index effd3d56..3b5622cb 100644 --- a/inst/traduire/pt-translation.json +++ b/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", diff --git a/man/hintr_prepare_datapack_download.Rd b/man/hintr_prepare_datapack_download.Rd new file mode 100644 index 00000000..44ee5c5f --- /dev/null +++ b/man/hintr_prepare_datapack_download.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/downloads.R +\name{hintr_prepare_datapack_download} +\alias{hintr_prepare_datapack_download} +\title{Prepare Datapack download} +\usage{ +hintr_prepare_datapack_download( + output, + path = tempfile(fileext = ".xlsx"), + vmmc_file = NULL, + ids = NULL +) +} +\arguments{ +\item{output}{hintr output object} + +\item{path}{Path to save output file} + +\item{vmmc_file}{Optional file object, with path, filename and hash for +VMMC input} + +\item{ids}{List of naomi web app queue ids for putting into metadata} +} +\value{ +Path to output file and metadata for file +} +\description{ +Prepare Datapack download +} diff --git a/tests/testthat/test-downloads.R b/tests/testthat/test-downloads.R index 7f46686f..0849cdd2 100644 --- a/tests/testthat/test-downloads.R +++ b/tests/testthat/test-downloads.R @@ -227,3 +227,127 @@ test_that("output description is translated", { expect_match(text, paste0("Paquet Naomi téléchargée depuis l'application ", "web Naomi\\n\\nPérimètre de zone - MWI\\n.+")) }) + +test_that("spectrum download can be created", { + mock_new_simple_progress <- mockery::mock(MockSimpleProgress$new()) + notes <- "these are my\nmultiline notes" + with_mock(new_simple_progress = mock_new_simple_progress, { + messages <- naomi_evaluate_promise( + out <- hintr_prepare_spectrum_download(a_hintr_output_calibrated, + notes = notes)) + }) + expect_true(file.exists(out$path)) + + expect_type(out$metadata$description, "character") + expect_length(out$metadata$description, 1) + expect_equal(out$metadata$areas, "MWI") + + tmp <- tempfile() + info <- naomi_info(format_data_input(a_hintr_data), a_hintr_options) + info_names <- paste0("info/", names(info)) + unzip(out$path, exdir = tmp, files = info_names) + expect_equal(dir(tmp), "info") + expect_equal(dir(file.path(tmp, "info")), names(info)) + + + ## # UNAIDS Navigator Checklist checks + navigator_checklist <- utils::read.csv(unz(out$path, "info/unaids_navigator_checklist.csv")) + + + expect_equal(names(navigator_checklist), + c("NaomiCheckPermPrimKey", "NaomiCheckDes", "TrueFalse")) + + checklist_primkeys <- c( "ART_is_Spectrum","ANC_is_Spectrum","Package_created", + "Package_has_all_data","Opt_recent_qtr","Opt_future_proj_qtr", + "Opt_area_ID_selected","Opt_calendar_survey_match","Opt_recent_survey_only", + "Opt_ART_coverage","Opt_ANC_data","Opt_ART_data", + "Opt_ART_attendance_yes","Model_fit","Cal_Population", + "Cal_PLHIV","Cal_ART","Cal_KOS", + "Cal_new_infections","Cal_method" ) + expect_equal(navigator_checklist$NaomiCheckPermPrimKey, checklist_primkeys) + expect_true(all(navigator_checklist$TrueFalse %in% c(TRUE, FALSE))) + ## Check tradiure translation hooks worked + expect_true("Calibration - method is logistic" %in% navigator_checklist$NaomiCheckDes) + + + outputs <- read_output_package(out$path) + expect_true( + all(c("area_level", "area_level_label", "area_id", "area_name", "parent_area_id", + "spectrum_region_code", "area_sort_order", "geometry") %in% + names(outputs$meta_area)) + ) + + tmpf <- tempfile() + unzip(out$path, "boundaries.geojson", exdir = tmpf) + output_boundaries <- sf::read_sf(file.path(tmpf, "boundaries.geojson")) + + ## Column 'name' added in boundaries.geojson during save_output() for Spectrum + expect_true( + all(c("area_level", "area_level_label", "area_id", "area_name", "parent_area_id", + "spectrum_region_code", "area_sort_order", "name", "geometry") %in% + names(output_boundaries)) + ) + + ## Progress messages printed + expect_length(messages$progress, 1) + expect_equal(messages$progress[[1]]$message, + "Generating output zip download") + + ## Notes are saved + t <- tempfile() + unzip(out$path, "notes.txt", exdir = t) + saved_notes <- readLines(file.path(t, "notes.txt")) + expect_equal(saved_notes, c("these are my", "multiline notes")) +}) + +test_that("datapack download can be created", { + mock_new_simple_progress <- mockery::mock(MockSimpleProgress$new()) + with_mock(new_simple_progress = mock_new_simple_progress, { + messages <- naomi_evaluate_promise( + out <- hintr_prepare_datapack_download(a_hintr_output_calibrated)) + }) + expect_true(file.exists(out$path)) + + expect_type(out$metadata$description, "character") + expect_length(out$metadata$description, 1) + expect_equal(out$metadata$areas, "MWI") + + 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]), "Naomi Version") +}) + +test_that("datapack download can include vmmc data", { + mock_new_simple_progress <- mockery::mock(MockSimpleProgress$new()) + vmmc_file <- list(path = file.path("testdata", "vmmc.xlsx"), + hash = "123", + filename = "vmmc.xlsx") + testthat::with_mocked_bindings( + messages <- naomi_evaluate_promise( + out <- hintr_prepare_datapack_download(a_hintr_output_calibrated, + vmmc_file = vmmc_file) + ), + new_simple_progress = mock_new_simple_progress + ) + expect_true(file.exists(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]), "Naomi Version") +})