From 28ee69066e315d544dad4d20d9aa28210e3150a6 Mon Sep 17 00:00:00 2001 From: javier Date: Mon, 8 Jun 2026 14:24:03 +0200 Subject: [PATCH 01/69] Add CLAUDE.md with architecture and development guidance Co-Authored-By: Claude Sonnet 4.6 --- CLAUDE.md | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 CLAUDE.md diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..af6602a --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,76 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## Package Overview + +**OutbreakExtractR** is an R package for epidemiological cholera outbreak surveillance. It extracts and identifies cholera outbreaks from surveillance data (sourced from a PostgreSQL/Global Cholera Taxonomy Database) using a configurable operational outbreak definition. + +## Development Commands + +```r +# Regenerate documentation (run before installing after any @param/@export changes) +devtools::document() + +# Install from source +install.packages('.', repo=NULL, type="source") + +# Run all tests +devtools::test() + +# Run a single test file +testthat::test_file("tests/testthat/test-clean_psql_data.R") + +# Load package interactively without reinstalling +devtools::load_all() + +# Check the full package (CRAN-style) +devtools::check() +``` + +NAMESPACE is auto-generated by roxygen2 — never edit it by hand. + +## Architecture + +The pipeline has five sequential layers: + +### 1. Ingestion & Cleaning (`R/clean_*.R`, `R/observation_filter.R`) +- `clean_psql_data()` — entry point for raw PostgreSQL CSV exports; standardizes types, identifies spatial/temporal scales, flags primary records +- `clean_location_names()` — normalizes `::`-delimited location hierarchy strings (`country::admin1::admin2::admin3::admin4`) +- `observation_filter()` — subsets by date range, WHO region, scale, and minimum case count + +### 2. Normalization (`R/observation_aggregator.R`, `R/fill_*.R`, `R/set_uniform_*.R`) +- Aggregates daily data to weekly; aligns week-start days; fills phantom zero-case weeks (±8 weeks padding) and missing location-periods from linked records +- Time periods are always represented as `TL` (start) / `TR` (end) date pairs + +### 3. Threshold Calculation (`R/get_outbreak_threshold.R`, `R/get_pop.R`, `R/calculate_population_density.R`) +- Supports four threshold modes: `fixed`, `mean_weekly_incidence`, `outbreak_dependent`, `time_restricted` +- Population data comes from bundled `WPP2022.rda` / `WPP2024.rda` (WorldPop) and `endemic_locs_gte50nz_3ydata.rda` + +### 4. Outbreak Detection (`R/identify_*.R`) +`identify_outbreaks()` is the main orchestrator. It calls: +- `identify_epidemic_start()` — two modes: `"consecutive"` (N weeks above threshold) or `"dual_window"` (sliding window + cumulative case trigger); key params: `min_weeks_above`, `window_weeks`, `cumulative_case_threshold_ratio` +- `identify_epidemic_tail()` — marks outbreak end after `tail_period` (default 6) consecutive weeks below threshold +- `identify_consecutive_outbreak_data()` / `identify_epidemic_period()` — group and extract bounded outbreak windows +- `identify_washout_period()` — labels inter-epidemic gaps + +### 5. Alert Generation & Post-Processing (`R/trigger_alert*.R`, `R/format_alerts.R`, `R/label_*.R`) +`trigger_alert()` fires 17 alert types across three families: +- **Trend**: single/double/triple week exceeding 4-week rolling mean +- **Case count**: 2/5/10/25/50/100/250 cases in 3 consecutive weeks +- **Cumulative**: 5/10/25/50/100/500/1000 cumulative cases in 3 weeks + +Functions suffixed `_obs` operate on observatory (observed) data; others operate on modeled/threshold data. + +## Key Conventions + +- **Location strings** use `::` as hierarchy delimiter (e.g., `"Chad::Borkou"`). Helper `custom_paste()` handles safe concatenation. +- **Spatial scales**: `country`, `admin1`–`admin4` (and `admin4+`) +- **Temporal scales**: `daily`, `multiday`, `weekly`, `multiweek`, `monthly`, `multimonth`, `yearly`, `multiyear` +- **WHO regions**: `AFR`, `EMR`, `AMR`, `SEAR`, `EUR`, `WPR` +- Code uses R 4.1+ lambda syntax (`\(x)`) throughout; pipe is `%>%` (magrittr) +- Rolling windows via `slider`; RLE-based grouping via `zoo`; per-location processing via `purrr::map` + +## Testing + +Test files live in `tests/testthat/` with CSV fixtures (`outbreak_testing_data.csv`, `clean_outbreak_testing_data.csv`). Tests use **testthat edition 3**. Coverage focuses on filtering boundaries, type coercion, NA handling, aggregation correctness, and de-duplication logic. From c36aa55122e3be9138c835ab5fe8897ded89a62b Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 08:58:27 +0200 Subject: [PATCH 02/69] =?UTF-8?q?Add=20analysis/=20HPC=20layer:=20config-d?= =?UTF-8?q?riven=20SLURM=20parallelization=20over=20countries=20=C3=97=20t?= =?UTF-8?q?ime=20windows?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements the plan in snuggly-crunching-kernighan.md: - analysis/config_defaults.yml + utils.R: shared config/helpers - analysis/00_make_configs.R: generates pull_set / detection_set / test YAML configs - analysis/01_pull_data.R (Batch 1): taxdat API pull → normalize → stage1 GeoParquet/flat Parquet - analysis/02_run_outbreak_detection.R (Batch 2): identify_outbreaks() + trigger_alert() per country - analysis/03_aggregate_results.R: parallel-load stage2 files → combined_outbreaks.{parquet,csv} - analysis/bash/submit_0{1,2}*.sh: SLURM array scripts with credential validation and bounds checks - R/get_shp.R: add output_parquet param + on.exit disconnect - DESCRIPTION: add DBI/RPostgres/glue/sf to Imports; sfarrow/arrow/yaml/optparse/furrr/future/here/taxdat to Suggests - CLAUDE.md: document analysis/ layer architecture and quick-start Co-Authored-By: Claude Sonnet 4.6 --- CLAUDE.md | 65 +++++++++ DESCRIPTION | 34 ++++- R/get_shp.R | 37 +++-- analysis/00_make_configs.R | 92 +++++++++++++ analysis/01_pull_data.R | 148 ++++++++++++++++++++ analysis/02_run_outbreak_detection.R | 197 +++++++++++++++++++++++++++ analysis/03_aggregate_results.R | 104 ++++++++++++++ analysis/bash/submit_01_pull_data.sh | 89 ++++++++++++ analysis/bash/submit_02_detection.sh | 65 +++++++++ analysis/config_defaults.yml | 70 ++++++++++ analysis/generated_data/.gitkeep | 0 analysis/utils.R | 108 +++++++++++++++ logs/.gitkeep | 0 13 files changed, 998 insertions(+), 11 deletions(-) create mode 100644 analysis/00_make_configs.R create mode 100644 analysis/01_pull_data.R create mode 100644 analysis/02_run_outbreak_detection.R create mode 100644 analysis/03_aggregate_results.R create mode 100755 analysis/bash/submit_01_pull_data.sh create mode 100755 analysis/bash/submit_02_detection.sh create mode 100644 analysis/config_defaults.yml create mode 100644 analysis/generated_data/.gitkeep create mode 100644 analysis/utils.R create mode 100644 logs/.gitkeep diff --git a/CLAUDE.md b/CLAUDE.md index af6602a..ca2f365 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -74,3 +74,68 @@ Functions suffixed `_obs` operate on observatory (observed) data; others operate ## Testing Test files live in `tests/testthat/` with CSV fixtures (`outbreak_testing_data.csv`, `clean_outbreak_testing_data.csv`). Tests use **testthat edition 3**. Coverage focuses on filtering boundaries, type coercion, NA handling, aggregation correctness, and de-duplication logic. + +--- + +## HPC / SLURM Analysis Layer (`analysis/`) + +A config-driven pipeline that parallelizes over **countries × time windows** on Yggdrasil (University of Geneva HPC). Built on the same pattern as `mpox-uvira-sprint`. + +### Quick start + +```bash +# 1. Generate YAML configs +Rscript analysis/00_make_configs.R + +# 2. Set API credentials (these propagate to SLURM tasks via --export=ALL) +export CHOLERA_API_USERNAME= +export CHOLERA_API_KEY= + +# 3. Submit Batch 1 (data pull), chain Batch 2 (outbreak detection) after it +BATCH1=$(sbatch --parsable analysis/bash/submit_01_pull_data.sh) +sbatch --dependency=afterok:$BATCH1 analysis/bash/submit_02_detection.sh + +# 4. After all jobs finish, aggregate results locally +Rscript analysis/03_aggregate_results.R +``` + +### Architecture + +**Two SLURM batches:** +- **Batch 1** (`submit_01_pull_data.sh`): array over `analysis/configs/pull_set/` — one task per country × time window. Pulls via `taxdat::pull_taxonomy_data(source="api")`, runs the full normalization pipeline, writes: + - `stage1_geo_{run_id}.parquet` — GeoParquet with geometry (via `sfarrow`) + - `stage1_flat_{run_id}.parquet` — flat Parquet without geometry (input to Batch 2) +- **Batch 2** (`submit_02_detection.sh`): array over `analysis/configs/detection_set/` — one task per country. Globs all Stage 1 flat files for that country, runs `identify_outbreaks()` + `trigger_alert()` per time window, writes `stage2_{region}_{iso3}.parquet`. + +### Config system + +- `analysis/config_defaults.yml` — full parameter schema with defaults +- `analysis/00_make_configs.R` — editable country list and time windows; generates `pull_set/` and `detection_set/` configs +- `analysis/utils.R` — shared helpers: `write_configs()`, `make_options_from_config()`, `make_taxdat_location()`, filename functions + +**taxdat location format:** `"CT-World::{WHO_REGION}::{ISO3}"` (e.g. `"CT-World::AFR::COD"`). +**Credentials:** always via env vars `CHOLERA_API_USERNAME` / `CHOLERA_API_KEY` — never in config files. + +### Local dry-run workflow + +```bash +# Generate a 1-country test config +# (already created by 00_make_configs.R as configs/test_pull/ and test_detection/) + +# Test Batch 1 +Rscript analysis/01_pull_data.R -c analysis/configs/test_pull/test_pull_1.yml + +# Test Batch 2 +Rscript analysis/02_run_outbreak_detection.R -c analysis/configs/test_detection/test_detection_1.yml + +# SLURM dry run (no submission) +SLURM_ARRAY_TASK_ID=0 bash analysis/bash/submit_01_pull_data.sh +``` + +### SLURM array bounds + +After running `00_make_configs.R`, it prints the exact `--array` bounds to set in the submission scripts. **Edit the `#SBATCH --array=` lines** in `submit_01_pull_data.sh` and `submit_02_detection.sh` before submitting. + +### GeoParquet + +`get_shp()` now accepts an `output_parquet` parameter — when provided, it saves the returned sf object as GeoParquet via `sfarrow::st_write_parquet()`. All `analysis/` layer outputs use `.parquet` format (`sfarrow` for spatial, `arrow` for tabular). diff --git a/DESCRIPTION b/DESCRIPTION index e77848f..a0950f1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,9 +8,37 @@ License: GLP-2 Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 -Suggests: - testthat (>= 3.0.0) +Imports: + DBI, + RPostgres, + glue, + sf, + dplyr, + purrr, + tidyr, + stringr, + tibble, + lubridate, + zoo, + tidyselect, + rlang, + magrittr, + slider, + curl, + raster, + exactextractr +Suggests: + testthat (>= 3.0.0), + sfarrow, + arrow, + yaml, + optparse, + furrr, + future, + here, + taxdat + # taxdat: github::HopkinsIDD/cholera-taxonomy (or local install) Config/testthat/edition: 3 -Depends: +Depends: R (>= 2.10) LazyData: true diff --git a/R/get_shp.R b/R/get_shp.R index 9fd1a7f..43d3be9 100644 --- a/R/get_shp.R +++ b/R/get_shp.R @@ -1,19 +1,40 @@ #' @export #' @title get_shp #' @name get_shp -#' @description this function is to extract shapefiles from -get_shp <- function (location_period_id,username=username,password=password,host="db.cholera-taxonomy.middle-distance.com",port=5432,dbname='CholeraTaxonomy_production'){ - conn=DBI::dbConnect( +#' @description this function is to extract shapefiles from the Cholera Taxonomy +#' database. Optionally saves the result as a GeoParquet file. +#' @param location_period_id numeric: the location period ID to retrieve +#' @param username character: PostgreSQL username +#' @param password character: PostgreSQL password +#' @param host character: database host +#' @param port integer: database port +#' @param dbname character: database name +#' @param output_parquet character: optional file path to save result as +#' GeoParquet (requires sfarrow package). If NULL, no file is written. +#' @return sf object with the shapefile geometry +get_shp <- function(location_period_id, username, password, + host = "db.cholera-taxonomy.middle-distance.com", + port = 5432, dbname = "CholeraTaxonomy_production", + output_parquet = NULL) { + conn <- DBI::dbConnect( RPostgres::Postgres(), - user= username, + user = username, password = password, host = host, - port = 5432, + port = port, dbname = dbname ) - qsql_code=paste0("select geojson from geojsons where location_period_id = ",location_period_id,';') - sql_query=DBI::dbSendQuery(conn,glue::glue_sql(.con=conn, qsql_code)) - shp=sf::st_read(DBI::dbFetch(sql_query)) + on.exit(DBI::dbDisconnect(conn)) + + qsql_code <- paste0("select geojson from geojsons where location_period_id = ", + location_period_id, ";") + sql_query <- DBI::dbSendQuery(conn, glue::glue_sql(.con = conn, qsql_code)) + shp <- sf::st_read(DBI::dbFetch(sql_query)) shp$lctn_pr <- location_period_id + + if (!is.null(output_parquet)) { + dir.create(dirname(output_parquet), recursive = TRUE, showWarnings = FALSE) + sfarrow::st_write_parquet(shp, output_parquet) + } return(shp) } diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R new file mode 100644 index 0000000..4e2bf7d --- /dev/null +++ b/analysis/00_make_configs.R @@ -0,0 +1,92 @@ +# 00_make_configs.R +# Generates YAML config files for the two SLURM batches: +# pull_set — one config per country × time_window (Batch 1) +# detection_set — one config per country (Batch 2) +# +# After running, the script prints the --array bounds to use in the SLURM +# submission scripts (submit_01_pull_data.sh, submit_02_detection.sh). +# +# Usage: Rscript analysis/00_make_configs.R + +library(here) +library(tibble) +library(tidyr) + +source(here("analysis/utils.R")) + +# --------------------------------------------------------------------------- +# 1. Define the country × WHO region grid +# --------------------------------------------------------------------------- +# Add or remove rows to control which countries are analysed. +# country_iso3 must match the ISO3 code used by the Cholera Taxonomy API. + +countries <- tibble::tribble( + ~who_region, ~country_iso3, + "AFR", "COD", + "AFR", "NGA", + "AFR", "ETH", + "AFR", "MOZ", + "AFR", "ZMB", + "EMR", "SOM", + "EMR", "SDN", + "EMR", "YEM", + "AMR", "HTI" +) + +# --------------------------------------------------------------------------- +# 2. Define time windows +# --------------------------------------------------------------------------- +# Each row is one analysis window. Windows may overlap — this is intentional +# to allow comparison of outbreak detection across different time horizons. + +time_windows <- tibble::tribble( + ~time_lower_bound, ~time_upper_bound, + "2010-01-01", "2015-12-31", + "2013-01-01", "2018-12-31", + "2016-01-01", "2021-12-31", + "2018-01-01", "2023-12-31" +) + +# --------------------------------------------------------------------------- +# 3. (Optional) outbreak-detection parameter variants +# --------------------------------------------------------------------------- +# Uncomment to generate separate jobs per outbreak_start_definition variant. +# param_variants <- tibble::tribble( +# ~threshold_type, ~outbreak_start_definition, +# "mean weekly incidence rate", "consecutive", +# "mean weekly incidence rate", "dual_window" +# ) + +# --------------------------------------------------------------------------- +# 4. Generate config sets +# --------------------------------------------------------------------------- + +# pull_set: country × time_window (for Batch 1 data pull) +pull_specs <- tidyr::crossing(countries, time_windows) +# pull_specs <- tidyr::crossing(countries, time_windows, param_variants) +write_configs(pull_specs, "pull_set") + +# detection_set: country only (for Batch 2 outbreak detection) +# Each Batch 2 task globs all Stage 1 parquet files for that country. +write_configs(countries, "detection_set") + +# --------------------------------------------------------------------------- +# 5. Print SLURM array bounds +# --------------------------------------------------------------------------- +cat("\n=== SLURM array bounds ===\n") +cat("submit_01_pull_data.sh → --array=0-", nrow(pull_specs) - 1, "%25\n", sep = "") +cat("submit_02_detection.sh → --array=0-", nrow(countries) - 1, "%10\n", sep = "") +cat("\n") +cat("Total Batch 1 jobs:", nrow(pull_specs), "\n") +cat("Total Batch 2 jobs:", nrow(countries), "\n") + +# --------------------------------------------------------------------------- +# 6. Minimal test config (1 country, 1 window — for local dry runs) +# --------------------------------------------------------------------------- +test_specs <- tibble::tribble( + ~who_region, ~country_iso3, ~time_lower_bound, ~time_upper_bound, + "AFR", "ETH", "2020-01-01", "2022-12-31" +) +write_configs(test_specs, "test_pull") +write_configs(dplyr::select(test_specs, who_region, country_iso3), "test_detection") +cat("\nTest configs written to analysis/configs/test_pull/ and test_detection/\n") diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R new file mode 100644 index 0000000..76d1816 --- /dev/null +++ b/analysis/01_pull_data.R @@ -0,0 +1,148 @@ +# 01_pull_data.R — Batch 1: pull + normalize data for one country × time window +# +# Reads a YAML config, calls the Cholera Taxonomy API via taxdat, runs the +# full OutbreakExtractR normalization pipeline, and writes two GeoParquet files: +# stage1_geo_{run_id}.parquet — sf object (retains geometry, for spatial use) +# stage1_flat_{run_id}.parquet — flat dataframe (no geometry, input to Batch 2) +# +# Skips gracefully if outputs already exist (re-run with --redo TRUE to force). +# +# Usage: +# Rscript analysis/01_pull_data.R -c analysis/configs/pull_set/pull_set_1.yml +# Rscript analysis/01_pull_data.R -c analysis/configs/pull_set/pull_set_1.yml --redo TRUE +# +# Required environment variables: +# CHOLERA_API_USERNAME — Cholera Taxonomy API username +# CHOLERA_API_KEY — Cholera Taxonomy API key + +library(here) +library(optparse) +library(dplyr) +library(lubridate) + +source(here("analysis/utils.R")) + +# --------------------------------------------------------------------------- +# CLI / config parsing +# --------------------------------------------------------------------------- + +option_list <- list( + make_option(c("-c", "--config"), + default = NULL, type = "character", + help = "Path to YAML config file (required)"), + make_option(c("--redo"), + default = FALSE, type = "logical", + help = "Force re-pull even if output already exists [default: FALSE]") +) + +opt <- make_options_from_config(option_list, enforce_options = "redo") +print_options(opt) + +# --------------------------------------------------------------------------- +# Skip if already done +# --------------------------------------------------------------------------- + +out_geo <- make_stage1_geo_filename(opt) +out_flat <- make_stage1_flat_filename(opt) +dir.create(dirname(out_flat), recursive = TRUE, showWarnings = FALSE) + +if (file.exists(out_flat) && !isTRUE(opt$redo)) { + message("Stage 1 output already exists, skipping: ", out_flat) + quit(status = 0) +} + +# --------------------------------------------------------------------------- +# Credentials +# --------------------------------------------------------------------------- + +api_user <- Sys.getenv("CHOLERA_API_USERNAME", unset = NA_character_) +api_key <- Sys.getenv("CHOLERA_API_KEY", unset = NA_character_) + +if (is.na(api_user) || is.na(api_key)) { + stop("CHOLERA_API_USERNAME and CHOLERA_API_KEY environment variables must be set.") +} + +# --------------------------------------------------------------------------- +# Stage 1a: pull raw data from Cholera Taxonomy API +# --------------------------------------------------------------------------- + +location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) +message("Pulling data: ", location_str, + " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") + +raw_sf <- taxdat::pull_taxonomy_data( + username = api_user, + password = api_key, + locations = location_str, + time_left = opt$time_lower_bound, + time_right = opt$time_upper_bound, + source = "api", + website = opt$api_website +) %>% + taxdat::rename_database_fields(source = "api") + +if (is.null(raw_sf) || nrow(raw_sf) == 0) { + warning("API returned no data for: ", location_str, + " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") + # Write empty sentinel files so Batch 2 can detect and skip gracefully + arrow::write_parquet(data.frame(), out_flat) + quit(status = 0) +} + +message("Pulled ", nrow(raw_sf), " raw observations.") + +# Save raw sf with geometry as GeoParquet (useful for spatial visualisation) +sfarrow::st_write_parquet(raw_sf, out_geo) +message("Saved raw GeoParquet: ", basename(out_geo)) + +# --------------------------------------------------------------------------- +# Stage 1b: normalize through the OutbreakExtractR pipeline +# --------------------------------------------------------------------------- + +# Drop geometry — OutbreakExtractR functions operate on flat dataframes +raw_df <- sf::st_drop_geometry(raw_sf) + +# Clean: standardize types, identify spatial/temporal scale, clean location names +clean_data <- OutbreakExtractR::clean_psql_data(raw_df) + +# Filter by time, scale, and case thresholds +filtered_data <- OutbreakExtractR::observation_filter( + outbreak_data = clean_data, + time_lower_bound_filter = lubridate::ymd(opt$time_lower_bound), + time_upper_bound_filter = lubridate::ymd(opt$time_upper_bound), + temporal_scale_filter = opt$temporal_scale_filter, + who_regions = opt$who_region, + spatial_scale_filter = opt$spatial_scale_filter, + remove_na_sCh = opt$remove_na_sCh, + remove_na_cCh = opt$remove_na_cCh, + remove_na_locationperiod = opt$remove_na_locationperiod, + minimum_daily_cases = opt$minimum_daily_cases +) + +# Separate daily and weekly; aggregate daily → weekly +daily_data <- dplyr::filter(filtered_data, temporal_scale == "daily") +weekly_data <- dplyr::filter(filtered_data, temporal_scale == "weekly") + +if (nrow(daily_data) > 0) { + aggregated_daily <- OutbreakExtractR::observation_aggregator(daily_data) + weekly_data <- dplyr::bind_rows(weekly_data, aggregated_daily) +} + +# Normalize weekly data: deduplicate, align week-start day, fill zeros +normalized <- weekly_data %>% + dplyr::ungroup() %>% + OutbreakExtractR::average_duplicate_observations() %>% + OutbreakExtractR::set_uniform_wday_start() %>% + OutbreakExtractR::fill_phantom_zeroes() %>% + OutbreakExtractR::fill_missing_lps() + +# --------------------------------------------------------------------------- +# Save flat parquet for Batch 2 +# --------------------------------------------------------------------------- + +arrow::write_parquet(normalized, out_flat) + +message("Stage 1 complete.") +message(" Rows: ", nrow(normalized)) +message(" Locations: ", length(unique(normalized$location))) +message(" Saved: ", basename(out_flat)) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R new file mode 100644 index 0000000..7016d35 --- /dev/null +++ b/analysis/02_run_outbreak_detection.R @@ -0,0 +1,197 @@ +# 02_run_outbreak_detection.R — Batch 2: outbreak detection for one country +# +# Reads a per-country YAML config (detection_set), discovers all Stage 1 flat +# parquet files for that country (across all time windows), and runs +# identify_outbreaks() + trigger_alert() for each time window sequentially. +# +# Outputs one parquet file per country containing results across all windows: +# stage2_{who_region}_{country_iso3}.parquet +# +# This script is intentionally single-threaded — the per-country loop is fast +# relative to data pull. SLURM parallelism happens at the country level. +# +# Usage: +# Rscript analysis/02_run_outbreak_detection.R \ +# -c analysis/configs/detection_set/detection_set_1.yml + +library(here) +library(optparse) +library(dplyr) +library(purrr) +library(lubridate) +library(stringr) +library(arrow) + +source(here("analysis/utils.R")) + +# --------------------------------------------------------------------------- +# CLI / config parsing +# --------------------------------------------------------------------------- + +option_list <- list( + make_option(c("-c", "--config"), + default = NULL, type = "character", + help = "Path to YAML config file (required)"), + make_option(c("--redo"), + default = FALSE, type = "logical", + help = "Force re-run even if output already exists [default: FALSE]") +) + +opt <- make_options_from_config(option_list, enforce_options = "redo") +print_options(opt) + +# --------------------------------------------------------------------------- +# Discover Stage 1 flat parquet files for this country +# --------------------------------------------------------------------------- + +stage1_dir <- here("analysis/generated_data") +pattern <- paste0("^stage1_flat_", opt$who_region, "_", opt$country_iso3, "_.*\\.parquet$") +stage1_files <- list.files(stage1_dir, pattern = pattern, full.names = TRUE) + +if (length(stage1_files) == 0) { + stop("No Stage 1 flat parquet files found for ", + opt$who_region, "::", opt$country_iso3, + " in: ", stage1_dir, + "\nRun Batch 1 (01_pull_data.R) first.") +} + +message("Found ", length(stage1_files), " Stage 1 file(s) for ", + opt$who_region, "::", opt$country_iso3) + +# --------------------------------------------------------------------------- +# Skip if already done +# --------------------------------------------------------------------------- + +out_file <- make_stage2_filename(opt$who_region, opt$country_iso3) + +if (file.exists(out_file) && !isTRUE(opt$redo)) { + message("Stage 2 output already exists, skipping: ", out_file) + quit(status = 0) +} + +# --------------------------------------------------------------------------- +# Run outbreak detection for each time window +# --------------------------------------------------------------------------- + +results_list <- lapply(stage1_files, function(f) { + + # Parse time bounds from the filename (encoded as TL{YYYYMMDD}_TR{YYYYMMDD}) + fname <- basename(f) + tl_str <- str_extract(fname, "(?<=_TL)\\d{8}") + tr_str <- str_extract(fname, "(?<=_TR)\\d{8}") + + if (is.na(tl_str) || is.na(tr_str)) { + warning("Could not parse time bounds from filename: ", fname, " — skipping.") + return(NULL) + } + + tl <- lubridate::ymd(tl_str) + tr <- lubridate::ymd(tr_str) + run_id <- str_remove(str_remove(fname, "^stage1_flat_"), "\\.parquet$") + + message("Processing: ", run_id) + + normalized <- arrow::read_parquet(f) + if (nrow(normalized) == 0) { + message(" Empty Stage 1 file — skipping.") + return(NULL) + } + + # --- identify_outbreaks() --- + outbreak_list <- tryCatch( + OutbreakExtractR::identify_outbreaks( + threshold_type = opt$threshold_type, + original_data = normalized, + zero_case_assumption = opt$zero_case_assumption, + customized_TL = tl, + customized_TR = tr, + outbreak_start_definition = opt$outbreak_start_definition, + min_weeks_above = opt$min_weeks_above, + require_increasing_trend = opt$require_increasing_trend, + window_weeks = opt$window_weeks, + cumulative_windows = opt$cumulative_windows, + cumulative_case_threshold_ratio = opt$cumulative_case_threshold_ratio, + cumulative_trigger_type = opt$cumulative_trigger_type, + use_cumulative_trigger = opt$use_cumulative_trigger, + cumulative_min_cases = opt$cumulative_min_cases, + nonzero_windows = opt$nonzero_windows, + tail_period = opt$tail_period + ), + error = function(e) { + warning("identify_outbreaks() failed for ", run_id, ": ", conditionMessage(e)) + NULL + } + ) + + if (is.null(outbreak_list)) return(NULL) + + # Flatten list → dataframe (one row per location-week) + outbreaks_df <- purrr::list_rbind( + purrr::keep(outbreak_list, \(x) is.data.frame(x) && nrow(x) > 0) + ) + + if (nrow(outbreaks_df) == 0) { + message(" No outbreaks detected.") + return(NULL) + } + + # --- trigger_alert() --- + alerts_df <- tryCatch( + OutbreakExtractR::trigger_alert(original_data = normalized), + error = function(e) { + warning("trigger_alert() failed for ", run_id, ": ", conditionMessage(e)) + NULL + } + ) + + # Attach alert columns if available + if (!is.null(alerts_df) && nrow(alerts_df) > 0) { + alert_cols <- names(alerts_df)[str_detect(names(alerts_df), "^alert")] + join_keys <- intersect(c("location", "TL", "TR"), names(alerts_df)) + if (length(join_keys) > 0 && length(alert_cols) > 0) { + outbreaks_df <- dplyr::left_join( + outbreaks_df, + dplyr::select(alerts_df, dplyr::all_of(c(join_keys, alert_cols))), + by = join_keys + ) + } + } + + # Attach run metadata for later aggregation + outbreaks_df <- dplyr::mutate( + outbreaks_df, + who_region = opt$who_region, + country_iso3 = opt$country_iso3, + time_lower_bound = as.character(tl), + time_upper_bound = as.character(tr), + run_id = run_id + ) + + n_outbreak_rows <- sum(outbreaks_df$outbreak_number > 0, na.rm = TRUE) + message(" Rows: ", nrow(outbreaks_df), + " | Outbreak-period rows: ", n_outbreak_rows) + + outbreaks_df +}) + +# --------------------------------------------------------------------------- +# Combine and save +# --------------------------------------------------------------------------- + +combined <- purrr::list_rbind(purrr::keep(results_list, \(x) !is.null(x))) + +if (nrow(combined) == 0) { + warning("No outbreak results to save for: ", + opt$who_region, "::", opt$country_iso3) + # Write empty parquet so post-processor can detect this gracefully + arrow::write_parquet(data.frame(), out_file) + quit(status = 0) +} + +arrow::write_parquet(combined, out_file) + +message("\nStage 2 complete.") +message(" Country: ", opt$who_region, "::", opt$country_iso3) +message(" Time windows: ", length(stage1_files)) +message(" Total rows: ", nrow(combined)) +message(" Saved: ", basename(out_file)) diff --git a/analysis/03_aggregate_results.R b/analysis/03_aggregate_results.R new file mode 100644 index 0000000..f9daed2 --- /dev/null +++ b/analysis/03_aggregate_results.R @@ -0,0 +1,104 @@ +# 03_aggregate_results.R — Post-processing: aggregate all Stage 2 outputs +# +# Run locally (not on SLURM) after all Batch 2 jobs complete. +# Loads every stage2_{who_region}_{country_iso3}.parquet file in generated_data/, +# binds rows, and saves a combined parquet + CSV. +# +# Uses furrr::future_map for parallel file loading across workers. +# +# Usage: +# Rscript analysis/03_aggregate_results.R +# Rscript analysis/03_aggregate_results.R --workers 4 --set_name cholera_v2 + +library(here) +library(optparse) +library(purrr) +library(furrr) +library(future) +library(arrow) +library(dplyr) +library(stringr) + +# --------------------------------------------------------------------------- +# CLI args +# --------------------------------------------------------------------------- + +option_list <- list( + make_option(c("-w", "--workers"), + default = 8L, type = "integer", + help = "Number of parallel workers for loading parquet files [default: 8]"), + make_option(c("-s", "--set_name"), + default = "cholera", type = "character", + help = "Label for the combined output filename [default: cholera]"), + make_option(c("-o", "--out_dir"), + default = here("analysis/generated_data"), type = "character", + help = "Directory containing stage2_*.parquet files") +) + +opt <- parse_args(OptionParser(option_list = option_list)) +cat("Workers:", opt$workers, "\n") +cat("Set name:", opt$set_name, "\n") +cat("Output dir:", opt$out_dir, "\n\n") + +# --------------------------------------------------------------------------- +# Discover Stage 2 parquet files +# --------------------------------------------------------------------------- + +stage2_files <- list.files(opt$out_dir, + pattern = "^stage2_.*\\.parquet$", + full.names = TRUE) + +if (length(stage2_files) == 0) { + stop("No stage2_*.parquet files found in: ", opt$out_dir, + "\nRun Batch 2 (02_run_outbreak_detection.R) first.") +} + +cat("Found", length(stage2_files), "Stage 2 file(s):\n") +cat(paste0(" ", basename(stage2_files), collapse = "\n"), "\n\n") + +# --------------------------------------------------------------------------- +# Load in parallel +# --------------------------------------------------------------------------- + +plan(multisession, workers = opt$workers) + +results_list <- future_map(stage2_files, function(f) { + tryCatch({ + df <- arrow::read_parquet(f) + if (nrow(df) == 0) return(NULL) + df + }, error = function(e) { + warning("Failed to read: ", basename(f), " — ", conditionMessage(e)) + NULL + }) +}, .options = furrr_options(seed = TRUE)) + +plan(sequential) + +# --------------------------------------------------------------------------- +# Combine +# --------------------------------------------------------------------------- + +combined <- purrr::list_rbind(purrr::keep(results_list, \(x) !is.null(x))) + +cat("Combined result:\n") +cat(" Total rows: ", nrow(combined), "\n") +cat(" Countries: ", length(unique(combined$country_iso3)), "\n") +cat(" WHO regions: ", length(unique(combined$who_region)), "\n") +cat(" Time windows: ", + length(unique(paste0(combined$time_lower_bound, "_", combined$time_upper_bound))), "\n\n") + +# --------------------------------------------------------------------------- +# Save combined outputs +# --------------------------------------------------------------------------- + +out_parquet <- file.path(opt$out_dir, + paste0("combined_outbreaks_", opt$set_name, ".parquet")) +out_csv <- file.path(opt$out_dir, + paste0("combined_outbreaks_", opt$set_name, ".csv")) + +arrow::write_parquet(combined, out_parquet) +message("Saved parquet: ", out_parquet) + +write.csv(combined, out_csv, row.names = FALSE) +message("Saved CSV: ", out_csv) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh new file mode 100755 index 0000000..ef39688 --- /dev/null +++ b/analysis/bash/submit_01_pull_data.sh @@ -0,0 +1,89 @@ +#!/bin/bash +# submit_01_pull_data.sh — Batch 1: pull + normalize data (country × time window) +# +# Each array task processes one YAML config from analysis/configs/pull_set/. +# One config = one country × one time window. +# +# Prerequisites: +# 1. Generate configs: +# Rscript analysis/00_make_configs.R +# 2. Set credentials (export persists to child SLURM jobs via --export=ALL): +# export CHOLERA_API_USERNAME= +# export CHOLERA_API_KEY= +# 3. Create log directory: +# mkdir -p logs +# +# Submission: +# BATCH1=$(sbatch --parsable analysis/bash/submit_01_pull_data.sh) +# echo "Batch 1 job ID: $BATCH1" +# +# Then chain Batch 2: +# sbatch --dependency=afterok:$BATCH1 analysis/bash/submit_02_detection.sh +# +# To re-run specific failed tasks (e.g. tasks 3 and 7): +# sbatch --array=3,7 analysis/bash/submit_01_pull_data.sh + +#SBATCH --job-name=cholera_pull +#SBATCH --output=logs/%x_%A_%a.log +#SBATCH --error=logs/%x_%A_%a.log +#SBATCH --mem=8G +#SBATCH --cpus-per-task=2 +#SBATCH --time=02:00:00 +#SBATCH --export=ALL +# Yggdrasil partition — verify available partitions with: sinfo -s +# Common options: shared-cpu, cpu, bigmem +#SBATCH --partition=shared-cpu +# EDIT: set upper bound to (N pull_set configs - 1) +# The exact value is printed by 00_make_configs.R +#SBATCH --array=0-35%25 + +echo "===== Batch 1 start: $(date) =====" +echo "SLURM_JOB_ID: $SLURM_JOB_ID" +echo "SLURM_ARRAY_TASK_ID: $SLURM_ARRAY_TASK_ID" +echo "Hostname: $(hostname)" + +# --- R executable --- +# Yggdrasil uses Lmod; check available versions with: module spider R +if command -v module &>/dev/null; then + module load R 2>/dev/null || true +fi +RSCRIPT=$(command -v Rscript) +echo "Rscript: $RSCRIPT" +$RSCRIPT --version + +# --- Validate credentials --- +if [ -z "$CHOLERA_API_USERNAME" ] || [ -z "$CHOLERA_API_KEY" ]; then + echo "ERROR: CHOLERA_API_USERNAME and CHOLERA_API_KEY must be set." + echo "Run: export CHOLERA_API_USERNAME= CHOLERA_API_KEY=" + exit 1 +fi + +# --- Config selection --- +CONFIGDIR=analysis/configs/pull_set + +if [ ! -d "$CONFIGDIR" ]; then + echo "ERROR: Config directory not found: $CONFIGDIR" + echo "Run: Rscript analysis/00_make_configs.R" + exit 1 +fi + +# sort -V ensures natural (numeric) ordering: pull_set_1, pull_set_2, ..., pull_set_10 +CONFIGNAMES=($(ls "$CONFIGDIR" | sort -V)) +N_CONFIGS=${#CONFIGNAMES[@]} +echo "Config set: $CONFIGDIR ($N_CONFIGS configs)" + +if [ "$SLURM_ARRAY_TASK_ID" -ge "$N_CONFIGS" ]; then + echo "Task ID $SLURM_ARRAY_TASK_ID >= N_CONFIGS $N_CONFIGS — nothing to do." + exit 0 +fi + +THISCONFIG="$CONFIGDIR/${CONFIGNAMES[$SLURM_ARRAY_TASK_ID]}" +echo "Config: $THISCONFIG" + +# --- Run Stage 1 --- +$RSCRIPT analysis/01_pull_data.R -c "$THISCONFIG" --redo FALSE || { + echo "ERROR: 01_pull_data.R failed for $THISCONFIG" + exit 1 +} + +echo "===== Batch 1 end: $(date) =====" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh new file mode 100755 index 0000000..c6e3984 --- /dev/null +++ b/analysis/bash/submit_02_detection.sh @@ -0,0 +1,65 @@ +#!/bin/bash +# submit_02_detection.sh — Batch 2: outbreak detection (per country) +# +# Each array task processes one YAML config from analysis/configs/detection_set/. +# One config = one country; the script globs all Stage 1 flat parquet files for +# that country and runs identify_outbreaks() + trigger_alert() per time window. +# +# Typically submitted with a dependency on Batch 1: +# BATCH1=$(sbatch --parsable analysis/bash/submit_01_pull_data.sh) +# sbatch --dependency=afterok:$BATCH1 analysis/bash/submit_02_detection.sh +# +# Can also be submitted independently (if Stage 1 outputs already exist). + +#SBATCH --job-name=cholera_detect +#SBATCH --output=logs/%x_%A_%a.log +#SBATCH --error=logs/%x_%A_%a.log +#SBATCH --mem=4G +#SBATCH --cpus-per-task=1 +#SBATCH --time=01:00:00 +#SBATCH --export=ALL +#SBATCH --partition=shared-cpu +# EDIT: set upper bound to (N detection_set configs - 1) +# The exact value is printed by 00_make_configs.R +#SBATCH --array=0-8%10 + +echo "===== Batch 2 start: $(date) =====" +echo "SLURM_JOB_ID: $SLURM_JOB_ID" +echo "SLURM_ARRAY_TASK_ID: $SLURM_ARRAY_TASK_ID" +echo "Hostname: $(hostname)" + +# --- R executable --- +if command -v module &>/dev/null; then + module load R 2>/dev/null || true +fi +RSCRIPT=$(command -v Rscript) +echo "Rscript: $RSCRIPT" + +# --- Config selection --- +CONFIGDIR=analysis/configs/detection_set + +if [ ! -d "$CONFIGDIR" ]; then + echo "ERROR: Config directory not found: $CONFIGDIR" + echo "Run: Rscript analysis/00_make_configs.R" + exit 1 +fi + +CONFIGNAMES=($(ls "$CONFIGDIR" | sort -V)) +N_CONFIGS=${#CONFIGNAMES[@]} +echo "Config set: $CONFIGDIR ($N_CONFIGS configs)" + +if [ "$SLURM_ARRAY_TASK_ID" -ge "$N_CONFIGS" ]; then + echo "Task ID $SLURM_ARRAY_TASK_ID >= N_CONFIGS $N_CONFIGS — nothing to do." + exit 0 +fi + +THISCONFIG="$CONFIGDIR/${CONFIGNAMES[$SLURM_ARRAY_TASK_ID]}" +echo "Config: $THISCONFIG" + +# --- Run Stage 2 --- +$RSCRIPT analysis/02_run_outbreak_detection.R -c "$THISCONFIG" --redo FALSE || { + echo "ERROR: 02_run_outbreak_detection.R failed for $THISCONFIG" + exit 1 +} + +echo "===== Batch 2 end: $(date) =====" diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml new file mode 100644 index 0000000..5b581c2 --- /dev/null +++ b/analysis/config_defaults.yml @@ -0,0 +1,70 @@ +# config_defaults.yml +# Default parameters for OutbreakExtractR HPC pipeline. +# These values are loaded first; 00_make_configs.R overwrites only the fields +# that vary across the country × time_window grid. +# +# CREDENTIALS: never stored here. Set as environment variables before running: +# export CHOLERA_API_USERNAME= +# export CHOLERA_API_KEY= + +# --- API endpoint --- +api_website: "https://api.cholera-taxonomy.middle-distance.com/" + +# --- Geography (overridden per job) --- +# who_region: WHO region prefix used in taxdat location strings +# country_iso3: ISO3 country code (e.g. COD, NGA, ETH) +# taxdat location format built as: "CT-World::{who_region}::{country_iso3}" +who_region: "AFR" +country_iso3: "COD" + +# Which spatial scales to retain after pulling +spatial_scale_filter: + - "country" + - "admin1" + - "admin2" + - "admin3" + +# --- Time window (overridden per job in pull_set configs) --- +time_lower_bound: "2010-01-01" +time_upper_bound: "2015-12-31" + +# --- observation_filter() params --- +temporal_scale_filter: + - "daily" + - "weekly" +remove_na_sCh: true +remove_na_cCh: false +remove_na_locationperiod: false +minimum_daily_cases: 0 + +# --- identify_outbreaks() params --- +# threshold_type options: +# "fixed threshold" +# "mean weekly incidence rate" +# "outbreak_dependent threshold" +# "time_restricted threshold" +threshold_type: "mean weekly incidence rate" +fixed_outbreak_threshold: ~ # only used when threshold_type == "fixed threshold" +zero_case_assumption: true +# outbreak_start_definition options: "consecutive" or "dual_window" +outbreak_start_definition: "consecutive" +min_weeks_above: 2 +require_increasing_trend: false +tail_period: 6 + +# --- dual_window params (ignored when outbreak_start_definition == "consecutive") --- +window_weeks: 3 +use_cumulative_trigger: true +# cumulative_trigger_type options: +# "cumulative_case_threshold" +# "cumulative_case_threshold_and_min_cases" +# "cumulative_case_threshold_and_nonzero_weeks" +cumulative_trigger_type: "cumulative_case_threshold" +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: ~ +nonzero_windows: ~ + +# --- Job metadata --- +set_name: "default" +output_dir: "analysis/generated_data" diff --git a/analysis/generated_data/.gitkeep b/analysis/generated_data/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/analysis/utils.R b/analysis/utils.R new file mode 100644 index 0000000..78bdba7 --- /dev/null +++ b/analysis/utils.R @@ -0,0 +1,108 @@ +# utils.R — shared helpers for the OutbreakExtractR analysis pipeline +# Sourced by 00_make_configs.R, 01_pull_data.R, 02_run_outbreak_detection.R, +# and 03_aggregate_results.R. + +library(yaml) +library(here) +library(stringr) +library(purrr) +library(optparse) + +# --------------------------------------------------------------------------- +# Config I/O +# --------------------------------------------------------------------------- + +get_default_config <- function() { + yaml::read_yaml(here("analysis/config_defaults.yml")) +} + +get_config_dir <- function() { + here("analysis/configs") +} + +#' Write one YAML config file per row of config_specs. +#' Loads config_defaults.yml, then overwrites each field present in config_specs. +write_configs <- function(config_specs, set_name) { + out_dir <- file.path(get_config_dir(), set_name) + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + walk(seq_len(nrow(config_specs)), function(x) { + cfg <- get_default_config() + for (nm in names(as.list(config_specs[x, ]))) { + cfg[[nm]] <- config_specs[[nm]][x] + } + yaml::write_yaml(cfg, file.path(out_dir, paste0(set_name, "_", x, ".yml"))) + }) + message("Wrote ", nrow(config_specs), " configs to: ", out_dir) +} + +#' Parse arguments from a YAML config file (-c flag) or direct CLI flags. +#' enforce_options: character vector of option names that should always come +#' from the CLI (overriding the config), useful for --redo. +make_options_from_config <- function(option_list, enforce_options = NULL) { + opt_ <- parse_args(OptionParser(option_list = option_list)) + opt <- if (!is.null(opt_$config)) yaml::read_yaml(opt_$config) else opt_ + if (!is.null(enforce_options)) { + for (i in enforce_options) opt[[i]] <- opt_[[i]] + } + opt +} + +# --------------------------------------------------------------------------- +# taxdat location string helper +# --------------------------------------------------------------------------- + +#' Build the location string expected by taxdat::pull_taxonomy_data(). +#' Format: "CT-World::{who_region}::{country_iso3}" +make_taxdat_location <- function(who_region, country_iso3) { + paste("CT-World", who_region, country_iso3, sep = "::") +} + +# --------------------------------------------------------------------------- +# Filename helpers — encode key params in output names for reproducibility +# --------------------------------------------------------------------------- + +#' Canonical run identifier string shared by Stage 1 and Stage 2 filenames. +make_run_id <- function(opt) { + str_glue( + "{opt$who_region}_{opt$country_iso3}", + "_TL{str_remove_all(opt$time_lower_bound, '-')}", + "_TR{str_remove_all(opt$time_upper_bound, '-')}", + "_thresh-{str_replace_all(opt$threshold_type, ' ', '_')}", + "_start-{opt$outbreak_start_definition}" + ) +} + +#' Stage 1 GeoParquet — raw sf object pulled from API (retains geometry). +make_stage1_geo_filename <- function(opt) { + file.path( + here(opt$output_dir), + paste0("stage1_geo_", make_run_id(opt), ".parquet") + ) +} + +#' Stage 1 flat Parquet — normalized tabular data (geometry dropped). +#' This is the input to Stage 2 outbreak detection. +make_stage1_flat_filename <- function(opt) { + file.path( + here(opt$output_dir), + paste0("stage1_flat_", make_run_id(opt), ".parquet") + ) +} + +#' Stage 2 Parquet — outbreak detection results for one country (all windows). +make_stage2_filename <- function(who_region, country_iso3) { + file.path( + here("analysis/generated_data"), + paste0("stage2_", who_region, "_", country_iso3, ".parquet") + ) +} + +# --------------------------------------------------------------------------- +# Logging helper +# --------------------------------------------------------------------------- + +print_options <- function(opt) { + cat("---------- Run config ----------\n") + str(opt) + cat("--------------------------------\n") +} diff --git a/logs/.gitkeep b/logs/.gitkeep new file mode 100644 index 0000000..e69de29 From eb15b96fdc03a6333f82a1ecfbf82b9dd723c8aa Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 09:22:20 +0200 Subject: [PATCH 03/69] Make GeoParquet optional via use_geoparquet config flag MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Default is now GeoJSON + RDS (no sfarrow/arrow required). Set use_geoparquet: true in any config to restore GeoParquet + Parquet output. - config_defaults.yml: add use_geoparquet: false - utils.R: make filename helpers format-aware (.geojson/.rds vs .parquet); add write_tabular(), read_tabular(), write_spatial() I/O helpers - 01_pull_data.R: replace sfarrow/arrow calls with helpers - 02_run_outbreak_detection.R: remove library(arrow); dynamic glob extension; update run_id suffix regex; replace arrow calls with helpers - 03_aggregate_results.R: remove library(arrow); add --format flag (default geojson); dynamic discovery pattern; inline conditional read; write parquet only in geoparquet mode, always write CSV Existing generated configs lacking the key default to GeoJSON mode via isTRUE(NULL) == FALSE — no regeneration required. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 8 ++--- analysis/02_run_outbreak_detection.R | 16 ++++----- analysis/03_aggregate_results.R | 43 +++++++++++++++--------- analysis/config_defaults.yml | 5 +++ analysis/utils.R | 49 ++++++++++++++++++++-------- 5 files changed, 81 insertions(+), 40 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 76d1816..e9b2392 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -85,15 +85,15 @@ if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") # Write empty sentinel files so Batch 2 can detect and skip gracefully - arrow::write_parquet(data.frame(), out_flat) + write_tabular(data.frame(), out_flat, opt$use_geoparquet) quit(status = 0) } message("Pulled ", nrow(raw_sf), " raw observations.") # Save raw sf with geometry as GeoParquet (useful for spatial visualisation) -sfarrow::st_write_parquet(raw_sf, out_geo) -message("Saved raw GeoParquet: ", basename(out_geo)) +write_spatial(raw_sf, out_geo, opt$use_geoparquet) +message("Saved raw geo file: ", basename(out_geo)) # --------------------------------------------------------------------------- # Stage 1b: normalize through the OutbreakExtractR pipeline @@ -140,7 +140,7 @@ normalized <- weekly_data %>% # Save flat parquet for Batch 2 # --------------------------------------------------------------------------- -arrow::write_parquet(normalized, out_flat) +write_tabular(normalized, out_flat, opt$use_geoparquet) message("Stage 1 complete.") message(" Rows: ", nrow(normalized)) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index 7016d35..9cd7238 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -20,7 +20,6 @@ library(dplyr) library(purrr) library(lubridate) library(stringr) -library(arrow) source(here("analysis/utils.R")) @@ -45,7 +44,8 @@ print_options(opt) # --------------------------------------------------------------------------- stage1_dir <- here("analysis/generated_data") -pattern <- paste0("^stage1_flat_", opt$who_region, "_", opt$country_iso3, "_.*\\.parquet$") +stage1_ext <- if (isTRUE(opt$use_geoparquet)) "\\.parquet" else "\\.rds" +pattern <- paste0("^stage1_flat_", opt$who_region, "_", opt$country_iso3, "_.*", stage1_ext, "$") stage1_files <- list.files(stage1_dir, pattern = pattern, full.names = TRUE) if (length(stage1_files) == 0) { @@ -62,7 +62,7 @@ message("Found ", length(stage1_files), " Stage 1 file(s) for ", # Skip if already done # --------------------------------------------------------------------------- -out_file <- make_stage2_filename(opt$who_region, opt$country_iso3) +out_file <- make_stage2_filename(opt$who_region, opt$country_iso3, opt$use_geoparquet) if (file.exists(out_file) && !isTRUE(opt$redo)) { message("Stage 2 output already exists, skipping: ", out_file) @@ -87,11 +87,11 @@ results_list <- lapply(stage1_files, function(f) { tl <- lubridate::ymd(tl_str) tr <- lubridate::ymd(tr_str) - run_id <- str_remove(str_remove(fname, "^stage1_flat_"), "\\.parquet$") + run_id <- str_remove(str_remove(fname, "^stage1_flat_"), "\\.(parquet|rds)$") message("Processing: ", run_id) - normalized <- arrow::read_parquet(f) + normalized <- read_tabular(f, opt$use_geoparquet) if (nrow(normalized) == 0) { message(" Empty Stage 1 file — skipping.") return(NULL) @@ -183,12 +183,12 @@ combined <- purrr::list_rbind(purrr::keep(results_list, \(x) !is.null(x))) if (nrow(combined) == 0) { warning("No outbreak results to save for: ", opt$who_region, "::", opt$country_iso3) - # Write empty parquet so post-processor can detect this gracefully - arrow::write_parquet(data.frame(), out_file) + # Write empty sentinel so post-processor can detect this gracefully + write_tabular(data.frame(), out_file, opt$use_geoparquet) quit(status = 0) } -arrow::write_parquet(combined, out_file) +write_tabular(combined, out_file, opt$use_geoparquet) message("\nStage 2 complete.") message(" Country: ", opt$who_region, "::", opt$country_iso3) diff --git a/analysis/03_aggregate_results.R b/analysis/03_aggregate_results.R index f9daed2..90ca2dd 100644 --- a/analysis/03_aggregate_results.R +++ b/analysis/03_aggregate_results.R @@ -1,21 +1,21 @@ # 03_aggregate_results.R — Post-processing: aggregate all Stage 2 outputs # # Run locally (not on SLURM) after all Batch 2 jobs complete. -# Loads every stage2_{who_region}_{country_iso3}.parquet file in generated_data/, -# binds rows, and saves a combined parquet + CSV. +# Loads every stage2_{who_region}_{country_iso3}.{rds,parquet} file in generated_data/, +# binds rows, and saves a combined CSV (plus Parquet when --format geoparquet). # # Uses furrr::future_map for parallel file loading across workers. # # Usage: # Rscript analysis/03_aggregate_results.R # Rscript analysis/03_aggregate_results.R --workers 4 --set_name cholera_v2 +# Rscript analysis/03_aggregate_results.R --format geoparquet library(here) library(optparse) library(purrr) library(furrr) library(future) -library(arrow) library(dplyr) library(stringr) @@ -26,30 +26,41 @@ library(stringr) option_list <- list( make_option(c("-w", "--workers"), default = 8L, type = "integer", - help = "Number of parallel workers for loading parquet files [default: 8]"), + help = "Number of parallel workers for loading files [default: 8]"), make_option(c("-s", "--set_name"), default = "cholera", type = "character", help = "Label for the combined output filename [default: cholera]"), make_option(c("-o", "--out_dir"), default = here("analysis/generated_data"), type = "character", - help = "Directory containing stage2_*.parquet files") + help = "Directory containing stage2_* files"), + make_option(c("-f", "--format"), + default = "geojson", type = "character", + help = "File format: 'geojson' (default, RDS tabular) or 'geoparquet' [default: geojson]") ) opt <- parse_args(OptionParser(option_list = option_list)) + +if (!opt$format %in% c("geojson", "geoparquet")) { + stop("--format must be 'geojson' or 'geoparquet', got: ", opt$format) +} +use_geoparquet <- opt$format == "geoparquet" + cat("Workers:", opt$workers, "\n") cat("Set name:", opt$set_name, "\n") -cat("Output dir:", opt$out_dir, "\n\n") +cat("Output dir:", opt$out_dir, "\n") +cat("Format:", opt$format, "\n\n") # --------------------------------------------------------------------------- # Discover Stage 2 parquet files # --------------------------------------------------------------------------- +stage2_ext <- if (use_geoparquet) "\\.parquet" else "\\.rds" stage2_files <- list.files(opt$out_dir, - pattern = "^stage2_.*\\.parquet$", + pattern = paste0("^stage2_.*", stage2_ext, "$"), full.names = TRUE) if (length(stage2_files) == 0) { - stop("No stage2_*.parquet files found in: ", opt$out_dir, + stop("No stage2_* ", opt$format, " files found in: ", opt$out_dir, "\nRun Batch 2 (02_run_outbreak_detection.R) first.") } @@ -64,7 +75,7 @@ plan(multisession, workers = opt$workers) results_list <- future_map(stage2_files, function(f) { tryCatch({ - df <- arrow::read_parquet(f) + df <- if (use_geoparquet) arrow::read_parquet(f) else readRDS(f) if (nrow(df) == 0) return(NULL) df }, error = function(e) { @@ -92,13 +103,15 @@ cat(" Time windows: ", # Save combined outputs # --------------------------------------------------------------------------- -out_parquet <- file.path(opt$out_dir, - paste0("combined_outbreaks_", opt$set_name, ".parquet")) -out_csv <- file.path(opt$out_dir, - paste0("combined_outbreaks_", opt$set_name, ".csv")) +out_csv <- file.path(opt$out_dir, + paste0("combined_outbreaks_", opt$set_name, ".csv")) -arrow::write_parquet(combined, out_parquet) -message("Saved parquet: ", out_parquet) +if (use_geoparquet) { + out_parquet <- file.path(opt$out_dir, + paste0("combined_outbreaks_", opt$set_name, ".parquet")) + arrow::write_parquet(combined, out_parquet) + message("Saved parquet: ", out_parquet) +} write.csv(combined, out_csv, row.names = FALSE) message("Saved CSV: ", out_csv) diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index 5b581c2..175e10b 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -68,3 +68,8 @@ nonzero_windows: ~ # --- Job metadata --- set_name: "default" output_dir: "analysis/generated_data" + +# --- Output format --- +# Set to true to write spatial files as GeoParquet (requires sfarrow) and +# tabular files as Parquet (requires arrow). Default false uses GeoJSON + RDS. +use_geoparquet: false diff --git a/analysis/utils.R b/analysis/utils.R index 78bdba7..ddbed37 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -72,31 +72,54 @@ make_run_id <- function(opt) { ) } -#' Stage 1 GeoParquet — raw sf object pulled from API (retains geometry). +#' Stage 1 geo file — raw sf object pulled from API (retains geometry). +#' Extension is .parquet (GeoParquet) when use_geoparquet is TRUE, else .geojson. make_stage1_geo_filename <- function(opt) { - file.path( - here(opt$output_dir), - paste0("stage1_geo_", make_run_id(opt), ".parquet") - ) + ext <- if (isTRUE(opt$use_geoparquet)) ".parquet" else ".geojson" + file.path(here(opt$output_dir), paste0("stage1_geo_", make_run_id(opt), ext)) } -#' Stage 1 flat Parquet — normalized tabular data (geometry dropped). +#' Stage 1 flat file — normalized tabular data (geometry dropped). +#' Extension is .parquet when use_geoparquet is TRUE, else .rds. #' This is the input to Stage 2 outbreak detection. make_stage1_flat_filename <- function(opt) { - file.path( - here(opt$output_dir), - paste0("stage1_flat_", make_run_id(opt), ".parquet") - ) + ext <- if (isTRUE(opt$use_geoparquet)) ".parquet" else ".rds" + file.path(here(opt$output_dir), paste0("stage1_flat_", make_run_id(opt), ext)) } -#' Stage 2 Parquet — outbreak detection results for one country (all windows). -make_stage2_filename <- function(who_region, country_iso3) { +#' Stage 2 file — outbreak detection results for one country (all windows). +#' Extension is .parquet when use_geoparquet is TRUE, else .rds. +make_stage2_filename <- function(who_region, country_iso3, use_geoparquet = FALSE) { + ext <- if (isTRUE(use_geoparquet)) ".parquet" else ".rds" file.path( here("analysis/generated_data"), - paste0("stage2_", who_region, "_", country_iso3, ".parquet") + paste0("stage2_", who_region, "_", country_iso3, ext) ) } +# --------------------------------------------------------------------------- +# Format-aware I/O helpers +# --------------------------------------------------------------------------- + +#' Write a flat data frame to .rds (default) or .parquet (use_geoparquet = TRUE). +write_tabular <- function(df, path, use_geoparquet = FALSE) { + if (isTRUE(use_geoparquet)) arrow::write_parquet(df, path) + else saveRDS(df, path) +} + +#' Read a flat data frame from .rds (default) or .parquet (use_geoparquet = TRUE). +read_tabular <- function(path, use_geoparquet = FALSE) { + if (isTRUE(use_geoparquet)) arrow::read_parquet(path) + else readRDS(path) +} + +#' Write a spatial sf object to .geojson (default) or .parquet (use_geoparquet = TRUE). +#' delete_dsn = TRUE is required: sf::st_write refuses to overwrite by default. +write_spatial <- function(sf_obj, path, use_geoparquet = FALSE) { + if (isTRUE(use_geoparquet)) sfarrow::st_write_parquet(sf_obj, path) + else sf::st_write(sf_obj, path, driver = "GeoJSON", delete_dsn = TRUE, quiet = TRUE) +} + # --------------------------------------------------------------------------- # Logging helper # --------------------------------------------------------------------------- From 3a21cac8c27ebeee4e6d0db3b09dcec496a612bb Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 09:41:55 +0200 Subject: [PATCH 04/69] make test config only 1 month of data --- analysis/00_make_configs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index 4e2bf7d..a999919 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -85,7 +85,7 @@ cat("Total Batch 2 jobs:", nrow(countries), "\n") # --------------------------------------------------------------------------- test_specs <- tibble::tribble( ~who_region, ~country_iso3, ~time_lower_bound, ~time_upper_bound, - "AFR", "ETH", "2020-01-01", "2022-12-31" + "AFR", "ETH", "2020-01-01", "2020-02-31" ) write_configs(test_specs, "test_pull") write_configs(dplyr::select(test_specs, who_region, country_iso3), "test_detection") From 2c66c49db15869347a5d80c8b424401e3054dabb Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 09:42:10 +0200 Subject: [PATCH 05/69] add module load for yggdrasil --- analysis/bash/submit_01_pull_data.sh | 2 ++ analysis/bash/submit_02_detection.sh | 3 +++ 2 files changed, 5 insertions(+) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index ef39688..5c70b07 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -37,6 +37,8 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-35%25 +module load GCC/11.3.0 OpenMPI/4.1.4 R/4.2.1 + echo "===== Batch 1 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" echo "SLURM_ARRAY_TASK_ID: $SLURM_ARRAY_TASK_ID" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index c6e3984..57dea29 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -23,6 +23,9 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-8%10 +module load GCC/11.3.0 OpenMPI/4.1.4 R/4.2.1 + + echo "===== Batch 2 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" echo "SLURM_ARRAY_TASK_ID: $SLURM_ARRAY_TASK_ID" From ce5d5cd0361dc62747011912b241e9a1190a7118 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 09:54:24 +0200 Subject: [PATCH 06/69] update model load for yggdrasil to allow abseil --- analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index 5c70b07..84205f9 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -37,7 +37,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-35%25 -module load GCC/11.3.0 OpenMPI/4.1.4 R/4.2.1 +module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 echo "===== Batch 1 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 57dea29..26aee84 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -23,7 +23,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-8%10 -module load GCC/11.3.0 OpenMPI/4.1.4 R/4.2.1 +module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 echo "===== Batch 2 start: $(date) =====" From 56bde248b954f7f593878e5618e75a735d941cbf Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 09:57:20 +0200 Subject: [PATCH 07/69] add taxonomy credentials call --- analysis/bash/submit_01_pull_data.sh | 3 +++ analysis/bash/submit_02_detection.sh | 3 +++ 2 files changed, 6 insertions(+) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index 84205f9..4aa115a 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -39,6 +39,9 @@ module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 +# Set taxonomy credentials +bash analysis/bash/set_taxonomy_api_keys.sh + echo "===== Batch 1 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" echo "SLURM_ARRAY_TASK_ID: $SLURM_ARRAY_TASK_ID" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 26aee84..a484749 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -25,6 +25,9 @@ module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 +# Set taxonomy credentials +bash analysis/bash/set_taxonomy_api_keys.sh + echo "===== Batch 2 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" From cf01ff09b4f2405014bff79d6de0f089b230ae53 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 10:24:07 +0200 Subject: [PATCH 08/69] add script to install packages on yggdrasil --- analysis/bash/install_r_packages.sh | 84 ++++++++++++++++++++++++++++ analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 3 files changed, 86 insertions(+), 2 deletions(-) create mode 100755 analysis/bash/install_r_packages.sh diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh new file mode 100755 index 0000000..d1b04d1 --- /dev/null +++ b/analysis/bash/install_r_packages.sh @@ -0,0 +1,84 @@ +#!/bin/bash +# install_r_packages.sh — install all R packages required by the OutbreakExtractR pipeline +# +# Run ONCE from a LOGIN NODE (not a compute node — internet access needed for GitHub): +# +# cd /path/to/OutbreakExtractR +# bash analysis/bash/install_r_packages.sh +# +# What this installs: +# - All DESCRIPTION Imports + analysis-layer Suggests (from CRAN) +# - taxdat (from GitHub: HopkinsIDD/cholera-taxonomy) +# - OutbreakExtractR itself (from the current directory) +# +# Before running, verify the libdeflate module name for your cluster: +# module spider libdeflate +# Then set LIBDEFLATE_MODULE below to the version matching GCCcore-11.3.0. + +set -euo pipefail + + +# --------------------------------------------------------------------------- +# Modules — toolchain must match R/4.2.1-foss-2022a (built with GCCcore-11.3.0) +# --------------------------------------------------------------------------- +module purge +module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 + +echo "R: $(Rscript --version 2>&1)" +echo "Library: $(Rscript -e 'cat(.libPaths()[1])' 2>/dev/null)" +echo "" + +# --------------------------------------------------------------------------- +# Run R install script +# Must be executed from the OutbreakExtractR project root. +# --------------------------------------------------------------------------- +REPO_ROOT="$(pwd)" + +Rscript - "$REPO_ROOT" <<'REOF' + +repo_root <- commandArgs(trailingOnly = TRUE)[1] +repo <- "https://cloud.r-project.org" + +# ---- CRAN packages --------------------------------------------------------- +pkgs <- c( + # OutbreakExtractR Imports (DESCRIPTION) + "DBI", "RPostgres", "glue", "sf", + "dplyr", "purrr", "tidyr", "stringr", "tibble", + "lubridate", "zoo", "tidyselect", "rlang", "magrittr", + "slider", "curl", "raster", "exactextractr", + + # analysis/ layer: configs, CLI, parquet I/O, parallelism + "yaml", "optparse", "here", + "arrow", "sfarrow", + "furrr", "future", + + # dev / testing + "testthat", "remotes" +) + +missing_pkgs <- pkgs[!pkgs %in% rownames(installed.packages())] + +if (length(missing_pkgs) > 0) { + message("Installing ", length(missing_pkgs), " CRAN package(s): ", + paste(missing_pkgs, collapse = ", ")) + install.packages(missing_pkgs, repos = repo) +} else { + message("All CRAN packages already installed.") +} + +# ---- taxdat (private GitHub package) --------------------------------------- +if (!"taxdat" %in% rownames(installed.packages())) { + message("Installing taxdat from GitHub (HopkinsIDD/cholera-taxonomy) ...") + remotes::install_github("HopkinsIDD/cholera-taxonomy", upgrade = "never") +} else { + message("taxdat already installed.") +} + +# ---- OutbreakExtractR from source ------------------------------------------ +message("Installing OutbreakExtractR from source: ", repo_root) +install.packages(repo_root, repos = NULL, type = "source") + +message("\n===== Installation complete =====") +message("Packages installed in: ", .libPaths()[1]) + +REOF diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index 4aa115a..4c74061 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -37,7 +37,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-35%25 -module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 +module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 # Set taxonomy credentials bash analysis/bash/set_taxonomy_api_keys.sh diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index a484749..1120c9c 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -23,7 +23,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-8%10 -module load GCCcore/14.3.0 Abseil/20250512.1 OpenMPI/4.1.4 R/4.2.1 +module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 # Set taxonomy credentials bash analysis/bash/set_taxonomy_api_keys.sh From 3efda6165075c7cb2e119f61655dc9b5f23ec947 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 11:16:44 +0200 Subject: [PATCH 09/69] update modules --- analysis/bash/install_r_packages.sh | 3 +++ analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh index d1b04d1..1f11ba7 100755 --- a/analysis/bash/install_r_packages.sh +++ b/analysis/bash/install_r_packages.sh @@ -47,6 +47,9 @@ pkgs <- c( "lubridate", "zoo", "tidyselect", "rlang", "magrittr", "slider", "curl", "raster", "exactextractr", + # population estimation (add_population / get_pop) + "rgeoboundaries", + # analysis/ layer: configs, CLI, parquet I/O, parallelism "yaml", "optparse", "here", "arrow", "sfarrow", diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index 4c74061..aa0d153 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -37,7 +37,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-35%25 -module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials bash analysis/bash/set_taxonomy_api_keys.sh diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 1120c9c..8dd07ef 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -23,7 +23,7 @@ # The exact value is printed by 00_make_configs.R #SBATCH --array=0-8%10 -module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials bash analysis/bash/set_taxonomy_api_keys.sh From 80a17d25369b7f0b4bebcbba57e04ee0f01a36ab Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 11:17:08 +0200 Subject: [PATCH 10/69] fix to add population using get_pop --- R/add_population.R | 217 +++++++++++++++++++++++++++++++++++ analysis/01_pull_data.R | 11 ++ analysis/config_defaults.yml | 6 + 3 files changed, 234 insertions(+) create mode 100644 R/add_population.R diff --git a/R/add_population.R b/R/add_population.R new file mode 100644 index 0000000..bf2a8bf --- /dev/null +++ b/R/add_population.R @@ -0,0 +1,217 @@ +#' @export +#' @title add_population +#' @name add_population +#' @description Attach WorldPop population estimates to a normalized weekly +#' data frame. Intended as a Stage 1 pipeline step immediately after +#' fill_missing_lps(), and before writing to parquet. +#' +#' A single population value is computed per unique location_period_id (not +#' per week), which is correct: get_outbreak_threshold() and +#' identify_epidemic_start() both use pop as a static denominator for +#' incidence calculations. +#' +#' Population is estimated by: +#' 1. Looking up each location_period_id geometry in raw_sf (already in +#' memory — no extra DB call). +#' 2. Clamping the representative year (median TL) to 2015-2030 (WorldPop +#' constrained raster range). +#' 3. For each unique year: loading the raster ONCE, computing the UN +#' adjustment factor with one exact_extract call on the country boundary, +#' then extracting ALL LP populations with a single vectorized +#' exact_extract call. The raster is released immediately after. +#' +#' This avoids the 2N-loads-per-year penalty that results from calling +#' get_pop() per LP (each call loads the raster twice: once for the LP +#' geometry and once inside estimate_adj_factors() for the country boundary). +#' +#' @param normalized_data data.frame: weekly normalized data from the Stage 1 +#' pipeline (output of fill_missing_lps()). Must contain columns +#' location_period_id and TL. +#' @param raw_sf sf object: geometry-bearing data returned by +#' taxdat::pull_taxonomy_data() (before geometry is dropped). Must contain +#' a location_period_id or lctn_pr column and an sf geometry column. +#' @param country_iso3 character: ISO3 country code (e.g. "COD"). Used to +#' download the correct WorldPop raster and to fetch the country boundary +#' for the UN population adjustment factor. +#' @param raster_dir character: directory for caching WorldPop raster files. +#' Defaults to "worldpop". Created if it does not exist. +#' +#' @return normalized_data with a numeric pop column added. Rows whose +#' location_period_id has no matching geometry in raw_sf receive NA. +add_population <- function(normalized_data, raw_sf, country_iso3, + raster_dir = "worldpop") { + + country_iso3 <- toupper(country_iso3) + + # --------------------------------------------------------------------------- + # 1. Build named geometry lookup: LP ID (character) -> sfg object + # --------------------------------------------------------------------------- + # taxdat::rename_database_fields() uses "location_period_id"; + # get_shp() uses "lctn_pr". Accept either. + geom_id_col <- if ("location_period_id" %in% names(raw_sf)) { + "location_period_id" + } else if ("lctn_pr" %in% names(raw_sf)) { + "lctn_pr" + } else { + stop("raw_sf must have a 'location_period_id' or 'lctn_pr' column.") + } + + lp_geoms <- raw_sf %>% + dplyr::rename(lp_id = !!geom_id_col) %>% + dplyr::group_by(lp_id) %>% + dplyr::slice(1) %>% + dplyr::ungroup() + + # Named list: character(LP ID) -> sfg geometry + geom_lookup <- setNames( + as.list(sf::st_geometry(lp_geoms)), + as.character(lp_geoms$lp_id) + ) + source_crs <- sf::st_crs(raw_sf) + + # --------------------------------------------------------------------------- + # 2. Representative year per LP (clamped to WorldPop range 2015-2030) + # --------------------------------------------------------------------------- + lp_years <- normalized_data %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::group_by(location_period_id) %>% + dplyr::summarise( + year = pmax(2015L, pmin(2030L, + as.integer(stats::median(lubridate::year(TL))))), + .groups = "drop" + ) + + # --------------------------------------------------------------------------- + # 3. Country boundary for the UN adjustment factor (fetched once) + # --------------------------------------------------------------------------- + # Primary: rgeoboundaries network call. + # Fallback: union of all LP geometries (approximation, avoids network dep). + country_shp <- tryCatch( + sf::st_transform(rgeoboundaries::gb_adm0(country = country_iso3), 4326), + error = function(e) { + message("rgeoboundaries::gb_adm0() failed: ", conditionMessage(e), + "\nFalling back to union of LP geometries as country boundary.") + all_geoms <- Filter(Negate(is.null), as.list(geom_lookup)) + sf::st_sf( + geometry = sf::st_union( + do.call(sf::st_sfc, c(all_geoms, list(crs = source_crs))) %>% + sf::st_transform(4326) + ) + ) + } + ) + + # --------------------------------------------------------------------------- + # 4. WPP2024 national totals (loaded once, used for adj factor in every year) + # --------------------------------------------------------------------------- + data("WPP2024", package = "OutbreakExtractR", envir = environment()) + + # --------------------------------------------------------------------------- + # 5. One raster load per year; two exact_extract calls per year + # + # Avoids the 2N raster-load penalty of calling get_pop() per LP, where + # each call loads the raster in get_pop() AND again inside + # estimate_adj_factors(). Here we load once and inline the adj-factor + # calculation against the same in-memory raster object. + # --------------------------------------------------------------------------- + message("add_population(): ", nrow(lp_years), " LP(s) across ", + dplyr::n_distinct(lp_years$year), " year(s) in ", country_iso3) + + lp_pop <- lp_years %>% + dplyr::group_by(year) %>% + dplyr::group_split() %>% + purrr::map(\(year_group) { + + yr <- year_group$year[1] + lp_ids <- year_group$location_period_id + message(" Year ", yr, ": ", length(lp_ids), " LP(s)") + + # -- a. Download / cache raster (no-op if already on disk) -------------- + raster_path <- tryCatch( + download_worldpop_constrained(country_iso3, yr, dest_dir = raster_dir), + error = function(e) { + message(" Raster download failed: ", conditionMessage(e)) + NULL + } + ) + + if (is.null(raster_path)) { + message(" Skipping year ", yr, " — all LPs set to NA.") + return(dplyr::tibble(location_period_id = lp_ids, pop = NA_real_)) + } + + # Load raster ONCE for this year + pop_raster <- raster::raster(raster_path) + + # -- b. Adj factor: one exact_extract call on the country boundary ------ + # Inlined from estimate_adj_factors() to reuse the already-loaded + # raster instead of having that function load it a second time. + country_raw <- sum( + exactextractr::exact_extract( + pop_raster, sf::st_geometry(country_shp), "sum" + ), + na.rm = TRUE + ) + tot_UN <- WPP2024$PopTotal[ + WPP2024$Time == yr & WPP2024$ISO3_code == country_iso3 + ] * 1e3 + + adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) { + tot_UN / country_raw + } else { + message(" Could not compute adj factor for year ", yr, + " — using 1.0 (population will be unadjusted).") + 1.0 + } + + # -- c. Identify which LPs have geometry in this batch ------------------ + geoms <- lapply(as.character(lp_ids), \(id) geom_lookup[[id]]) + missing <- vapply(geoms, is.null, logical(1L)) + + if (any(missing)) { + message(" No geometry for LP(s): ", + paste(lp_ids[missing], collapse = ", "), " — pop = NA.") + } + + pop_values <- rep(NA_real_, length(lp_ids)) + valid_idx <- which(!missing) + + if (length(valid_idx) > 0L) { + # -- d. Single vectorized exact_extract call for all LPs this year ---- + # exactextractr processes multiple geometries in one C++ pass, + # reading each raster tile at most once. + valid_sfc <- do.call( + sf::st_sfc, c(geoms[valid_idx], list(crs = source_crs)) + ) %>% + sf::st_transform(4326) + + raw_pops <- exactextractr::exact_extract( + pop_raster, valid_sfc, "sum" + ) + pop_values[valid_idx] <- as.numeric(raw_pops) * adj_factor + } + + # -- e. Release raster from memory before moving to the next year ------- + rm(pop_raster) + gc(verbose = FALSE) + + dplyr::tibble(location_period_id = lp_ids, pop = pop_values) + }) %>% + purrr::list_rbind() + + # --------------------------------------------------------------------------- + # 6. Join pop back onto the normalized data + # --------------------------------------------------------------------------- + if ("pop" %in% names(normalized_data)) { + normalized_data <- dplyr::select(normalized_data, -pop) + } + + normalized_data <- dplyr::left_join(normalized_data, lp_pop, + by = "location_period_id") + + n_with <- sum(!is.na(normalized_data$pop)) + message(sprintf("add_population(): %d / %d rows have a population estimate.", + n_with, nrow(normalized_data))) + + normalized_data +} diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index e9b2392..eaaf1c0 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -136,6 +136,17 @@ normalized <- weekly_data %>% OutbreakExtractR::fill_phantom_zeroes() %>% OutbreakExtractR::fill_missing_lps() +# Attach WorldPop population estimates (one value per location_period_id). +# Required downstream by get_outbreak_threshold() and identify_epidemic_start() +# for incidence-based threshold modes. +# Rasters are downloaded once into opt$raster_dir and cached for subsequent runs. +normalized <- OutbreakExtractR::add_population( + normalized_data = normalized, + raw_sf = raw_sf, + country_iso3 = opt$country_iso3, + raster_dir = here::here(opt$raster_dir) +) + # --------------------------------------------------------------------------- # Save flat parquet for Batch 2 # --------------------------------------------------------------------------- diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index 175e10b..aa7be91 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -65,6 +65,12 @@ cumulative_case_threshold_ratio: 1.5 cumulative_min_cases: ~ nonzero_windows: ~ +# --- Population estimation --- +# Directory to cache WorldPop constrained rasters (100m, 2015-2030, per country/year). +# Downloaded automatically by add_population() on first use; reused on subsequent runs. +# Relative paths are resolved from the project root (here::here()). +raster_dir: "analysis/worldpop" + # --- Job metadata --- set_name: "default" output_dir: "analysis/generated_data" From afa967c5c0c9d127a5d07bf1b1fcd8c72ebdbf91 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 11:21:59 +0200 Subject: [PATCH 11/69] update module loading for hpc --- analysis/bash/install_r_packages.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh index 1f11ba7..902dc9c 100755 --- a/analysis/bash/install_r_packages.sh +++ b/analysis/bash/install_r_packages.sh @@ -22,7 +22,7 @@ set -euo pipefail # Modules — toolchain must match R/4.2.1-foss-2022a (built with GCCcore-11.3.0) # --------------------------------------------------------------------------- module purge -module load GCCcore/13.3.0 GCC/13.3.0 libdeflate/1.20 Abseil/20240722.0 OpenMPI/5.0.3 R/4.4.2 +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 CMake echo "R: $(Rscript --version 2>&1)" echo "Library: $(Rscript -e 'cat(.libPaths()[1])' 2>/dev/null)" From ec0831623c9c50e83caef86c5ae751570b61acb7 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 11:40:51 +0200 Subject: [PATCH 12/69] use source to apply env variable --- analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index aa0d153..f58d541 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -40,7 +40,7 @@ module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials -bash analysis/bash/set_taxonomy_api_keys.sh +source analysis/bash/set_taxonomy_api_keys.sh echo "===== Batch 1 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 8dd07ef..8bd81d3 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -26,7 +26,7 @@ module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials -bash analysis/bash/set_taxonomy_api_keys.sh +source analysis/bash/set_taxonomy_api_keys.sh echo "===== Batch 2 start: $(date) =====" From 6a5cd17e7d0852f483131b2680ba954a7d19faaf Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:02:19 +0200 Subject: [PATCH 13/69] fix call to taxdat rename_database_fields --- analysis/01_pull_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index eaaf1c0..0e1c37d 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -79,7 +79,7 @@ raw_sf <- taxdat::pull_taxonomy_data( source = "api", website = opt$api_website ) %>% - taxdat::rename_database_fields(source = "api") + taxdat:::rename_database_fields(source = "api") if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, From e8e28b2ed1b67f7217230006b8f93a08fa68fea3 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:04:51 +0200 Subject: [PATCH 14/69] patch rename_database_fields --- analysis/01_pull_data.R | 2 +- analysis/utils.R | 44 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 0e1c37d..68d9503 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -79,7 +79,7 @@ raw_sf <- taxdat::pull_taxonomy_data( source = "api", website = opt$api_website ) %>% - taxdat:::rename_database_fields(source = "api") + rename_database_fields(source = "api") if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, diff --git a/analysis/utils.R b/analysis/utils.R index ddbed37..0b2e450 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -129,3 +129,47 @@ print_options <- function(opt) { str(opt) cat("--------------------------------\n") } + + +# Taxdat patch ------------------------------------------------------------ + +#' @title Rename cholera data columns +#' @description Renames the columns of the data pulled either from the the +#' API staging database or by SQL from taxdat +#' +#' @param database_df Data who's columns are to be modified +#' @param source Whether the source is the staging database (sing the API) or taxdat (using SQL). +#' @details source is one of 'api' or 'sql' +#' @return the renamed dataframe +rename_database_fields <- function(database_df, + source = "api") { + + if (source == "api") { + new_database_df <- database_df %>% + dplyr::rename( + TL = attributes.time_left, + TR = attributes.time_right, + is_primary = attributes.primary, + is_phantom = attributes.phantom, + locationPeriod_id = attributes.id, + OC_UID = relationships.observation_collection.data.id, + location_name = attributes.location_name + ) + } else if (source == "sql") { + new_database_df <- database_df %>% + dplyr::rename( + TL = time_left, + TR = time_right, + is_primary = primary, + is_phantom = phantom, + locationPeriod_id = location_period_id, + OC_UID = observation_collection_id, + location_name = location_name + ) + } else { + stop("Source needs to be one of 'api', 'sql', found ", source) + } + # names(new_database_df) <- gsub("attributes.fields.", "", names(new_database_df)) + # names(new_database_df) <- gsub("attributes.", "", names(new_database_df)) + return(new_database_df) +} From bdb42d0084f58f9cc5b2b9f7c55b0261cf7434aa Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:15:23 +0200 Subject: [PATCH 15/69] temp hack to turn off ssl verification to pull api --- analysis/01_pull_data.R | 2 +- analysis/utils.R | 1875 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 1876 insertions(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 68d9503..e076c93 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -70,7 +70,7 @@ location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -raw_sf <- taxdat::pull_taxonomy_data( +raw_sf <- pull_taxonomy_data( username = api_user, password = api_key, locations = location_str, diff --git a/analysis/utils.R b/analysis/utils.R index 0b2e450..ff97788 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -173,3 +173,1878 @@ rename_database_fields <- function(database_df, # names(new_database_df) <- gsub("attributes.", "", names(new_database_df)) return(new_database_df) } + + +#' @import methods dplyr +library(methods) +library(dplyr) +################################################################ +######################Taxonomy Data Parser###################### +################################################################ +#' Taxonomy Data Parser +################################################################ +## Note: #' at the beginning of the line means to pass to R +## Markdown +#' +#' The Taxonomy Data Parser package loads and handles Taxonomy Data. +#' It provides 1 category of functions: +#' Taxonomy Parsing +#' +#' @section Taxonomy Parsing Functions: +## +#' @details Taxonomy parsing functions are designed to read flat +#' files from a filesystem storing taxonomy data. If the file +#' system is called taxonomy.directory, then the following +#' subdirectories must exist: +#' \itemize{ +#' \item taxonomy.directory/Description - files must end in _DESC.csv +#' \item taxonomy.directory/Location - files must end in _LOC.csv +#' \item taxonomy.directory/EpiCurves - files must end in _EPI.csv +#' \item taxonomy.directory/Population - files must end in _POP.csv +#' } +#' The files Description and Population files are regular .csv files, +#' and the Location and Epi files are transposed .csv files. +################################################################ +################################################################ +##TODO: +## 1. Only read in relevant epi files in read_taxonomy_data +## 2. Specify the types of all columns in code, so the warnings +## go away in read_taxonomy_csv and read_transposed_taxonomy_csv +## 3. Comment the code more effectively +## 4. Parallelize the reading. +################################################################ + +################################################################ +#' @name read_taxonomy_csv +#' @title read_taxonomy_csv +#' @description This function reads a csv file which is column major. +#' It will also fail without throwing an error, so it can be used on +#' missing data +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file should be column major +## vals: +#' @return A data.frame containing the data from \code{filename} or a +#' data.frame with a single column missing=\code{filename}) +################################################################ + +read_taxonomy_csv= function(filename,verbose=FALSE){ + if(!file.exists(filename)){ + if(verbose){ + warning(paste(filename,": Does not exist"),immediate.=FALSE) + } + return(data.frame(missing=filename,stringsAsFactors = FALSE)) + } + output.data = tryCatch( + read.csv( + filename, + sep=',', + header=TRUE, + stringsAsFactors=FALSE, + na.strings = "", + colClasses = 'character', + quote = "\"", + check.names = FALSE, + row.names=NULL + ), + warning = function(w){ + if(length(w$message > 0)){ + if(grepl(pattern="ncomplete final line",x=w$message)){ + return(suppressWarnings( + read.csv( + filename, + sep=',', + header=TRUE, + stringsAsFactors=FALSE, + na.strings = "", + colClasses = 'character', + quote = "\"", + check.names = FALSE + ) + )) + } + } + if(verbose){ + warning(paste(filename,":",w$message),immediate.=TRUE) + } + return(w) + }, + error = function(e){ + if(verbose){ + warning(paste(filename,":",e),immediate.=TRUE) + } + return(e) + } + ) + if(length(class(output.data))>0){ + if(class(output.data)[[1]] != "data.frame"){ + output.data = data.frame( + missing=filename, + stringsAsFactors = FALSE + ) + } + } + return(output.data) +} + +################################################################ +#' @name read_transposed_taxonomy_csv +#' @title read_transposed_taxonomy_csv +#' @description This function reads a csv file which is row major. It +#' will also fail without throwing an error, so it can be used on +#' missing data +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file should be row major +## vals: +#' @return A data.frame containing the data from \code{filename} or a +#' data.frame with a single column missing=\code{filename}) +################################################################ + +read_transposed_taxonomy_csv = function(filename,verbose=FALSE){ + if(!file.exists(filename)){ + if(verbose){ + warning(paste(filename,": Does not exist"),immediate.=FALSE) + } + return(data.frame(missing=filename,stringsAsFactors = FALSE)) + } + output.data = tryCatch( + as.data.frame( + t(read.csv( + filename, + sep=',', + header=FALSE, + stringsAsFactors=FALSE, + na.strings = "", + colClasses = 'character', + quote = "\"", + check.names = FALSE + )), + stringsAsFactors=FALSE + ), + warning = function(w){ + if(length(w$message > 0)){ + if(grepl(pattern="ncomplete final line",x=w$message)){ + return(suppressWarnings( + as.data.frame( + t(read.csv( + filename, + sep=',', + header=FALSE, + stringsAsFactors=FALSE, + na.strings = "", + colClasses = 'character', + quote = "\"", + check.names = FALSE + )), + stringsAsFators = FALSE + ))) + } + } + if(verbose){ + warning(paste(filename,":",w$message),immediate.=TRUE) + } + return(w) + }, + error = function(e){ + if(verbose){ + warning(paste(filename,":",e),immediate.=TRUE) + } + return(e) + } + ) + if(length(class(output.data))>0){ + if(class(output.data)[[1]] != "data.frame"){ + warning(paste( + "Output date is of type", + class(output.data), + "instead of data.frame." + )) + output.data = data.frame( + missing=filename,stringsAsFactors = FALSE + ) + } else{ + colnames(output.data) = as.character(unlist(output.data[1,])) + output.data = output.data[-1,] + } + } + return(output.data) +} + +################################################################ +#' @name safe.function +#' @title safe.function +#' @description This function runs a function, and returns either +#' the return of that function, or a default return if it fails +## args: +#' @param function The function to run safely +#' @param \dots The normal arguments to the function +#' @param default The value the function should return if it fails +## vals: +#' @return The return value of the function if the function runs, +#' or \code{default} otherwise +################################################################ +safe.function <- function(fxn,...,default=warning("The function failed to run")){ + tryCatch( + fxn(...), + error = function(e){ + warning(e$message) + return(default) + } + ) +} + +##Include methods for reading each particular type of file +################################################################ +#' @name read_description_csv +#' @title read_description_csv +#' @description This function reads a csv file containing a +#' description file. +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file format is described in the +#' documentation +## vals: +#' @return A \code{data.frame} containing the data from +#' \code{filename} or a single column missing with the filename +#' listed +################################################################ + +description_coltypes = c( + uid = "integer", + source = "character", + source_uid = "character", + source_url = "character", + contact = "character", + contact_email = "character", + is_public = "integer", + mou_dsa_notes = "character", + contains_pii = "integer", + irb_protocol = "character", + owner = "character", + owner_email = "character", + source_file = "character", + who_region = "character", + ISO_A1 = "character", + ISO_A2_L1 = "character", + ISO_A2_L2 = "character", + ISO_A2_L3 = "character", + ISO_A2_L4 = "character", + ISO_A2_L5 = "character", + ISO_A2_L6 = "character", + ISO_A2_L7 = "character", + ISO_A2_L8 = "character", + ISO_A2_L9 = "character", + suspected_case_def = "character", + confirmed_case_def = "character", + day_start = "Date", + day_end = "Date", + primary_time_criteria = "character", + deaths = "integer", + cases = "integer", + strains = "character", + tet_res = "integer", + sul_res = "integer", + cip_res = "integer", + az_res = "integer", + humanitarian_crisis_assoc = "integer", + reactive_vaccination = "integer", + prev_vaccination = "integer", + notes = "character" +) + +read_description_csv = function(filename){ + rc <- read_transposed_taxonomy_csv(filename) + for(column in colnames(rc)){ + if(!is.na(description_coltypes[column])){ + if(description_coltypes[column] == "Date"){ + rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) + # rc[[column]] <- as.Date(rc[[column]]) + } else { + rc[[column]] <- as(rc[[column]],description_coltypes[column]) + } + } + + } + old.ncol = ncol(rc) + if(old.ncol == 1){ + return(rc) + } + rc <- rc[,!is.na(colnames(rc))] + rc <- rc[,!(colnames(rc) == "")] + if(ncol(rc) != old.ncol){ + warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) + } + return(rc) +} + + + +################################################################ +#' @name read_epi_csv +#' @title read_epi_csv +#' @description This function reads a csv file containing a epi file +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file format is described in the +#' documentation +## vals: +#' @return A \code{data.frame} containing the data from +#' \code{filename} or a single column missing with the filename +#' listed +################################################################ +epi_coltypes = c( + TL = "Date", + TR = "Date", + TL_onset = "Date", + TR_onset = "Date", + TL_clinic = "Date", + TR_clinic = "Date", + TL_death = "Date", + TR_death = "Date", + ISO_A1 = "character", + ISO_A2_L1 = "character", + ISO_A2_L2 = "character", + ISO_A2_L3 = "character", + ISO_A2_L4 = "character", + ISO_A2_L5 = "character", + ISO_A2_L6 = "character", + ISO_A2_L7 = "character", + ISO_A2_L8 = "character", + ISO_A2_L9 = "character", + lat_case = "character", + long_case = "character", + sCh = "numeric", + cCh = "numeric", + deaths_L = "numeric", + deaths_R = "numeric", + sCh_L = "numeric", + sCh_R = "numeric", + cCh_L = "numeric", + cCh_R = "numeric", + age_U = "numeric", + sex_U = "numeric", + vac_U = "numeric" +) + +read_epi_csv = function(filename,verbose=FALSE){ + rc <- read_taxonomy_csv(filename) + for(column in colnames(rc)){ + if(!is.na(epi_coltypes[column])){ + if(epi_coltypes[column] == "Date"){ + #rc[[column]] <- as.Date(rc[[column]]) + rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) + } else { + rc[[column]] <- as(rc[[column]],epi_coltypes[column]) + } + } + } + old.ncol = ncol(rc) + if(old.ncol == 1){ + return(rc) + } + rc <- rc[,!is.na(colnames(rc))] + rc <- rc[,!(colnames(rc) == "")] + if(verbose && (ncol(rc) != old.ncol)){ + warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) + } + return(rc) +} + +################################################################ +#' @name read_location_csv +#' @title read_location_csv +#' @description This function reads a csv file containing a location file +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file format is described in the +#' documentation +## vals: +#' @return A \code{data.frame} containing the data from +#' \code{filename} or a single column missing with the filename +#' listed +################################################################ + +location_coltypes = c( + name = "character", + cent_lat = "numeric", + cent_long = "numeric", + isISO_A1 = "numeric", + isISO_A2_L1 = "numeric", + isISO_A2_L2 = "numeric", + isISO_A2_L3 = "numeric", + isISO_A2_L4 = "numeric", + isISO_A2_L5 = "numeric", + isISO_A2_L6 = "numeric", + isISO_A2_L7 = "numeric", + isISO_A2_L8 = "numeric", + isISO_A2_L9 = "numeric", + gis_file = 'character', + gis_file_2 = 'character', + gis_file_3 = 'character', + gis_file_4 = 'character', + gis_file_5 = 'character', + gis_start_1 = 'Date', + gis_start_2 = 'Date', + gis_start_3 = 'Date', + gis_start_4 = 'Date', + gis_start_5 = 'Date', + gis_end_1 = 'Date', + gis_end_2 = 'Date', + gis_end_3 = 'Date', + gis_end_4 = 'Date', + gis_end_5 = 'Date', + enclosed_by = "character", + notes = "character" +) + +read_location_csv = function(filename){ + rc <- read_transposed_taxonomy_csv(filename) + for(column in colnames(rc)){ + if(!is.na(location_coltypes[column])){ + if(location_coltypes[column] == "Date"){ + # rc[[column]] <- as.Date(rc[[column]]) + rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) + } else { + rc[[column]] <- as(rc[[column]],location_coltypes[column]) + } + } + } + if(nrow(rc) > 1){ + return(data.frame(missing=filename,stringsAsFactors = FALSE)) + } + + old.ncol = ncol(rc) + if(old.ncol == 1){ + return(rc) + } + rc <- rc[,!is.na(colnames(rc))] + rc <- rc[,!(colnames(rc) == "")] + if(ncol(rc) != old.ncol){ + warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) + } + ## rc <- rc %>% mutate(is_public = is_public == 1) + return(rc) +} + +################################################################ +#' @name read_population_csv +#' @title read_population_csv +#' @description This function reads a csv file containing a population +#' file +## args: +#' @param filename A string for the relative or absolute path to the +#' file to be read. The file format is described in the +#' documentation +## vals: +#' @return A \code{data.frame} containing the data from +#' \code{filename} or a single column missing with the filename +#' listed +################################################################ +population_coltypes = c( + TL = "Date", + TR = "Date", + pop = "numeric", + source = "character" +) +read_population_csv = function(filename){ + rc <- read_taxonomy_csv(filename) + for(column in colnames(rc)){ + if(!is.na(population_coltypes[column])){ + if(population_coltypes[column] == "Date"){ + # rc[[column]] <- as.Date(rc[[column]]) + rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) + } else { + rc[[column]] <- as(rc[[column]],population_coltypes[column]) + } + } + } + old.ncol = ncol(rc) + if(old.ncol == 1){ + return(rc) + } + rc <- rc[,!is.na(colnames(rc))] + rc <- rc[,!(colnames(rc) == "")] + if(length(ncol(rc)) == 0){ + browser() + } + if(ncol(rc) != old.ncol){ + warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) + } + + return(rc) +} + +################################################################ +#' @name filter_description_data +#' @title filter_description_data +#' @description This function selects from a data.frame based on user +#' provided filters +## args: +#' @param data A data.frame to filter +#' @param ... As many string arguments as desired. +#' \itemize{ +#' \item "who_region == 'AFR'" +#' \item 'ISO_A1 %in% c("COD","NGA")' +#' \item 'source != "ProMED"' +#' } +#' Each filter is applied sequentially, so only data that matches all +#' filters will be returned. +#' +## vals: +#' @return A data.frame with the filters applied +################################################################ + +filter_description_data = function(data,...){ + ##print(paste('(',paste(...,sep=') &( '),')',sep='')) + if(!missing(...)){ + data = data %>% filter_(paste('(',paste(...,sep=') & ('),')',sep='')) + } + ##print(data) + ##print("finished") + return(data) +} + + +################################################################ +#' @name read_description_taxonomy +#' @title read_description_taxonomy +#' @export read_description_taxonomy +#' @description This function will pull all of the description +#' information. It reads all of the description files, and combines +#' them into a single data.frame +## args: +#' @param taxonomy.directory A string for the path for the directory +#' described above. +#' @param ... A sequence of filters used to filter the description +#' files. See \code{filter_description_data} for details +#' @param uids A vector of uids to read the description files for. +#' This parameter is optional. If missing, this function will read +#' all present uids. +## vals: +#' @return A data.frame containing the data read from the directory +#' \code{taxonomy.directory} filtered by the filters \code{...} +################################################################ +read_description_taxonomy = function(taxonomy.directory,...,uids){ + if(!missing(uids)){ + all.description.files = paste("CHOLERA",uids,"_DESC.csv",sep='') + stop("The argument uids is not yet implemented") + } else { + all.description.files = list.files( + paste(taxonomy.directory,"Description",sep='/'), + no..=TRUE, + recursive = TRUE, + include.dirs=FALSE + ) + } + all.description.files = lapply( + all.description.files, + function(file){ + paste(taxonomy.directory,"Description",file,sep='/') + } + ) + + ##Read all of the data from our description files, and turn them + ## into a single data.table + all.description.data = lapply( + all.description.files, + function(file){ + read_description_csv(file) + } + ) + ##This next line makes sure the files close after reading. + # closeAllConnections() + all.description.data = bind_rows(all.description.data) + ##This next line ensures that we treat uid as an integer + all.description.data = all.description.data %>% + #' @importFrom dplyr mutate + mutate(uid = as.integer(uid)) + ##We now select only the data we want from the description.data + all.description.data = filter_description_data( + all.description.data, + ... + ) +} + + +################################################################ +#' @name read_epi_taxonomy +#' @title read_epi_taxonomy +#' @export read_epi_taxonomy +#' @description This function will pull all of the epi case +#' information. It reads all of the epi files, and combines them +#' into a single data.frame +## args: +#' @param taxonomy.directory A string for the path for the directory +#' described above. +#' @param columns From the final data, which columns to select before +#' returning the data. +#' @param uids A vector of uids to read the description files for. +#' This parameter is optional. If missing, this function will read +#' all present uids. +#' @return A data.frame containing the specified data read from the +#' directory \code{taxonomy.directory} filtered by the filters +#' \code{...} +################################################################ +read_epi_taxonomy = function(taxonomy.directory,uids,verbose=FALSE){ + if(!missing(uids)){ + ##This will need to account for public and private somehow + public.dir <- paste(taxonomy.directory,"EpiCurves","Public",sep='/') + private.dir <- paste(taxonomy.directory,"EpiCurves","Restricted",sep='/') + all.epi.files = paste("CHOLERA",uids,"_EPI.csv",sep='') + public.files = list.files(public.dir)[list.files(public.dir) %in% all.epi.files] + private.files = list.files(private.dir)[list.files(private.dir) %in% all.epi.files] + missing.files = all.epi.files[!(all.epi.files %in% c(public.files,private.files))] + if(verbose){ + warning("There are", length(missing.files), "missing.") + } + all.epi.files = c(paste("Public",public.files,sep='/'),paste("Restricted",private.files,sep='/')) + } else { + all.epi.files = list.files( + paste(taxonomy.directory,"EpiCurves",sep='/'), + no..=TRUE, + recursive = TRUE, + include.dirs=FALSE + ) + } + all.epi.files = lapply( + all.epi.files, + function(file){ + paste(taxonomy.directory,"EpiCurves",file,sep='/') + } + ) + + ## check which files are csvs + are_csvs <- sapply(all.epi.files,function(my_file) endsWith(my_file,"csv"),simplify = TRUE) + + all.epi.data = lapply(all.epi.files[are_csvs],read_epi_csv) + all.epi.files = all.epi.files[are_csvs] + # closeAllConnections() + + ##Insert a row into the epi data containing the uid. We need this + ## to join with the description data + all.epi.uids = lapply( + all.epi.files, + function(file){ + unlist(strsplit(file,'_'))[1] + } + ) + all.epi.uids = lapply( + all.epi.uids, + function(uid){ + data.frame(unlist(strsplit(uid,'CHOLERA'))[2],stringsAsFactors = FALSE) + } + ) + ##Consider putting the as.numeric here + for(idx in 1:length(all.epi.uids)){ + all.epi.data[[idx]] = mutate(all.epi.data[[idx]],'uid'=unlist(all.epi.uids[[idx]])) + } + # all.epi.data = mapply( + # uid=all.epi.uids, + # table=all.epi.data, + # function(uid,table){ + # return(mutate(table,'uid'=unlist(uid))) + # } + # ) + ##all.epi.data = Map( + ## function(uid,table){ + ## return(mutate(table,'uid'=unlist(uid))) + ## }, + ## uid=all.epi.uids, + ## table=all.epi.data + ##) + + ##We need to transform our data from a list of data.tables into a + ## single data.table. + all.epi.data = bind_rows(all.epi.data) + all.epi.data = all.epi.data %>% + #' @importFrom dplyr mutate + mutate(uid = as.integer(uid)) + return(all.epi.data) +} + +################################################################ +#' @name read_taxonomy_data +#' @title read_taxonomy_data +#' @export read_taxonomy_data +#' @description This function is the main function in this package. +#' It reads the taxonomy files from the filesystem, and combines +#' them all into a single data.frame +## args: +#' @param taxonomy.directory A string for the path for the directory +#' described above. +#' @param columns From the final data, which columns to select before +#' returning the data. +#' @param ... A sequence of filters used to filter the description +#' files. See \code{filter_description_data} for details +## vals: +#' @return A data.frame containing the specified \code{columns} of the +#' data read from the directory \code{taxonomy.directory} filtered +#' by the filters \code{...} +################################################################ +read_taxonomy_data = function( + taxonomy.directory = 'taxonomy-verified', + columns=NULL, + ... +){ + ##Start by getting lists of all of the appropriate description files + ## Everything else will depend on description files, so there's no + ## need to get the other files yet + all.description.data <- read_description_taxonomy( + taxonomy.directory = taxonomy.directory, + ... + ) + + ##Get relevent uids + relevent_uids = unique(all.description.data$uid) + + ##Now we do the same thing for the epi files + ##Read all of the data from our epi files + + all.epi.data <- read_epi_taxonomy( + taxonomy.directory = taxonomy.directory, + uids = relevent_uids + ) + + ##Now we join all the epi files together + join.columns = c('uid') + all.data = inner_join( + all.description.data, + all.epi.data, + by = setNames(join.columns,join.columns) + ) + + names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = + gsub( + '\\.x$', + '.desc', + names(all.data)[ grepl(pattern='\\.x$',names(all.data))] + ) + + names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = + gsub( + '\\.y$', + '', + names(all.data)[ grepl(pattern='\\.y$',names(all.data))] + ) + + ##Fix this to use all available ISO levels + all.locations = data.frame( + data = apply( + # select_(all.data,.dots = c("who_region","ISO_A1",sort(names(all.data)[(!endsWith(names(all.data),"desc")) & (startsWith(names(all.data),'ISO_A2'))]))), + select_( + all.data, + .dots = c( + names(all.data)[grepl('^who_region$',names(all.data))], + names(all.data)[grepl('^ISO_A1$',names(all.data))], + sort(names(all.data)[grepl('^ISO_A2_L[1234567890]*$',names(all.data))]) + ) + ), + 1, + function(x){ + gsub('(_NA)+$','',paste(x,collapse='_')) + } + ), + stringsAsFactors = FALSE + ) + + all.locations = all.locations %>% + mutate(location=data) %>% + #' @importFrom dplyr select + select(location) + unique.locations = all.locations %>% + #' @importFrom dplyr group_by + group_by(location) %>% + #' @importFrom dplyr summarize + summarize() + + ##all.locations = lapply(locations,function(...){data.table(location=...)}) + ##all.locations = bind_rows(locations) + all.data = all.data %>% bind_cols(all.locations) + location.description.files = unique.locations %>% + #' @importFrom dplyr mutate + mutate( + location = paste( + taxonomy.directory, + '/Location/', + location, + "_LOC.csv", + sep='' + ) + ) %>% + select(location) + location.population.files = unique.locations %>% + #' @importFrom dplyr mutate + mutate( + location = paste( + taxonomy.directory, + '/Population/', + location, + "_POP.csv", + sep='' + ) + ) %>% + select(location) + + ##So, location population is more complicated, because we need to + ## join on TL,TR... this will likely involve something hard + # closeAllConnections() + ##apply(location.population.files,1,read_taxonomy_csv) + # closeAllConnections() + + if(nrow(location.population.files) > 0){ + location.population.data = apply( + location.population.files, + 1, + function(x){read_population_csv(x[[1]])} + ) + + location.population.data = mapply( + location=unique.locations[[1]], + table=location.population.data, + function(location,table){ + #' @importFrom dplyr mutate + return(mutate(table,'location'=location)) + }, + SIMPLIFY = FALSE + ) + + location.population.data = bind_rows(location.population.data) + + ##Consider doing something smarter here. + join.columns = c("location","TL","TR"); + join.columns = join.columns[join.columns %in% colnames(all.data)] + join.columns = join.columns[ + join.columns %in% colnames(location.population.data) + ] + + all.data = all.data %>% + left_join(location.population.data,by=join.columns) + names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = + gsub( + '\\.y$', + '.pop', + names(all.data)[ grepl(pattern='\\.y$',names(all.data))] + ) + + names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = + gsub( + '\\.x$', + '', + names(all.data)[ grepl(pattern='\\.x$',names(all.data))] + ) + } + + if(nrow(location.description.files) > 0){ + location.description.data = apply( + location.description.files, + 1, + function(x){ + read_location_csv(x[[1]]) + } + ) + ##This requires location descriptions to only have a single row + location.description.data = bind_rows(location.description.data) + ##locations = bind_rows(all.locations) + location.description.data = location.description.data %>% + bind_cols(unique.locations) + location.description.data = bind_rows(location.description.data) + ##Then we can bind everything together. + join.columns = c("location"); + join.columns = join.columns[join.columns %in% colnames(all.data)] + join.columns = join.columns[ + join.columns %in% colnames(location.description.data) + ] + ##all.data = all.data %>% + ## left_join( + ## location.description.data,by=join.columns,suffix=c('','.loc') + ## ) + all.data = all.data %>% + left_join(location.description.data,by=join.columns) + names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = + gsub( + '\\.y$', + '.loc', + names(all.data)[ grepl(pattern='\\.y$',names(all.data))] + ) + names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = + gsub( + '\\.x$', + '', + names(all.data)[ grepl(pattern='\\.x$',names(all.data))] + ) + } + + + ##Only take the columns which have some amount of data in them. + all.data = select( + all.data, + which(summarise_all(all.data,funs(sum(!is.na(.)))) > 0) + ) + + if((!missing(columns)) && (length(columns) > 0)){ + print(columns) + try( + return(select(all.data,one_of(columns))),silent=TRUE + ) + try( + return(select(all.data,starts_with(columns))),silent=TRUE + ) + warning("Could not find the columns\n",immediate.=TRUE); + } + return(all.data) +} + +################################################################ +#' @name aggregate_taxonomy_data +#' @title aggregate_taxonomy_data +#' @export aggregate_taxonomy_data +#' @description This function groups data by certain fields and sums over places where those fields match. +## args: +#' @param data a \code{tbl_dt(data.frame} containing the data.) +#' @param ISO_level spatial level to aggreate_to. Either 0 for country level, a positive integer for ISO_A2_L?, 'official' to the nearest official shapefile, or Inf, for no aggregation +#' @param temporal_aggregate_time_unit Currently does nothing. Intended to allow for considering observations at multiple time aggregates (or none) +#' @param aggregate_columns which columns to aggregate over. +#' @param time_combine If 'strict', require time periods to match end to end to make an observation. Otherwise, just assume all grouped observations are the same. +#' @param max_overlap In order to shunt cases into one year instead of dividing them, how many days can be removed from a year. +#' @param min_total_length In order to shunt cases into one year instead of dividing them, how many days does an observation need to cover? +#' @param filter_NA_cases Whether or not to remove cases which are NA (as opposed to 0) +#' @return A \code{tbl_dt(data.frame} the aggregated data.) +################################################################ +aggregate_taxonomy_data = function( + data, + ISO_level=2, + temporal_aggregate_time_unit = 'year', + aggregate_columns = 'sCh', + observation=TRUE, + min_total_length = 60, + max_overlap = 8, + filter_NA_cases = TRUE, + time_combine = 'none' +){ + ##Notes: + ####This function does not make observations out of time points quite correctly. In the future we should do the following steps in order: + # a - group the data by by uid and location + # b - combine data at a particular uid/location into time intervals by combining adjacent intervals + # c - ungroup by location, and now group by uid/time interval + # d - combine data at a particular uid/time interval into unions of locations by grouping + # e - track the percent area of the shape covered by the aggregation + # f - Within each time interval, decide whether to collect that interval entirely into a particular time unit based on the length of the whole observation + # g - Aggregate time as decided above, keeping track of the fraction of the year involved and adding cases appropriately. + aggregate_to_start <- time_unit_to_start_function(temporal_aggregate_time_unit) + aggregate_to_end <- time_unit_to_end_function(temporal_aggregate_time_unit) + + + #Filter out NA case values + if(filter_NA_cases){ + data <- data %>% + #' @importFrom dplyr group_by + group_by(uid) %>% + #' @importFrom dplyr filter_ + filter_( + .dots = paste('!is.na(',aggregate_columns,')') + ) + } + if(temporal_aggregate_time_unit == "None"){ + stop("Not yet written") + } + time_change_func = time_unit_to_aggregate_function(temporal_aggregate_time_unit) + ## Aggregate by time: + ###### For now, the grouping columns are all spatial columns, and 'uid'. (This will change once time aggregation is done) + names(aggregate_columns) = NULL + grouping_columns <- c('uid','who_region','ISO_A1',names(data)[grepl('^ISO_A2_L[1234567890]*$',names(data))]) + ###### Remove columns we don't want to deal with. This could be changed into an option later. And should get moved to the end + data <- data %>% select_(.dots = c('TL','TR',grouping_columns,aggregate_columns)) + #### Define ttL and ttR, the first and last time unit the observation covers. + data %>% + group_by_(.dots=c('TL','TR',grouping_columns)) %>% + #importFrom dplyr summarize_ + summarize_(.dots = setNames( + paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), + aggregate_columns + )) %>% + ungroup %>% + group_by_(.dots=c('TL','TR',grouping_columns)) %>% + mutate( + ttL = time_change_func(TL), + ttR = time_change_func(TR) + ) %>% + ungroup -> + data + #### Divide into single time unit and multiple time unit observations + data_single_year = data %>% filter(ttL == ttR) + data_multi_year = data %>% filter(ttL != ttR) + #### Allocate the multiple time unit observations into one observation per time unit + if(nrow(data_multi_year) > 0){ + data_multi_year %>% + #' @importFrom dplyr group_by_ + group_by_(.dots = c('TL','TR','ttL','ttR',grouping_columns)) %>% + do({ + # if(length(.$ttL) != 1){stop("Impossible")} + # if(length(.$ttR) != 1){stop("Impossible")} + if(any(is.na(c(.$ttL,.$ttR)))){ + browser() + } + if(length(.$ttL) > 1){ browser()} + tmp <- data.frame(t = .$ttL:.$ttR) + # if((nrow(tmp) > 1) & (!is.na(.$sCh)) &(any(.$sCh > 0))){browser()} + tmp$TL = if_else(aggregate_to_start(tmp$t) > .$TL,aggregate_to_start(tmp$t),.$TL) + tmp$TR = if_else(aggregate_to_end(tmp$t) < .$TR,aggregate_to_end(tmp$t),.$TR) + if(!all(tmp$TL <= tmp$TR)){browser()} + #### tfrac is the proportion of the this time unit this observation covers + tmp$tfrac = (as.numeric((tmp$TR - tmp$TL),'days')+1)/(as.numeric((aggregate_to_end(tmp$t) - aggregate_to_start(tmp$t)),'days') + 1) + #### tdur is the duration of the observation within the time unit + tmp$tdur = (as.numeric((tmp$TR - tmp$TL),'days')+1) + #### tprop is the proporition of the observation within this time unit + tmp$tprop = (as.numeric((tmp$TR - tmp$TL),'days')+1)/(as.numeric((.$TR - .$TL),'days') + 1) + ## This is to adjust so that single day periods get kept with the rest of their observation if that observation is at least a week long. + ## First find the number of points where the first and last day are the same + tmp$t = .$ttL + tmp[[aggregate_columns]] = diff(c(0,round(cumsum(.[[aggregate_columns]] * tmp$tprop)))) + tmp$obs_TL = .$TL + tmp$obs_TR = .$TR + tmp + }) %>% + ungroup() %>% + select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> + data_multi_year + } + + #### Make the single time unit data have the same info as the multi time unit + if(nrow(data_single_year) > 0){ + data_single_year %>% + #' @importFrom dplyr group_by_ + mutate( + t = ttL, + obs_TL = TL, + obs_TR = TR, + tfrac = (as.numeric((TR - TL),'days')+1)/(as.numeric((aggregate_to_end(t) - aggregate_to_start(t)),'days') + 1), + #### tdur is the duration of the observation within the time unit + tdur = as.numeric(TR-TL,'days') + 1, + #### tprop is the proporition of the observation within this time unit + tprop = 1 + ) %>% + ungroup() %>% + select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> + data_single_year + } + + #### Recombine + #' @importFrom dplyr bind_rows + data = bind_rows(data_single_year,data_multi_year) + + #### Group data together by time year + ###### Note that this fails when the time units don't work out + if(!filter_NA_cases){ + warning( + "This does not work right now. Building time units does not account for suspected vs deaths reports" + ) + } + + if(time_combine == 'strict'){ + data %>% + #' @importFrom dplyr ungroup + ungroup() %>% + #' @importFrom dplyr group_by_ + group_by_(.dots = grouping_columns) %>% + do({ + changed = TRUE + new = . + new$tmp_obs_TL = new$obs_TL + new$tmp_obs_TR = new$obs_TR + iter = 0 + #### Connect greedily until no more reports are left to connect + while(changed){ + old = new + iter = iter + 1 + # print(iter) + total_idx = length(which(new$obs_TL %in% (new$obs_TR + 1))) + if(total_idx>0){ + for(idx1 in which(new$obs_TL %in% (new$TR + 1))){ + # print(paste(idx1,'/',total_idx)) + if(length(which(new$obs_TL[idx1] == (new$TR+1)) ) <= 0){stop("Bad")} + idx2 = which(new$obs_TL[idx1] == (new$TR+1)) + new$tmp_obs_TL[idx1] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx1]) + new$tmp_obs_TL[idx2] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx2]) + new$tmp_obs_TR[idx2] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx2]) + new$tmp_obs_TR[idx1] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx1]) + } + } + total_idx = length(which(new$obs_TR %in% (new$TL - 1))) + if(total_idx > 0){ + for(idx1 in which(new$obs_TR %in% (new$TL - 1))){ + # print(paste(idx1,'/',total_idx)) + if(length(which(new$obs_TR[idx1] == (new$TL-1)) ) <= 0){browser()} + idx2 = which(new$obs_TR[idx1] == (new$TL - 1)) + # if(length(unique(new$tmp_obs_TL[idx2])) > 1){browser()} + # if(length(unique(new$tmp_obs_TR[idx2])) > 1){browser()} + new$tmp_obs_TL[idx1] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx1]) + new$tmp_obs_TL[idx2] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx2]) + new$tmp_obs_TR[idx2] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx2]) + new$tmp_obs_TR[idx1] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx1]) + } + new$obs_TL = new$tmp_obs_TL + new$obs_TR = new$tmp_obs_TR + } + if(isTRUE(all.equal(old,new))){ + changed = FALSE + } + } + if(any(.$obs_TL < new$obs_TL)){ + browser() + } + new + }) -> + data + } else if(time_combine == 'unstrict'){ + + data %>% + #' @importFrom dplyr ungroup + ungroup() %>% + #' @importFrom dplyr group_by_ + group_by_(.dots = grouping_columns) %>% + mutate( + obs_TL = min(TL), + obs_TR = max(TR), + TL = ymd(mapply(lhs = obs_TL, rhs = aggregate_to_start(t),function(lhs,rhs){paste(max(c(lhs,rhs)))})), + TR = ymd(mapply(lhs = obs_TR, rhs = aggregate_to_end(t),function(lhs,rhs){paste(min(c(lhs,rhs)))})), + obs_t = ymd(mapply(tl = obs_TL,tr = obs_TR,function(tl,tr){paste(mean(c(tl,tr)))})), + tdur = TR-TL + 1, + obs_tdur = obs_TR - obs_TL + 1 + ) %>% + mutate( + t = ifelse( + (tdur < max_overlap) & (obs_tdur > min_total_length), + t + (t < obs_t) - (t > obs_t), + t + ) + ) -> data + } else if(time_combine == 'none') { + + } else { + stop("time_combine must be one of 'strict', 'unstrict', or 'none'") + } + + #### Now that we have time units properly done, t becomes a grouping column. + grouping_columns = c(grouping_columns,'t') + + #### We now need to move partial time units to the rest of their report if they meet the criteria given by + #### max_overlap and min_total_length + data %>% + group_by_(.dots=c(grouping_columns,'obs_TL','obs_TR')) %>% + summarize_( + .dots = setNames( + c('min(TL)','max(TR)',paste('sum(',aggregate_columns,')')), + c("TL","TR",aggregate_columns) + ) + ) %>% + ungroup %>% + group_by_(.dots = grouping_columns) %>% + mutate( + tdur = TR - TL + 1, + obs_tdur = obs_TR - obs_TL + 1, + #' @importFrom lubridate ymd + obs_t = time_change_func(ymd(mapply(tl=obs_TL,tr=obs_TR,function(tl,tr){paste(mean(c(tl,tr)))}))) + ) -> data + + #### Do the adjustments only if the criterion are met + data %>% + ungroup() %>% + mutate( + t = ifelse( + (obs_t == t) | (obs_tdur < min_total_length) | (tdur > max_overlap), + t, + ifelse( + obs_t > t, + t+1, + t-1 + ) + ) + ) %>% + group_by_(.dots=grouping_columns) %>% + summarize_(.dots = setNames( + paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), + aggregate_columns + )) -> + data + + ## Time aggregation is finished + ## Starting Spatial Aggregation + data$iso_level = apply(!is.na(data[,grepl('ISO_A',colnames(data))]),1,sum) + + #### Picking which spatial columns to aggregate on based on input: + if(is.null(ISO_level)){ + grouping_columns = c('uid','t') + } else if(ISO_level == 'oficial'){ + data %>% + ungroup %>% + mutate( + ISO_A2_L1 = ifelse( + (isISO_A2_L1 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), + ISO_A2_L1, + NA + ), + ISO_A2_L2 = ifelse( + (isISO_A2_L2 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), + ISO_A2_L2, + NA + ), + ISO_A2_L3 = ifelse( + (isISO_A2_L3 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), + ISO_A2_L3, + NA + ), + ISO_A2_L4 = ifelse( + (isISO_A2_L4 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), + ISO_A2_L4, + NA + ), + ISO_A2_L5 = ifelse( + (isISO_A2_L5 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), + ISO_A2_L5, + NA + ) + ) -> + tmp + } else if (ISO_level == 0){ + grouping_columns <- c('uid','t','who_region','ISO_A1') + } else if(is.finite(ISO_level)){ + grouping_columns <- c('uid','t','who_region','ISO_A1',paste("ISO_A2_L",1:ISO_level,sep='')) + } else { + grouping_columns <- c('uid','t','who_region','ISO_A1',names(data)[grep('^ISO_A2_L[1234567890]*$',names(data))]) + } + if(!all(grouping_columns %in% names(data))){ + warning("Not all grouping columns are present in case data") + grouping_columns = grouping_columns[grouping_columns %in% names(data)] + } + warning("In the process of modifying this function.") + browser() + data %>% + group_by_(.dots=grouping_columns) %>% + do({ + tmp = . + tmp$iso_level = list(unique(.$iso_level)) + tmp$max_iso_level = min(c(max(.$iso_level),.$iso_level)) + }) + summarize(iso_level = list(unique(iso_level))) + ## Final Aggregation + #### We have everything done, so its just a group_by and a summarize from here + data %>% + ungroup() %>% group_by_(.dots=grouping_columns) %>% + summarize_(.dots = setNames( + paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), + aggregate_columns + )) -> + rc + return(rc) +} + +#' @export +#' @name case_definition_to_column_name +#' @title case_definition_to_column_name +#' @description Turns human readable types of cholera case definitions into taxdat codes +#' @param type string of type +#' @param database Whether or not we're using the database +#' @return string of column names in the data taxonomy data frame. +case_definition_to_column_name = function(type,database=FALSE,sql=FALSE){ + if((!database) & (!sql)){ + warning("The svn column names are deprecated, please use database column names.") + changer <- c( + 'suspected' = 'sCh', + 'confirmed' = 'cCh', + "presence"=c("sCh","sCh_R","sCh_L","cCh","cCh_L","cCh_R","deaths","deaths_L","deaths_R") + ) + } else if((database) & (!sql)){ + changer <- c( + 'suspected' = 'attributes.fields.suspected_cases', + 'confirmed' = 'attributes.fields.confirmed_cases', + "presence"=c( + "attributes.fields.suspected_cases", + "attributes.fields.suspected_cases_R", + "attributes.fields.suspected_cases_L", + "attributes.fields.confirmed_cases", + "attributes.fields.confirmed_cases_L", + "attributes.fields.confirmed_cases_R", + "attributes.fields.deaths", + "attributes.fields.deaths_L", + "attributes.fields.deaths_R" + ) + ) + } else if((!database) & (sql)){ + changer <- c( + "suspected" = "suspected_cases", + "confirmed" = "confirmed_cases", + "presence"=c( + "suspected_cases", + "suspected_cases_R", + "suspected_cases_L", + "confirmed_cases", + "confirmed_cases_L", + "confirmed_cases_R", + "deaths", + "deaths_L", + "deaths_R" + ) + ) + } + return(changer[type]) +} + +#' @export +#' @name time_unit_to_start_function +#' @title time_unit_to_start_function +#' @description Turns human readable time units into a functions that convert time units to the start of the time unit +#' @param type string of type +#' @return function to convert dates to the right thing +time_unit_to_start_function <- function(unit){ + + # Remove the 's' at the end of the unit + unit <- gsub("s$", "", unit) + + changer = list( + 'year' = function(x){ + return(as.Date(paste(x,'01','01',sep='-'),format='%Y-%m-%d')) + }, + 'isoweek' = function(x){return(stop("Not yet written"))} + ) + return(changer[[unit]]) +} + +#' @export +#' @name time_unit_to_end_function +#' @title time_unit_to_end_function +#' @description Turns human readable time units into a functions that convert time units to the end of the time unit +#' @param type string of type +#' @return function to convert dates to the right thing +time_unit_to_end_function <- function(unit){ + + # Remove the 's' at the end of the unit + unit <- gsub("s$", "", unit) + + changer = list( + 'year' = function(x){ + return(as.Date(paste(x,'12','31',sep='-'),format='%Y-%m-%d')) + }, + 'isoweek' = function(x){return(stop("Not yet written"))} + ) + return(changer[[unit]]) +} +#' @export +#' @name time_unit_to_aggregate_function +#' @title time_unit_to_aggregate_function +#' @description Turns the +#' @param unit Human readable unit of time aggregation +#' @return function to convert dates to the right thing +#' @importFrom lubridate year +time_unit_to_aggregate_function <- function(unit){ + + # Remove the 's' at the end of the unit + unit <- gsub("s$", "", unit) + + changer = list( + 'year' = lubridate::year, + 'isoweek' = function(x){return(stop("Not yet written"))} + ) + return(changer[[unit]]) +} + +## print("Part 1") +## Rprof() +## read_taxonomy_data() +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 2") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns='deaths') +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 3") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns='deaths.x', "who_region == 'AFR'") +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 4") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns='deaths.x', "!(source == 'ProMED')","deaths == '1'") +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 6") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns='ISO_A1','ISO_A1 %in% c("MWI","NGA")') +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 7") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns='pygmy_shrew') +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## print("Part 8") +## Rprof() +## read_taxonomy_data('taxonomy-verified',columns=c("who_region","ISO_A1")) +## Rprof(NULL) +## print(summaryRprof()$sampling.time) +## Rprof() +## test = read_taxonomy_data('taxonomy-working/working-entry1/',columns = c('TL','TR','location','sCh','cCh')) +## Rprof(NULL) +## print(summaryRprof()$sampling.time) + + +## JSON API interface to database +#' @name read_taxonomy_data_database +#' @title read_taxonomy_data_database +#' @export read_taxonomy_data_database +#' @description This function accesses the cholera-taxonomy stored +#' at https://staging.cholera-taxonomy.middle-distance.com pulls +#' data based on function parameters, links it together, and +#' transforms it into a simple features object (sf). +#' @param username The username for a user of the database +#' @param api_key A working api.key for the user of the database +#' @param locations A vector of locations to pull observations from (should be in the form who_region::ISO_L1::ISO_A2_...) +#' @param time_left First time for observations +#' @param time_right Last time for observations +#' @param uids unique observation collections ids to pull +#' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) +#' @return An sf object containing data pulled from the database +read_taxonomy_data_database <- function(username, + api_key, + locations = NULL, + time_left = NULL, + time_right = NULL, + uids = NULL, + website = "https://api.cholera-taxonomy.middle-distance.com/"){ + ## Before we start, I want to explain some weird syntax that will come up: + ## #' @importFrom package function + ## The above line is the preferred way of importing a function from a package. + ## It works in the context of R's autodocumenter (roxygen). + ## It works similarly to the following more sensible code: + ## toJSON = jsonlite::toJSON + ## except that it handles conflicts better by producing a warning, and + ## tells the package about the dependency. + + + ## First, we want to set up the https POST request. + ## We make a list containing the arguments for the request: + ## If the API changes, we will just need to change this list + api_type = "" + if(is.null(uids)){ + api_type = "by_location" + if(length(locations == 1)){ + locations = c(locations,locations) + } + + ## Prevent continents, or too many countries + if(any(!grepl('::',locations))){ + stop("Trying to pull data for a continent is not allowed") + } + #' @importFrom stringr str_count + if((sum(str_count(string = unique(locations),pattern='::') == 1) > 2)){ + stop("Trying to pull data for more than 2 countries at a time is not allowed") + } + + https_post_argument_list = list( + email=username, + api_key=api_key, + locations=gsub('::',' ',locations), + time_left=time_left, + time_right=time_right + ) + } else if(is.null(locations) && is.null(time_left) && is.null(time_right)){ + api_type = "by_observation_collections" + https_post_argument_list = list( + email=username, + api_key=api_key, + observation_collection_ids = uids + ) + } else { + stop("Not supported") + } + + website = paste0(website,"/api/v1/observations/",api_type) + + #' @importFrom jsonlite toJSON + ## Every object in R is a vector, even the primitives. For example, c(1,5,6) is of type + ## integer. Because of this, we need to explicitly tell the JSON parser to treat vectors + ## of length 1 differently. The option for this is auto_unbox = T + json = toJSON(https_post_argument_list,auto_unbox = T) + #' @importFrom httr POST + #' @importFrom httr add_headers + ## Message prints a message to the user. It's somewhere between a warning and a normal print. + ## In this case, this function might take a while to run, so we let the user know up front. + message("Fetching results from JSON API") + + ## This is the line that actually fetches the results. + ## The syntax for adding headers is a little weird. The function add_headers takes named arguments + ## and returns whatever the arguments to POST are supposed to be. + ## body is the body + ## encode is the transformation to perform on the body to make it into text + results = POST( + website, + add_headers("Content-Type" = "application/json"), + body=json, + encode='form', + config(ssl_verifyhost = 0) + ) + + ## Now we process the status code to make sure that things are working correctly + #' @importFrom httr status_code + code = status_code(results) + ## Right now, anything that isn't correct is an error + if(code != 200){ + stop(paste('Error: Status Code',code)) + } + + ## Next we extract just the content of the results + #' @importFrom httr content + original_results_data = content(results) + ## This returns something correct, but the formatting is really + ## odd. It is a little messy, but instead of debugging the + ## formatting, for now I'm converting to json and back, which + ## fixes the problems. + jsondata = rjson::toJSON(original_results_data) + #' @importFrom jsonlite validate + if(!validate(jsondata)){ + stop("Could not validate json response") + } + #' @importFrom jsonlite fromJSON + results_data = fromJSON(jsondata) + + ## Now we have the results of the api data as a nested list. + ## We want to do the following in no particular order + ## for the observations, we want to turn them into a data frame + ## with one row per observation for the location_periods, we want + ## to turn them into a geometry object and link them to the + ## observations + + ## We start with the observations + if( # The | operator is logical or + (!("observations" %in% names(results_data))) | # The results should have observations + (!("data" %in% names(results_data[['observations']]))) | # The observations should have data + (length(results_data[['observations']]) > 1) # The data should be the only thing in observations + ){ + stop("Could not parse results properly. Contact package maintainer") + } + results_data[['observations']] = results_data[['observations']][['data']] + ## jsonlite's flatten + #' @importFrom jsonlite flatten + if(!is.data.frame(results_data[['observations']])){ + results_data[['observations']] = as.data.frame(results_data[['observations']]) + } + results_data[['observations']] = flatten(results_data[['observations']]) + + observation_collections_present <- FALSE + if( + ("observation_collections" %in% names(results_data)) && # The results should have observations + ("data" %in% names(results_data[['observation_collections']])) && # The observations should have data + (length(results_data[['observation_collections']]) == 1) # The data should be the only thing in observations + ){ + results_data[['observation_collections']] = results_data[['observation_collections']][['data']] + if(!is.data.frame(results_data[['observation_collections']])){ + results_data[['observation_collections']] = as.data.frame(results_data[['observation_collections']]) + } + results_data[['observation_collections']] = flatten(results_data[['observation_collections']]) + observation_collections_present <- TRUE + } + + ## Check to make sure that the number of ids and number of rows match + if(!length(unique(results_data$observations$id)) == nrow(results_data$observations)){ + stop("Could not parse results properly. Contact package maintainer") + } + + ## Now we want to handle the location periods + ## We need to process these individually, so we'll loop over + ## location periods to extract the geojsons + ## We use the original_results_data here, since the formatting + ## transformation we did earlier prevents this code from working + tmp_results = original_results_data[['location_periods']][['data']] + all_locations = list() # This will be a list of the geojson objects + if(length(tmp_results) > 0){ + for(idx in 1:length(tmp_results)){ + ## We process the geojson in three pieces. + ## 1. Convert to json string + ## 2. Convert to sf object + ## 3. Add to location list + message(paste(idx,'/',length(tmp_results))) + ## Ignore NULL elements. Undefined list elements default to + ## NULL anyway + if(is.null(tmp_results[[idx]]$attributes$geojson)){ + all_locations[[idx]] = st_sf(geometry = st_sfc(st_point())) + next; + } + unformatted_geojson = tmp_results[[idx]][['attributes']][['geojson']] + json_geojson = jsonlite::toJSON(unformatted_geojson,auto_unbox = TRUE) # 1. + sf_geojson = geojsonsf::geojson_sf(json_geojson) # 2. + all_locations[[idx]] = sf_geojson #3. + } + } + ## reduce_sf_vector turns a list of sf objects into a single sf + ## object containing the same information + locations_sf = taxdat::reduce_sf_vector(all_locations) + ## We are going to take our properly formatted geojson files and + ## replace the badly formatted ones + results_data$location_periods$data$geojson = NULL + results_data$location_periods$data$attributes$geojson = NULL + if(!is.data.frame(results_data$location_periods$data)){ + results_data$location_periods$data <- as.data.frame(results_data$location_periods$data) + } + results_data$location_periods = flatten(results_data$location_periods$data) + if(nrow(results_data$location_periods) > 0){ + results_data$location_periods$sf_id = 1:nrow(results_data$location_periods) + } + results_data$observations$attributes.location_period_id = as(results_data$observations$attributes.location_period_id,class(results_data$location_periods$id)) + + ## We then join (as in sql) by the location_periods with the + ## observations by location_period_id + all_results <- results_data$observations + if( + observation_collections_present && + (nrow(all_results) > 0) && + (nrow(results_data$observation_collections) > 0) + ){ + all_results <- dplyr::left_join( + results_data$observations, + results_data$observation_collections, + by=c( + 'relationships.observation_collection.data.id' = 'id' # lhs column name = rhs column name + ) + ) + } + if( + (nrow(all_results) > 0) && + (nrow(results_data$location_periods) > 0) + ){ + all_results = dplyr::left_join( + all_results, + results_data$location_periods, + by=c( + 'attributes.location_period_id' = 'id' # lhs column name = rhs column name + ) + ) + } + + geoinput <- st_sf(geometry=st_sfc(st_point(1.*c(NA,NA))))$geometry + if(nrow(all_results) == 0){ + geoinput <- geoinput[0] + } + all_results$geojson = geoinput + all_results$geojson[!is.na(all_results$sf_id)] = locations_sf$geometry[all_results[!is.na(all_results$sf_id),][['sf_id']] ] + return(sf::st_sf(all_results,sf_column_name = 'geojson')) +} + +#' @title Pull taxonomy data +#' @description Pulls data from the taxonomy database +#' +#' @param username taxonomy username +#' @param api_key A working api.key for the user of the database +#' @param password taxonomy password +#' @param locations list of locations to pull. For now this only supports country ISO codes. +#' @param time_left left bound for observation times (in date format) +#' @param time_right right bound for observation times (in date format) +#' @param uids list of unique observation collection ids to pull +#' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) +#' @param source whether to pull data from the website or using sql on idmodeling2. +#' Needs to be one of 'api' or 'sql'. +#' +#' @details This is a wrapper which calls either read_taxonomy_data_database or +#' read_taxonomy_data_sql depending on the source that the user specifies. +#' @return An sf object containing data pulled from the database +#' @export +pull_taxonomy_data <- function(username, + password, + locations = NULL, + time_left = NULL, + time_right = NULL, + uids = NULL, + website = "https://api.cholera-taxonomy.middle-distance.com/", + source) { + + if (missing(source) | is.null(source)) + stop("No source specified to pull taxonomy data, please specify one of 'api' or 'sql'.") + + if (source == 'api') { + if (missing(username) | missing(password) | is.null(username) | is.null(password)) + stop("Trying to pull data from API, please provide username and api_key.") + + # Return API data pull + rc <- read_taxonomy_data_database(username = username, + api_key = password, + locations = locations, + time_left = time_left, + time_right = time_right, + uids = uids, + website = website) + + } else if (source == 'sql') { + if (missing(username) | missing(password) | is.null(username) | is.null(password)) + stop("Trying to pull data using sql on idemodelin2, please provide database username and password.") + + # Return SQL data pull + rc <- read_taxonomy_data_sql(username = username, + password = password, + locations = locations, + time_left = time_left, + time_right = time_right, + uids = uids) + rc$attributes.fields.suspected_cases <- rc$suspected_cases + rc$attributes.fields.confirmed_cases <- rc$confirmed_cases + rc$attributes.fields.location_id <- rc$location_id + rc$attributes.location_period_id <- rc$location_period_id + + } else { + stop("Parameter 'source' needs to be one of 'api' or 'sql'.") + } + + if(nrow(rc) == 0) { + if (!is.null(uids)) { + err_mssg <- paste("in uids", paste(uids, collapse = ",")) + } else if (!is.null(locations)) { + err_mssg <- paste("in locations", paste(locations, collapse = ",")) + } else { + err_mssg <- "" + } + stop("Didn't find any data ", err_mssg, " in time range [", + ifelse(is.null(time_left), "-Inf", as.character(time_left)), " - ", + ifelse(is.null(time_right), "-nf", as.character(time_right)), "]") + } + return(rc) +} + +#' @title Taxonomy SQL data pull +#' @description Extracts data for a given set of country using SQL from the taxonomy +#' postgresql database stored on idmodeling2 +#' +#' @param username taxonomy username +#' @param password taxonomy password +#' @param locations list of locations to pull. For now this only supports country ISO codes. +#' @param time_left left bound for observation times (in date format) +#' @param time_right right bound for observation times (in date format) +#' @param uids list of unique observation collection ids to pull +#' +#' @details Code follows taxdat::read_taxonomy_data_database template. +#' @return An sf object containing data extracted from the database +#' @export +read_taxonomy_data_sql <- function(username, + password, + locations = NULL, + time_left = NULL, + time_right = NULL, + uids = NULL) { + + if (missing(username) | missing(password)) + stop("Please provide username and password to connect to the taxonomy database.") + + # Connect to database + conn <- RPostgres::dbConnect(RPostgres::Postgres(), + host = "db.cholera-taxonomy.middle-distance.com", + dbname = "CholeraTaxonomy_production", + user = username, + password = password, + port = "5432") + + # Build query for observations + obs_query <- paste("SELECT observations.id::text, observations.observation_collection_id::text, observations.time_left, observations.time_right,", + "observations.suspected_cases, observations.confirmed_cases, observations.deaths, observations.location_period_id::text, observations.location_id::text,", + "observations.phantom, observations.primary + FROM observations left join location_hierarchies on observations.location_id = location_hierarchies.descendant_id") + + cat("-- Pulling data from taxonomy database with SQL \n") + + # Add filters + if (any(c(!is.null(locations), + !is.null(time_left), + !is.null(time_right), + !is.null(uids)))) { + obs_query <- paste(obs_query, "\n WHERE ") + } else { + warning("No filters specified on data pull, pulling all data.") + } + + if (!is.null(time_left)) { + time_left_filter <- paste0("time_left >= '", format(time_left, "%Y-%m-%d"), "'") + } else { + time_left_filter <- NULL + } + + if (!is.null(time_right)) { + time_right_filter <- paste0("time_right <= '", format(time_right, "%Y-%m-%d"), "'") + } else { + time_right_filter <- NULL + } + + if (!is.null(locations)) { + if(all(is.numeric(locations))){ + locations_filter <- paste0("ancestor_id in ({locations*})") + } else { + stop("SQL access by location name is not yet implemented") + } + } else { + locations_filter <- NULL + } + + if (!is.null(uids)) { + uids_filter <- paste0("observation_collection_id IN ({uids*})") + } else { + uids_filter <- NULL + } + + # Combine filters + filters <- c(time_left_filter, time_right_filter, + locations_filter, uids_filter) %>% + paste(collapse = " AND ") + + # Run query for observations + obs_query <- glue::glue_sql(paste(obs_query, filters, ";"), .con = conn) + observations <- DBI::dbGetQuery(conn = conn, obs_query) + if(nrow(observations) == 0){ + stop(paste0("No observations found using query ||",obs_query,"||")) + } + + # Pull location_periods + u_lps <- unique(observations$location_period_id) # unique location period ids + u_lps <- u_lps[!is.na(u_lps)] + if(all(u_lps == as.numeric(u_lps))){ + u_lps <- as.numeric(u_lps) + } else { + stop("Location period id exceeds max integer in R, and glue doesn't work on int64s") + } + lp_query <- glue::glue_sql("SELECT id as location_period_id, geojson FROM location_periods + WHERE id IN ({u_lps*});", .con = conn) + location_periods <- DBI::dbGetQuery(conn = conn, lp_query) + + # Get missing geometries + location_period_issues <- location_periods %>% + filter(is.na(geojson) | geojson == "{}") + + # Get unique valid geojsons + location_periods <- location_periods %>% + filter(!is.na(geojson), geojson != "{}") %>% + group_by(location_period_id) %>% + slice(1) + + # Convert to sf object + location_periods.sf <- purrr::map(location_periods$geojson, ~try(geojsonsf::geojson_sf(.), silent = F)) + + # Get errors + errors <- purrr::map2(location_periods.sf, seq_along(location_periods.sf), ~ if (inherits(.x, "try-error")) .y) %>% + unlist() + if (length(errors) > 0) { + cat("Found unreadable geojson for location periods:", str_c(errors, collapse = ", ")) + location_periods.sf <- location_periods.sf[-errors] + location_periods <- location_periods[-errors, ] + } + + # extract geometries and metadata + location_periods.sf <- do.call(rbind, location_periods.sf) %>% + mutate(location_period_id = location_periods$location_period_id, + location_name = purrr::map_chr(location_periods$geojson, ~ jsonlite::parse_json(.)[["name"]] %>% + ifelse(is.null(.), NA, .)), + times = ifelse(is.na(location_name), NA, str_extract(location_name, "([0-9]{4}-[0-9]{2}-[0-9]{2}_[0-9]{4}-[0-9]{2}-[0-9]{2})")), + location_name = ifelse(is.na(location_name), NA, str_replace_all(str_replace(location_name, str_c("_", times, "_SHP"), ""), "_", "::")) + ) %>% + select(-times) %>% + rename(geojson = geometry) + + # Combine observations and geojsons + res <- right_join(location_periods.sf, observations, by = "location_period_id") + + return(res) +} From 91f7a1eb208f47932d3f7235e14573b41b674280 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:17:31 +0200 Subject: [PATCH 16/69] add rjson to library loads --- analysis/utils.R | 1 + 1 file changed, 1 insertion(+) diff --git a/analysis/utils.R b/analysis/utils.R index ff97788..71c0208 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -178,6 +178,7 @@ rename_database_fields <- function(database_df, #' @import methods dplyr library(methods) library(dplyr) +library(rjson) ################################################################ ######################Taxonomy Data Parser###################### ################################################################ From 925f664d4ce09b48e5c562580df53afce817096c Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:20:04 +0200 Subject: [PATCH 17/69] replace rjson with jsonlite --- analysis/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/utils.R b/analysis/utils.R index 71c0208..68bdc67 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -178,7 +178,7 @@ rename_database_fields <- function(database_df, #' @import methods dplyr library(methods) library(dplyr) -library(rjson) +library(jsonlite) ################################################################ ######################Taxonomy Data Parser###################### ################################################################ From 70f1fa8e5b92dcaaaa9a2cb0c88d86dae3e7d3b5 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 12:21:34 +0200 Subject: [PATCH 18/69] add missing packages --- analysis/utils.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/analysis/utils.R b/analysis/utils.R index 68bdc67..12ba966 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -179,6 +179,10 @@ rename_database_fields <- function(database_df, library(methods) library(dplyr) library(jsonlite) +library(httr) +library(lubridate) +library(stringr) + ################################################################ ######################Taxonomy Data Parser###################### ################################################################ From b1d80465457ef17c815ae94697e8efc40e4d8cc5 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 13:59:35 +0200 Subject: [PATCH 19/69] add WorldPop population estimation to Stage 1 pipeline - R/add_population.R: new exported add_population() function; groups LPs by year and loads each WorldPop raster once, running two vectorized exact_extract calls (adj-factor + all LPs) rather than 2N per-LP loads that would result from calling get_pop() in a loop - analysis/01_pull_data.R: call add_population() after fill_missing_lps(), before writing to parquet; fixes missing pop column consumed by get_outbreak_threshold() and identify_epidemic_start() - analysis/config_defaults.yml: add raster_dir key for WorldPop cache path - analysis/bash/install_r_packages.sh: update module load to GCC/12.3.0 + R/4.3.2, add rgeoboundaries, ISOcodes, readr, reshape2; fix taxdat GitHub path and pin Matrix version - analysis/utils.R: whitespace cleanup; fix length(locations == 1) -> length(locations) == 1 parenthesis bug in read_taxonomy_data_database() Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 2 +- analysis/bash/install_r_packages.sh | 16 +- analysis/utils.R | 243 ++++++++++++++-------------- 3 files changed, 134 insertions(+), 127 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index e076c93..68d9503 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -70,7 +70,7 @@ location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -raw_sf <- pull_taxonomy_data( +raw_sf <- taxdat::pull_taxonomy_data( username = api_user, password = api_key, locations = location_str, diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh index 902dc9c..64838dd 100755 --- a/analysis/bash/install_r_packages.sh +++ b/analysis/bash/install_r_packages.sh @@ -10,16 +10,15 @@ # - All DESCRIPTION Imports + analysis-layer Suggests (from CRAN) # - taxdat (from GitHub: HopkinsIDD/cholera-taxonomy) # - OutbreakExtractR itself (from the current directory) -# -# Before running, verify the libdeflate module name for your cluster: -# module spider libdeflate -# Then set LIBDEFLATE_MODULE below to the version matching GCCcore-11.3.0. +# +# !! This takes a while to complete + set -euo pipefail # --------------------------------------------------------------------------- -# Modules — toolchain must match R/4.2.1-foss-2022a (built with GCCcore-11.3.0) +# Modules — toolchain # --------------------------------------------------------------------------- module purge module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 CMake @@ -54,6 +53,9 @@ pkgs <- c( "yaml", "optparse", "here", "arrow", "sfarrow", "furrr", "future", + + # for taxdat + "ISOcodes", "readr", "reshape2", # dev / testing "testthat", "remotes" @@ -71,8 +73,10 @@ if (length(missing_pkgs) > 0) { # ---- taxdat (private GitHub package) --------------------------------------- if (!"taxdat" %in% rownames(installed.packages())) { +# NOTE: Needed to rebuild the documentation rm -rf man/ NAMESPACE && Rscript -e "devtools::document()" message("Installing taxdat from GitHub (HopkinsIDD/cholera-taxonomy) ...") - remotes::install_github("HopkinsIDD/cholera-taxonomy", upgrade = "never") + remotes::install_version("Matrix", version = "1.6-5", repos = "https://cran.r-project.org") + remotes::install_github("HopkinsIDD/cholera-taxonomy/packages/taxdat", upgrade = "never") } else { message("taxdat already installed.") } diff --git a/analysis/utils.R b/analysis/utils.R index 12ba966..96e8a4f 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -469,7 +469,7 @@ read_description_csv = function(filename){ rc[[column]] <- as(rc[[column]],description_coltypes[column]) } } - + } old.ncol = ncol(rc) if(old.ncol == 1){ @@ -618,7 +618,7 @@ read_location_csv = function(filename){ if(nrow(rc) > 1){ return(data.frame(missing=filename,stringsAsFactors = FALSE)) } - + old.ncol = ncol(rc) if(old.ncol == 1){ return(rc) @@ -676,7 +676,7 @@ read_population_csv = function(filename){ if(ncol(rc) != old.ncol){ warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) } - + return(rc) } @@ -748,7 +748,7 @@ read_description_taxonomy = function(taxonomy.directory,...,uids){ paste(taxonomy.directory,"Description",file,sep='/') } ) - + ##Read all of the data from our description files, and turn them ## into a single data.table all.description.data = lapply( @@ -818,14 +818,14 @@ read_epi_taxonomy = function(taxonomy.directory,uids,verbose=FALSE){ paste(taxonomy.directory,"EpiCurves",file,sep='/') } ) - + ## check which files are csvs are_csvs <- sapply(all.epi.files,function(my_file) endsWith(my_file,"csv"),simplify = TRUE) - + all.epi.data = lapply(all.epi.files[are_csvs],read_epi_csv) all.epi.files = all.epi.files[are_csvs] # closeAllConnections() - + ##Insert a row into the epi data containing the uid. We need this ## to join with the description data all.epi.uids = lapply( @@ -858,7 +858,7 @@ read_epi_taxonomy = function(taxonomy.directory,uids,verbose=FALSE){ ## uid=all.epi.uids, ## table=all.epi.data ##) - + ##We need to transform our data from a list of data.tables into a ## single data.table. all.epi.data = bind_rows(all.epi.data) @@ -899,18 +899,18 @@ read_taxonomy_data = function( taxonomy.directory = taxonomy.directory, ... ) - + ##Get relevent uids relevent_uids = unique(all.description.data$uid) - + ##Now we do the same thing for the epi files ##Read all of the data from our epi files - + all.epi.data <- read_epi_taxonomy( taxonomy.directory = taxonomy.directory, uids = relevent_uids ) - + ##Now we join all the epi files together join.columns = c('uid') all.data = inner_join( @@ -918,21 +918,21 @@ read_taxonomy_data = function( all.epi.data, by = setNames(join.columns,join.columns) ) - + names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = gsub( '\\.x$', '.desc', names(all.data)[ grepl(pattern='\\.x$',names(all.data))] ) - + names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = gsub( '\\.y$', '', names(all.data)[ grepl(pattern='\\.y$',names(all.data))] ) - + ##Fix this to use all available ISO levels all.locations = data.frame( data = apply( @@ -952,7 +952,7 @@ read_taxonomy_data = function( ), stringsAsFactors = FALSE ) - + all.locations = all.locations %>% mutate(location=data) %>% #' @importFrom dplyr select @@ -962,7 +962,7 @@ read_taxonomy_data = function( group_by(location) %>% #' @importFrom dplyr summarize summarize() - + ##all.locations = lapply(locations,function(...){data.table(location=...)}) ##all.locations = bind_rows(locations) all.data = all.data %>% bind_cols(all.locations) @@ -990,20 +990,20 @@ read_taxonomy_data = function( ) ) %>% select(location) - + ##So, location population is more complicated, because we need to ## join on TL,TR... this will likely involve something hard # closeAllConnections() ##apply(location.population.files,1,read_taxonomy_csv) # closeAllConnections() - + if(nrow(location.population.files) > 0){ location.population.data = apply( location.population.files, 1, function(x){read_population_csv(x[[1]])} ) - + location.population.data = mapply( location=unique.locations[[1]], table=location.population.data, @@ -1013,16 +1013,16 @@ read_taxonomy_data = function( }, SIMPLIFY = FALSE ) - + location.population.data = bind_rows(location.population.data) - + ##Consider doing something smarter here. join.columns = c("location","TL","TR"); join.columns = join.columns[join.columns %in% colnames(all.data)] join.columns = join.columns[ join.columns %in% colnames(location.population.data) ] - + all.data = all.data %>% left_join(location.population.data,by=join.columns) names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = @@ -1031,7 +1031,7 @@ read_taxonomy_data = function( '.pop', names(all.data)[ grepl(pattern='\\.y$',names(all.data))] ) - + names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = gsub( '\\.x$', @@ -1039,7 +1039,7 @@ read_taxonomy_data = function( names(all.data)[ grepl(pattern='\\.x$',names(all.data))] ) } - + if(nrow(location.description.files) > 0){ location.description.data = apply( location.description.files, @@ -1079,14 +1079,14 @@ read_taxonomy_data = function( names(all.data)[ grepl(pattern='\\.x$',names(all.data))] ) } - - + + ##Only take the columns which have some amount of data in them. all.data = select( all.data, which(summarise_all(all.data,funs(sum(!is.na(.)))) > 0) ) - + if((!missing(columns)) && (length(columns) > 0)){ print(columns) try( @@ -1138,8 +1138,8 @@ aggregate_taxonomy_data = function( # g - Aggregate time as decided above, keeping track of the fraction of the year involved and adding cases appropriately. aggregate_to_start <- time_unit_to_start_function(temporal_aggregate_time_unit) aggregate_to_end <- time_unit_to_end_function(temporal_aggregate_time_unit) - - + + #Filter out NA case values if(filter_NA_cases){ data <- data %>% @@ -1214,7 +1214,7 @@ aggregate_taxonomy_data = function( select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> data_multi_year } - + #### Make the single time unit data have the same info as the multi time unit if(nrow(data_single_year) > 0){ data_single_year %>% @@ -1233,11 +1233,11 @@ aggregate_taxonomy_data = function( select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> data_single_year } - + #### Recombine #' @importFrom dplyr bind_rows data = bind_rows(data_single_year,data_multi_year) - + #### Group data together by time year ###### Note that this fails when the time units don't work out if(!filter_NA_cases){ @@ -1245,7 +1245,7 @@ aggregate_taxonomy_data = function( "This does not work right now. Building time units does not account for suspected vs deaths reports" ) } - + if(time_combine == 'strict'){ data %>% #' @importFrom dplyr ungroup @@ -1302,7 +1302,7 @@ aggregate_taxonomy_data = function( }) -> data } else if(time_combine == 'unstrict'){ - + data %>% #' @importFrom dplyr ungroup ungroup() %>% @@ -1325,14 +1325,14 @@ aggregate_taxonomy_data = function( ) ) -> data } else if(time_combine == 'none') { - + } else { stop("time_combine must be one of 'strict', 'unstrict', or 'none'") } - + #### Now that we have time units properly done, t becomes a grouping column. grouping_columns = c(grouping_columns,'t') - + #### We now need to move partial time units to the rest of their report if they meet the criteria given by #### max_overlap and min_total_length data %>% @@ -1351,7 +1351,7 @@ aggregate_taxonomy_data = function( #' @importFrom lubridate ymd obs_t = time_change_func(ymd(mapply(tl=obs_TL,tr=obs_TR,function(tl,tr){paste(mean(c(tl,tr)))}))) ) -> data - + #### Do the adjustments only if the criterion are met data %>% ungroup() %>% @@ -1372,11 +1372,11 @@ aggregate_taxonomy_data = function( aggregate_columns )) -> data - + ## Time aggregation is finished ## Starting Spatial Aggregation data$iso_level = apply(!is.na(data[,grepl('ISO_A',colnames(data))]),1,sum) - + #### Picking which spatial columns to aggregate on based on input: if(is.null(ISO_level)){ grouping_columns = c('uid','t') @@ -1502,10 +1502,10 @@ case_definition_to_column_name = function(type,database=FALSE,sql=FALSE){ #' @param type string of type #' @return function to convert dates to the right thing time_unit_to_start_function <- function(unit){ - - # Remove the 's' at the end of the unit + + # Remove the 's' at the end of the unit unit <- gsub("s$", "", unit) - + changer = list( 'year' = function(x){ return(as.Date(paste(x,'01','01',sep='-'),format='%Y-%m-%d')) @@ -1522,10 +1522,10 @@ time_unit_to_start_function <- function(unit){ #' @param type string of type #' @return function to convert dates to the right thing time_unit_to_end_function <- function(unit){ - - # Remove the 's' at the end of the unit + + # Remove the 's' at the end of the unit unit <- gsub("s$", "", unit) - + changer = list( 'year' = function(x){ return(as.Date(paste(x,'12','31',sep='-'),format='%Y-%m-%d')) @@ -1542,10 +1542,10 @@ time_unit_to_end_function <- function(unit){ #' @return function to convert dates to the right thing #' @importFrom lubridate year time_unit_to_aggregate_function <- function(unit){ - - # Remove the 's' at the end of the unit + + # Remove the 's' at the end of the unit unit <- gsub("s$", "", unit) - + changer = list( 'year' = lubridate::year, 'isoweek' = function(x){return(stop("Not yet written"))} @@ -1610,12 +1610,12 @@ time_unit_to_aggregate_function <- function(unit){ #' @param uids unique observation collections ids to pull #' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) #' @return An sf object containing data pulled from the database -read_taxonomy_data_database <- function(username, - api_key, - locations = NULL, - time_left = NULL, - time_right = NULL, - uids = NULL, +read_taxonomy_data_database <- function(username, + api_key, + locations = NULL, + time_left = NULL, + time_right = NULL, + uids = NULL, website = "https://api.cholera-taxonomy.middle-distance.com/"){ ## Before we start, I want to explain some weird syntax that will come up: ## #' @importFrom package function @@ -1625,18 +1625,18 @@ read_taxonomy_data_database <- function(username, ## toJSON = jsonlite::toJSON ## except that it handles conflicts better by producing a warning, and ## tells the package about the dependency. - - + + ## First, we want to set up the https POST request. ## We make a list containing the arguments for the request: ## If the API changes, we will just need to change this list api_type = "" if(is.null(uids)){ api_type = "by_location" - if(length(locations == 1)){ + if(length(locations) == 1){ locations = c(locations,locations) } - + ## Prevent continents, or too many countries if(any(!grepl('::',locations))){ stop("Trying to pull data for a continent is not allowed") @@ -1645,7 +1645,7 @@ read_taxonomy_data_database <- function(username, if((sum(str_count(string = unique(locations),pattern='::') == 1) > 2)){ stop("Trying to pull data for more than 2 countries at a time is not allowed") } - + https_post_argument_list = list( email=username, api_key=api_key, @@ -1663,9 +1663,9 @@ read_taxonomy_data_database <- function(username, } else { stop("Not supported") } - + website = paste0(website,"/api/v1/observations/",api_type) - + #' @importFrom jsonlite toJSON ## Every object in R is a vector, even the primitives. For example, c(1,5,6) is of type ## integer. Because of this, we need to explicitly tell the JSON parser to treat vectors @@ -1676,7 +1676,7 @@ read_taxonomy_data_database <- function(username, ## Message prints a message to the user. It's somewhere between a warning and a normal print. ## In this case, this function might take a while to run, so we let the user know up front. message("Fetching results from JSON API") - + ## This is the line that actually fetches the results. ## The syntax for adding headers is a little weird. The function add_headers takes named arguments ## and returns whatever the arguments to POST are supposed to be. @@ -1686,10 +1686,13 @@ read_taxonomy_data_database <- function(username, website, add_headers("Content-Type" = "application/json"), body=json, - encode='form', - config(ssl_verifyhost = 0) + encode='json', + config = c( + httr::config(ssl_verifyhost = 0, ssl_verifypeer = 0), + httr::verbose() # <--- ADD THIS LINE + ) ) - + ## Now we process the status code to make sure that things are working correctly #' @importFrom httr status_code code = status_code(results) @@ -1697,7 +1700,7 @@ read_taxonomy_data_database <- function(username, if(code != 200){ stop(paste('Error: Status Code',code)) } - + ## Next we extract just the content of the results #' @importFrom httr content original_results_data = content(results) @@ -1712,14 +1715,14 @@ read_taxonomy_data_database <- function(username, } #' @importFrom jsonlite fromJSON results_data = fromJSON(jsondata) - + ## Now we have the results of the api data as a nested list. ## We want to do the following in no particular order ## for the observations, we want to turn them into a data frame ## with one row per observation for the location_periods, we want ## to turn them into a geometry object and link them to the ## observations - + ## We start with the observations if( # The | operator is logical or (!("observations" %in% names(results_data))) | # The results should have observations @@ -1735,7 +1738,7 @@ read_taxonomy_data_database <- function(username, results_data[['observations']] = as.data.frame(results_data[['observations']]) } results_data[['observations']] = flatten(results_data[['observations']]) - + observation_collections_present <- FALSE if( ("observation_collections" %in% names(results_data)) && # The results should have observations @@ -1749,12 +1752,12 @@ read_taxonomy_data_database <- function(username, results_data[['observation_collections']] = flatten(results_data[['observation_collections']]) observation_collections_present <- TRUE } - + ## Check to make sure that the number of ids and number of rows match if(!length(unique(results_data$observations$id)) == nrow(results_data$observations)){ stop("Could not parse results properly. Contact package maintainer") } - + ## Now we want to handle the location periods ## We need to process these individually, so we'll loop over ## location periods to extract the geojsons @@ -1796,7 +1799,7 @@ read_taxonomy_data_database <- function(username, results_data$location_periods$sf_id = 1:nrow(results_data$location_periods) } results_data$observations$attributes.location_period_id = as(results_data$observations$attributes.location_period_id,class(results_data$location_periods$id)) - + ## We then join (as in sql) by the location_periods with the ## observations by location_period_id all_results <- results_data$observations @@ -1825,7 +1828,7 @@ read_taxonomy_data_database <- function(username, ) ) } - + geoinput <- st_sf(geometry=st_sfc(st_point(1.*c(NA,NA))))$geometry if(nrow(all_results) == 0){ geoinput <- geoinput[0] @@ -1846,9 +1849,9 @@ read_taxonomy_data_database <- function(username, #' @param time_right right bound for observation times (in date format) #' @param uids list of unique observation collection ids to pull #' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) -#' @param source whether to pull data from the website or using sql on idmodeling2. +#' @param source whether to pull data from the website or using sql on idmodeling2. #' Needs to be one of 'api' or 'sql'. -#' +#' #' @details This is a wrapper which calls either read_taxonomy_data_database or #' read_taxonomy_data_sql depending on the source that the user specifies. #' @return An sf object containing data pulled from the database @@ -1858,17 +1861,17 @@ pull_taxonomy_data <- function(username, locations = NULL, time_left = NULL, time_right = NULL, - uids = NULL, + uids = NULL, website = "https://api.cholera-taxonomy.middle-distance.com/", source) { - + if (missing(source) | is.null(source)) stop("No source specified to pull taxonomy data, please specify one of 'api' or 'sql'.") - + if (source == 'api') { if (missing(username) | missing(password) | is.null(username) | is.null(password)) stop("Trying to pull data from API, please provide username and api_key.") - + # Return API data pull rc <- read_taxonomy_data_database(username = username, api_key = password, @@ -1877,11 +1880,11 @@ pull_taxonomy_data <- function(username, time_right = time_right, uids = uids, website = website) - + } else if (source == 'sql') { if (missing(username) | missing(password) | is.null(username) | is.null(password)) stop("Trying to pull data using sql on idemodelin2, please provide database username and password.") - + # Return SQL data pull rc <- read_taxonomy_data_sql(username = username, password = password, @@ -1893,11 +1896,11 @@ pull_taxonomy_data <- function(username, rc$attributes.fields.confirmed_cases <- rc$confirmed_cases rc$attributes.fields.location_id <- rc$location_id rc$attributes.location_period_id <- rc$location_period_id - + } else { stop("Parameter 'source' needs to be one of 'api' or 'sql'.") } - + if(nrow(rc) == 0) { if (!is.null(uids)) { err_mssg <- paste("in uids", paste(uids, collapse = ",")) @@ -1906,7 +1909,7 @@ pull_taxonomy_data <- function(username, } else { err_mssg <- "" } - stop("Didn't find any data ", err_mssg, " in time range [", + stop("Didn't find any data ", err_mssg, " in time range [", ifelse(is.null(time_left), "-Inf", as.character(time_left)), " - ", ifelse(is.null(time_right), "-nf", as.character(time_right)), "]") } @@ -1923,7 +1926,7 @@ pull_taxonomy_data <- function(username, #' @param time_left left bound for observation times (in date format) #' @param time_right right bound for observation times (in date format) #' @param uids list of unique observation collection ids to pull -#' +#' #' @details Code follows taxdat::read_taxonomy_data_database template. #' @return An sf object containing data extracted from the database #' @export @@ -1933,10 +1936,10 @@ read_taxonomy_data_sql <- function(username, time_left = NULL, time_right = NULL, uids = NULL) { - + if (missing(username) | missing(password)) stop("Please provide username and password to connect to the taxonomy database.") - + # Connect to database conn <- RPostgres::dbConnect(RPostgres::Postgres(), host = "db.cholera-taxonomy.middle-distance.com", @@ -1944,37 +1947,37 @@ read_taxonomy_data_sql <- function(username, user = username, password = password, port = "5432") - + # Build query for observations - obs_query <- paste("SELECT observations.id::text, observations.observation_collection_id::text, observations.time_left, observations.time_right,", + obs_query <- paste("SELECT observations.id::text, observations.observation_collection_id::text, observations.time_left, observations.time_right,", "observations.suspected_cases, observations.confirmed_cases, observations.deaths, observations.location_period_id::text, observations.location_id::text,", "observations.phantom, observations.primary FROM observations left join location_hierarchies on observations.location_id = location_hierarchies.descendant_id") - + cat("-- Pulling data from taxonomy database with SQL \n") - + # Add filters - if (any(c(!is.null(locations), + if (any(c(!is.null(locations), !is.null(time_left), - !is.null(time_right), + !is.null(time_right), !is.null(uids)))) { obs_query <- paste(obs_query, "\n WHERE ") } else { warning("No filters specified on data pull, pulling all data.") } - + if (!is.null(time_left)) { time_left_filter <- paste0("time_left >= '", format(time_left, "%Y-%m-%d"), "'") } else { time_left_filter <- NULL } - + if (!is.null(time_right)) { time_right_filter <- paste0("time_right <= '", format(time_right, "%Y-%m-%d"), "'") } else { time_right_filter <- NULL } - + if (!is.null(locations)) { if(all(is.numeric(locations))){ locations_filter <- paste0("ancestor_id in ({locations*})") @@ -1984,25 +1987,25 @@ read_taxonomy_data_sql <- function(username, } else { locations_filter <- NULL } - + if (!is.null(uids)) { uids_filter <- paste0("observation_collection_id IN ({uids*})") } else { uids_filter <- NULL } - + # Combine filters - filters <- c(time_left_filter, time_right_filter, - locations_filter, uids_filter) %>% + filters <- c(time_left_filter, time_right_filter, + locations_filter, uids_filter) %>% paste(collapse = " AND ") - + # Run query for observations obs_query <- glue::glue_sql(paste(obs_query, filters, ";"), .con = conn) observations <- DBI::dbGetQuery(conn = conn, obs_query) if(nrow(observations) == 0){ stop(paste0("No observations found using query ||",obs_query,"||")) } - + # Pull location_periods u_lps <- unique(observations$location_period_id) # unique location period ids u_lps <- u_lps[!is.na(u_lps)] @@ -2014,42 +2017,42 @@ read_taxonomy_data_sql <- function(username, lp_query <- glue::glue_sql("SELECT id as location_period_id, geojson FROM location_periods WHERE id IN ({u_lps*});", .con = conn) location_periods <- DBI::dbGetQuery(conn = conn, lp_query) - + # Get missing geometries - location_period_issues <- location_periods %>% + location_period_issues <- location_periods %>% filter(is.na(geojson) | geojson == "{}") - + # Get unique valid geojsons - location_periods <- location_periods %>% - filter(!is.na(geojson), geojson != "{}") %>% - group_by(location_period_id) %>% + location_periods <- location_periods %>% + filter(!is.na(geojson), geojson != "{}") %>% + group_by(location_period_id) %>% slice(1) - + # Convert to sf object location_periods.sf <- purrr::map(location_periods$geojson, ~try(geojsonsf::geojson_sf(.), silent = F)) - + # Get errors - errors <- purrr::map2(location_periods.sf, seq_along(location_periods.sf), ~ if (inherits(.x, "try-error")) .y) %>% + errors <- purrr::map2(location_periods.sf, seq_along(location_periods.sf), ~ if (inherits(.x, "try-error")) .y) %>% unlist() if (length(errors) > 0) { cat("Found unreadable geojson for location periods:", str_c(errors, collapse = ", ")) location_periods.sf <- location_periods.sf[-errors] location_periods <- location_periods[-errors, ] } - + # extract geometries and metadata - location_periods.sf <- do.call(rbind, location_periods.sf) %>% + location_periods.sf <- do.call(rbind, location_periods.sf) %>% mutate(location_period_id = location_periods$location_period_id, - location_name = purrr::map_chr(location_periods$geojson, ~ jsonlite::parse_json(.)[["name"]] %>% + location_name = purrr::map_chr(location_periods$geojson, ~ jsonlite::parse_json(.)[["name"]] %>% ifelse(is.null(.), NA, .)), times = ifelse(is.na(location_name), NA, str_extract(location_name, "([0-9]{4}-[0-9]{2}-[0-9]{2}_[0-9]{4}-[0-9]{2}-[0-9]{2})")), location_name = ifelse(is.na(location_name), NA, str_replace_all(str_replace(location_name, str_c("_", times, "_SHP"), ""), "_", "::")) - ) %>% - select(-times) %>% + ) %>% + select(-times) %>% rename(geojson = geometry) - + # Combine observations and geojsons res <- right_join(location_periods.sf, observations, by = "location_period_id") - + return(res) } From 5e335bd77a7ee5bfca5df40f072ad8cbd254cc3b Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:13:41 +0200 Subject: [PATCH 20/69] use hack to get around ssl --- analysis/01_pull_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 68d9503..e076c93 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -70,7 +70,7 @@ location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -raw_sf <- taxdat::pull_taxonomy_data( +raw_sf <- pull_taxonomy_data( username = api_user, password = api_key, locations = location_str, From d16d480f0ba0a84b1065982d549e6b9a4619e1e1 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:34:26 +0200 Subject: [PATCH 21/69] wire taxdat:: namespace and normalize API column names - analysis/01_pull_data.R: qualify pull_taxonomy_data() and rename_database_fields() with taxdat:: so they resolve correctly without any re-exports in utils.R - R/clean_psql_data.R: add column normalization block at entry to bridge taxdat API naming (is_primary, locationPeriod_id, OC_UID, location_name, attributes.fields.*) to the OutbreakExtractR convention (primary, location_period_id, observation_collection_id, location, sCh, cCh, deaths). Also handle already-logical primary values from the API so filter(primary) is not silently vacuous. - R/add_population.R: accept locationPeriod_id (taxdat camelCase) as a third fallback for the LP geometry ID column, alongside location_period_id and lctn_pr. - analysis/utils.R: remove taxdat duplicate functions (pull_taxonomy_data, rename_database_fields, get_shp, and all helpers); these are now called via taxdat:: directly. - analysis/bash/install_r_packages.sh: fix taxdat source repo to HopkinsIDD/cholera-mapping-pipeline (subdir packages/taxdat, branch dev); add missing runtime deps igraph, geodata, geojsonsf, rjson, httr, jsonlite. Co-Authored-By: Claude Sonnet 4.6 --- R/add_population.R | 12 +- R/clean_psql_data.R | 37 +- analysis/01_pull_data.R | 6 +- analysis/bash/install_r_packages.sh | 17 +- analysis/utils.R | 1926 --------------------------- 5 files changed, 58 insertions(+), 1940 deletions(-) diff --git a/R/add_population.R b/R/add_population.R index bf2a8bf..184b4ca 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -29,7 +29,8 @@ #' location_period_id and TL. #' @param raw_sf sf object: geometry-bearing data returned by #' taxdat::pull_taxonomy_data() (before geometry is dropped). Must contain -#' a location_period_id or lctn_pr column and an sf geometry column. +#' a location_period_id, locationPeriod_id, or lctn_pr column and an sf +#' geometry column. #' @param country_iso3 character: ISO3 country code (e.g. "COD"). Used to #' download the correct WorldPop raster and to fetch the country boundary #' for the UN population adjustment factor. @@ -46,14 +47,17 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # --------------------------------------------------------------------------- # 1. Build named geometry lookup: LP ID (character) -> sfg object # --------------------------------------------------------------------------- - # taxdat::rename_database_fields() uses "location_period_id"; - # get_shp() uses "lctn_pr". Accept either. + # taxdat::rename_database_fields(source="api") uses "locationPeriod_id" (camelCase); + # taxdat::rename_database_fields(source="psql") / after clean_psql_data() uses + # "location_period_id" (snake_case); get_shp() uses "lctn_pr". Accept all three. geom_id_col <- if ("location_period_id" %in% names(raw_sf)) { "location_period_id" + } else if ("locationPeriod_id" %in% names(raw_sf)) { + "locationPeriod_id" } else if ("lctn_pr" %in% names(raw_sf)) { "lctn_pr" } else { - stop("raw_sf must have a 'location_period_id' or 'lctn_pr' column.") + stop("raw_sf must have a 'location_period_id', 'locationPeriod_id', or 'lctn_pr' column.") } lp_geoms <- raw_sf %>% diff --git a/R/clean_psql_data.R b/R/clean_psql_data.R index 81c8930..921dae3 100644 --- a/R/clean_psql_data.R +++ b/R/clean_psql_data.R @@ -6,9 +6,41 @@ clean_psql_data <- function( original_data,... ){ - + library(tidyverse) + # --------------------------------------------------------------------------- + # Normalize taxdat API column names to OutbreakExtractR conventions. + # taxdat::rename_database_fields(source = "api") produces different column + # names than a direct psql export. This block maps either naming convention + # to the names expected by the rest of this function, making it compatible + # with both data sources. + # + # API names -> OutbreakExtractR names + # is_primary -> primary + # locationPeriod_id -> location_period_id + # OC_UID -> observation_collection_id + # location_name -> location + # attributes.fields.suspected_cases -> sCh + # attributes.fields.confirmed_cases -> cCh + # attributes.fields.deaths -> deaths + # --------------------------------------------------------------------------- + col_map <- c( + primary = "is_primary", + location_period_id = "locationPeriod_id", + observation_collection_id = "OC_UID", + location = "location_name", + sCh = "attributes.fields.suspected_cases", + cCh = "attributes.fields.confirmed_cases", + deaths = "attributes.fields.deaths" + ) + for (new_name in names(col_map)) { + old_name <- col_map[[new_name]] + if (old_name %in% names(original_data) && !new_name %in% names(original_data)) { + original_data <- dplyr::rename(original_data, !!new_name := !!old_name) + } + } + # clean the location names (keep updated) # clean and add descriptive columns outbreak_data <- clean_location_names(original_data=original_data) %>% @@ -19,7 +51,8 @@ clean_psql_data <- function( TL = lubridate::ymd(TL), TR = lubridate::ymd(TR), primary = dplyr::case_when( - primary == "f" ~ FALSE, + is.logical(primary) ~ primary, # API source: already TRUE/FALSE + primary == "f" ~ FALSE, # psql source: "f"/"t" strings primary == "t" ~ TRUE) ) %>% dplyr::filter(primary) %>% ## always only keep primary data diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index e076c93..ad78ff2 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -70,16 +70,16 @@ location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -raw_sf <- pull_taxonomy_data( +raw_sf <- taxdat::pull_taxonomy_data( username = api_user, password = api_key, locations = location_str, time_left = opt$time_lower_bound, time_right = opt$time_upper_bound, source = "api", - website = opt$api_website + website = "http://cholera-taxonomy.middle-distance.com/" ) %>% - rename_database_fields(source = "api") + taxdat::rename_database_fields(source = "api") if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh index 64838dd..74762fd 100755 --- a/analysis/bash/install_r_packages.sh +++ b/analysis/bash/install_r_packages.sh @@ -8,7 +8,7 @@ # # What this installs: # - All DESCRIPTION Imports + analysis-layer Suggests (from CRAN) -# - taxdat (from GitHub: HopkinsIDD/cholera-taxonomy) +# - taxdat (from GitHub: HopkinsIDD/cholera-mapping-pipeline, branch dev) # - OutbreakExtractR itself (from the current directory) # # !! This takes a while to complete @@ -54,8 +54,12 @@ pkgs <- c( "arrow", "sfarrow", "furrr", "future", - # for taxdat - "ISOcodes", "readr", "reshape2", + # taxdat Depends + runtime deps used in pull_data_helpers.R + # (ISOcodes, igraph, geodata are in DESCRIPTION Depends; + # geojsonsf, rjson, httr, jsonlite are called directly in pull_data_helpers.R) + "ISOcodes", "igraph", "geodata", + "geojsonsf", "rjson", "httr", "jsonlite", + "readr", "reshape2", # dev / testing "testthat", "remotes" @@ -74,9 +78,12 @@ if (length(missing_pkgs) > 0) { # ---- taxdat (private GitHub package) --------------------------------------- if (!"taxdat" %in% rownames(installed.packages())) { # NOTE: Needed to rebuild the documentation rm -rf man/ NAMESPACE && Rscript -e "devtools::document()" - message("Installing taxdat from GitHub (HopkinsIDD/cholera-taxonomy) ...") + message("Installing taxdat from GitHub (HopkinsIDD/cholera-mapping-pipeline, branch dev) ...") remotes::install_version("Matrix", version = "1.6-5", repos = "https://cran.r-project.org") - remotes::install_github("HopkinsIDD/cholera-taxonomy/packages/taxdat", upgrade = "never") + remotes::install_github("HopkinsIDD/cholera-mapping-pipeline", + subdir = "packages/taxdat", + ref = "dev", + upgrade = "never") } else { message("taxdat already installed.") } diff --git a/analysis/utils.R b/analysis/utils.R index 96e8a4f..70b4379 100644 --- a/analysis/utils.R +++ b/analysis/utils.R @@ -130,1929 +130,3 @@ print_options <- function(opt) { cat("--------------------------------\n") } - -# Taxdat patch ------------------------------------------------------------ - -#' @title Rename cholera data columns -#' @description Renames the columns of the data pulled either from the the -#' API staging database or by SQL from taxdat -#' -#' @param database_df Data who's columns are to be modified -#' @param source Whether the source is the staging database (sing the API) or taxdat (using SQL). -#' @details source is one of 'api' or 'sql' -#' @return the renamed dataframe -rename_database_fields <- function(database_df, - source = "api") { - - if (source == "api") { - new_database_df <- database_df %>% - dplyr::rename( - TL = attributes.time_left, - TR = attributes.time_right, - is_primary = attributes.primary, - is_phantom = attributes.phantom, - locationPeriod_id = attributes.id, - OC_UID = relationships.observation_collection.data.id, - location_name = attributes.location_name - ) - } else if (source == "sql") { - new_database_df <- database_df %>% - dplyr::rename( - TL = time_left, - TR = time_right, - is_primary = primary, - is_phantom = phantom, - locationPeriod_id = location_period_id, - OC_UID = observation_collection_id, - location_name = location_name - ) - } else { - stop("Source needs to be one of 'api', 'sql', found ", source) - } - # names(new_database_df) <- gsub("attributes.fields.", "", names(new_database_df)) - # names(new_database_df) <- gsub("attributes.", "", names(new_database_df)) - return(new_database_df) -} - - -#' @import methods dplyr -library(methods) -library(dplyr) -library(jsonlite) -library(httr) -library(lubridate) -library(stringr) - -################################################################ -######################Taxonomy Data Parser###################### -################################################################ -#' Taxonomy Data Parser -################################################################ -## Note: #' at the beginning of the line means to pass to R -## Markdown -#' -#' The Taxonomy Data Parser package loads and handles Taxonomy Data. -#' It provides 1 category of functions: -#' Taxonomy Parsing -#' -#' @section Taxonomy Parsing Functions: -## -#' @details Taxonomy parsing functions are designed to read flat -#' files from a filesystem storing taxonomy data. If the file -#' system is called taxonomy.directory, then the following -#' subdirectories must exist: -#' \itemize{ -#' \item taxonomy.directory/Description - files must end in _DESC.csv -#' \item taxonomy.directory/Location - files must end in _LOC.csv -#' \item taxonomy.directory/EpiCurves - files must end in _EPI.csv -#' \item taxonomy.directory/Population - files must end in _POP.csv -#' } -#' The files Description and Population files are regular .csv files, -#' and the Location and Epi files are transposed .csv files. -################################################################ -################################################################ -##TODO: -## 1. Only read in relevant epi files in read_taxonomy_data -## 2. Specify the types of all columns in code, so the warnings -## go away in read_taxonomy_csv and read_transposed_taxonomy_csv -## 3. Comment the code more effectively -## 4. Parallelize the reading. -################################################################ - -################################################################ -#' @name read_taxonomy_csv -#' @title read_taxonomy_csv -#' @description This function reads a csv file which is column major. -#' It will also fail without throwing an error, so it can be used on -#' missing data -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file should be column major -## vals: -#' @return A data.frame containing the data from \code{filename} or a -#' data.frame with a single column missing=\code{filename}) -################################################################ - -read_taxonomy_csv= function(filename,verbose=FALSE){ - if(!file.exists(filename)){ - if(verbose){ - warning(paste(filename,": Does not exist"),immediate.=FALSE) - } - return(data.frame(missing=filename,stringsAsFactors = FALSE)) - } - output.data = tryCatch( - read.csv( - filename, - sep=',', - header=TRUE, - stringsAsFactors=FALSE, - na.strings = "", - colClasses = 'character', - quote = "\"", - check.names = FALSE, - row.names=NULL - ), - warning = function(w){ - if(length(w$message > 0)){ - if(grepl(pattern="ncomplete final line",x=w$message)){ - return(suppressWarnings( - read.csv( - filename, - sep=',', - header=TRUE, - stringsAsFactors=FALSE, - na.strings = "", - colClasses = 'character', - quote = "\"", - check.names = FALSE - ) - )) - } - } - if(verbose){ - warning(paste(filename,":",w$message),immediate.=TRUE) - } - return(w) - }, - error = function(e){ - if(verbose){ - warning(paste(filename,":",e),immediate.=TRUE) - } - return(e) - } - ) - if(length(class(output.data))>0){ - if(class(output.data)[[1]] != "data.frame"){ - output.data = data.frame( - missing=filename, - stringsAsFactors = FALSE - ) - } - } - return(output.data) -} - -################################################################ -#' @name read_transposed_taxonomy_csv -#' @title read_transposed_taxonomy_csv -#' @description This function reads a csv file which is row major. It -#' will also fail without throwing an error, so it can be used on -#' missing data -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file should be row major -## vals: -#' @return A data.frame containing the data from \code{filename} or a -#' data.frame with a single column missing=\code{filename}) -################################################################ - -read_transposed_taxonomy_csv = function(filename,verbose=FALSE){ - if(!file.exists(filename)){ - if(verbose){ - warning(paste(filename,": Does not exist"),immediate.=FALSE) - } - return(data.frame(missing=filename,stringsAsFactors = FALSE)) - } - output.data = tryCatch( - as.data.frame( - t(read.csv( - filename, - sep=',', - header=FALSE, - stringsAsFactors=FALSE, - na.strings = "", - colClasses = 'character', - quote = "\"", - check.names = FALSE - )), - stringsAsFactors=FALSE - ), - warning = function(w){ - if(length(w$message > 0)){ - if(grepl(pattern="ncomplete final line",x=w$message)){ - return(suppressWarnings( - as.data.frame( - t(read.csv( - filename, - sep=',', - header=FALSE, - stringsAsFactors=FALSE, - na.strings = "", - colClasses = 'character', - quote = "\"", - check.names = FALSE - )), - stringsAsFators = FALSE - ))) - } - } - if(verbose){ - warning(paste(filename,":",w$message),immediate.=TRUE) - } - return(w) - }, - error = function(e){ - if(verbose){ - warning(paste(filename,":",e),immediate.=TRUE) - } - return(e) - } - ) - if(length(class(output.data))>0){ - if(class(output.data)[[1]] != "data.frame"){ - warning(paste( - "Output date is of type", - class(output.data), - "instead of data.frame." - )) - output.data = data.frame( - missing=filename,stringsAsFactors = FALSE - ) - } else{ - colnames(output.data) = as.character(unlist(output.data[1,])) - output.data = output.data[-1,] - } - } - return(output.data) -} - -################################################################ -#' @name safe.function -#' @title safe.function -#' @description This function runs a function, and returns either -#' the return of that function, or a default return if it fails -## args: -#' @param function The function to run safely -#' @param \dots The normal arguments to the function -#' @param default The value the function should return if it fails -## vals: -#' @return The return value of the function if the function runs, -#' or \code{default} otherwise -################################################################ -safe.function <- function(fxn,...,default=warning("The function failed to run")){ - tryCatch( - fxn(...), - error = function(e){ - warning(e$message) - return(default) - } - ) -} - -##Include methods for reading each particular type of file -################################################################ -#' @name read_description_csv -#' @title read_description_csv -#' @description This function reads a csv file containing a -#' description file. -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file format is described in the -#' documentation -## vals: -#' @return A \code{data.frame} containing the data from -#' \code{filename} or a single column missing with the filename -#' listed -################################################################ - -description_coltypes = c( - uid = "integer", - source = "character", - source_uid = "character", - source_url = "character", - contact = "character", - contact_email = "character", - is_public = "integer", - mou_dsa_notes = "character", - contains_pii = "integer", - irb_protocol = "character", - owner = "character", - owner_email = "character", - source_file = "character", - who_region = "character", - ISO_A1 = "character", - ISO_A2_L1 = "character", - ISO_A2_L2 = "character", - ISO_A2_L3 = "character", - ISO_A2_L4 = "character", - ISO_A2_L5 = "character", - ISO_A2_L6 = "character", - ISO_A2_L7 = "character", - ISO_A2_L8 = "character", - ISO_A2_L9 = "character", - suspected_case_def = "character", - confirmed_case_def = "character", - day_start = "Date", - day_end = "Date", - primary_time_criteria = "character", - deaths = "integer", - cases = "integer", - strains = "character", - tet_res = "integer", - sul_res = "integer", - cip_res = "integer", - az_res = "integer", - humanitarian_crisis_assoc = "integer", - reactive_vaccination = "integer", - prev_vaccination = "integer", - notes = "character" -) - -read_description_csv = function(filename){ - rc <- read_transposed_taxonomy_csv(filename) - for(column in colnames(rc)){ - if(!is.na(description_coltypes[column])){ - if(description_coltypes[column] == "Date"){ - rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) - # rc[[column]] <- as.Date(rc[[column]]) - } else { - rc[[column]] <- as(rc[[column]],description_coltypes[column]) - } - } - - } - old.ncol = ncol(rc) - if(old.ncol == 1){ - return(rc) - } - rc <- rc[,!is.na(colnames(rc))] - rc <- rc[,!(colnames(rc) == "")] - if(ncol(rc) != old.ncol){ - warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) - } - return(rc) -} - - - -################################################################ -#' @name read_epi_csv -#' @title read_epi_csv -#' @description This function reads a csv file containing a epi file -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file format is described in the -#' documentation -## vals: -#' @return A \code{data.frame} containing the data from -#' \code{filename} or a single column missing with the filename -#' listed -################################################################ -epi_coltypes = c( - TL = "Date", - TR = "Date", - TL_onset = "Date", - TR_onset = "Date", - TL_clinic = "Date", - TR_clinic = "Date", - TL_death = "Date", - TR_death = "Date", - ISO_A1 = "character", - ISO_A2_L1 = "character", - ISO_A2_L2 = "character", - ISO_A2_L3 = "character", - ISO_A2_L4 = "character", - ISO_A2_L5 = "character", - ISO_A2_L6 = "character", - ISO_A2_L7 = "character", - ISO_A2_L8 = "character", - ISO_A2_L9 = "character", - lat_case = "character", - long_case = "character", - sCh = "numeric", - cCh = "numeric", - deaths_L = "numeric", - deaths_R = "numeric", - sCh_L = "numeric", - sCh_R = "numeric", - cCh_L = "numeric", - cCh_R = "numeric", - age_U = "numeric", - sex_U = "numeric", - vac_U = "numeric" -) - -read_epi_csv = function(filename,verbose=FALSE){ - rc <- read_taxonomy_csv(filename) - for(column in colnames(rc)){ - if(!is.na(epi_coltypes[column])){ - if(epi_coltypes[column] == "Date"){ - #rc[[column]] <- as.Date(rc[[column]]) - rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) - } else { - rc[[column]] <- as(rc[[column]],epi_coltypes[column]) - } - } - } - old.ncol = ncol(rc) - if(old.ncol == 1){ - return(rc) - } - rc <- rc[,!is.na(colnames(rc))] - rc <- rc[,!(colnames(rc) == "")] - if(verbose && (ncol(rc) != old.ncol)){ - warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) - } - return(rc) -} - -################################################################ -#' @name read_location_csv -#' @title read_location_csv -#' @description This function reads a csv file containing a location file -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file format is described in the -#' documentation -## vals: -#' @return A \code{data.frame} containing the data from -#' \code{filename} or a single column missing with the filename -#' listed -################################################################ - -location_coltypes = c( - name = "character", - cent_lat = "numeric", - cent_long = "numeric", - isISO_A1 = "numeric", - isISO_A2_L1 = "numeric", - isISO_A2_L2 = "numeric", - isISO_A2_L3 = "numeric", - isISO_A2_L4 = "numeric", - isISO_A2_L5 = "numeric", - isISO_A2_L6 = "numeric", - isISO_A2_L7 = "numeric", - isISO_A2_L8 = "numeric", - isISO_A2_L9 = "numeric", - gis_file = 'character', - gis_file_2 = 'character', - gis_file_3 = 'character', - gis_file_4 = 'character', - gis_file_5 = 'character', - gis_start_1 = 'Date', - gis_start_2 = 'Date', - gis_start_3 = 'Date', - gis_start_4 = 'Date', - gis_start_5 = 'Date', - gis_end_1 = 'Date', - gis_end_2 = 'Date', - gis_end_3 = 'Date', - gis_end_4 = 'Date', - gis_end_5 = 'Date', - enclosed_by = "character", - notes = "character" -) - -read_location_csv = function(filename){ - rc <- read_transposed_taxonomy_csv(filename) - for(column in colnames(rc)){ - if(!is.na(location_coltypes[column])){ - if(location_coltypes[column] == "Date"){ - # rc[[column]] <- as.Date(rc[[column]]) - rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) - } else { - rc[[column]] <- as(rc[[column]],location_coltypes[column]) - } - } - } - if(nrow(rc) > 1){ - return(data.frame(missing=filename,stringsAsFactors = FALSE)) - } - - old.ncol = ncol(rc) - if(old.ncol == 1){ - return(rc) - } - rc <- rc[,!is.na(colnames(rc))] - rc <- rc[,!(colnames(rc) == "")] - if(ncol(rc) != old.ncol){ - warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) - } - ## rc <- rc %>% mutate(is_public = is_public == 1) - return(rc) -} - -################################################################ -#' @name read_population_csv -#' @title read_population_csv -#' @description This function reads a csv file containing a population -#' file -## args: -#' @param filename A string for the relative or absolute path to the -#' file to be read. The file format is described in the -#' documentation -## vals: -#' @return A \code{data.frame} containing the data from -#' \code{filename} or a single column missing with the filename -#' listed -################################################################ -population_coltypes = c( - TL = "Date", - TR = "Date", - pop = "numeric", - source = "character" -) -read_population_csv = function(filename){ - rc <- read_taxonomy_csv(filename) - for(column in colnames(rc)){ - if(!is.na(population_coltypes[column])){ - if(population_coltypes[column] == "Date"){ - # rc[[column]] <- as.Date(rc[[column]]) - rc[[column]] <- safe.function(as.Date,x=rc[[column]],default=as.Date(NA)) - } else { - rc[[column]] <- as(rc[[column]],population_coltypes[column]) - } - } - } - old.ncol = ncol(rc) - if(old.ncol == 1){ - return(rc) - } - rc <- rc[,!is.na(colnames(rc))] - rc <- rc[,!(colnames(rc) == "")] - if(length(ncol(rc)) == 0){ - browser() - } - if(ncol(rc) != old.ncol){ - warning(paste("Columns were removed from file",filename,"during the reading process. They are presumed to be empty")) - } - - return(rc) -} - -################################################################ -#' @name filter_description_data -#' @title filter_description_data -#' @description This function selects from a data.frame based on user -#' provided filters -## args: -#' @param data A data.frame to filter -#' @param ... As many string arguments as desired. -#' \itemize{ -#' \item "who_region == 'AFR'" -#' \item 'ISO_A1 %in% c("COD","NGA")' -#' \item 'source != "ProMED"' -#' } -#' Each filter is applied sequentially, so only data that matches all -#' filters will be returned. -#' -## vals: -#' @return A data.frame with the filters applied -################################################################ - -filter_description_data = function(data,...){ - ##print(paste('(',paste(...,sep=') &( '),')',sep='')) - if(!missing(...)){ - data = data %>% filter_(paste('(',paste(...,sep=') & ('),')',sep='')) - } - ##print(data) - ##print("finished") - return(data) -} - - -################################################################ -#' @name read_description_taxonomy -#' @title read_description_taxonomy -#' @export read_description_taxonomy -#' @description This function will pull all of the description -#' information. It reads all of the description files, and combines -#' them into a single data.frame -## args: -#' @param taxonomy.directory A string for the path for the directory -#' described above. -#' @param ... A sequence of filters used to filter the description -#' files. See \code{filter_description_data} for details -#' @param uids A vector of uids to read the description files for. -#' This parameter is optional. If missing, this function will read -#' all present uids. -## vals: -#' @return A data.frame containing the data read from the directory -#' \code{taxonomy.directory} filtered by the filters \code{...} -################################################################ -read_description_taxonomy = function(taxonomy.directory,...,uids){ - if(!missing(uids)){ - all.description.files = paste("CHOLERA",uids,"_DESC.csv",sep='') - stop("The argument uids is not yet implemented") - } else { - all.description.files = list.files( - paste(taxonomy.directory,"Description",sep='/'), - no..=TRUE, - recursive = TRUE, - include.dirs=FALSE - ) - } - all.description.files = lapply( - all.description.files, - function(file){ - paste(taxonomy.directory,"Description",file,sep='/') - } - ) - - ##Read all of the data from our description files, and turn them - ## into a single data.table - all.description.data = lapply( - all.description.files, - function(file){ - read_description_csv(file) - } - ) - ##This next line makes sure the files close after reading. - # closeAllConnections() - all.description.data = bind_rows(all.description.data) - ##This next line ensures that we treat uid as an integer - all.description.data = all.description.data %>% - #' @importFrom dplyr mutate - mutate(uid = as.integer(uid)) - ##We now select only the data we want from the description.data - all.description.data = filter_description_data( - all.description.data, - ... - ) -} - - -################################################################ -#' @name read_epi_taxonomy -#' @title read_epi_taxonomy -#' @export read_epi_taxonomy -#' @description This function will pull all of the epi case -#' information. It reads all of the epi files, and combines them -#' into a single data.frame -## args: -#' @param taxonomy.directory A string for the path for the directory -#' described above. -#' @param columns From the final data, which columns to select before -#' returning the data. -#' @param uids A vector of uids to read the description files for. -#' This parameter is optional. If missing, this function will read -#' all present uids. -#' @return A data.frame containing the specified data read from the -#' directory \code{taxonomy.directory} filtered by the filters -#' \code{...} -################################################################ -read_epi_taxonomy = function(taxonomy.directory,uids,verbose=FALSE){ - if(!missing(uids)){ - ##This will need to account for public and private somehow - public.dir <- paste(taxonomy.directory,"EpiCurves","Public",sep='/') - private.dir <- paste(taxonomy.directory,"EpiCurves","Restricted",sep='/') - all.epi.files = paste("CHOLERA",uids,"_EPI.csv",sep='') - public.files = list.files(public.dir)[list.files(public.dir) %in% all.epi.files] - private.files = list.files(private.dir)[list.files(private.dir) %in% all.epi.files] - missing.files = all.epi.files[!(all.epi.files %in% c(public.files,private.files))] - if(verbose){ - warning("There are", length(missing.files), "missing.") - } - all.epi.files = c(paste("Public",public.files,sep='/'),paste("Restricted",private.files,sep='/')) - } else { - all.epi.files = list.files( - paste(taxonomy.directory,"EpiCurves",sep='/'), - no..=TRUE, - recursive = TRUE, - include.dirs=FALSE - ) - } - all.epi.files = lapply( - all.epi.files, - function(file){ - paste(taxonomy.directory,"EpiCurves",file,sep='/') - } - ) - - ## check which files are csvs - are_csvs <- sapply(all.epi.files,function(my_file) endsWith(my_file,"csv"),simplify = TRUE) - - all.epi.data = lapply(all.epi.files[are_csvs],read_epi_csv) - all.epi.files = all.epi.files[are_csvs] - # closeAllConnections() - - ##Insert a row into the epi data containing the uid. We need this - ## to join with the description data - all.epi.uids = lapply( - all.epi.files, - function(file){ - unlist(strsplit(file,'_'))[1] - } - ) - all.epi.uids = lapply( - all.epi.uids, - function(uid){ - data.frame(unlist(strsplit(uid,'CHOLERA'))[2],stringsAsFactors = FALSE) - } - ) - ##Consider putting the as.numeric here - for(idx in 1:length(all.epi.uids)){ - all.epi.data[[idx]] = mutate(all.epi.data[[idx]],'uid'=unlist(all.epi.uids[[idx]])) - } - # all.epi.data = mapply( - # uid=all.epi.uids, - # table=all.epi.data, - # function(uid,table){ - # return(mutate(table,'uid'=unlist(uid))) - # } - # ) - ##all.epi.data = Map( - ## function(uid,table){ - ## return(mutate(table,'uid'=unlist(uid))) - ## }, - ## uid=all.epi.uids, - ## table=all.epi.data - ##) - - ##We need to transform our data from a list of data.tables into a - ## single data.table. - all.epi.data = bind_rows(all.epi.data) - all.epi.data = all.epi.data %>% - #' @importFrom dplyr mutate - mutate(uid = as.integer(uid)) - return(all.epi.data) -} - -################################################################ -#' @name read_taxonomy_data -#' @title read_taxonomy_data -#' @export read_taxonomy_data -#' @description This function is the main function in this package. -#' It reads the taxonomy files from the filesystem, and combines -#' them all into a single data.frame -## args: -#' @param taxonomy.directory A string for the path for the directory -#' described above. -#' @param columns From the final data, which columns to select before -#' returning the data. -#' @param ... A sequence of filters used to filter the description -#' files. See \code{filter_description_data} for details -## vals: -#' @return A data.frame containing the specified \code{columns} of the -#' data read from the directory \code{taxonomy.directory} filtered -#' by the filters \code{...} -################################################################ -read_taxonomy_data = function( - taxonomy.directory = 'taxonomy-verified', - columns=NULL, - ... -){ - ##Start by getting lists of all of the appropriate description files - ## Everything else will depend on description files, so there's no - ## need to get the other files yet - all.description.data <- read_description_taxonomy( - taxonomy.directory = taxonomy.directory, - ... - ) - - ##Get relevent uids - relevent_uids = unique(all.description.data$uid) - - ##Now we do the same thing for the epi files - ##Read all of the data from our epi files - - all.epi.data <- read_epi_taxonomy( - taxonomy.directory = taxonomy.directory, - uids = relevent_uids - ) - - ##Now we join all the epi files together - join.columns = c('uid') - all.data = inner_join( - all.description.data, - all.epi.data, - by = setNames(join.columns,join.columns) - ) - - names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = - gsub( - '\\.x$', - '.desc', - names(all.data)[ grepl(pattern='\\.x$',names(all.data))] - ) - - names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = - gsub( - '\\.y$', - '', - names(all.data)[ grepl(pattern='\\.y$',names(all.data))] - ) - - ##Fix this to use all available ISO levels - all.locations = data.frame( - data = apply( - # select_(all.data,.dots = c("who_region","ISO_A1",sort(names(all.data)[(!endsWith(names(all.data),"desc")) & (startsWith(names(all.data),'ISO_A2'))]))), - select_( - all.data, - .dots = c( - names(all.data)[grepl('^who_region$',names(all.data))], - names(all.data)[grepl('^ISO_A1$',names(all.data))], - sort(names(all.data)[grepl('^ISO_A2_L[1234567890]*$',names(all.data))]) - ) - ), - 1, - function(x){ - gsub('(_NA)+$','',paste(x,collapse='_')) - } - ), - stringsAsFactors = FALSE - ) - - all.locations = all.locations %>% - mutate(location=data) %>% - #' @importFrom dplyr select - select(location) - unique.locations = all.locations %>% - #' @importFrom dplyr group_by - group_by(location) %>% - #' @importFrom dplyr summarize - summarize() - - ##all.locations = lapply(locations,function(...){data.table(location=...)}) - ##all.locations = bind_rows(locations) - all.data = all.data %>% bind_cols(all.locations) - location.description.files = unique.locations %>% - #' @importFrom dplyr mutate - mutate( - location = paste( - taxonomy.directory, - '/Location/', - location, - "_LOC.csv", - sep='' - ) - ) %>% - select(location) - location.population.files = unique.locations %>% - #' @importFrom dplyr mutate - mutate( - location = paste( - taxonomy.directory, - '/Population/', - location, - "_POP.csv", - sep='' - ) - ) %>% - select(location) - - ##So, location population is more complicated, because we need to - ## join on TL,TR... this will likely involve something hard - # closeAllConnections() - ##apply(location.population.files,1,read_taxonomy_csv) - # closeAllConnections() - - if(nrow(location.population.files) > 0){ - location.population.data = apply( - location.population.files, - 1, - function(x){read_population_csv(x[[1]])} - ) - - location.population.data = mapply( - location=unique.locations[[1]], - table=location.population.data, - function(location,table){ - #' @importFrom dplyr mutate - return(mutate(table,'location'=location)) - }, - SIMPLIFY = FALSE - ) - - location.population.data = bind_rows(location.population.data) - - ##Consider doing something smarter here. - join.columns = c("location","TL","TR"); - join.columns = join.columns[join.columns %in% colnames(all.data)] - join.columns = join.columns[ - join.columns %in% colnames(location.population.data) - ] - - all.data = all.data %>% - left_join(location.population.data,by=join.columns) - names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = - gsub( - '\\.y$', - '.pop', - names(all.data)[ grepl(pattern='\\.y$',names(all.data))] - ) - - names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = - gsub( - '\\.x$', - '', - names(all.data)[ grepl(pattern='\\.x$',names(all.data))] - ) - } - - if(nrow(location.description.files) > 0){ - location.description.data = apply( - location.description.files, - 1, - function(x){ - read_location_csv(x[[1]]) - } - ) - ##This requires location descriptions to only have a single row - location.description.data = bind_rows(location.description.data) - ##locations = bind_rows(all.locations) - location.description.data = location.description.data %>% - bind_cols(unique.locations) - location.description.data = bind_rows(location.description.data) - ##Then we can bind everything together. - join.columns = c("location"); - join.columns = join.columns[join.columns %in% colnames(all.data)] - join.columns = join.columns[ - join.columns %in% colnames(location.description.data) - ] - ##all.data = all.data %>% - ## left_join( - ## location.description.data,by=join.columns,suffix=c('','.loc') - ## ) - all.data = all.data %>% - left_join(location.description.data,by=join.columns) - names(all.data)[ grepl(pattern='\\.y$',names(all.data),perl=TRUE)] = - gsub( - '\\.y$', - '.loc', - names(all.data)[ grepl(pattern='\\.y$',names(all.data))] - ) - names(all.data)[ grepl(pattern='\\.x$',names(all.data),perl=TRUE)] = - gsub( - '\\.x$', - '', - names(all.data)[ grepl(pattern='\\.x$',names(all.data))] - ) - } - - - ##Only take the columns which have some amount of data in them. - all.data = select( - all.data, - which(summarise_all(all.data,funs(sum(!is.na(.)))) > 0) - ) - - if((!missing(columns)) && (length(columns) > 0)){ - print(columns) - try( - return(select(all.data,one_of(columns))),silent=TRUE - ) - try( - return(select(all.data,starts_with(columns))),silent=TRUE - ) - warning("Could not find the columns\n",immediate.=TRUE); - } - return(all.data) -} - -################################################################ -#' @name aggregate_taxonomy_data -#' @title aggregate_taxonomy_data -#' @export aggregate_taxonomy_data -#' @description This function groups data by certain fields and sums over places where those fields match. -## args: -#' @param data a \code{tbl_dt(data.frame} containing the data.) -#' @param ISO_level spatial level to aggreate_to. Either 0 for country level, a positive integer for ISO_A2_L?, 'official' to the nearest official shapefile, or Inf, for no aggregation -#' @param temporal_aggregate_time_unit Currently does nothing. Intended to allow for considering observations at multiple time aggregates (or none) -#' @param aggregate_columns which columns to aggregate over. -#' @param time_combine If 'strict', require time periods to match end to end to make an observation. Otherwise, just assume all grouped observations are the same. -#' @param max_overlap In order to shunt cases into one year instead of dividing them, how many days can be removed from a year. -#' @param min_total_length In order to shunt cases into one year instead of dividing them, how many days does an observation need to cover? -#' @param filter_NA_cases Whether or not to remove cases which are NA (as opposed to 0) -#' @return A \code{tbl_dt(data.frame} the aggregated data.) -################################################################ -aggregate_taxonomy_data = function( - data, - ISO_level=2, - temporal_aggregate_time_unit = 'year', - aggregate_columns = 'sCh', - observation=TRUE, - min_total_length = 60, - max_overlap = 8, - filter_NA_cases = TRUE, - time_combine = 'none' -){ - ##Notes: - ####This function does not make observations out of time points quite correctly. In the future we should do the following steps in order: - # a - group the data by by uid and location - # b - combine data at a particular uid/location into time intervals by combining adjacent intervals - # c - ungroup by location, and now group by uid/time interval - # d - combine data at a particular uid/time interval into unions of locations by grouping - # e - track the percent area of the shape covered by the aggregation - # f - Within each time interval, decide whether to collect that interval entirely into a particular time unit based on the length of the whole observation - # g - Aggregate time as decided above, keeping track of the fraction of the year involved and adding cases appropriately. - aggregate_to_start <- time_unit_to_start_function(temporal_aggregate_time_unit) - aggregate_to_end <- time_unit_to_end_function(temporal_aggregate_time_unit) - - - #Filter out NA case values - if(filter_NA_cases){ - data <- data %>% - #' @importFrom dplyr group_by - group_by(uid) %>% - #' @importFrom dplyr filter_ - filter_( - .dots = paste('!is.na(',aggregate_columns,')') - ) - } - if(temporal_aggregate_time_unit == "None"){ - stop("Not yet written") - } - time_change_func = time_unit_to_aggregate_function(temporal_aggregate_time_unit) - ## Aggregate by time: - ###### For now, the grouping columns are all spatial columns, and 'uid'. (This will change once time aggregation is done) - names(aggregate_columns) = NULL - grouping_columns <- c('uid','who_region','ISO_A1',names(data)[grepl('^ISO_A2_L[1234567890]*$',names(data))]) - ###### Remove columns we don't want to deal with. This could be changed into an option later. And should get moved to the end - data <- data %>% select_(.dots = c('TL','TR',grouping_columns,aggregate_columns)) - #### Define ttL and ttR, the first and last time unit the observation covers. - data %>% - group_by_(.dots=c('TL','TR',grouping_columns)) %>% - #importFrom dplyr summarize_ - summarize_(.dots = setNames( - paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), - aggregate_columns - )) %>% - ungroup %>% - group_by_(.dots=c('TL','TR',grouping_columns)) %>% - mutate( - ttL = time_change_func(TL), - ttR = time_change_func(TR) - ) %>% - ungroup -> - data - #### Divide into single time unit and multiple time unit observations - data_single_year = data %>% filter(ttL == ttR) - data_multi_year = data %>% filter(ttL != ttR) - #### Allocate the multiple time unit observations into one observation per time unit - if(nrow(data_multi_year) > 0){ - data_multi_year %>% - #' @importFrom dplyr group_by_ - group_by_(.dots = c('TL','TR','ttL','ttR',grouping_columns)) %>% - do({ - # if(length(.$ttL) != 1){stop("Impossible")} - # if(length(.$ttR) != 1){stop("Impossible")} - if(any(is.na(c(.$ttL,.$ttR)))){ - browser() - } - if(length(.$ttL) > 1){ browser()} - tmp <- data.frame(t = .$ttL:.$ttR) - # if((nrow(tmp) > 1) & (!is.na(.$sCh)) &(any(.$sCh > 0))){browser()} - tmp$TL = if_else(aggregate_to_start(tmp$t) > .$TL,aggregate_to_start(tmp$t),.$TL) - tmp$TR = if_else(aggregate_to_end(tmp$t) < .$TR,aggregate_to_end(tmp$t),.$TR) - if(!all(tmp$TL <= tmp$TR)){browser()} - #### tfrac is the proportion of the this time unit this observation covers - tmp$tfrac = (as.numeric((tmp$TR - tmp$TL),'days')+1)/(as.numeric((aggregate_to_end(tmp$t) - aggregate_to_start(tmp$t)),'days') + 1) - #### tdur is the duration of the observation within the time unit - tmp$tdur = (as.numeric((tmp$TR - tmp$TL),'days')+1) - #### tprop is the proporition of the observation within this time unit - tmp$tprop = (as.numeric((tmp$TR - tmp$TL),'days')+1)/(as.numeric((.$TR - .$TL),'days') + 1) - ## This is to adjust so that single day periods get kept with the rest of their observation if that observation is at least a week long. - ## First find the number of points where the first and last day are the same - tmp$t = .$ttL - tmp[[aggregate_columns]] = diff(c(0,round(cumsum(.[[aggregate_columns]] * tmp$tprop)))) - tmp$obs_TL = .$TL - tmp$obs_TR = .$TR - tmp - }) %>% - ungroup() %>% - select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> - data_multi_year - } - - #### Make the single time unit data have the same info as the multi time unit - if(nrow(data_single_year) > 0){ - data_single_year %>% - #' @importFrom dplyr group_by_ - mutate( - t = ttL, - obs_TL = TL, - obs_TR = TR, - tfrac = (as.numeric((TR - TL),'days')+1)/(as.numeric((aggregate_to_end(t) - aggregate_to_start(t)),'days') + 1), - #### tdur is the duration of the observation within the time unit - tdur = as.numeric(TR-TL,'days') + 1, - #### tprop is the proporition of the observation within this time unit - tprop = 1 - ) %>% - ungroup() %>% - select_(.dots=c(grouping_columns,aggregate_columns,'t','TL','TR','obs_TL','obs_TR')) -> - data_single_year - } - - #### Recombine - #' @importFrom dplyr bind_rows - data = bind_rows(data_single_year,data_multi_year) - - #### Group data together by time year - ###### Note that this fails when the time units don't work out - if(!filter_NA_cases){ - warning( - "This does not work right now. Building time units does not account for suspected vs deaths reports" - ) - } - - if(time_combine == 'strict'){ - data %>% - #' @importFrom dplyr ungroup - ungroup() %>% - #' @importFrom dplyr group_by_ - group_by_(.dots = grouping_columns) %>% - do({ - changed = TRUE - new = . - new$tmp_obs_TL = new$obs_TL - new$tmp_obs_TR = new$obs_TR - iter = 0 - #### Connect greedily until no more reports are left to connect - while(changed){ - old = new - iter = iter + 1 - # print(iter) - total_idx = length(which(new$obs_TL %in% (new$obs_TR + 1))) - if(total_idx>0){ - for(idx1 in which(new$obs_TL %in% (new$TR + 1))){ - # print(paste(idx1,'/',total_idx)) - if(length(which(new$obs_TL[idx1] == (new$TR+1)) ) <= 0){stop("Bad")} - idx2 = which(new$obs_TL[idx1] == (new$TR+1)) - new$tmp_obs_TL[idx1] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx1]) - new$tmp_obs_TL[idx2] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx2]) - new$tmp_obs_TR[idx2] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx2]) - new$tmp_obs_TR[idx1] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx1]) - } - } - total_idx = length(which(new$obs_TR %in% (new$TL - 1))) - if(total_idx > 0){ - for(idx1 in which(new$obs_TR %in% (new$TL - 1))){ - # print(paste(idx1,'/',total_idx)) - if(length(which(new$obs_TR[idx1] == (new$TL-1)) ) <= 0){browser()} - idx2 = which(new$obs_TR[idx1] == (new$TL - 1)) - # if(length(unique(new$tmp_obs_TL[idx2])) > 1){browser()} - # if(length(unique(new$tmp_obs_TR[idx2])) > 1){browser()} - new$tmp_obs_TL[idx1] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx1]) - new$tmp_obs_TL[idx2] = min(new$obs_TL[c(idx1,idx2)],new$tmp_obs_TL[idx2]) - new$tmp_obs_TR[idx2] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx2]) - new$tmp_obs_TR[idx1] = max(new$obs_TR[c(idx1,idx2)],new$tmp_obs_TR[idx1]) - } - new$obs_TL = new$tmp_obs_TL - new$obs_TR = new$tmp_obs_TR - } - if(isTRUE(all.equal(old,new))){ - changed = FALSE - } - } - if(any(.$obs_TL < new$obs_TL)){ - browser() - } - new - }) -> - data - } else if(time_combine == 'unstrict'){ - - data %>% - #' @importFrom dplyr ungroup - ungroup() %>% - #' @importFrom dplyr group_by_ - group_by_(.dots = grouping_columns) %>% - mutate( - obs_TL = min(TL), - obs_TR = max(TR), - TL = ymd(mapply(lhs = obs_TL, rhs = aggregate_to_start(t),function(lhs,rhs){paste(max(c(lhs,rhs)))})), - TR = ymd(mapply(lhs = obs_TR, rhs = aggregate_to_end(t),function(lhs,rhs){paste(min(c(lhs,rhs)))})), - obs_t = ymd(mapply(tl = obs_TL,tr = obs_TR,function(tl,tr){paste(mean(c(tl,tr)))})), - tdur = TR-TL + 1, - obs_tdur = obs_TR - obs_TL + 1 - ) %>% - mutate( - t = ifelse( - (tdur < max_overlap) & (obs_tdur > min_total_length), - t + (t < obs_t) - (t > obs_t), - t - ) - ) -> data - } else if(time_combine == 'none') { - - } else { - stop("time_combine must be one of 'strict', 'unstrict', or 'none'") - } - - #### Now that we have time units properly done, t becomes a grouping column. - grouping_columns = c(grouping_columns,'t') - - #### We now need to move partial time units to the rest of their report if they meet the criteria given by - #### max_overlap and min_total_length - data %>% - group_by_(.dots=c(grouping_columns,'obs_TL','obs_TR')) %>% - summarize_( - .dots = setNames( - c('min(TL)','max(TR)',paste('sum(',aggregate_columns,')')), - c("TL","TR",aggregate_columns) - ) - ) %>% - ungroup %>% - group_by_(.dots = grouping_columns) %>% - mutate( - tdur = TR - TL + 1, - obs_tdur = obs_TR - obs_TL + 1, - #' @importFrom lubridate ymd - obs_t = time_change_func(ymd(mapply(tl=obs_TL,tr=obs_TR,function(tl,tr){paste(mean(c(tl,tr)))}))) - ) -> data - - #### Do the adjustments only if the criterion are met - data %>% - ungroup() %>% - mutate( - t = ifelse( - (obs_t == t) | (obs_tdur < min_total_length) | (tdur > max_overlap), - t, - ifelse( - obs_t > t, - t+1, - t-1 - ) - ) - ) %>% - group_by_(.dots=grouping_columns) %>% - summarize_(.dots = setNames( - paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), - aggregate_columns - )) -> - data - - ## Time aggregation is finished - ## Starting Spatial Aggregation - data$iso_level = apply(!is.na(data[,grepl('ISO_A',colnames(data))]),1,sum) - - #### Picking which spatial columns to aggregate on based on input: - if(is.null(ISO_level)){ - grouping_columns = c('uid','t') - } else if(ISO_level == 'oficial'){ - data %>% - ungroup %>% - mutate( - ISO_A2_L1 = ifelse( - (isISO_A2_L1 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), - ISO_A2_L1, - NA - ), - ISO_A2_L2 = ifelse( - (isISO_A2_L2 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), - ISO_A2_L2, - NA - ), - ISO_A2_L3 = ifelse( - (isISO_A2_L3 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), - ISO_A2_L3, - NA - ), - ISO_A2_L4 = ifelse( - (isISO_A2_L4 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), - ISO_A2_L4, - NA - ), - ISO_A2_L5 = ifelse( - (isISO_A2_L5 == 1) | grepl('|',location,fixed=TRUE) | !is.na(gis_file), - ISO_A2_L5, - NA - ) - ) -> - tmp - } else if (ISO_level == 0){ - grouping_columns <- c('uid','t','who_region','ISO_A1') - } else if(is.finite(ISO_level)){ - grouping_columns <- c('uid','t','who_region','ISO_A1',paste("ISO_A2_L",1:ISO_level,sep='')) - } else { - grouping_columns <- c('uid','t','who_region','ISO_A1',names(data)[grep('^ISO_A2_L[1234567890]*$',names(data))]) - } - if(!all(grouping_columns %in% names(data))){ - warning("Not all grouping columns are present in case data") - grouping_columns = grouping_columns[grouping_columns %in% names(data)] - } - warning("In the process of modifying this function.") - browser() - data %>% - group_by_(.dots=grouping_columns) %>% - do({ - tmp = . - tmp$iso_level = list(unique(.$iso_level)) - tmp$max_iso_level = min(c(max(.$iso_level),.$iso_level)) - }) - summarize(iso_level = list(unique(iso_level))) - ## Final Aggregation - #### We have everything done, so its just a group_by and a summarize from here - data %>% - ungroup() %>% group_by_(.dots=grouping_columns) %>% - summarize_(.dots = setNames( - paste("ifelse(all(is.na(",aggregate_columns,")),NA,sum(",aggregate_columns,",na.rm=T))"), - aggregate_columns - )) -> - rc - return(rc) -} - -#' @export -#' @name case_definition_to_column_name -#' @title case_definition_to_column_name -#' @description Turns human readable types of cholera case definitions into taxdat codes -#' @param type string of type -#' @param database Whether or not we're using the database -#' @return string of column names in the data taxonomy data frame. -case_definition_to_column_name = function(type,database=FALSE,sql=FALSE){ - if((!database) & (!sql)){ - warning("The svn column names are deprecated, please use database column names.") - changer <- c( - 'suspected' = 'sCh', - 'confirmed' = 'cCh', - "presence"=c("sCh","sCh_R","sCh_L","cCh","cCh_L","cCh_R","deaths","deaths_L","deaths_R") - ) - } else if((database) & (!sql)){ - changer <- c( - 'suspected' = 'attributes.fields.suspected_cases', - 'confirmed' = 'attributes.fields.confirmed_cases', - "presence"=c( - "attributes.fields.suspected_cases", - "attributes.fields.suspected_cases_R", - "attributes.fields.suspected_cases_L", - "attributes.fields.confirmed_cases", - "attributes.fields.confirmed_cases_L", - "attributes.fields.confirmed_cases_R", - "attributes.fields.deaths", - "attributes.fields.deaths_L", - "attributes.fields.deaths_R" - ) - ) - } else if((!database) & (sql)){ - changer <- c( - "suspected" = "suspected_cases", - "confirmed" = "confirmed_cases", - "presence"=c( - "suspected_cases", - "suspected_cases_R", - "suspected_cases_L", - "confirmed_cases", - "confirmed_cases_L", - "confirmed_cases_R", - "deaths", - "deaths_L", - "deaths_R" - ) - ) - } - return(changer[type]) -} - -#' @export -#' @name time_unit_to_start_function -#' @title time_unit_to_start_function -#' @description Turns human readable time units into a functions that convert time units to the start of the time unit -#' @param type string of type -#' @return function to convert dates to the right thing -time_unit_to_start_function <- function(unit){ - - # Remove the 's' at the end of the unit - unit <- gsub("s$", "", unit) - - changer = list( - 'year' = function(x){ - return(as.Date(paste(x,'01','01',sep='-'),format='%Y-%m-%d')) - }, - 'isoweek' = function(x){return(stop("Not yet written"))} - ) - return(changer[[unit]]) -} - -#' @export -#' @name time_unit_to_end_function -#' @title time_unit_to_end_function -#' @description Turns human readable time units into a functions that convert time units to the end of the time unit -#' @param type string of type -#' @return function to convert dates to the right thing -time_unit_to_end_function <- function(unit){ - - # Remove the 's' at the end of the unit - unit <- gsub("s$", "", unit) - - changer = list( - 'year' = function(x){ - return(as.Date(paste(x,'12','31',sep='-'),format='%Y-%m-%d')) - }, - 'isoweek' = function(x){return(stop("Not yet written"))} - ) - return(changer[[unit]]) -} -#' @export -#' @name time_unit_to_aggregate_function -#' @title time_unit_to_aggregate_function -#' @description Turns the -#' @param unit Human readable unit of time aggregation -#' @return function to convert dates to the right thing -#' @importFrom lubridate year -time_unit_to_aggregate_function <- function(unit){ - - # Remove the 's' at the end of the unit - unit <- gsub("s$", "", unit) - - changer = list( - 'year' = lubridate::year, - 'isoweek' = function(x){return(stop("Not yet written"))} - ) - return(changer[[unit]]) -} - -## print("Part 1") -## Rprof() -## read_taxonomy_data() -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 2") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns='deaths') -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 3") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns='deaths.x', "who_region == 'AFR'") -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 4") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns='deaths.x', "!(source == 'ProMED')","deaths == '1'") -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 6") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns='ISO_A1','ISO_A1 %in% c("MWI","NGA")') -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 7") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns='pygmy_shrew') -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## print("Part 8") -## Rprof() -## read_taxonomy_data('taxonomy-verified',columns=c("who_region","ISO_A1")) -## Rprof(NULL) -## print(summaryRprof()$sampling.time) -## Rprof() -## test = read_taxonomy_data('taxonomy-working/working-entry1/',columns = c('TL','TR','location','sCh','cCh')) -## Rprof(NULL) -## print(summaryRprof()$sampling.time) - - -## JSON API interface to database -#' @name read_taxonomy_data_database -#' @title read_taxonomy_data_database -#' @export read_taxonomy_data_database -#' @description This function accesses the cholera-taxonomy stored -#' at https://staging.cholera-taxonomy.middle-distance.com pulls -#' data based on function parameters, links it together, and -#' transforms it into a simple features object (sf). -#' @param username The username for a user of the database -#' @param api_key A working api.key for the user of the database -#' @param locations A vector of locations to pull observations from (should be in the form who_region::ISO_L1::ISO_A2_...) -#' @param time_left First time for observations -#' @param time_right Last time for observations -#' @param uids unique observation collections ids to pull -#' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) -#' @return An sf object containing data pulled from the database -read_taxonomy_data_database <- function(username, - api_key, - locations = NULL, - time_left = NULL, - time_right = NULL, - uids = NULL, - website = "https://api.cholera-taxonomy.middle-distance.com/"){ - ## Before we start, I want to explain some weird syntax that will come up: - ## #' @importFrom package function - ## The above line is the preferred way of importing a function from a package. - ## It works in the context of R's autodocumenter (roxygen). - ## It works similarly to the following more sensible code: - ## toJSON = jsonlite::toJSON - ## except that it handles conflicts better by producing a warning, and - ## tells the package about the dependency. - - - ## First, we want to set up the https POST request. - ## We make a list containing the arguments for the request: - ## If the API changes, we will just need to change this list - api_type = "" - if(is.null(uids)){ - api_type = "by_location" - if(length(locations) == 1){ - locations = c(locations,locations) - } - - ## Prevent continents, or too many countries - if(any(!grepl('::',locations))){ - stop("Trying to pull data for a continent is not allowed") - } - #' @importFrom stringr str_count - if((sum(str_count(string = unique(locations),pattern='::') == 1) > 2)){ - stop("Trying to pull data for more than 2 countries at a time is not allowed") - } - - https_post_argument_list = list( - email=username, - api_key=api_key, - locations=gsub('::',' ',locations), - time_left=time_left, - time_right=time_right - ) - } else if(is.null(locations) && is.null(time_left) && is.null(time_right)){ - api_type = "by_observation_collections" - https_post_argument_list = list( - email=username, - api_key=api_key, - observation_collection_ids = uids - ) - } else { - stop("Not supported") - } - - website = paste0(website,"/api/v1/observations/",api_type) - - #' @importFrom jsonlite toJSON - ## Every object in R is a vector, even the primitives. For example, c(1,5,6) is of type - ## integer. Because of this, we need to explicitly tell the JSON parser to treat vectors - ## of length 1 differently. The option for this is auto_unbox = T - json = toJSON(https_post_argument_list,auto_unbox = T) - #' @importFrom httr POST - #' @importFrom httr add_headers - ## Message prints a message to the user. It's somewhere between a warning and a normal print. - ## In this case, this function might take a while to run, so we let the user know up front. - message("Fetching results from JSON API") - - ## This is the line that actually fetches the results. - ## The syntax for adding headers is a little weird. The function add_headers takes named arguments - ## and returns whatever the arguments to POST are supposed to be. - ## body is the body - ## encode is the transformation to perform on the body to make it into text - results = POST( - website, - add_headers("Content-Type" = "application/json"), - body=json, - encode='json', - config = c( - httr::config(ssl_verifyhost = 0, ssl_verifypeer = 0), - httr::verbose() # <--- ADD THIS LINE - ) - ) - - ## Now we process the status code to make sure that things are working correctly - #' @importFrom httr status_code - code = status_code(results) - ## Right now, anything that isn't correct is an error - if(code != 200){ - stop(paste('Error: Status Code',code)) - } - - ## Next we extract just the content of the results - #' @importFrom httr content - original_results_data = content(results) - ## This returns something correct, but the formatting is really - ## odd. It is a little messy, but instead of debugging the - ## formatting, for now I'm converting to json and back, which - ## fixes the problems. - jsondata = rjson::toJSON(original_results_data) - #' @importFrom jsonlite validate - if(!validate(jsondata)){ - stop("Could not validate json response") - } - #' @importFrom jsonlite fromJSON - results_data = fromJSON(jsondata) - - ## Now we have the results of the api data as a nested list. - ## We want to do the following in no particular order - ## for the observations, we want to turn them into a data frame - ## with one row per observation for the location_periods, we want - ## to turn them into a geometry object and link them to the - ## observations - - ## We start with the observations - if( # The | operator is logical or - (!("observations" %in% names(results_data))) | # The results should have observations - (!("data" %in% names(results_data[['observations']]))) | # The observations should have data - (length(results_data[['observations']]) > 1) # The data should be the only thing in observations - ){ - stop("Could not parse results properly. Contact package maintainer") - } - results_data[['observations']] = results_data[['observations']][['data']] - ## jsonlite's flatten - #' @importFrom jsonlite flatten - if(!is.data.frame(results_data[['observations']])){ - results_data[['observations']] = as.data.frame(results_data[['observations']]) - } - results_data[['observations']] = flatten(results_data[['observations']]) - - observation_collections_present <- FALSE - if( - ("observation_collections" %in% names(results_data)) && # The results should have observations - ("data" %in% names(results_data[['observation_collections']])) && # The observations should have data - (length(results_data[['observation_collections']]) == 1) # The data should be the only thing in observations - ){ - results_data[['observation_collections']] = results_data[['observation_collections']][['data']] - if(!is.data.frame(results_data[['observation_collections']])){ - results_data[['observation_collections']] = as.data.frame(results_data[['observation_collections']]) - } - results_data[['observation_collections']] = flatten(results_data[['observation_collections']]) - observation_collections_present <- TRUE - } - - ## Check to make sure that the number of ids and number of rows match - if(!length(unique(results_data$observations$id)) == nrow(results_data$observations)){ - stop("Could not parse results properly. Contact package maintainer") - } - - ## Now we want to handle the location periods - ## We need to process these individually, so we'll loop over - ## location periods to extract the geojsons - ## We use the original_results_data here, since the formatting - ## transformation we did earlier prevents this code from working - tmp_results = original_results_data[['location_periods']][['data']] - all_locations = list() # This will be a list of the geojson objects - if(length(tmp_results) > 0){ - for(idx in 1:length(tmp_results)){ - ## We process the geojson in three pieces. - ## 1. Convert to json string - ## 2. Convert to sf object - ## 3. Add to location list - message(paste(idx,'/',length(tmp_results))) - ## Ignore NULL elements. Undefined list elements default to - ## NULL anyway - if(is.null(tmp_results[[idx]]$attributes$geojson)){ - all_locations[[idx]] = st_sf(geometry = st_sfc(st_point())) - next; - } - unformatted_geojson = tmp_results[[idx]][['attributes']][['geojson']] - json_geojson = jsonlite::toJSON(unformatted_geojson,auto_unbox = TRUE) # 1. - sf_geojson = geojsonsf::geojson_sf(json_geojson) # 2. - all_locations[[idx]] = sf_geojson #3. - } - } - ## reduce_sf_vector turns a list of sf objects into a single sf - ## object containing the same information - locations_sf = taxdat::reduce_sf_vector(all_locations) - ## We are going to take our properly formatted geojson files and - ## replace the badly formatted ones - results_data$location_periods$data$geojson = NULL - results_data$location_periods$data$attributes$geojson = NULL - if(!is.data.frame(results_data$location_periods$data)){ - results_data$location_periods$data <- as.data.frame(results_data$location_periods$data) - } - results_data$location_periods = flatten(results_data$location_periods$data) - if(nrow(results_data$location_periods) > 0){ - results_data$location_periods$sf_id = 1:nrow(results_data$location_periods) - } - results_data$observations$attributes.location_period_id = as(results_data$observations$attributes.location_period_id,class(results_data$location_periods$id)) - - ## We then join (as in sql) by the location_periods with the - ## observations by location_period_id - all_results <- results_data$observations - if( - observation_collections_present && - (nrow(all_results) > 0) && - (nrow(results_data$observation_collections) > 0) - ){ - all_results <- dplyr::left_join( - results_data$observations, - results_data$observation_collections, - by=c( - 'relationships.observation_collection.data.id' = 'id' # lhs column name = rhs column name - ) - ) - } - if( - (nrow(all_results) > 0) && - (nrow(results_data$location_periods) > 0) - ){ - all_results = dplyr::left_join( - all_results, - results_data$location_periods, - by=c( - 'attributes.location_period_id' = 'id' # lhs column name = rhs column name - ) - ) - } - - geoinput <- st_sf(geometry=st_sfc(st_point(1.*c(NA,NA))))$geometry - if(nrow(all_results) == 0){ - geoinput <- geoinput[0] - } - all_results$geojson = geoinput - all_results$geojson[!is.na(all_results$sf_id)] = locations_sf$geometry[all_results[!is.na(all_results$sf_id),][['sf_id']] ] - return(sf::st_sf(all_results,sf_column_name = 'geojson')) -} - -#' @title Pull taxonomy data -#' @description Pulls data from the taxonomy database -#' -#' @param username taxonomy username -#' @param api_key A working api.key for the user of the database -#' @param password taxonomy password -#' @param locations list of locations to pull. For now this only supports country ISO codes. -#' @param time_left left bound for observation times (in date format) -#' @param time_right right bound for observation times (in date format) -#' @param uids list of unique observation collection ids to pull -#' @param website Which website to pull from (default is cholera-taxonomy.middle-distance.com) -#' @param source whether to pull data from the website or using sql on idmodeling2. -#' Needs to be one of 'api' or 'sql'. -#' -#' @details This is a wrapper which calls either read_taxonomy_data_database or -#' read_taxonomy_data_sql depending on the source that the user specifies. -#' @return An sf object containing data pulled from the database -#' @export -pull_taxonomy_data <- function(username, - password, - locations = NULL, - time_left = NULL, - time_right = NULL, - uids = NULL, - website = "https://api.cholera-taxonomy.middle-distance.com/", - source) { - - if (missing(source) | is.null(source)) - stop("No source specified to pull taxonomy data, please specify one of 'api' or 'sql'.") - - if (source == 'api') { - if (missing(username) | missing(password) | is.null(username) | is.null(password)) - stop("Trying to pull data from API, please provide username and api_key.") - - # Return API data pull - rc <- read_taxonomy_data_database(username = username, - api_key = password, - locations = locations, - time_left = time_left, - time_right = time_right, - uids = uids, - website = website) - - } else if (source == 'sql') { - if (missing(username) | missing(password) | is.null(username) | is.null(password)) - stop("Trying to pull data using sql on idemodelin2, please provide database username and password.") - - # Return SQL data pull - rc <- read_taxonomy_data_sql(username = username, - password = password, - locations = locations, - time_left = time_left, - time_right = time_right, - uids = uids) - rc$attributes.fields.suspected_cases <- rc$suspected_cases - rc$attributes.fields.confirmed_cases <- rc$confirmed_cases - rc$attributes.fields.location_id <- rc$location_id - rc$attributes.location_period_id <- rc$location_period_id - - } else { - stop("Parameter 'source' needs to be one of 'api' or 'sql'.") - } - - if(nrow(rc) == 0) { - if (!is.null(uids)) { - err_mssg <- paste("in uids", paste(uids, collapse = ",")) - } else if (!is.null(locations)) { - err_mssg <- paste("in locations", paste(locations, collapse = ",")) - } else { - err_mssg <- "" - } - stop("Didn't find any data ", err_mssg, " in time range [", - ifelse(is.null(time_left), "-Inf", as.character(time_left)), " - ", - ifelse(is.null(time_right), "-nf", as.character(time_right)), "]") - } - return(rc) -} - -#' @title Taxonomy SQL data pull -#' @description Extracts data for a given set of country using SQL from the taxonomy -#' postgresql database stored on idmodeling2 -#' -#' @param username taxonomy username -#' @param password taxonomy password -#' @param locations list of locations to pull. For now this only supports country ISO codes. -#' @param time_left left bound for observation times (in date format) -#' @param time_right right bound for observation times (in date format) -#' @param uids list of unique observation collection ids to pull -#' -#' @details Code follows taxdat::read_taxonomy_data_database template. -#' @return An sf object containing data extracted from the database -#' @export -read_taxonomy_data_sql <- function(username, - password, - locations = NULL, - time_left = NULL, - time_right = NULL, - uids = NULL) { - - if (missing(username) | missing(password)) - stop("Please provide username and password to connect to the taxonomy database.") - - # Connect to database - conn <- RPostgres::dbConnect(RPostgres::Postgres(), - host = "db.cholera-taxonomy.middle-distance.com", - dbname = "CholeraTaxonomy_production", - user = username, - password = password, - port = "5432") - - # Build query for observations - obs_query <- paste("SELECT observations.id::text, observations.observation_collection_id::text, observations.time_left, observations.time_right,", - "observations.suspected_cases, observations.confirmed_cases, observations.deaths, observations.location_period_id::text, observations.location_id::text,", - "observations.phantom, observations.primary - FROM observations left join location_hierarchies on observations.location_id = location_hierarchies.descendant_id") - - cat("-- Pulling data from taxonomy database with SQL \n") - - # Add filters - if (any(c(!is.null(locations), - !is.null(time_left), - !is.null(time_right), - !is.null(uids)))) { - obs_query <- paste(obs_query, "\n WHERE ") - } else { - warning("No filters specified on data pull, pulling all data.") - } - - if (!is.null(time_left)) { - time_left_filter <- paste0("time_left >= '", format(time_left, "%Y-%m-%d"), "'") - } else { - time_left_filter <- NULL - } - - if (!is.null(time_right)) { - time_right_filter <- paste0("time_right <= '", format(time_right, "%Y-%m-%d"), "'") - } else { - time_right_filter <- NULL - } - - if (!is.null(locations)) { - if(all(is.numeric(locations))){ - locations_filter <- paste0("ancestor_id in ({locations*})") - } else { - stop("SQL access by location name is not yet implemented") - } - } else { - locations_filter <- NULL - } - - if (!is.null(uids)) { - uids_filter <- paste0("observation_collection_id IN ({uids*})") - } else { - uids_filter <- NULL - } - - # Combine filters - filters <- c(time_left_filter, time_right_filter, - locations_filter, uids_filter) %>% - paste(collapse = " AND ") - - # Run query for observations - obs_query <- glue::glue_sql(paste(obs_query, filters, ";"), .con = conn) - observations <- DBI::dbGetQuery(conn = conn, obs_query) - if(nrow(observations) == 0){ - stop(paste0("No observations found using query ||",obs_query,"||")) - } - - # Pull location_periods - u_lps <- unique(observations$location_period_id) # unique location period ids - u_lps <- u_lps[!is.na(u_lps)] - if(all(u_lps == as.numeric(u_lps))){ - u_lps <- as.numeric(u_lps) - } else { - stop("Location period id exceeds max integer in R, and glue doesn't work on int64s") - } - lp_query <- glue::glue_sql("SELECT id as location_period_id, geojson FROM location_periods - WHERE id IN ({u_lps*});", .con = conn) - location_periods <- DBI::dbGetQuery(conn = conn, lp_query) - - # Get missing geometries - location_period_issues <- location_periods %>% - filter(is.na(geojson) | geojson == "{}") - - # Get unique valid geojsons - location_periods <- location_periods %>% - filter(!is.na(geojson), geojson != "{}") %>% - group_by(location_period_id) %>% - slice(1) - - # Convert to sf object - location_periods.sf <- purrr::map(location_periods$geojson, ~try(geojsonsf::geojson_sf(.), silent = F)) - - # Get errors - errors <- purrr::map2(location_periods.sf, seq_along(location_periods.sf), ~ if (inherits(.x, "try-error")) .y) %>% - unlist() - if (length(errors) > 0) { - cat("Found unreadable geojson for location periods:", str_c(errors, collapse = ", ")) - location_periods.sf <- location_periods.sf[-errors] - location_periods <- location_periods[-errors, ] - } - - # extract geometries and metadata - location_periods.sf <- do.call(rbind, location_periods.sf) %>% - mutate(location_period_id = location_periods$location_period_id, - location_name = purrr::map_chr(location_periods$geojson, ~ jsonlite::parse_json(.)[["name"]] %>% - ifelse(is.null(.), NA, .)), - times = ifelse(is.na(location_name), NA, str_extract(location_name, "([0-9]{4}-[0-9]{2}-[0-9]{2}_[0-9]{4}-[0-9]{2}-[0-9]{2})")), - location_name = ifelse(is.na(location_name), NA, str_replace_all(str_replace(location_name, str_c("_", times, "_SHP"), ""), "_", "::")) - ) %>% - select(-times) %>% - rename(geojson = geometry) - - # Combine observations and geojsons - res <- right_join(location_periods.sf, observations, by = "location_period_id") - - return(res) -} From 434c40662e43df385913cd54192880dd5748abf1 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:36:39 +0200 Subject: [PATCH 22/69] fix 404: use opt\$api_website instead of hardcoded URL The hardcoded URL "http://cholera-taxonomy.middle-distance.com/" was wrong on two counts: it used http instead of https, and was missing the api. subdomain. The correct URL is already in config_defaults.yml as api_website. Use opt\$api_website so the value flows from the config. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index ad78ff2..eaaf1c0 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -77,7 +77,7 @@ raw_sf <- taxdat::pull_taxonomy_data( time_left = opt$time_lower_bound, time_right = opt$time_upper_bound, source = "api", - website = "http://cholera-taxonomy.middle-distance.com/" + website = opt$api_website ) %>% taxdat::rename_database_fields(source = "api") From 8c8bd1906ae4904498c77584dd8fe1f94d22e843 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:39:38 +0200 Subject: [PATCH 23/69] bypass ssl_verifypeer for API call (server cert covers base domain only) The server's TLS certificate does not list api.cholera-taxonomy.middle-distance.com as an alternative name, so curl rejects the connection. Wrap the pull_taxonomy_data() call in httr::with_config(ssl_verifypeer = FALSE) to bypass peer verification for just this request until the server cert is updated. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index eaaf1c0..46aaf13 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -70,14 +70,19 @@ location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -raw_sf <- taxdat::pull_taxonomy_data( - username = api_user, - password = api_key, - locations = location_str, - time_left = opt$time_lower_bound, - time_right = opt$time_upper_bound, - source = "api", - website = opt$api_website +# NOTE: The server certificate covers the base domain only, not the api. +# subdomain — ssl_verifypeer is disabled for this call until the cert is fixed. +raw_sf <- httr::with_config( + httr::config(ssl_verifypeer = FALSE), + taxdat::pull_taxonomy_data( + username = api_user, + password = api_key, + locations = location_str, + time_left = opt$time_lower_bound, + time_right = opt$time_upper_bound, + source = "api", + website = opt$api_website + ) ) %>% taxdat::rename_database_fields(source = "api") From f84576560ba14d475591ceb1600df324be453e39 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:41:58 +0200 Subject: [PATCH 24/69] fix ssl bypass: use set_config/reset_config instead of with_config httr::with_config() has a promise-evaluation timing issue when the HTTP call happens inside a nested function (pull_taxonomy_data -> read_taxonomy_data_api -> httr::POST): the curl handle is created before with_config has applied the options to the global httr state. httr::set_config() modifies the global config synchronously before the call, which is what httr::POST reads when building the handle. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 46aaf13..05a0838 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -72,19 +72,20 @@ message("Pulling data: ", location_str, # NOTE: The server certificate covers the base domain only, not the api. # subdomain — ssl_verifypeer is disabled for this call until the cert is fixed. -raw_sf <- httr::with_config( - httr::config(ssl_verifypeer = FALSE), - taxdat::pull_taxonomy_data( - username = api_user, - password = api_key, - locations = location_str, - time_left = opt$time_lower_bound, - time_right = opt$time_upper_bound, - source = "api", - website = opt$api_website - ) +# httr::with_config() has a promise-evaluation timing issue when the curl handle +# is created inside a nested function; set_config/reset_config is reliable. +httr::set_config(httr::config(ssl_verifypeer = FALSE)) +raw_sf <- taxdat::pull_taxonomy_data( + username = api_user, + password = api_key, + locations = location_str, + time_left = opt$time_lower_bound, + time_right = opt$time_upper_bound, + source = "api", + website = opt$api_website ) %>% taxdat::rename_database_fields(source = "api") +httr::reset_config() if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, From 7d46bb7b474bbc1a4bc3d844e6fd10edd1b89a3d Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:43:50 +0200 Subject: [PATCH 25/69] fix ssl: disable ssl_verifyhost (hostname mismatch, not CA trust) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The error is 'no alternative certificate subject name matches target host name' — this is a hostname verification failure controlled by CURLOPT_SSL_VERIFYHOST (ssl_verifyhost), not CURLOPT_SSL_VERIFYPEER. ssl_verifyhost must be 0L (integer zero), not FALSE, for curl to accept it. Also keep ssl_verifypeer = 0L for completeness. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 05a0838..5725642 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -71,10 +71,11 @@ message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") # NOTE: The server certificate covers the base domain only, not the api. -# subdomain — ssl_verifypeer is disabled for this call until the cert is fixed. -# httr::with_config() has a promise-evaluation timing issue when the curl handle -# is created inside a nested function; set_config/reset_config is reliable. -httr::set_config(httr::config(ssl_verifypeer = FALSE)) +# subdomain — both ssl_verifypeer and ssl_verifyhost are disabled until the +# cert is fixed. ssl_verifypeer controls CA trust; ssl_verifyhost (must be 0L, +# not FALSE) controls the SAN/CN hostname match — this is the specific check +# that fails here. +httr::set_config(httr::config(ssl_verifypeer = 0L, ssl_verifyhost = 0L)) raw_sf <- taxdat::pull_taxonomy_data( username = api_user, password = api_key, From 99c7bb472f00018ba1416621ef1184bed246ead2 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:47:54 +0200 Subject: [PATCH 26/69] switch to taxdat::read_taxonomy_data_api (drop pull_taxonomy_data wrapper) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit pull_taxonomy_data is a source-routing wrapper; since we always use the API path, call read_taxonomy_data_api directly. Changes vs the wrapper call: - password= renamed to api_key= (inner function's actual param name) - source= dropped (wrapper-only routing param) - time_left/time_right wrapped in as.character() — the wrapper did this coercion internally before forwarding; the inner function does not Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 5725642..3726500 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -76,13 +76,12 @@ message("Pulling data: ", location_str, # not FALSE) controls the SAN/CN hostname match — this is the specific check # that fails here. httr::set_config(httr::config(ssl_verifypeer = 0L, ssl_verifyhost = 0L)) -raw_sf <- taxdat::pull_taxonomy_data( +raw_sf <- taxdat::read_taxonomy_data_api( username = api_user, - password = api_key, + api_key = api_key, locations = location_str, - time_left = opt$time_lower_bound, - time_right = opt$time_upper_bound, - source = "api", + time_left = as.character(opt$time_lower_bound), + time_right = as.character(opt$time_upper_bound), website = opt$api_website ) %>% taxdat::rename_database_fields(source = "api") From d80aa3cabb2ddb5726fe042e7077fe401cf2f6d1 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 14:58:00 +0200 Subject: [PATCH 27/69] fix HPC 500 and clean_columns parse error HPC 500: the taxdat dev branch changed the API base URL from https://api.cholera-taxonomy.middle-distance.com/ to https://cholera-taxonomy.middle-distance.com (no api. subdomain, no trailing slash). Update config_defaults.yml to match, and restore website = opt\$api_website in the call so both local and HPC explicitly use the configured URL rather than each relying on the package default. clean_columns error: taxdat::flatten_json_result calls jsonlite::flatten() which fails on list columns whose elements are nested data frames or raw vectors. Patch the function in the taxdat namespace via assignInNamespace() before calling read_taxonomy_data_api, dropping such columns before flattening. They carry no information used downstream. Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 37 +++++++++++++++++++++++++++++++----- analysis/config_defaults.yml | 2 +- 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 3726500..b2a8ae3 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -66,15 +66,42 @@ if (is.na(api_user) || is.na(api_key)) { # Stage 1a: pull raw data from Cholera Taxonomy API # --------------------------------------------------------------------------- +# Patch taxdat::flatten_json_result to handle list columns that contain nested +# data frames or raw vectors — these cause jsonlite::flatten() to throw +# "list columns are only allowed with raw vector contents". The fix drops any +# such column before flattening; they carry no information used downstream. +utils::assignInNamespace( + "flatten_json_result", + function(json_results) { + if (!is.data.frame(json_results)) json_results <- as.data.frame(json_results) + # Drop list columns whose elements are data frames or raw vectors — + # jsonlite::flatten() cannot handle them. + bad_col <- vapply(json_results, function(col) { + is.list(col) && any(vapply(col, function(x) is.data.frame(x) || is.raw(x), logical(1L))) + }, logical(1L)) + json_results <- json_results[, !bad_col, drop = FALSE] + json_results <- jsonlite::flatten(json_results) + for (colname in names(json_results)) { + if (mode(json_results[[colname]]) == "list") { + if (max(sapply(json_results[[colname]], length)) == 1) { + json_results[[colname]] <- sapply(json_results[[colname]], function(x) { + ifelse(length(x) == 1, x, NA) + }) + } + } + } + json_results + }, + ns = "taxdat" +) + location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) message("Pulling data: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") -# NOTE: The server certificate covers the base domain only, not the api. -# subdomain — both ssl_verifypeer and ssl_verifyhost are disabled until the -# cert is fixed. ssl_verifypeer controls CA trust; ssl_verifyhost (must be 0L, -# not FALSE) controls the SAN/CN hostname match — this is the specific check -# that fails here. +# SSL note: ssl_verifyhost = 0L is kept as a safety net for environments +# where the cert chain differs (e.g. HPC proxies). The correct base-domain +# URL (no api. subdomain) is used per taxdat dev branch default. httr::set_config(httr::config(ssl_verifypeer = 0L, ssl_verifyhost = 0L)) raw_sf <- taxdat::read_taxonomy_data_api( username = api_user, diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index aa7be91..d2e4654 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -8,7 +8,7 @@ # export CHOLERA_API_KEY= # --- API endpoint --- -api_website: "https://api.cholera-taxonomy.middle-distance.com/" +api_website: "https://cholera-taxonomy.middle-distance.com" # --- Geography (overridden per job) --- # who_region: WHO region prefix used in taxdat location strings From a6262c171b4c101eef31220cc4e5da27efac8c60 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 15:46:57 +0200 Subject: [PATCH 28/69] fixes for step 1 --- R/add_population.R | 16 ++-- analysis/00_make_configs.R | 2 +- analysis/01_pull_data.R | 115 ++++++++++++++++++++------- analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 5 files changed, 98 insertions(+), 39 deletions(-) diff --git a/R/add_population.R b/R/add_population.R index 184b4ca..2143c20 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -96,11 +96,12 @@ add_population <- function(normalized_data, raw_sf, country_iso3, message("rgeoboundaries::gb_adm0() failed: ", conditionMessage(e), "\nFalling back to union of LP geometries as country boundary.") all_geoms <- Filter(Negate(is.null), as.list(geom_lookup)) + all_geoms_sfc <- do.call(sf::st_sfc, all_geoms) + # Set CRS separately — passing crs inside the do.call list triggers + # c.sfc dispatch which tries to compute st_bbox on the crs object. + sf::st_crs(all_geoms_sfc) <- if (!is.na(source_crs)) source_crs else 4326 sf::st_sf( - geometry = sf::st_union( - do.call(sf::st_sfc, c(all_geoms, list(crs = source_crs))) %>% - sf::st_transform(4326) - ) + geometry = sf::st_union(sf::st_transform(all_geoms_sfc, 4326)) ) } ) @@ -184,10 +185,9 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # -- d. Single vectorized exact_extract call for all LPs this year ---- # exactextractr processes multiple geometries in one C++ pass, # reading each raster tile at most once. - valid_sfc <- do.call( - sf::st_sfc, c(geoms[valid_idx], list(crs = source_crs)) - ) %>% - sf::st_transform(4326) + valid_sfc <- do.call(sf::st_sfc, geoms[valid_idx]) + sf::st_crs(valid_sfc) <- if (!is.na(source_crs)) source_crs else 4326 + valid_sfc <- sf::st_transform(valid_sfc, 4326) raw_pops <- exactextractr::exact_extract( pop_raster, valid_sfc, "sum" diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index a999919..ec762d7 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -85,7 +85,7 @@ cat("Total Batch 2 jobs:", nrow(countries), "\n") # --------------------------------------------------------------------------- test_specs <- tibble::tribble( ~who_region, ~country_iso3, ~time_lower_bound, ~time_upper_bound, - "AFR", "ETH", "2020-01-01", "2020-02-31" + "AFR", "ETH", "2020-01-01", "2020-03-01" ) write_configs(test_specs, "test_pull") write_configs(dplyr::select(test_specs, who_region, country_iso3), "test_detection") diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index b2a8ae3..49765aa 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -42,8 +42,12 @@ print_options(opt) # Skip if already done # --------------------------------------------------------------------------- -out_geo <- make_stage1_geo_filename(opt) -out_flat <- make_stage1_flat_filename(opt) +out_geo <- make_stage1_geo_filename(opt) +out_flat <- make_stage1_flat_filename(opt) +out_api_cache <- file.path( + here(opt$output_dir), + paste0("raw_api_cache_", make_run_id(opt), ".rds") +) dir.create(dirname(out_flat), recursive = TRUE, showWarnings = FALSE) if (file.exists(out_flat) && !isTRUE(opt$redo)) { @@ -52,13 +56,13 @@ if (file.exists(out_flat) && !isTRUE(opt$redo)) { } # --------------------------------------------------------------------------- -# Credentials +# Credentials — only required when no API cache exists # --------------------------------------------------------------------------- api_user <- Sys.getenv("CHOLERA_API_USERNAME", unset = NA_character_) api_key <- Sys.getenv("CHOLERA_API_KEY", unset = NA_character_) -if (is.na(api_user) || is.na(api_key)) { +if (!file.exists(out_api_cache) && (is.na(api_user) || is.na(api_key))) { stop("CHOLERA_API_USERNAME and CHOLERA_API_KEY environment variables must be set.") } @@ -74,13 +78,33 @@ utils::assignInNamespace( "flatten_json_result", function(json_results) { if (!is.data.frame(json_results)) json_results <- as.data.frame(json_results) - # Drop list columns whose elements are data frames or raw vectors — - # jsonlite::flatten() cannot handle them. - bad_col <- vapply(json_results, function(col) { - is.list(col) && any(vapply(col, function(x) is.data.frame(x) || is.raw(x), logical(1L))) - }, logical(1L)) - json_results <- json_results[, !bad_col, drop = FALSE] + + # jsonlite::flatten() fails when nested data frames contain raw-vector + # list columns ("list columns are only allowed with raw vector contents"). + # Fix: walk every list-of-data-frame column recursively and strip only the + # raw-vector leaf columns — do NOT remove the parent data frame columns, + # because jsonlite::flatten() needs them to produce the attributes.* names. + clean_df <- function(df) { + for (col in names(df)) { + v <- df[[col]] + if (is.data.frame(v)) { + # Nested data frame column: recurse directly — do NOT lapply over it, + # which would iterate columns (not rows) and produce wrong-length output. + df[[col]] <- clean_df(v) + } else if (is.list(v)) { + # Pure list column: remove if any element is a raw vector + if (any(vapply(v, is.raw, logical(1L)))) { + message(" [flatten_json_result patch] removing raw-vector column: ", col) + df[[col]] <- NULL + } + } + } + df + } + + json_results <- clean_df(json_results) json_results <- jsonlite::flatten(json_results) + for (colname in names(json_results)) { if (mode(json_results[[colname]]) == "list") { if (max(sapply(json_results[[colname]], length)) == 1) { @@ -96,23 +120,58 @@ utils::assignInNamespace( ) location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) -message("Pulling data: ", location_str, - " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") - -# SSL note: ssl_verifyhost = 0L is kept as a safety net for environments -# where the cert chain differs (e.g. HPC proxies). The correct base-domain -# URL (no api. subdomain) is used per taxdat dev branch default. -httr::set_config(httr::config(ssl_verifypeer = 0L, ssl_verifyhost = 0L)) -raw_sf <- taxdat::read_taxonomy_data_api( - username = api_user, - api_key = api_key, - locations = location_str, - time_left = as.character(opt$time_lower_bound), - time_right = as.character(opt$time_upper_bound), - website = opt$api_website -) %>% - taxdat::rename_database_fields(source = "api") -httr::reset_config() + +# Pull raw data from API — use cache if available to skip the network call on +# debug reruns. Delete raw_api_cache_*.rds manually (or with --redo-api) to +# force a fresh pull. +if (file.exists(out_api_cache)) { + message("Loading cached API response: ", basename(out_api_cache)) + raw_api <- readRDS(out_api_cache) +} else { + message("Pulling data: ", location_str, + " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") + raw_api <- taxdat::read_taxonomy_data_api( + username = api_user, + api_key = api_key, + locations = location_str, + time_left = as.Date(opt$time_lower_bound), + time_right = as.Date(opt$time_upper_bound) + ) + saveRDS(raw_api, out_api_cache) + message("Cached API response: ", basename(out_api_cache)) +} + +# Select and rename API columns to OutbreakExtractR conventions. +# rename_database_fields() maps attributes.id → locationPeriod_id, but the +# correct LP identifier in the API response is attributes.location_period_id. +# Using direct column selection based on actual API response structure. +# Selecting only needed columns also drops list columns with raw-vector elements +# that would cause sf::st_write to fail. +raw_sf <- raw_api %>% + dplyr::select( + dplyr::any_of(c( + "relationships.observation_collection.data.id", + "attributes.time_left", + "attributes.time_right", + "attributes.fields.suspected_cases", + "attributes.fields.confirmed_cases", + "attributes.fields.deaths", + "attributes.location_period_id", + "attributes.primary", + "attributes.location_name" + )) + ) %>% + dplyr::rename( + observation_collection_id = relationships.observation_collection.data.id, + TL = attributes.time_left, + TR = attributes.time_right, + sCh = attributes.fields.suspected_cases, + cCh = attributes.fields.confirmed_cases, + deaths = attributes.fields.deaths, + location_period_id = attributes.location_period_id, + primary = attributes.primary, + location = attributes.location_name + ) if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, @@ -175,7 +234,7 @@ normalized <- weekly_data %>% # Rasters are downloaded once into opt$raster_dir and cached for subsequent runs. normalized <- OutbreakExtractR::add_population( normalized_data = normalized, - raw_sf = raw_sf, + raw_sf = raw_sf, # has location_period_id + geometry (sf select preserves geom) country_iso3 = opt$country_iso3, raster_dir = here::here(opt$raster_dir) ) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index f58d541..0d2cffe 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -40,7 +40,7 @@ module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials -source analysis/bash/set_taxonomy_api_keys.sh +source analysis/bash/set_taxonomy_api_key.sh echo "===== Batch 1 start: $(date) =====" echo "SLURM_JOB_ID: $SLURM_JOB_ID" diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 8bd81d3..08b558c 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -26,7 +26,7 @@ module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials -source analysis/bash/set_taxonomy_api_keys.sh +source analysis/bash/set_taxonomy_api_key.sh echo "===== Batch 2 start: $(date) =====" From d0f345060e601f7e8fc6061a0f781e9b311db0a9 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 15:52:18 +0200 Subject: [PATCH 29/69] update descdiption --- DESCRIPTION | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a0950f1..cbc04b3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,7 +7,6 @@ Description: This package License: GLP-2 Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 Imports: DBI, RPostgres, @@ -37,8 +36,8 @@ Suggests: future, here, taxdat - # taxdat: github::HopkinsIDD/cholera-taxonomy (or local install) Config/testthat/edition: 3 Depends: R (>= 2.10) LazyData: true +Config/roxygen2/version: 8.0.0 From ef86ed68f17f55cc8aa15cde051962147c316ea0 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 15:59:25 +0200 Subject: [PATCH 30/69] remove dependency on tidyverse --- R/clean_psql_data.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/clean_psql_data.R b/R/clean_psql_data.R index 921dae3..919ffcf 100644 --- a/R/clean_psql_data.R +++ b/R/clean_psql_data.R @@ -7,7 +7,6 @@ clean_psql_data <- function( original_data,... ){ - library(tidyverse) # --------------------------------------------------------------------------- # Normalize taxdat API column names to OutbreakExtractR conventions. From 54b2739630d14210908b42943fffe8ca8a6cb81c Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:05:19 +0200 Subject: [PATCH 31/69] add sf to 01 --- analysis/01_pull_data.R | 1 + 1 file changed, 1 insertion(+) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 49765aa..69475ba 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -19,6 +19,7 @@ library(here) library(optparse) library(dplyr) library(lubridate) +library(sf) source(here("analysis/utils.R")) From aee1d53e507f7a32f924f72ca3f0809cfce21136 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:19:45 +0200 Subject: [PATCH 32/69] update configs to 4-monthly time bounds --- analysis/00_make_configs.R | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index ec762d7..d428aef 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -28,25 +28,32 @@ countries <- tibble::tribble( "AFR", "MOZ", "AFR", "ZMB", "EMR", "SOM", - "EMR", "SDN", - "EMR", "YEM", - "AMR", "HTI" + "EMR", "SDN" ) # --------------------------------------------------------------------------- # 2. Define time windows # --------------------------------------------------------------------------- -# Each row is one analysis window. Windows may overlap — this is intentional -# to allow comparison of outbreak detection across different time horizons. +# Each row is one pull window. Each window is a given month to make data download manageable. -time_windows <- tibble::tribble( - ~time_lower_bound, ~time_upper_bound, - "2010-01-01", "2015-12-31", - "2013-01-01", "2018-12-31", - "2016-01-01", "2021-12-31", - "2018-01-01", "2023-12-31" +# time_windows <- tibble::tribble( +# ~time_lower_bound, ~time_upper_bound, +# "2010-01-01", "2015-12-31", +# "2013-01-01", "2018-12-31", +# "2016-01-01", "2021-12-31", +# "2018-01-01", "2023-12-31" +# ) + +tstart <- "2010-01-01" +tend <- "2024-12-31" +tseq <- seq.Date(tstart, tend, by = "4 months") + +time_windows <- tibble( + time_lower_bound = tseq + 1, + time_upper_bound = c(tseq[-1], tend) ) + # --------------------------------------------------------------------------- # 3. (Optional) outbreak-detection parameter variants # --------------------------------------------------------------------------- From 8a8ffe71c36adb2d1bbe214d998aad880512d33d Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:21:25 +0200 Subject: [PATCH 33/69] date time bounds for configs --- analysis/00_make_configs.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index d428aef..e5d0a83 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -44,8 +44,8 @@ countries <- tibble::tribble( # "2018-01-01", "2023-12-31" # ) -tstart <- "2010-01-01" -tend <- "2024-12-31" +tstart <- as.Date("2010-01-01") +tend <- as.Date("2024-12-31") tseq <- seq.Date(tstart, tend, by = "4 months") time_windows <- tibble( From 9692d0fdce0a8277e9438e5b5a6dc3f69b3e941b Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:24:21 +0200 Subject: [PATCH 34/69] update for first test run --- analysis/00_make_configs.R | 3 ++- analysis/bash/install_r_packages.sh | 4 ++-- analysis/bash/submit_01_pull_data.sh | 7 ++++--- analysis/bash/submit_02_detection.sh | 7 ++++--- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index e5d0a83..1235dca 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -69,7 +69,8 @@ time_windows <- tibble( # --------------------------------------------------------------------------- # pull_set: country × time_window (for Batch 1 data pull) -pull_specs <- tidyr::crossing(countries, time_windows) +pull_specs <- tidyr::crossing(countries, time_windows) %>% + arrange(time_lower_bound) # pull_specs <- tidyr::crossing(countries, time_windows, param_variants) write_configs(pull_specs, "pull_set") diff --git a/analysis/bash/install_r_packages.sh b/analysis/bash/install_r_packages.sh index 74762fd..4bf9ac3 100755 --- a/analysis/bash/install_r_packages.sh +++ b/analysis/bash/install_r_packages.sh @@ -21,7 +21,7 @@ set -euo pipefail # Modules — toolchain # --------------------------------------------------------------------------- module purge -module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 CMake +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 PostgreSQL/16.1 echo "R: $(Rscript --version 2>&1)" echo "Library: $(Rscript -e 'cat(.libPaths()[1])' 2>/dev/null)" @@ -62,7 +62,7 @@ pkgs <- c( "readr", "reshape2", # dev / testing - "testthat", "remotes" + "testthat", "remotes", "geojsonsf" ) missing_pkgs <- pkgs[!pkgs %in% rownames(installed.packages())] diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index 0d2cffe..c411219 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -27,7 +27,7 @@ #SBATCH --output=logs/%x_%A_%a.log #SBATCH --error=logs/%x_%A_%a.log #SBATCH --mem=8G -#SBATCH --cpus-per-task=2 +#SBATCH --cpus-per-task=1 #SBATCH --time=02:00:00 #SBATCH --export=ALL # Yggdrasil partition — verify available partitions with: sinfo -s @@ -35,9 +35,10 @@ #SBATCH --partition=shared-cpu # EDIT: set upper bound to (N pull_set configs - 1) # The exact value is printed by 00_make_configs.R -#SBATCH --array=0-35%25 +#SBATCH --array=0-314%25 + +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 PostgreSQL/16.1 -module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials source analysis/bash/set_taxonomy_api_key.sh diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 08b558c..4cac046 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -14,16 +14,17 @@ #SBATCH --job-name=cholera_detect #SBATCH --output=logs/%x_%A_%a.log #SBATCH --error=logs/%x_%A_%a.log -#SBATCH --mem=4G +#SBATCH --mem=10G #SBATCH --cpus-per-task=1 #SBATCH --time=01:00:00 #SBATCH --export=ALL #SBATCH --partition=shared-cpu # EDIT: set upper bound to (N detection_set configs - 1) # The exact value is printed by 00_make_configs.R -#SBATCH --array=0-8%10 +#SBATCH --array=0-314%20 + +module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 PostgreSQL/16.1 -module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 # Set taxonomy credentials source analysis/bash/set_taxonomy_api_key.sh From 586e31c825ce6f4ef58a7dde8e42a24f12a10ff3 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:25:14 +0200 Subject: [PATCH 35/69] fix dplry in 00 --- analysis/00_make_configs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index 1235dca..40708cb 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -70,7 +70,7 @@ time_windows <- tibble( # pull_set: country × time_window (for Batch 1 data pull) pull_specs <- tidyr::crossing(countries, time_windows) %>% - arrange(time_lower_bound) + dplyr::arrange(time_lower_bound) # pull_specs <- tidyr::crossing(countries, time_windows, param_variants) write_configs(pull_specs, "pull_set") From fd6cde87b7affbc609077a0e42ccadca94da1122 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:54:45 +0200 Subject: [PATCH 36/69] make time bounds characters --- analysis/00_make_configs.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index 40708cb..877b3c9 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -70,7 +70,10 @@ time_windows <- tibble( # pull_set: country × time_window (for Batch 1 data pull) pull_specs <- tidyr::crossing(countries, time_windows) %>% - dplyr::arrange(time_lower_bound) + dplyr::arrange(time_lower_bound) %>% + dplyr::mutate(time_lower_bound = as.character(time_lower_bound), + time_upper_bound = as.character(time_upper_bound)) + # pull_specs <- tidyr::crossing(countries, time_windows, param_variants) write_configs(pull_specs, "pull_set") From 9ec70915426f873b9cc53d61c91d869bcc6bb490 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:55:05 +0200 Subject: [PATCH 37/69] guard against dropping cCh --- analysis/01_pull_data.R | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 69475ba..45ab3fb 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -167,13 +167,20 @@ raw_sf <- raw_api %>% TL = attributes.time_left, TR = attributes.time_right, sCh = attributes.fields.suspected_cases, - cCh = attributes.fields.confirmed_cases, deaths = attributes.fields.deaths, location_period_id = attributes.location_period_id, primary = attributes.primary, location = attributes.location_name ) +if ("attributes.fields.confirmed_cases" %in% colnames (raw_api)) { + raw_sf <- dplyr::rename(raw_sf, + cCh = "attributes.fields.confirmed_cases") +} else { + raw_sf <- raw_sf %>% + dplyr::mutate(cCh = NA) +} + if (is.null(raw_sf) || nrow(raw_sf) == 0) { warning("API returned no data for: ", location_str, " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") From 705e1a4164087c42085134cf4ca2d38340233673 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 16:56:29 +0200 Subject: [PATCH 38/69] dont use s2 --- analysis/01_pull_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 45ab3fb..a6cea8d 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -20,7 +20,7 @@ library(optparse) library(dplyr) library(lubridate) library(sf) - +sf_use_s2(FALSE) source(here("analysis/utils.R")) # --------------------------------------------------------------------------- From 8cffb30ec3dee8d9c50665d6437c328014c6d893 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 22:20:47 +0200 Subject: [PATCH 39/69] fix pull_set errors 1-3 from 2026-06-09 run MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Error 1 (103 jobs): guard optional API column renames in 01_pull_data.R — rename if present, else mutate to NA. Affects observation_collection_id, sCh, cCh, deaths, location_period_id which are absent from some API responses. Consolidates the existing cCh guard into the same loop. Error 2 (27 jobs): fix fill_phantom_zeroes() — add early return for empty input (0 rows after filtering trips the start_weekday guard), narrow the guard to na.omit() to tolerate NA dates, and replace error() with stop() (error() is not an R function). Error 3 (22 jobs): guard empty geometries in add_population() — API returns GEOMETRYCOLLECTION EMPTY for some LPs; sf::st_dimension() returns NA for these, causing exactextractr to throw "missing value where TRUE/FALSE needed". Filter them out after st_transform, before the exact_extract call. Also adds analysis/pull_set_errors_2026-06-09.md summarising all six error types from the 315-job array run. Co-Authored-By: Claude Sonnet 4.6 --- R/add_population.R | 25 +++++++-- R/fill_phantom_zeroes.R | 10 ++-- analysis/01_pull_data.R | 34 +++++++----- analysis/pull_set_errors_2026-06-09.md | 75 ++++++++++++++++++++++++++ 4 files changed, 121 insertions(+), 23 deletions(-) create mode 100644 analysis/pull_set_errors_2026-06-09.md diff --git a/R/add_population.R b/R/add_population.R index 2143c20..46e0357 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -189,17 +189,32 @@ add_population <- function(normalized_data, raw_sf, country_iso3, sf::st_crs(valid_sfc) <- if (!is.na(source_crs)) source_crs else 4326 valid_sfc <- sf::st_transform(valid_sfc, 4326) - raw_pops <- exactextractr::exact_extract( - pop_raster, valid_sfc, "sum" - ) - pop_values[valid_idx] <- as.numeric(raw_pops) * adj_factor + # Guard: empty geometries (API returns GEOMETRYCOLLECTION EMPTY when a + # location has no spatial data) cause sf::st_dimension() to return NA, + # which makes exactextractr's internal if(!all(st_dimension(y)==2)) + # throw "missing value where TRUE/FALSE needed". + empty <- sf::st_is_empty(valid_sfc) + if (any(empty)) { + message(" Empty geometry for LP(s): ", + paste(lp_ids[valid_idx[empty]], collapse = ", "), + " — pop = NA.") + valid_idx <- valid_idx[!empty] + valid_sfc <- valid_sfc[!empty] + } + + if (length(valid_idx) > 0L) { + raw_pops <- exactextractr::exact_extract( + pop_raster, valid_sfc, "sum" + ) + pop_values[valid_idx] <- as.numeric(raw_pops) * adj_factor + } } # -- e. Release raster from memory before moving to the next year ------- rm(pop_raster) gc(verbose = FALSE) - dplyr::tibble(location_period_id = lp_ids, pop = pop_values) + dplyr::tibble(location_period_id = lp_ids, pop = pop_values, adj_factor) }) %>% purrr::list_rbind() diff --git a/R/fill_phantom_zeroes.R b/R/fill_phantom_zeroes.R index dac237b..31d3632 100644 --- a/R/fill_phantom_zeroes.R +++ b/R/fill_phantom_zeroes.R @@ -5,14 +5,16 @@ #' @description Fill in weekly zeroes for sCh if no reporting between min(TL)- 8 weeks and max(TL)+ 8 weeks for that location #' @param original_data dataframe with location, epiweek, TL, TR, sCh, cCh, deaths fill_phantom_zeroes <- function(original_data){ - - if(length(unique(original_data$start_weekday))!=1){ - error("All observations should have the same start_weekday. Please run set_uniform_wday_start on this dataset.") + + if (nrow(original_data) == 0) return(original_data) + + if(length(unique(na.omit(original_data$start_weekday))) > 1){ + stop("All observations should have the same start_weekday. Please run set_uniform_wday_start on this dataset.") } else if(nrow(dplyr::distinct(original_data, location, TL) %>% dplyr::group_by(location, TL) %>% dplyr::add_count() %>% dplyr::filter(n>1)) > 1){ - error("There are overlapping weekly observations. Please run_average_duplicate_observations on this dataset.") + stop("There are overlapping weekly observations. Please run_average_duplicate_observations on this dataset.") } tmp_function <- function(df_original, loc){ diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index a6cea8d..96d1928 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -163,22 +163,28 @@ raw_sf <- raw_api %>% )) ) %>% dplyr::rename( - observation_collection_id = relationships.observation_collection.data.id, - TL = attributes.time_left, - TR = attributes.time_right, - sCh = attributes.fields.suspected_cases, - deaths = attributes.fields.deaths, - location_period_id = attributes.location_period_id, - primary = attributes.primary, - location = attributes.location_name + TL = attributes.time_left, + TR = attributes.time_right, + primary = attributes.primary, + location = attributes.location_name ) -if ("attributes.fields.confirmed_cases" %in% colnames (raw_api)) { - raw_sf <- dplyr::rename(raw_sf, - cCh = "attributes.fields.confirmed_cases") -} else { - raw_sf <- raw_sf %>% - dplyr::mutate(cCh = NA) +# Optional columns: rename if present, else add as NA. +# Mirrors the confirmed_cases guard below — some API responses omit these fields. +optional_col_map <- list( + observation_collection_id = "relationships.observation_collection.data.id", + sCh = "attributes.fields.suspected_cases", + cCh = "attributes.fields.confirmed_cases", + deaths = "attributes.fields.deaths", + location_period_id = "attributes.location_period_id" +) +for (new_name in names(optional_col_map)) { + old_name <- optional_col_map[[new_name]] + if (old_name %in% names(raw_sf)) { + raw_sf <- dplyr::rename(raw_sf, !!new_name := !!old_name) + } else { + raw_sf[[new_name]] <- NA + } } if (is.null(raw_sf) || nrow(raw_sf) == 0) { diff --git a/analysis/pull_set_errors_2026-06-09.md b/analysis/pull_set_errors_2026-06-09.md new file mode 100644 index 0000000..41424f8 --- /dev/null +++ b/analysis/pull_set_errors_2026-06-09.md @@ -0,0 +1,75 @@ +# Pull Set Error Analysis — 2026-06-09 + +Job array: `44806696` (315 tasks, `analysis/configs/pull_set/`) + +## Summary + +| Outcome | Count | % | +|---|---|---| +| Success | 149 | 47.3% | +| Failed | 166 | 52.7% | + +--- + +## Error Groups + +### 1. Missing column in `dplyr::rename()` — 103 jobs (62% of failures) + +`analysis/01_pull_data.R` lines 165–174: the `rename()` call is unconditional — `any_of()` guards the preceding `select()` but not the rename. Columns absent from the API response cause the job to fail. + +**Fix**: apply the cCh guard pattern (rename if present, else `mutate(col = NA)`) to all optional columns. + +| Missing column | Count | +|---|---| +| `relationships.observation_collection.data.id` | 90 | +| `attributes.fields.deaths` | 7 | +| `attributes.location_period_id` | 5 | +| `attributes.fields.suspected_cases` | 1 | + +Affected job IDs: 1, 4, 5, 6, 8, 9, 11, 12, 15, 16, 18, 19, 22, 25, 30, 32, 33, 40, 43, 44, 46, 47, 50, 51, 54, 57, 58, 60, 61, 64, 65, 67, 68, 71, 72, 74, 75, 78, 79, 82, 83, 85, 86, 88, 89, 90, 92, 93, 95, 96, 97, 99, 100, 102, 103, 104, 106, 109, 110, 114, 116, 117, 121, 123, 124, 131, 137, 180, 187, 194, 205, 207, 213, 214, 215, 220, 221, 222, 228, 229, 232, 233, 235, 236, 242, 243, 249, 250, 257, 263, 264, 266, 271, 273, 278, 280, 282, 284, 285, 286, 289, 292, 312 + +--- + +### 2. Inconsistent `start_weekday` — 27 jobs (16% of failures) + +`Error: All observations should have the same start_weekday. Please run set_uniform_wday_start on this dataset.` + +`set_uniform_wday_start()` is called in `01_pull_data.R` but the error fires downstream, suggesting some code path bypasses or re-introduces mixed weekdays after normalization. + +Affected: 2, 13, 20, 81, 128, 135, 142, 144, 149, 151, 252, 287, 291, 293, 294, 298, 299, 300, 301, 303, 305, 306, 307, 308, 310, 313, 314 + +--- + +### 3. `purrr::map()` — missing value where TRUE/FALSE needed — 22 jobs (13% of failures) + +Occurs in `add_population()` during `exactextractr::exact_extract()` on invalid or degenerate geometries. Likely a NULL/empty geometry row slipping through before the spatial join. + +Affected: 0, 7, 14, 21, 35, 42, 49, 56, 63, 70, 77, 84, 91, 132, 139, 146, 153, 165, 168, 175, 189, 203 + +--- + +### 4. SSL/network timeout — 9 jobs (5% of failures) + +`Error in curl::curl_fetch_memory(): Timeout was reached: [cholera-taxonomy.middle-distance.com] SSL connection timeout` + +Transient. Safe to requeue. + +Affected: 26, 27, 28, 29, 31, 36, 37, 38, 39 + +--- + +### 5. `dplyr::left_join()` — missing `location_period_id` — 3 jobs (2% of failures) + +`"Join columns in y must be present in the data. Problem with location_period_id."` + +Downstream join fails when `location_period_id` is NA throughout (from Error 1 unfixed, or when the column is absent). Investigate after Error 1 fix. + +Affected: 41, 277, 296 + +--- + +### 6. `[readValues] cannot read values` — 2 jobs (1% of failures) + +Corrupted WorldPop raster during `exactextractr::exact_extract()`. Delete the cached raster and requeue. + +Affected: 24, 53 From eb02e53d513a2998892c3b48bbb7948ea503ea02 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 23:00:03 +0200 Subject: [PATCH 40/69] Fix pull_set errors 4-6 and clean up add_population geometry guards MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Errors fixed (from analysis/pull_set_errors_2026-06-09.md): Error 5 — empty lp_years early return (add_population.R): purrr::list_rbind() on an empty map returns a 0-column tibble, breaking the downstream left_join on location_period_id. Added early return with pop = NA when no valid location_period_ids are present. Error 6a — corrupted WorldPop download (get_pop.R): A partial/interrupted download of a large raster produces a truncated LZW stream; GDAL reports "code not yet in table" / TIFFReadEncodedTile at read time. download_worldpop_constrained() now reads one block after download to verify the file is intact; if corrupt, it deletes the cached file and retries with the next release (R2024B). Both releases use identical LZW+PREDICTOR=2 compression, confirmed by gdalinfo on both R2025A and R2024B files. Error 6b — non-polygon geometry passed to exact_extract (add_population.R): POINT geometries (centroid-only API responses) caused exact_extract to fail because it requires 2-D polygon input. Previously only empty geometries were filtered; now a single st_dimension() pass covers both empty (NA) and non-polygon (dim != 2) cases, replacing the two-step st_is_empty + st_dimension pattern with one combined filter. Also: add .gitignore entries for logs/, analysis/generated_data/, analysis/worldpop/, and *.Rcheck/; add .Rbuildignore and .Rproj. Co-Authored-By: Claude Sonnet 4.6 --- .Rbuildignore | 2 + .gitignore | 14 ++++ NAMESPACE | 2 + OutbreakExtractR.Rproj | 20 ++++++ R/add_population.R | 32 ++++++--- R/get_pop.R | 91 +++++++++++++++++++------- analysis/pull_set_errors_2026-06-09.md | 6 +- man/add_alert_columns.Rd | 5 -- man/add_alert_columns_outbreak.Rd | 5 -- man/add_alert_stringency.Rd | 3 - man/add_country_column.Rd | 3 - man/add_outcome_bin.Rd | 5 -- man/add_population.Rd | 53 +++++++++++++++ man/download_worldpop_constrained.Rd | 29 ++++++++ man/filter_ms_data.Rd | 35 ++++++++++ man/format_alerts.Rd | 3 - man/get_pop.Rd | 3 + man/get_shp.Rd | 29 ++++++-- man/identify_epidemic_start.Rd | 13 +++- man/identify_outbreaks.Rd | 13 +++- 20 files changed, 300 insertions(+), 66 deletions(-) create mode 100644 .Rbuildignore create mode 100644 .gitignore create mode 100644 OutbreakExtractR.Rproj create mode 100644 man/add_population.Rd create mode 100644 man/download_worldpop_constrained.Rd create mode 100644 man/filter_ms_data.Rd diff --git a/.Rbuildignore b/.Rbuildignore new file mode 100644 index 0000000..91114bf --- /dev/null +++ b/.Rbuildignore @@ -0,0 +1,2 @@ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5de40de --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +.Rproj.user +.Rhistory +.RData +.Ruserdata + +# R check artifacts +*.Rcheck/ + +# Generated analysis outputs — large binaries, not source +analysis/generated_data/ +analysis/worldpop/ + +# SLURM logs +logs/ diff --git a/NAMESPACE b/NAMESPACE index 724425e..4c9b905 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ export(add_outcome_bin) export(add_pop3_adm_columns) export(add_pop3_adm_columns_outbreak) export(add_pop6_adm_columns) +export(add_population) export(add_unique_alert_ids) export(average_duplicate_observations) export(calculate_cases) @@ -25,6 +26,7 @@ export(extract_alert_outcomes) export(extract_binary_case_outcomes) export(fill_missing_lps) export(fill_phantom_zeroes) +export(filter_ms_data) export(format_alerts) export(get_epiweek) export(get_ghs_pop) diff --git a/OutbreakExtractR.Rproj b/OutbreakExtractR.Rproj new file mode 100644 index 0000000..ff46899 --- /dev/null +++ b/OutbreakExtractR.Rproj @@ -0,0 +1,20 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +AutoAppendNewline: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace diff --git a/R/add_population.R b/R/add_population.R index 46e0357..8f56105 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -85,6 +85,15 @@ add_population <- function(normalized_data, raw_sf, country_iso3, .groups = "drop" ) + # All location_period_ids are NA (absent from API response or filtered out). + # purrr::list_rbind() on an empty map returns a 0-column tibble, which breaks + # the left_join below. Return early with pop = NA for all rows. + if (nrow(lp_years) == 0) { + message("add_population(): no valid location_period_ids — pop set to NA for all rows.") + normalized_data$pop <- NA_real_ + return(normalized_data) + } + # --------------------------------------------------------------------------- # 3. Country boundary for the UN adjustment factor (fetched once) # --------------------------------------------------------------------------- @@ -189,17 +198,20 @@ add_population <- function(normalized_data, raw_sf, country_iso3, sf::st_crs(valid_sfc) <- if (!is.na(source_crs)) source_crs else 4326 valid_sfc <- sf::st_transform(valid_sfc, 4326) - # Guard: empty geometries (API returns GEOMETRYCOLLECTION EMPTY when a - # location has no spatial data) cause sf::st_dimension() to return NA, - # which makes exactextractr's internal if(!all(st_dimension(y)==2)) - # throw "missing value where TRUE/FALSE needed". - empty <- sf::st_is_empty(valid_sfc) - if (any(empty)) { - message(" Empty geometry for LP(s): ", - paste(lp_ids[valid_idx[empty]], collapse = ", "), + # exact_extract requires 2-D polygon geometries. + # st_dimension() returns: NA for empty, 0 for point, 1 for line, 2 for polygon. + # A single pass covers both the "GEOMETRYCOLLECTION EMPTY" case (NA) and + # the centroid-only "POINT" case (0) that would otherwise cause + # exactextractr's internal if(!all(st_dimension(y)==2)) to throw + # "missing value where TRUE/FALSE needed". + dims <- sf::st_dimension(valid_sfc) + bad_geom <- is.na(dims) | dims != 2L + if (any(bad_geom)) { + message(" Unusable geometry (empty/non-polygon) for LP(s): ", + paste(lp_ids[valid_idx[bad_geom]], collapse = ", "), " — pop = NA.") - valid_idx <- valid_idx[!empty] - valid_sfc <- valid_sfc[!empty] + valid_idx <- valid_idx[!bad_geom] + valid_sfc <- valid_sfc[!bad_geom] } if (length(valid_idx) > 0L) { diff --git a/R/get_pop.R b/R/get_pop.R index ae17a4b..c884a27 100644 --- a/R/get_pop.R +++ b/R/get_pop.R @@ -1,29 +1,70 @@ # Helper function -#' Download country-specific constrained world pop 100*100m raster (2015-2030) from the worldpop data repo: -#' @param country country iso code -#' @param year the year of the population raster -#' @param dest_dir folder name where the downloaded population raster will be saved -download_worldpop_constrained <- function(country, year, dest_dir = "worldpop") { - if (!dir.exists(dest_dir)) dir.create(dest_dir) - - out_file <- file.path( - dest_dir, - paste0(tolower(country), "_pop_", year, "_CN_100m_R2025A_v1.tif") - ) - - if (file.exists(out_file)) return(out_file) - - url <- paste0( - "https://data.worldpop.org/GIS/Population/Global_2015_2030/", - "R2025A/", year, "/", country, - "/v1/100m/constrained/", - tolower(country), "_pop_", year, "_CN_100m_R2025A_v1.tif" - ) - - message("Downloading WorldPop constrained raster: ", url) - curl::curl_download(url, out_file) - - return(out_file) +#' Download country-specific constrained WorldPop 100m raster (2015-2030). +#' +#' Tries releases in order (newest first): R2025A → R2024B. After each +#' download, reads one cell to verify the file is intact. Both releases use +#' standard LZW+PREDICTOR=2 compression readable by any GDAL version; the +#' fallback exists to handle interrupted or corrupted downloads (a partial +#' LZW stream produces "code not yet in table" / TIFFReadEncodedTile errors +#' indistinguishable from a codec problem). If R2025A is corrupt, its cached +#' file is deleted and R2024B is fetched fresh. +#' +#' @param country Country ISO3 code (upper-case). +#' @param year Population year (integer, 2015-2030). +#' @param dest_dir Directory for cached raster files. Created if absent. +#' @param releases Character vector of WorldPop release tags to try, in order. +download_worldpop_constrained <- function(country, year, dest_dir = "worldpop", + releases = c("R2025A", "R2024B")) { + if (!dir.exists(dest_dir)) dir.create(dest_dir, recursive = TRUE) + + for (release in releases) { + out_file <- file.path( + dest_dir, + paste0(tolower(country), "_pop_", year, "_CN_100m_", release, "_v1.tif") + ) + + if (!file.exists(out_file)) { + url <- paste0( + "https://data.worldpop.org/GIS/Population/Global_2015_2030/", + release, "/", year, "/", country, + "/v1/100m/constrained/", + tolower(country), "_pop_", year, "_CN_100m_", release, "_v1.tif" + ) + message("Downloading WorldPop (", release, "): ", url) + dl_ok <- tryCatch({ + curl::curl_download(url, out_file) + TRUE + }, error = function(e) { + message(" Download failed: ", conditionMessage(e)) + file.remove(out_file) # no-op (returns FALSE) if partial write did not occur + FALSE + }) + if (!dl_ok) next + } else { + message("Using cached WorldPop raster (", release, "): ", basename(out_file)) + } + + # Verify the raster is actually intact after download. + # Both releases use LZW+PREDICTOR=2 (universally supported), but a + # partial/interrupted download produces a truncated LZW stream that + # causes "code not yet in table" / TIFFReadEncodedTile failures at read + # time. Reading one block is the earliest point these errors surface. + readable <- tryCatch({ + r <- raster::raster(out_file) + suppressWarnings(raster::getValuesBlock(r, 1L, 1L, 1L, 1L)) + TRUE + }, error = function(e) { + message(" Raster unreadable (corrupted download?): ", + conditionMessage(e), + "\n Removing cached file and trying next release.") + file.remove(out_file) + FALSE + }) + if (readable) return(out_file) + } + + stop("All WorldPop releases failed for ", country, " year ", year, + ". Tried: ", paste(releases, collapse = ", ")) } #' Estimate Adjustment Factors for Population Data (for years >=2021, use the adjustment factors at 2020 instead) diff --git a/analysis/pull_set_errors_2026-06-09.md b/analysis/pull_set_errors_2026-06-09.md index 41424f8..6d7921c 100644 --- a/analysis/pull_set_errors_2026-06-09.md +++ b/analysis/pull_set_errors_2026-06-09.md @@ -70,6 +70,10 @@ Affected: 41, 277, 296 ### 6. `[readValues] cannot read values` — 2 jobs (1% of failures) -Corrupted WorldPop raster during `exactextractr::exact_extract()`. Delete the cached raster and requeue. +Two distinct root causes, both handled in `R/get_pop.R` / `R/add_population.R`. + +**Job 24 (NGA):** Corrupted WorldPop download. Both R2024B and R2025A use identical LZW+PREDICTOR=2 compression (standard, readable by all GDAL versions). The "Using code not yet in table" / `TIFFReadEncodedTile` errors are produced by a truncated LZW stream — i.e., a partial download of the 150 MB NGA raster. Fix: `download_worldpop_constrained()` now reads one tile after download to verify the file is intact; if corrupt, it deletes the cached file and retries with the next release (R2024B). On a clean re-run the R2025A download will succeed and no fallback is needed. + +**Job 53 (ZMB):** Single-observation LP had a POINT geometry (centroid coordinates only). `exactextractr::exact_extract()` only supports polygon geometries (`st_dimension == 2`). Fix: non-polygon geometries are now filtered out alongside empty geometries in `add_population()`, with pop set to NA. Affected: 24, 53 diff --git a/man/add_alert_columns.Rd b/man/add_alert_columns.Rd index 5ba1689..e5b4848 100644 --- a/man/add_alert_columns.Rd +++ b/man/add_alert_columns.Rd @@ -6,11 +6,6 @@ \usage{ add_alert_columns(basedf, alertdf) } -\arguments{ -\item{basedf}{} - -\item{alertdf}{} -} \value{ dataframe } diff --git a/man/add_alert_columns_outbreak.Rd b/man/add_alert_columns_outbreak.Rd index 64f5e16..3d3028c 100644 --- a/man/add_alert_columns_outbreak.Rd +++ b/man/add_alert_columns_outbreak.Rd @@ -6,11 +6,6 @@ \usage{ add_alert_columns_outbreak(basedf, alertdf) } -\arguments{ -\item{basedf}{} - -\item{alertdf}{} -} \value{ dataframe } diff --git a/man/add_alert_stringency.Rd b/man/add_alert_stringency.Rd index 6e53afd..d5422b8 100644 --- a/man/add_alert_stringency.Rd +++ b/man/add_alert_stringency.Rd @@ -6,9 +6,6 @@ \usage{ add_alert_stringency(basedf) } -\arguments{ -\item{basedf}{} -} \value{ dataframe } diff --git a/man/add_country_column.Rd b/man/add_country_column.Rd index 9aec5d5..2d5a0c1 100644 --- a/man/add_country_column.Rd +++ b/man/add_country_column.Rd @@ -6,9 +6,6 @@ \usage{ add_country_column(basedf) } -\arguments{ -\item{basedf}{} -} \value{ dataframe } diff --git a/man/add_outcome_bin.Rd b/man/add_outcome_bin.Rd index 9738650..552c5af 100644 --- a/man/add_outcome_bin.Rd +++ b/man/add_outcome_bin.Rd @@ -6,11 +6,6 @@ \usage{ add_outcome_bin(basedf, bins) } -\arguments{ -\item{basedf}{} - -\item{bins}{} -} \value{ dataframe } diff --git a/man/add_population.Rd b/man/add_population.Rd new file mode 100644 index 0000000..e885e12 --- /dev/null +++ b/man/add_population.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_population.R +\name{add_population} +\alias{add_population} +\title{add_population} +\usage{ +add_population(normalized_data, raw_sf, country_iso3, raster_dir = "worldpop") +} +\arguments{ +\item{normalized_data}{data.frame: weekly normalized data from the Stage 1 +pipeline (output of fill_missing_lps()). Must contain columns +location_period_id and TL.} + +\item{raw_sf}{sf object: geometry-bearing data returned by +taxdat::pull_taxonomy_data() (before geometry is dropped). Must contain +a location_period_id, locationPeriod_id, or lctn_pr column and an sf +geometry column.} + +\item{country_iso3}{character: ISO3 country code (e.g. "COD"). Used to +download the correct WorldPop raster and to fetch the country boundary +for the UN population adjustment factor.} + +\item{raster_dir}{character: directory for caching WorldPop raster files. +Defaults to "worldpop". Created if it does not exist.} +} +\value{ +normalized_data with a numeric pop column added. Rows whose +location_period_id has no matching geometry in raw_sf receive NA. +} +\description{ +Attach WorldPop population estimates to a normalized weekly +data frame. Intended as a Stage 1 pipeline step immediately after +fill_missing_lps(), and before writing to parquet. + +A single population value is computed per unique location_period_id (not +per week), which is correct: get_outbreak_threshold() and +identify_epidemic_start() both use pop as a static denominator for +incidence calculations. + +Population is estimated by: +1. Looking up each location_period_id geometry in raw_sf (already in +memory — no extra DB call). +2. Clamping the representative year (median TL) to 2015-2030 (WorldPop +constrained raster range). +3. For each unique year: loading the raster ONCE, computing the UN +adjustment factor with one exact_extract call on the country boundary, +then extracting ALL LP populations with a single vectorized +exact_extract call. The raster is released immediately after. + +This avoids the 2N-loads-per-year penalty that results from calling +get_pop() per LP (each call loads the raster twice: once for the LP +geometry and once inside estimate_adj_factors() for the country boundary). +} diff --git a/man/download_worldpop_constrained.Rd b/man/download_worldpop_constrained.Rd new file mode 100644 index 0000000..473b660 --- /dev/null +++ b/man/download_worldpop_constrained.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_pop.R +\name{download_worldpop_constrained} +\alias{download_worldpop_constrained} +\title{Download country-specific constrained WorldPop 100m raster (2015-2030).} +\usage{ +download_worldpop_constrained( + country, + year, + dest_dir = "worldpop", + releases = c("R2025A", "R2024B") +) +} +\arguments{ +\item{country}{Country ISO3 code (upper-case).} + +\item{year}{Population year (integer, 2015-2030).} + +\item{dest_dir}{Directory for cached raster files. Created if absent.} + +\item{releases}{Character vector of WorldPop release tags to try, in order.} +} +\description{ +Tries releases in order (newest first): R2025A → R2024B. After each +download, reads one cell to verify the local GDAL build can decode the +file. Older GDAL versions (e.g., 3.7.1 on some HPC clusters) cannot read +the compression codec used by R2025A; R2024B uses an older codec that is +broadly compatible. +} diff --git a/man/filter_ms_data.Rd b/man/filter_ms_data.Rd new file mode 100644 index 0000000..bb9a3dd --- /dev/null +++ b/man/filter_ms_data.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/filter_ms_data.R +\name{filter_ms_data} +\alias{filter_ms_data} +\title{filter_ms_data} +\usage{ +filter_ms_data( + df, + which_setting = c("epidemic", "endemic", "all"), + incl_trend_alerts = TRUE +) +} +\arguments{ +\item{df}{A dataframe containing alert data. Must include columns: +\itemize{ +\item \code{location}: character, name of the location +\item \code{spatial_scale}: character, e.g., "country", "admin1", etc... +\item \code{alert_type}: character, e.g., "trend" or other alert types +}} + +\item{which_setting}{Character. One of \code{"endemic"}, \code{"epidemic"}, or \code{"all"}. +Controls which subset of locations to keep. Default is \code{"epidemic"}.} + +\item{incl_trend_alerts}{Logical. If \code{TRUE}, trend-based alerts are included; +if \code{FALSE}, they are removed. Default is \code{TRUE}.} +} +\value{ +A filtered dataframe with subnational locations and the requested subset of endemic/epidemic/all. +} +\description{ +Filters a dataframe of outbreak alerts by spatial scale, endemic status, and trend-based alerts. +This function removes country-level locations, optionally removes trend-based alerts, +and allows keeping only endemic, epidemic, or all locations. Endemic locations are determined +based on the package dataset \code{endemic_locs_gte50nz_3ydata}. +} diff --git a/man/format_alerts.Rd b/man/format_alerts.Rd index 2aa01dc..5281e04 100644 --- a/man/format_alerts.Rd +++ b/man/format_alerts.Rd @@ -6,9 +6,6 @@ \usage{ format_alerts(alerts_df) } -\arguments{ -\item{alerts_df}{} -} \value{ a 'long' version of the alerts dataframe with columns for the alert_id, location, TL, spatial scale, country, alert number (numeric), and alert type } diff --git a/man/get_pop.Rd b/man/get_pop.Rd index 9845035..161a02e 100644 --- a/man/get_pop.Rd +++ b/man/get_pop.Rd @@ -32,3 +32,6 @@ numeric \description{ this function is used to get population data for each location period } +\details{ +Estimate population function - updated in May 2026: use the updated population raster between 2015-2030 +} diff --git a/man/get_shp.Rd b/man/get_shp.Rd index 3b3870b..7c1c1df 100644 --- a/man/get_shp.Rd +++ b/man/get_shp.Rd @@ -6,13 +6,34 @@ \usage{ get_shp( location_period_id, - username = username, - password = password, + username, + password, host = "db.cholera-taxonomy.middle-distance.com", port = 5432, - dbname = "CholeraTaxonomy_production" + dbname = "CholeraTaxonomy_production", + output_parquet = NULL ) } +\arguments{ +\item{location_period_id}{numeric: the location period ID to retrieve} + +\item{username}{character: PostgreSQL username} + +\item{password}{character: PostgreSQL password} + +\item{host}{character: database host} + +\item{port}{integer: database port} + +\item{dbname}{character: database name} + +\item{output_parquet}{character: optional file path to save result as +GeoParquet (requires sfarrow package). If NULL, no file is written.} +} +\value{ +sf object with the shapefile geometry +} \description{ -this function is to extract shapefiles from +this function is to extract shapefiles from the Cholera Taxonomy +database. Optionally saves the result as a GeoParquet file. } diff --git a/man/identify_epidemic_start.Rd b/man/identify_epidemic_start.Rd index 0d4d9fc..7d00373 100644 --- a/man/identify_epidemic_start.Rd +++ b/man/identify_epidemic_start.Rd @@ -6,7 +6,18 @@ \usage{ identify_epidemic_start( outbreak_data = outbreak_data, - minimum_consecutive_reports = 3 + outbreak_start_definition = c("consecutive", "dual_window"), + min_weeks_above = 2, + require_increasing_trend = FALSE, + window_weeks = 3, + use_cumulative_trigger = TRUE, + cumulative_trigger_type = c("cumulative_case_threshold", + "cumulative_case_threshold_and_min_cases", + "cumulative_case_threshold_and_nonzero_weeks"), + cumulative_windows = 3, + cumulative_case_threshold_ratio = 1.5, + cumulative_min_cases = NULL, + nonzero_windows = NULL ) } \description{ diff --git a/man/identify_outbreaks.Rd b/man/identify_outbreaks.Rd index 0cd7790..a6f1ae5 100644 --- a/man/identify_outbreaks.Rd +++ b/man/identify_outbreaks.Rd @@ -9,7 +9,18 @@ identify_outbreaks( original_data, zero_case_assumption = T, customized_TL = NULL, - customized_TR = NULL + customized_TR = NULL, + outbreak_start_definition = c("consecutive", "dual_window"), + min_weeks_above = 2, + require_increasing_trend = FALSE, + window_weeks = window_weeks, + cumulative_windows = cumulative_windows, + cumulative_case_threshold_ratio = cumulative_case_threshold_ratio, + cumulative_trigger_type = cumulative_trigger_type, + use_cumulative_trigger = use_cumulative_trigger, + cumulative_min_cases = cumulative_min_cases, + nonzero_windows = nonzero_windows, + tail_period = 6 ) } \arguments{ From 1812eb479899d26aa52b34605b5cf3dd4220a3a6 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 23:07:15 +0200 Subject: [PATCH 41/69] expand pull set to all countries --- analysis/00_make_configs.R | 67 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 64 insertions(+), 3 deletions(-) diff --git a/analysis/00_make_configs.R b/analysis/00_make_configs.R index 877b3c9..bdb0c15 100644 --- a/analysis/00_make_configs.R +++ b/analysis/00_make_configs.R @@ -22,13 +22,74 @@ source(here("analysis/utils.R")) countries <- tibble::tribble( ~who_region, ~country_iso3, + "AFR", "AGO", + "AFR", "BDI", + "AFR", "BEN", + "AFR", "BFA", + "AFR", "BWA", + "AFR", "CAF", + "AFR", "CIV", + "AFR", "CMR", "AFR", "COD", - "AFR", "NGA", + "AFR", "COG", + "EMR", "DJI", + "AFR", "ERI", "AFR", "ETH", + "AFR", "GAB", + "AFR", "GHA", + "AFR", "GIN", + "AFR", "GMB", + "AFR", "GNB", + "AFR", "GNQ", + "AFR", "KEN", + "AFR", "LBR", + "AFR", "LSO", + "AFR", "MDG", + "AFR", "MLI", "AFR", "MOZ", - "AFR", "ZMB", + "AFR", "MRT", + "AFR", "MWI", + "AFR", "NAM", + "AFR", "NER", + "AFR", "NGA", + "AFR", "RWA", + "EMR", "SDN", + "AFR", "SEN", + "AFR", "SLE", "EMR", "SOM", - "EMR", "SDN" + "AFR", "SSD", + "AFR", "SWZ", + "AFR", "TCD", + "AFR", "TGO", + "AFR", "TZA::Mainland", + "AFR", "UGA", + "EMR", "YEM", + "AFR", "ZAF", + "AFR", "ZMB", + "AFR", "ZWE", + "AFR", "TZA::Zanzibar", + "AFR", "COM", + "EUR", "MYT", + "AMR", "HTI", + "EMR", "LBN", + "SEAR", "BGD", + "EMR", "AFG", + "EMR", "PAK", + "SEAR", "IND", + "SEAR", "MMR", + "SEAR", "NPL", + "EMR", "SYR", + "EMR", "IRQ", + "WPR", "PHL", + "AMR", "DOM", + "SEAR", "THA", + "WPR", "CHN", + "WPR", "KHM", + "WPR", "MYS", + "EMR", "IRN", + "WPR", "PNG", + "EMR", "SAU", + "EMR", "ARE" ) # --------------------------------------------------------------------------- From 21107e87ca97bec391c6eac4ea916e7b5c00b001 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 9 Jun 2026 23:08:56 +0200 Subject: [PATCH 42/69] add full country list jobs --- analysis/bash/submit_01_pull_data.sh | 2 +- analysis/bash/submit_02_detection.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/analysis/bash/submit_01_pull_data.sh b/analysis/bash/submit_01_pull_data.sh index c411219..34c1241 100755 --- a/analysis/bash/submit_01_pull_data.sh +++ b/analysis/bash/submit_01_pull_data.sh @@ -35,7 +35,7 @@ #SBATCH --partition=shared-cpu # EDIT: set upper bound to (N pull_set configs - 1) # The exact value is printed by 00_make_configs.R -#SBATCH --array=0-314%25 +#SBATCH --array=0-3059%25 module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 PostgreSQL/16.1 diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 4cac046..66935bd 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -21,7 +21,7 @@ #SBATCH --partition=shared-cpu # EDIT: set upper bound to (N detection_set configs - 1) # The exact value is printed by 00_make_configs.R -#SBATCH --array=0-314%20 +#SBATCH --array=0-67%10 module load GCCcore/12.3.0 GCC/12.3.0 libdeflate/1.18 Abseil/20230125.3 OpenMPI/4.1.5 R/4.3.2 GDAL/3.7.1 PostgreSQL/16.1 From 67ba2522878140b77d395b73d2123707ec26d669 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 08:59:38 +0200 Subject: [PATCH 43/69] Fix pull_set topology and empty-response crashes - 01_pull_data.R: move empty-API guard before select/rename so zero-row sf objects (no attributes.time_left) exit cleanly instead of crashing - add_population.R: apply st_make_valid() on unique LP geometries at deduplication time so all downstream uses (fallback st_union, exact_extract) receive topologically valid polygons - add_population.R: extract bare ISO3 with regexpr("[A-Z]{3}") before gb_adm0() so sub-national codes like "TZA::Mainland" resolve correctly Co-Authored-By: Claude Sonnet 4.6 --- R/add_population.R | 8 ++++++-- analysis/01_pull_data.R | 18 ++++++++++-------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/R/add_population.R b/R/add_population.R index 8f56105..25651aa 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -64,7 +64,8 @@ add_population <- function(normalized_data, raw_sf, country_iso3, dplyr::rename(lp_id = !!geom_id_col) %>% dplyr::group_by(lp_id) %>% dplyr::slice(1) %>% - dplyr::ungroup() + dplyr::ungroup() %>% + sf::st_make_valid() # Named list: character(LP ID) -> sfg geometry geom_lookup <- setNames( @@ -99,8 +100,11 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # --------------------------------------------------------------------------- # Primary: rgeoboundaries network call. # Fallback: union of all LP geometries (approximation, avoids network dep). + # Strip any sub-national suffix (e.g. "TZA::Mainland" -> "TZA") so that + # gb_adm0() receives a plain ISO3 code it can resolve. + iso3_for_boundary <- regmatches(country_iso3, regexpr("[A-Z]{3}", country_iso3)) country_shp <- tryCatch( - sf::st_transform(rgeoboundaries::gb_adm0(country = country_iso3), 4326), + sf::st_transform(rgeoboundaries::gb_adm0(country = iso3_for_boundary), 4326), error = function(e) { message("rgeoboundaries::gb_adm0() failed: ", conditionMessage(e), "\nFalling back to union of LP geometries as country boundary.") diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 96d1928..49b1e5f 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -142,6 +142,16 @@ if (file.exists(out_api_cache)) { message("Cached API response: ", basename(out_api_cache)) } +# Guard: empty API response means no observations for this location/window. +# Must happen before select/rename — an empty sf has only a geometry column, +# which would cause rename(TL = attributes.time_left) to crash. +if (is.null(raw_api) || nrow(raw_api) == 0) { + warning("API returned no data for: ", location_str, + " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") + write_tabular(data.frame(), out_flat, opt$use_geoparquet) + quit(status = 0) +} + # Select and rename API columns to OutbreakExtractR conventions. # rename_database_fields() maps attributes.id → locationPeriod_id, but the # correct LP identifier in the API response is attributes.location_period_id. @@ -187,14 +197,6 @@ for (new_name in names(optional_col_map)) { } } -if (is.null(raw_sf) || nrow(raw_sf) == 0) { - warning("API returned no data for: ", location_str, - " [", opt$time_lower_bound, " → ", opt$time_upper_bound, "]") - # Write empty sentinel files so Batch 2 can detect and skip gracefully - write_tabular(data.frame(), out_flat, opt$use_geoparquet) - quit(status = 0) -} - message("Pulled ", nrow(raw_sf), " raw observations.") # Save raw sf with geometry as GeoParquet (useful for spatial visualisation) From 1aba0996385ed749ab54a27a7401220d8a59fe70 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 09:38:00 +0200 Subject: [PATCH 44/69] Fix positional arg bug in identify_outbreaks() call to get_outbreak_threshold() customized_TL and customized_TR were passed without names, so R matched them positionally to fixed_outbreak_threshold and customized_TL respectively, leaving customized_TR=NULL inside get_outbreak_threshold(). The subsequent subset(TL >= customized_TL & TR <= customized_TR) then evaluated NULL on the right-hand side, producing logical(0) and crashing the tibble row subscript. Discovered during smoke tests on AGO and COD. Co-Authored-By: Claude Sonnet 4.6 --- R/identify_outbreaks.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/identify_outbreaks.R b/R/identify_outbreaks.R index 41ec621..ed723b7 100644 --- a/R/identify_outbreaks.R +++ b/R/identify_outbreaks.R @@ -35,8 +35,8 @@ identify_outbreaks <- function( threshold_type = threshold_type, surveillance_data = original_data, zero_case_assumption = zero_case_assumption, - customized_TL, - customized_TR) + customized_TL = customized_TL, + customized_TR = customized_TR) # Create an empty list to store outbreaks outbreak_list <- vector(mode = 'list', length = length(unique(original_data_threshold$location))) From 215d9ba7789703d88a022915b04a123a49579b1c Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 11:27:08 +0200 Subject: [PATCH 45/69] Fix identify_outbreaks() crash when last outbreak has no epidemic tail When the last detected epidemic start had already been assigned an outbreak number (via the multi-outbreak loop), the code called min() on an empty set to find the tail end, returning Inf. The subsequent row subscript [X:Inf] crashed with "result would be too long a vector". Fix: guard the min() call with any(epidemic_tail); fall back to nrow() when the outbreak extends to the end of the time window without a detected tail. Also cap the end index at nrow() to prevent out-of-bounds subscripting. This bug caused identify_outbreaks() to error on virtually every non-empty window for countries with real data (e.g. 45/46 ETH windows crashed before this fix), producing near-empty Stage 2 output. Co-Authored-By: Claude Sonnet 4.6 --- R/identify_outbreaks.R | 12 ++++++++++-- man/download_worldpop_constrained.Rd | 10 ++++++---- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/R/identify_outbreaks.R b/R/identify_outbreaks.R index ed723b7..b72f0a3 100644 --- a/R/identify_outbreaks.R +++ b/R/identify_outbreaks.R @@ -91,8 +91,16 @@ identify_outbreaks <- function( if(last_epidemic_start$outbreak_number>0){ final_outbreak_number = last_epidemic_start$outbreak_number after_last_epidemi_start = preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:nrow(preoutbreak_by_location_start_end_washout),] - last_outbreak_end_idx = min(as.numeric(after_last_epidemi_start[after_last_epidemi_start$epidemic_tail,]$row_idx)) - preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:(last_outbreak_end_idx+2-1),]$outbreak_number = last_epidemic_start$outbreak_number + # Guard: if no epidemic_tail exists after the last start (outbreak extends + # to the end of the window), fall back to the last row index. + if(any(after_last_epidemi_start$epidemic_tail)){ + last_outbreak_end_idx = min(as.numeric(after_last_epidemi_start[after_last_epidemi_start$epidemic_tail,]$row_idx)) + } else { + last_outbreak_end_idx = nrow(preoutbreak_by_location_start_end_washout) + } + end_idx = min(as.numeric(last_outbreak_end_idx) + 2 - 1, + nrow(preoutbreak_by_location_start_end_washout)) + preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:end_idx,]$outbreak_number = last_epidemic_start$outbreak_number } else { #there's only one outbreak start (one potential outbreak) data_between_epidemic_start = preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:nrow(preoutbreak_by_location_start_end_washout),] diff --git a/man/download_worldpop_constrained.Rd b/man/download_worldpop_constrained.Rd index 473b660..13b8cc9 100644 --- a/man/download_worldpop_constrained.Rd +++ b/man/download_worldpop_constrained.Rd @@ -22,8 +22,10 @@ download_worldpop_constrained( } \description{ Tries releases in order (newest first): R2025A → R2024B. After each -download, reads one cell to verify the local GDAL build can decode the -file. Older GDAL versions (e.g., 3.7.1 on some HPC clusters) cannot read -the compression codec used by R2025A; R2024B uses an older codec that is -broadly compatible. +download, reads one cell to verify the file is intact. Both releases use +standard LZW+PREDICTOR=2 compression readable by any GDAL version; the +fallback exists to handle interrupted or corrupted downloads (a partial +LZW stream produces "code not yet in table" / TIFFReadEncodedTile errors +indistinguishable from a codec problem). If R2025A is corrupt, its cached +file is deleted and R2024B is fetched fresh. } From cc64609ac518eb89939e11ed2ff652c6cc1dbfd0 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 11:28:49 +0200 Subject: [PATCH 46/69] redo outbreak detection by default --- analysis/bash/submit_02_detection.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/analysis/bash/submit_02_detection.sh b/analysis/bash/submit_02_detection.sh index 66935bd..4322bf3 100755 --- a/analysis/bash/submit_02_detection.sh +++ b/analysis/bash/submit_02_detection.sh @@ -64,7 +64,7 @@ THISCONFIG="$CONFIGDIR/${CONFIGNAMES[$SLURM_ARRAY_TASK_ID]}" echo "Config: $THISCONFIG" # --- Run Stage 2 --- -$RSCRIPT analysis/02_run_outbreak_detection.R -c "$THISCONFIG" --redo FALSE || { +$RSCRIPT analysis/02_run_outbreak_detection.R -c "$THISCONFIG" --redo TRUE || { echo "ERROR: 02_run_outbreak_detection.R failed for $THISCONFIG" exit 1 } From ccf82ce883d1c2862583422c10fe95f60ca96413 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 11:56:20 +0200 Subject: [PATCH 47/69] Fix NA risk propagation crash in outbreak detection When add_population() cannot find a WorldPop raster match for a location, pop = NA. This caused get_outbreak_threshold() to produce threshold = NA and subsequently risk = NA via ifelse(NA >= threshold, "high", "low"). Downstream, NA risk values crashed identify_epidemic_start() and identify_epidemic_tail() with "missing value where TRUE/FALSE needed" because if(all(NA)) and if(any(NA)) evaluate to NA rather than FALSE. Fixes: - get_outbreak_threshold(): use case_when to map NA pop/threshold to "low" risk rather than propagating NA (conservative: unknown incidence = not high) - identify_epidemic_start(): wrap consecutive-high check with isTRUE() to treat NA comparisons as FALSE - identify_epidemic_tail(): wrap rle any() check with isTRUE() for same reason Also adds: - analysis/parse_detect_logs.R: SLURM log parser for Stage 2 detection jobs, with per-batch breakdowns and per-window failure classification - analysis/scratch_coverage.R: Stage 1 coverage heatmaps (presence, obs rows, suspected cases) with 3-level status (has data / zero cases / no data) - analysis/scratch_api_vs_stage1.R: systematic API cache vs Stage 1 comparison Co-Authored-By: Claude Sonnet 4.6 --- R/get_outbreak_threshold.R | 13 +- R/identify_epidemic_start.R | 2 +- R/identify_epidemic_tail.R | 2 +- analysis/parse_detect_logs.R | 232 +++++++++++++++++++++++++++ analysis/scratch_api_vs_stage1.R | 225 ++++++++++++++++++++++++++ analysis/scratch_coverage.R | 267 +++++++++++++++++++++++++++++++ 6 files changed, 736 insertions(+), 5 deletions(-) create mode 100644 analysis/parse_detect_logs.R create mode 100644 analysis/scratch_api_vs_stage1.R create mode 100644 analysis/scratch_coverage.R diff --git a/R/get_outbreak_threshold.R b/R/get_outbreak_threshold.R index 4c123a7..9049894 100644 --- a/R/get_outbreak_threshold.R +++ b/R/get_outbreak_threshold.R @@ -63,10 +63,17 @@ get_outbreak_threshold <- function ( } - surveillance_data_threshold <- surveillance_data_threshold %>% - ungroup() %>% + surveillance_data_threshold <- surveillance_data_threshold %>% + ungroup() %>% mutate( - risk = ifelse(sCh/pop >= threshold & sCh>0, "high","low") + # When pop or threshold is NA (population lookup failed for this + # location), incidence cannot be computed — treat as "low" risk rather + # than propagating NA, which crashes downstream if() conditions. + risk = dplyr::case_when( + is.na(pop) | is.na(threshold) ~ "low", + sCh / pop >= threshold & sCh > 0 ~ "high", + TRUE ~ "low" + ) ) return(surveillance_data_threshold) diff --git a/R/identify_epidemic_start.R b/R/identify_epidemic_start.R index 7008d12..9822b76 100644 --- a/R/identify_epidemic_start.R +++ b/R/identify_epidemic_start.R @@ -40,7 +40,7 @@ identify_epidemic_start <- function( } } else { for (idx in 1:(nrow(outbreak_data_with_epistart)-min_weeks_above+1)) { - if(all(outbreak_data_with_epistart$risk[idx:(idx+min_weeks_above-1)] == "high")){ + if(isTRUE(all(outbreak_data_with_epistart$risk[idx:(idx+min_weeks_above-1)] == "high"))){ outbreak_data_with_epistart$epidemic_start[idx] = TRUE } } diff --git a/R/identify_epidemic_tail.R b/R/identify_epidemic_tail.R index a130a3a..7e3da0d 100644 --- a/R/identify_epidemic_tail.R +++ b/R/identify_epidemic_tail.R @@ -16,7 +16,7 @@ identify_epidemic_tail <- function ( tail_position <- rle(tail_vector) - if(any(tail_position$lengths[tail_position$values==1] >= tail_period)){ + if(isTRUE(any(tail_position$lengths[tail_position$values==1] >= tail_period))){ tail_position_table <- data.frame( values = tail_position$values, lengths = tail_position$lengths, diff --git a/analysis/parse_detect_logs.R b/analysis/parse_detect_logs.R new file mode 100644 index 0000000..1a06464 --- /dev/null +++ b/analysis/parse_detect_logs.R @@ -0,0 +1,232 @@ +#!/usr/bin/env Rscript +# parse_detect_logs.R +# Parses all Stage 2 (detection) SLURM logs, classifies outcomes, and writes +# summary CSVs parallel to parse_pull_logs.R. +# +# Key differences from pull logs: +# - One log = one country (not one country × window) +# - Outcomes are at country level; per-window failures surface as warnings +# - Extracts Stage 2 row counts and window tallies from log body +# +# Usage: +# Rscript analysis/parse_detect_logs.R [--log-dir logs] \ +# [--out analysis/detect_log_summary.csv] + +suppressPackageStartupMessages({ + library(dplyr) + library(readr) + library(stringr) + library(purrr) + library(tidyr) +}) + +# ── CLI args ────────────────────────────────────────────────────────────────── +args <- commandArgs(trailingOnly = TRUE) + +get_arg <- function(flag, default) { + idx <- which(args == flag) + if (length(idx) && length(args) >= idx + 1) args[[idx + 1]] else default +} + +log_dir <- get_arg("--log-dir", "logs") +out_csv <- get_arg("--out", "analysis/detect_log_summary.csv") + +# ── Per-window warning error classification ─────────────────────────────────── +# Matches the warning body emitted by identify_outbreaks() / trigger_alert() +window_error_classes <- list( + missing_value_logical = "missing value where TRUE/FALSE needed", + too_long_vector = "result would be too long a vector", + subscript_out_of_range = "subscript out of bounds|attempt to select less than one", + no_non_missing_min = "no non-missing arguments to min", + trigger_alert_failed = "trigger_alert\\(\\) failed", + identify_failed_other = "identify_outbreaks\\(\\) failed" +) + +classify_window_error <- function(msg) { + for (cls in names(window_error_classes)) { + if (grepl(window_error_classes[[cls]], msg, perl = TRUE)) return(cls) + } + "unknown_window_error" +} + +# ── Per-log parser ───────────────────────────────────────────────────────────── +parse_log <- function(path) { + + lines <- tryCatch(readLines(path, warn = FALSE), error = function(e) character(0)) + + empty_row <- tibble( + log_file = basename(path), + array_task_id = NA_integer_, + config = NA_character_, + who_region = NA_character_, + country_iso3 = NA_character_, + outcome = "unreadable", + n_stage1_files = NA_integer_, + n_windows_empty = NA_integer_, + n_windows_no_ob = NA_integer_, + n_windows_ob = NA_integer_, + n_windows_failed = NA_integer_, + total_rows = NA_integer_, + window_error_types = NA_character_ + ) + + if (length(lines) == 0) return(empty_row) + + # ── Header fields ──────────────────────────────────────────────────────────── + grab <- function(pattern) { + m <- str_match(lines, pattern) + hit <- m[!is.na(m[, 2]), 2, drop = TRUE] + if (length(hit)) hit[[1]] else NA_character_ + } + + array_task_id <- as.integer(grab("SLURM_ARRAY_TASK_ID:\\s*(\\d+)")) + config <- grab("^Config:\\s*(.+)") + who_region <- grab("\\$\\s*who_region\\s*:\\s*chr\\s*\"([^\"]+)\"") + country_iso3 <- grab("\\$\\s*country_iso3\\s*:\\s*chr\\s*\"([^\"]+)\"") + + # ── Window-level counts ────────────────────────────────────────────────────── + n_stage1_files <- as.integer(grab("Found (\\d+) Stage 1 file")) + n_windows_empty <- sum(grepl("Empty Stage 1 file", lines, fixed = TRUE)) + n_windows_no_ob <- sum(grepl("No outbreaks detected", lines, fixed = TRUE)) + n_windows_ob <- sum(grepl("Rows:\\s*\\d+\\s*\\|\\s*Outbreak-period rows", lines)) + total_rows <- { + m <- str_match(lines, "Total rows:\\s*(\\d+)") + hit <- m[!is.na(m[, 2]), 2] + if (length(hit)) as.integer(hit[[1]]) else NA_integer_ + } + + # ── Per-window failure warnings ────────────────────────────────────────────── + # Warning lines look like: + # identify_outbreaks() failed for : + # trigger_alert() failed for : + warn_lines <- lines[grepl("(identify_outbreaks|trigger_alert)\\(\\) failed for", lines)] + n_windows_failed <- length(warn_lines) + + window_error_types <- if (n_windows_failed > 0) { + warn_lines |> + map_chr(classify_window_error) |> + unique() |> + sort() |> + paste(collapse = ";") + } else { + NA_character_ + } + + # ── Outcome ─────────────────────────────────────────────────────────────────── + completed <- any(grepl("Batch 2 end:", lines, fixed = TRUE)) + no_results <- any(grepl("No outbreak results to save", lines, fixed = TRUE)) + skipped <- any(grepl("Stage 2 output already exists, skipping", lines, fixed = TRUE)) + halted <- any(grepl("Execution halted", lines, fixed = TRUE)) + error_line <- any(grepl("^ERROR:", lines)) + + outcome <- case_when( + halted | error_line ~ "error", + skipped & !completed ~ "skipped", + completed & no_results ~ "success_no_results", + completed ~ "success", + TRUE ~ "incomplete" + ) + + # Extract SLURM job ID from filename (cholera_detect_{job_id}_{task}.log) + slurm_job_id <- str_match(basename(path), "^cholera_detect_(\\d+)_")[, 2] + + tibble( + log_file = basename(path), + slurm_job_id = slurm_job_id, + array_task_id = array_task_id, + config = config, + who_region = who_region, + country_iso3 = country_iso3, + outcome = outcome, + n_stage1_files = n_stage1_files, + n_windows_empty = n_windows_empty, + n_windows_no_ob = n_windows_no_ob, + n_windows_ob = n_windows_ob, + n_windows_failed = n_windows_failed, + total_rows = total_rows, + window_error_types = window_error_types + ) +} + +# ── Main ─────────────────────────────────────────────────────────────────────── +log_files <- list.files(log_dir, + pattern = "^cholera_detect.*\\.log$", + full.names = TRUE) + +if (length(log_files) == 0) stop("No detection .log files found in: ", log_dir) + +message(sprintf("Parsing %d detection log files from '%s' ...", + length(log_files), log_dir)) + +results <- map(log_files, parse_log, .progress = TRUE) |> list_rbind() + +# ── Console summary ──────────────────────────────────────────────────────────── +batches <- sort(unique(results$slurm_job_id)) +cat(sprintf("\n%d batch(es) found: %s\n", length(batches), paste(batches, collapse = ", "))) + +print_batch_summary <- function(df, label) { + cat(sprintf("\n========== %s ==========\n", label)) + + cat("--- Outcome ---\n") + df |> + count(outcome, sort = TRUE) |> + mutate(pct = sprintf("%.1f%%", 100 * n / sum(n))) |> + print(n = Inf) + + cat("--- Window counts ---\n") + df |> + summarise( + countries_run = sum(outcome %in% c("success", "success_no_results")), + total_stage1_files = sum(n_stage1_files, na.rm = TRUE), + windows_empty = sum(n_windows_empty, na.rm = TRUE), + windows_no_ob = sum(n_windows_no_ob, na.rm = TRUE), + windows_with_ob = sum(n_windows_ob, na.rm = TRUE), + windows_failed = sum(n_windows_failed, na.rm = TRUE), + total_output_rows = sum(total_rows, na.rm = TRUE) + ) |> print() + + failed_df <- df |> filter(n_windows_failed > 0) + if (nrow(failed_df) > 0) { + cat(sprintf("--- Per-window error types (%d countries affected) ---\n", + nrow(failed_df))) + failed_df |> + mutate(error_type = str_split(window_error_types, ";")) |> + unnest(error_type) |> + count(error_type, sort = TRUE) |> + mutate(pct = sprintf("%.1f%%", 100 * n / sum(n))) |> + print(n = Inf) + + cat("--- Countries with failures ---\n") + failed_df |> + select(who_region, country_iso3, n_windows_failed, window_error_types, + n_windows_ob, total_rows) |> + arrange(desc(n_windows_failed)) |> + print(n = 40) + } + + incomplete <- df |> filter(outcome == "incomplete") + if (nrow(incomplete) > 0) { + cat(sprintf("--- Incomplete jobs (%d) ---\n", nrow(incomplete))) + incomplete |> + select(log_file, array_task_id, who_region, country_iso3, + n_windows_ob, n_windows_failed) |> + print(n = Inf) + } +} + +# Per-batch summaries +for (b in batches) { + print_batch_summary(results |> filter(slurm_job_id == b), + paste("Batch", b)) +} + +# Combined summary across all batches (latest per country if duplicated) +cat("\n========== Combined (latest batch per country) ==========\n") +latest <- results |> + arrange(desc(slurm_job_id)) |> + distinct(who_region, country_iso3, .keep_all = TRUE) +print_batch_summary(latest, "Latest run per country") + +# ── Write CSV ───────────────────────────────────────────────────────────────── +write_csv(results, out_csv) +message(sprintf("\nSummary written to: %s", out_csv)) diff --git a/analysis/scratch_api_vs_stage1.R b/analysis/scratch_api_vs_stage1.R new file mode 100644 index 0000000..c09e7ea --- /dev/null +++ b/analysis/scratch_api_vs_stage1.R @@ -0,0 +1,225 @@ +# scratch_api_vs_stage1.R — Compare raw API cache to Stage 1 flat output +# +# For every country × time window that has a raw_api_cache_*.rds file, this +# script counts rows at each filtering stage and compares to the corresponding +# stage1_flat_*.rds to identify where data is being lost (or is genuinely absent). +# +# Filtering stages tracked (in pipeline order): +# 1. n_api_raw — total rows returned by the API (before any processing) +# 2. n_api_primary — rows where attributes.primary == TRUE +# 3. n_stage1_all — all rows in Stage 1 flat (including phantom zeroes) +# 4. n_stage1_obs — non-phantom rows in Stage 1 flat (real observations) +# 5. n_stage1_sCh — non-phantom rows with sCh > 0 +# +# Between stage 2 and 3 the pipeline also applies observation_filter() (temporal +# scale, spatial scale, NA-sCh removal, minimum daily cases) and aggregation, +# so n_stage1_obs ≤ n_api_primary is expected. The script flags windows where +# n_api_primary > 0 but n_stage1_obs == 0 as "potential data loss" for review. +# +# Output: +# analysis/generated_data/api_vs_stage1.csv — full row-by-row table +# console summary table — printed at end + +library(here) +library(dplyr) +library(purrr) +library(tidyr) +library(stringr) +library(lubridate) + +stage1_dir <- here("analysis/generated_data") + +# --------------------------------------------------------------------------- +# 1. Discover raw API cache files and parse metadata +# --------------------------------------------------------------------------- + +cache_files <- list.files(stage1_dir, + pattern = "^raw_api_cache_.*\\.rds$", + full.names = TRUE) + +m <- str_match(basename(cache_files), + "^raw_api_cache_([A-Z]+)_([^_]+)_TL(\\d{8})_TR(\\d{8})") + +cache_meta <- tibble( + cache_path = cache_files, + run_id = str_remove(basename(cache_files), "^raw_api_cache_") |> + str_remove("\\.rds$"), + who_region = m[, 2], + iso3 = m[, 3], + tl_str = m[, 4], + tr_str = m[, 5] +) |> + filter(!is.na(who_region), !is.na(iso3)) |> + mutate( + TL = ymd(tl_str), + TR = ymd(tr_str), + flat_path = file.path(stage1_dir, + paste0("stage1_flat_", run_id, ".rds")) + ) + +message("Found ", nrow(cache_meta), " API cache files across ", + n_distinct(cache_meta$iso3), " countries") +message(" Stage 1 flat file present: ", + sum(file.exists(cache_meta$flat_path)), " / ", nrow(cache_meta)) + +# --------------------------------------------------------------------------- +# 2. Per-window comparison function +# --------------------------------------------------------------------------- + +compare_window <- function(cache_path, flat_path) { + + # --- Raw API cache --- + api <- tryCatch(readRDS(cache_path), error = function(e) NULL) + + if (is.null(api) || nrow(api) == 0) { + return(tibble( + n_api_raw = 0L, + n_api_primary = 0L, + flat_exists = file.exists(flat_path), + n_stage1_all = NA_integer_, + n_stage1_obs = NA_integer_, + n_stage1_sCh = NA_integer_ + )) + } + + n_api_raw <- nrow(api) + + # "primary" lives as attributes.primary in raw API sf objects + primary_col <- intersect(c("primary", "attributes.primary"), names(api)) + if (length(primary_col) == 0) { + # Fallback: assume all primary if column absent + n_api_primary <- n_api_raw + } else { + n_api_primary <- sum(api[[primary_col[1]]] == TRUE, na.rm = TRUE) + } + + # --- Stage 1 flat file --- + if (!file.exists(flat_path)) { + return(tibble( + n_api_raw = n_api_raw, + n_api_primary = n_api_primary, + flat_exists = FALSE, + n_stage1_all = NA_integer_, + n_stage1_obs = NA_integer_, + n_stage1_sCh = NA_integer_ + )) + } + + flat <- tryCatch(readRDS(flat_path), error = function(e) NULL) + + if (is.null(flat) || nrow(flat) == 0) { + return(tibble( + n_api_raw = n_api_raw, + n_api_primary = n_api_primary, + flat_exists = TRUE, + n_stage1_all = 0L, + n_stage1_obs = 0L, + n_stage1_sCh = 0L + )) + } + + obs <- filter(flat, !phantom) + tibble( + n_api_raw = n_api_raw, + n_api_primary = n_api_primary, + flat_exists = TRUE, + n_stage1_all = nrow(flat), + n_stage1_obs = nrow(obs), + n_stage1_sCh = sum(obs$sCh > 0, na.rm = TRUE) + ) +} + +# --------------------------------------------------------------------------- +# 3. Run comparison (with progress bar) +# --------------------------------------------------------------------------- + +message("Comparing API cache vs Stage 1 flat files …") + +results <- map2( + cache_meta$cache_path, + cache_meta$flat_path, + compare_window, + .progress = TRUE +) + +comparison <- bind_cols(cache_meta, list_rbind(results)) |> + mutate( + # Classify each window + status = case_when( + n_api_raw == 0 ~ "api_empty", + n_api_primary == 0 ~ "api_nonprimary_only", + !flat_exists ~ "stage1_missing", + n_stage1_obs == 0 & n_api_primary > 0 ~ "data_lost", + n_stage1_sCh == 0 & n_stage1_obs > 0 ~ "zero_sCh", + TRUE ~ "ok" + ), + # Retention rate: what fraction of primary API rows appear as Stage 1 obs + # (can be > 1 after zero-filling / aggregation, but usually ≤ 1) + retention = if_else(n_api_primary > 0, + n_stage1_obs / n_api_primary, + NA_real_) + ) + +# --------------------------------------------------------------------------- +# 4. Save full table +# --------------------------------------------------------------------------- + +out_csv <- here("analysis/generated_data/api_vs_stage1.csv") +readr::write_csv(comparison |> select(-cache_path, -flat_path), out_csv) +message("Saved: ", basename(out_csv)) + +# --------------------------------------------------------------------------- +# 5. Console summary +# --------------------------------------------------------------------------- + +cat("\n=== API cache vs Stage 1 — window status counts ===\n") +comparison |> + count(status, sort = TRUE) |> + print() + +cat("\n=== 'data_lost' windows: primary API rows > 0 but Stage 1 obs == 0 ===\n") +lost <- comparison |> + filter(status == "data_lost") |> + select(who_region, iso3, TL, TR, n_api_raw, n_api_primary, + n_stage1_all, n_stage1_obs) + +if (nrow(lost) == 0) { + cat("None — no data loss detected.\n") +} else { + cat(nrow(lost), "windows affected across", + n_distinct(lost$iso3), "countries\n\n") + print(lost, n = 50) +} + +cat("\n=== 'stage1_missing' windows: cache exists but no Stage 1 file ===\n") +missing_s1 <- comparison |> + filter(status == "stage1_missing") |> + select(who_region, iso3, TL, TR, n_api_raw, n_api_primary) + +if (nrow(missing_s1) == 0) { + cat("None.\n") +} else { + cat(nrow(missing_s1), "windows missing Stage 1 output\n\n") + missing_s1 |> + count(who_region, iso3, name = "n_missing") |> + arrange(desc(n_missing)) |> + print(n = 30) +} + +cat("\n=== Countries with ≥1 'data_lost' window ===\n") +comparison |> + filter(status == "data_lost") |> + count(who_region, iso3, name = "n_lost_windows") |> + arrange(desc(n_lost_windows)) |> + print(n = 30) + +cat("\n=== Retention rate summary (n_stage1_obs / n_api_primary) ===\n") +comparison |> + filter(status == "ok") |> + summarise( + median_retention = median(retention, na.rm = TRUE), + p05_retention = quantile(retention, 0.05, na.rm = TRUE), + p95_retention = quantile(retention, 0.95, na.rm = TRUE), + n_windows = n() + ) |> + print() diff --git a/analysis/scratch_coverage.R b/analysis/scratch_coverage.R new file mode 100644 index 0000000..4452257 --- /dev/null +++ b/analysis/scratch_coverage.R @@ -0,0 +1,267 @@ +# scratch_coverage.R — Data coverage across countries from Stage 1 flat files +# +# Reads every stage1_flat_*.rds, summarises per (country, time-window): +# - whether the file is empty +# - number of non-phantom observed rows +# - total suspected cases (sCh) +# - number of unique sub-national locations (admin1+) +# +# Produces three figures saved to analysis/generated_data/: +# 1. Presence/absence heatmap (coverage_presence.png) +# 2. Observed-row-count heatmap (coverage_obs_rows.png) +# 3. Suspected-case-count heatmap (coverage_sCh.png) + +library(here) +library(dplyr) +library(purrr) +library(tidyr) +library(stringr) +library(lubridate) +library(ggplot2) +library(forcats) + +# --------------------------------------------------------------------------- +# 1. Collect all Stage 1 flat files and parse metadata from filenames +# --------------------------------------------------------------------------- + +stage1_dir <- here("analysis/generated_data") + +files_raw <- list.files(stage1_dir, + pattern = "^stage1_flat_.*\\.rds$", + full.names = TRUE) + +# Use str_match so variable-length region codes (AFR/AMR/EMR/SEAR/WPR/EUR) +# are captured correctly — lookbehind can't handle variable width in R. +m <- str_match(basename(files_raw), + "^stage1_flat_([A-Z]+)_([^_]+)_TL(\\d{8})_TR(\\d{8})") + +files <- tibble( + path = files_raw, + fname = basename(files_raw), + who_region = m[, 2], + iso3_raw = m[, 3], + tl_str = m[, 4], + tr_str = m[, 5] +) |> + mutate( + TL = lubridate::ymd(tl_str), + TR = lubridate::ymd(tr_str), + window_mid = TL + as.numeric(TR - TL) / 2, + window_yr = year(TL) + ) |> + filter(!is.na(TL), !is.na(TR), !is.na(who_region), !is.na(iso3_raw)) + +message("Found ", nrow(files), " Stage 1 files across ", + n_distinct(files$iso3_raw), " country/sub-country units") + +# --------------------------------------------------------------------------- +# 2. Read each file and summarise +# --------------------------------------------------------------------------- + +message("Reading files … (this takes ~30-60 s)") + +summarise_file <- function(path) { + d <- tryCatch(readRDS(path), error = function(e) NULL) + if (is.null(d) || nrow(d) == 0) { + return(tibble(n_rows = 0L, n_obs = 0L, total_sCh = 0, n_locations = 0L, + empty = TRUE)) + } + obs <- filter(d, !phantom) + tibble( + n_rows = nrow(d), + n_obs = nrow(obs), + total_sCh = sum(obs$sCh, na.rm = TRUE), + n_locations = n_distinct(obs$location[obs$spatial_scale != "country"], + na.rm = TRUE), + empty = FALSE + ) +} + +summaries <- map(files$path, summarise_file, .progress = TRUE) + +coverage <- bind_cols(files, list_rbind(summaries)) |> + mutate( + status = case_when( + empty | n_obs == 0 ~ "no data", # empty file OR phantom rows only + total_sCh == 0 ~ "zero cases", # real obs but all sCh = 0 + TRUE ~ "has data" # real obs with sCh > 0 + ), + status = factor(status, levels = c("has data", "zero cases", "no data")) + ) + +# --------------------------------------------------------------------------- +# 3. Shared plot helpers +# --------------------------------------------------------------------------- + +# WHO-region colour palette (for y-axis strip / row label colouring) +region_pal <- c(AFR = "#E05C2F", AMR = "#2E86AB", EMR = "#A23B72", + SEAR = "#F18F01", WPR = "#C73E1D", EUR = "#3B1F2B") + +# Order countries: by WHO region, then alphabetically within region +country_order <- coverage |> + distinct(iso3_raw, who_region) |> + arrange(who_region, iso3_raw) |> + pull(iso3_raw) + +coverage <- coverage |> + mutate(iso3_f = factor(iso3_raw, levels = rev(country_order))) # rev so top = first + +# X-axis: use TL directly; tile width = actual window duration in days. +# This avoids the visual gap that arises from using floor_date(mid, "quarter"), +# which maps the 3 windows to Q1/Q3/Q4 (skipping Q2) and leaves a 3-month +# blank strip mid-year because geom_tile's default width = min spacing (92 d). +coverage <- coverage |> + mutate( + win_days = as.numeric(TR - TL) # tile width in days + ) + +# X-axis breaks: Jan 1 of each year +year_breaks <- tibble( + break_dt = seq( + floor_date(min(coverage$TL), "year"), + floor_date(max(coverage$TL), "year"), + by = "1 year" + ) +) |> mutate(label = year(break_dt)) + +base_theme <- theme_minimal(base_size = 10) + + theme( + axis.text.x = element_text(angle = 45, hjust = 1, size = 7), + axis.text.y = element_text(size = 7), + panel.grid = element_blank(), + legend.position = "bottom", + plot.title = element_text(face = "bold"), + strip.text = element_text(face = "bold", size = 8) + ) + +# Y-axis coloured by WHO region +region_colour_scale <- function(df) { + cols <- region_pal[df |> distinct(iso3_raw, who_region) |> + arrange(factor(iso3_raw, levels = rev(country_order))) |> + pull(who_region)] + scale_y_discrete(labels = setNames( + str_replace(rev(country_order), "\n", "::"), + rev(country_order) + )) +} + +# --------------------------------------------------------------------------- +# 4. Figure 1 — Presence / absence heatmap +# --------------------------------------------------------------------------- + +fig1_pal <- c( + "has data" = "#2C7BB6", # blue — real sCh data + "zero cases" = "#FDB462", # amber — obs present, sCh all zero + "no data" = "#DDDDDD" # light grey — no real observations +) + +p1 <- ggplot(coverage, + aes(x = TL + win_days / 2, y = iso3_f, fill = status, + width = win_days)) + + geom_tile(colour = "white", linewidth = 0.15) + + scale_fill_manual(values = fig1_pal, name = "Stage 1 status", + drop = FALSE) + + scale_x_date( + breaks = year_breaks$break_dt, + labels = year_breaks$label, + expand = expansion(add = 0) + ) + + facet_grid(who_region ~ ., scales = "free_y", space = "free_y") + + labs( + title = "Stage 1 data coverage — presence / absence", + x = NULL, y = NULL + ) + + base_theme + +out1 <- here("analysis/generated_data/coverage_presence.png") +ggsave(out1, p1, width = 14, height = 10, dpi = 150) +message("Saved: ", basename(out1)) + +# --------------------------------------------------------------------------- +# 5. Figure 2 — Observed-row heatmap (log10 scale) +# --------------------------------------------------------------------------- + +p2 <- coverage |> + mutate(n_obs_plot = if_else(n_obs == 0, NA_integer_, n_obs)) |> + ggplot(aes(x = TL + win_days / 2, y = iso3_f, fill = n_obs_plot, + width = win_days)) + + geom_tile(colour = "white", linewidth = 0.15) + + scale_fill_viridis_c( + name = "Observed rows\n(log10 + 1)", + trans = "log1p", + option = "plasma", + na.value = "#BBBBBB", + labels = scales::label_comma() + ) + + scale_x_date( + breaks = year_breaks$break_dt, + labels = year_breaks$label, + expand = expansion(add = 0) + ) + + facet_grid(who_region ~ ., scales = "free_y", space = "free_y") + + labs( + title = "Stage 1 data coverage — observed (non-phantom) rows per window", + x = NULL, y = NULL + ) + + base_theme + +out2 <- here("analysis/generated_data/coverage_obs_rows.png") +ggsave(out2, p2, width = 14, height = 10, dpi = 150) +message("Saved: ", basename(out2)) + +# --------------------------------------------------------------------------- +# 6. Figure 3 — Suspected-case heatmap (log10 scale) +# --------------------------------------------------------------------------- + +p3 <- coverage |> + mutate(sCh_plot = if_else(total_sCh == 0, NA_real_, total_sCh)) |> + ggplot(aes(x = TL + win_days / 2, y = iso3_f, fill = sCh_plot, + width = win_days)) + + geom_tile(colour = "white", linewidth = 0.15) + + scale_fill_viridis_c( + name = "Suspected cases\n(log10 + 1)", + trans = "log1p", + option = "inferno", + na.value = "#BBBBBB", + labels = scales::label_comma() + ) + + scale_x_date( + breaks = year_breaks$break_dt, + labels = year_breaks$label, + expand = expansion(add = 0) + ) + + facet_grid(who_region ~ ., scales = "free_y", space = "free_y") + + labs( + title = "Stage 1 data coverage — total suspected cases (sCh) per window", + x = NULL, y = NULL + ) + + base_theme + +out3 <- here("analysis/generated_data/coverage_sCh.png") +ggsave(out3, p3, width = 14, height = 10, dpi = 150) +message("Saved: ", basename(out3)) + +# --------------------------------------------------------------------------- +# 7. Quick console summary +# --------------------------------------------------------------------------- + +cat("\n=== Coverage summary ===\n") +coverage |> + count(who_region, status) |> + tidyr::pivot_wider(names_from = status, values_from = n, values_fill = 0L) |> + print() + +cat("\nCountries with ≥1 window of real data:\n") +coverage |> + filter(status == "has data") |> + distinct(who_region, iso3_raw) |> + count(who_region) |> + print() + +cat("\nCountries with NO real data in any window:\n") +no_data <- coverage |> + group_by(iso3_raw) |> + summarise(any_data = any(status == "has data")) |> + filter(!any_data) |> + pull(iso3_raw) +print(no_data) From 607b3120c84cc5c143b624e3346d73832ab14620 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 13:11:20 +0200 Subject: [PATCH 48/69] Add stage2 summary scratchpad with coverage and outbreak descriptive stats MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Four-panel figure (PDF) loading all stage2_*.rds outputs: - Panel A: outbreak burden by country (% of span-weeks), gaps = 0 - Panel B: temporal heatmap with explicit data-gap cells (grey) - Panel C: outbreak prevalence by spatial scale (all loc-weeks as denom) - Panel D: outbreak sCh per span-week normalised for observation period Fix: Panel A denominator is now country-scale calendar-weeks to avoid inflating pct_outbreak 10-28× when counting all-admin location-week pairs against a calendar-week span (COD was showing 2800%, IRQ 1949%). Co-Authored-By: Claude Sonnet 4.6 --- analysis/scratch_stage2_summary.R | 300 ++++++++++++++++++++++++++++++ 1 file changed, 300 insertions(+) create mode 100644 analysis/scratch_stage2_summary.R diff --git a/analysis/scratch_stage2_summary.R b/analysis/scratch_stage2_summary.R new file mode 100644 index 0000000..1b4fbe5 --- /dev/null +++ b/analysis/scratch_stage2_summary.R @@ -0,0 +1,300 @@ +# scratch_stage2_summary.R +# Scratchpad: coverage and descriptive statistics of Stage 2 outbreak outputs +# +# Run from project root: +# Rscript analysis/scratch_stage2_summary.R + +library(here) +library(dplyr) +library(tidyr) +library(ggplot2) +library(patchwork) +library(scales) +library(lubridate) +library(forcats) +library(stringr) + +# ── 0. Load & combine ───────────────────────────────────────────────────────── + +stage2_files <- list.files( + here("analysis/generated_data"), + pattern = "^stage2_.*\\.rds$", + full.names = TRUE +) + +message("Loading ", length(stage2_files), " stage2 files …") + +combined <- lapply(stage2_files, function(f) { + tryCatch({ + df <- readRDS(f) + if (nrow(df) == 0) return(NULL) + df + }, error = function(e) { + warning("Failed: ", basename(f), " — ", conditionMessage(e)); NULL + }) +}) |> bind_rows() + +message("Combined: ", nrow(combined), " rows, ", n_distinct(combined$country_iso3), " countries") + +# ── 1. Derived fields ───────────────────────────────────────────────────────── + +scale_levels <- c("country", "admin1", "admin2", "admin3", "admin4 or lower") +existing_scale <- intersect(scale_levels, unique(as.character(combined$spatial_scale))) + +combined <- combined |> + mutate( + year = year(TL), + in_outbreak = outbreak_number > 0, + spatial_scale = fct_relevel(as.character(spatial_scale), existing_scale) + ) + +real <- combined |> filter(!phantom) + +# Full observation span per country (min TL → max TR across all time windows) +# Gap weeks fall inside this span; they contribute 0 to all numerators. +country_span <- combined |> + group_by(who_region, country_iso3) |> + summarise( + span_start = min(TL, na.rm = TRUE), + span_end = max(TR, na.rm = TRUE), + span_weeks = as.numeric(difftime(max(TR, na.rm = TRUE), + min(TL, na.rm = TRUE), units = "weeks")), + .groups = "drop" + ) + +# ── 2. Panel A — Outbreak burden by country ─────────────────────────────────── +# Denominator = full span_weeks (gaps count as 0 outbreak-weeks). + +# Use country-scale rows only so that outbreak_weeks counts unique *calendar* +# weeks, not location-weeks across all admin levels. Mixing all-scale +# location-week counts with a calendar-week denominator (span_weeks) inflates +# pct_outbreak by 10-28× for countries with dense sub-national data (COD → +# 2800%, IRQ → 1949%, etc.). +country_summary <- real |> + filter(spatial_scale == "country") |> + group_by(who_region, country_iso3) |> + summarise( + outbreak_weeks = n_distinct(TL[in_outbreak]), # unique calendar weeks in outbreak + n_outbreaks = max(outbreak_number, na.rm = TRUE), + total_sCh = sum(sCh, na.rm = TRUE), + .groups = "drop" + ) |> + left_join(country_span, by = c("who_region", "country_iso3")) |> + mutate( + pct_outbreak = outbreak_weeks / span_weeks, + who_region = factor(who_region, levels = c("AFR", "EMR", "SEAR", "AMR", "EUR", "WPR")) + ) + +region_order <- country_summary |> + group_by(who_region) |> + summarise(med = median(pct_outbreak, na.rm = TRUE)) |> + arrange(desc(med)) |> + pull(who_region) + +pa <- country_summary |> + mutate(who_region = fct_relevel(who_region, as.character(region_order))) |> + ggplot(aes(x = fct_reorder(country_iso3, pct_outbreak), y = pct_outbreak, + colour = who_region)) + + geom_segment(aes(xend = country_iso3, y = 0, yend = pct_outbreak), + linewidth = 0.5, alpha = 0.6) + + geom_point(size = 2) + + scale_y_continuous(labels = percent_format(accuracy = 1), limits = c(0, NA)) + + scale_colour_brewer(palette = "Dark2", name = "WHO region") + + coord_flip() + + facet_wrap(~who_region, scales = "free_y", ncol = 3) + + labs( + title = "A Outbreak burden by country", + subtitle = "Outbreak-weeks ÷ full observation span (data gaps treated as 0)", + x = NULL, y = "% of span-weeks in outbreak" + ) + + theme_minimal(base_size = 9) + + theme( + legend.position = "none", + panel.grid.major.y = element_blank(), + strip.text = element_text(face = "bold"), + axis.text.y = element_text(size = 6.5) + ) + +# ── 3. Panel B — Temporal heatmap with explicit data gaps ───────────────────── +# Three visual states: +# grey = no data at all (gap) +# light yellow = data present but no outbreak detected +# yellow→red = outbreak detected (intensity = log1p outbreak-weeks) + +year_range <- range(combined$year, na.rm = TRUE) +all_years <- seq(year_range[1], year_range[2]) + +# Country-level rows only: one row per (country, week) — cleanest proxy for +# "is this country covered in this year?" +country_yr <- combined |> + filter(spatial_scale == "country") |> + group_by(who_region, country_iso3, year) |> + summarise( + has_data = TRUE, + outbreak_weeks = sum(in_outbreak, na.rm = TRUE), + .groups = "drop" + ) + +ctry_order <- country_span |> + arrange(who_region, country_iso3) |> + pull(country_iso3) + +year_grid <- expand_grid( + country_iso3 = unique(combined$country_iso3), + year = all_years +) |> + left_join(distinct(combined, who_region, country_iso3), by = "country_iso3") |> + left_join(country_yr, by = c("who_region", "country_iso3", "year")) |> + mutate( + # NA → gap (no rows for this country-year at country scale) + # 0 → covered, no outbreak + # >0 → covered, with outbreaks + fill_val = if_else(is.na(has_data), NA_real_, as.numeric(outbreak_weeks)) + ) + +pb <- year_grid |> + mutate(country_iso3 = factor(country_iso3, levels = ctry_order)) |> + ggplot(aes(x = year, y = country_iso3, fill = log1p(fill_val))) + + geom_tile(colour = "white", linewidth = 0.15) + + scale_fill_gradient( + low = "#ffffcc", + high = "#b10026", + na.value = "grey72", + name = "log1p(outbreak-weeks)" + ) + + scale_x_continuous(breaks = seq(2010, 2024, 2)) + + labs( + title = "B Outbreak activity over time", + subtitle = "Yellow = data, no outbreak | Red = outbreak | Grey = data gap", + x = "Year", y = NULL + ) + + theme_minimal(base_size = 9) + + theme( + axis.text.y = element_text(size = 6), + legend.position = "bottom", + legend.key.width = unit(1.2, "cm") + ) + +# ── 4. Panel C — Outbreak prevalence by spatial scale ──────────────────────── +# Denominator = ALL rows (phantom + non-phantom) per WHO region × scale. +# Phantom rows are the zero-case weeks already filled in; this makes +# "no-data weeks within a window" zero-numerator but positive-denominator. + +scale_colors <- c( + "country" = "#4e79a7", + "admin1" = "#59a14f", + "admin2" = "#f28e2b", + "admin3" = "#e15759", + "admin4 or lower" = "#b07aa1" +) + +scale_summary <- combined |> + group_by(who_region, spatial_scale) |> + summarise( + total_loc_weeks = n(), + outbreak_loc_weeks = sum(in_outbreak, na.rm = TRUE), + pct_outbreak = outbreak_loc_weeks / total_loc_weeks, + .groups = "drop" + ) + +pc <- scale_summary |> + mutate(who_region = fct_relevel(who_region, as.character(region_order))) |> + ggplot(aes(x = who_region, y = pct_outbreak, fill = spatial_scale)) + + geom_col(position = "dodge", width = 0.75) + + scale_fill_manual(values = scale_colors, name = "Spatial scale") + + scale_y_continuous(labels = percent_format(accuracy = 1)) + + labs( + title = "C Outbreak prevalence by spatial scale", + subtitle = "% of all covered location-weeks (incl. phantom zero-weeks) in outbreak", + x = "WHO region", y = "% of location-weeks in outbreak" + ) + + theme_minimal(base_size = 9) + + theme(legend.position = "right") + +# ── 5. Panel D — Outbreak sCh per span-week ─────────────────────────────────── +# Normalise outbreak-period sCh by the full observation span (gaps = 0 sCh). +# Countries with more data gaps will appear lower, as intended. + +cases_country <- real |> + filter(in_outbreak) |> + group_by(who_region, country_iso3) |> + summarise(total_ob_sCh = sum(sCh, na.rm = TRUE), .groups = "drop") |> + right_join(country_span, by = c("who_region", "country_iso3")) |> + mutate( + total_ob_sCh = coalesce(total_ob_sCh, 0), + ob_sCh_per_span_wk = total_ob_sCh / span_weeks + ) |> + filter(ob_sCh_per_span_wk > 0) + +pd <- cases_country |> + mutate(who_region = fct_relevel(who_region, as.character(region_order))) |> + ggplot(aes(x = who_region, y = ob_sCh_per_span_wk, colour = who_region)) + + geom_jitter(width = 0.2, height = 0, alpha = 0.7, size = 2) + + geom_boxplot(alpha = 0, outlier.shape = NA, linewidth = 0.6) + + scale_y_log10(labels = label_number(scale_cut = cut_short_scale())) + + scale_colour_brewer(palette = "Dark2") + + labs( + title = "D Outbreak sCh per span-week", + subtitle = "Total outbreak-period sCh ÷ full observation span (gaps = 0); log scale", + x = "WHO region", y = "sCh / span-week (log)" + ) + + theme_minimal(base_size = 9) + + theme(legend.position = "none") + +# ── 6. Compose & save ───────────────────────────────────────────────────────── + +layout <- " +AABB +AABB +AABB +CCDD +" + +fig <- pa + pb + pc + pd + + plot_layout(design = layout) + + plot_annotation( + title = "Stage 2 outputs — coverage and outbreak descriptive statistics", + subtitle = paste0( + n_distinct(combined$country_iso3), " countries · ", + n_distinct(combined$who_region), " WHO regions · ", + min(year(combined$TL), na.rm = TRUE), "–", max(year(combined$TR), na.rm = TRUE) + ), + theme = theme( + plot.title = element_text(size = 13, face = "bold"), + plot.subtitle = element_text(size = 9, colour = "grey40") + ) + ) + +out_path <- here("analysis/generated_data/stage2_summary_fig.pdf") +ggsave(out_path, fig, width = 16, height = 14, units = "in", device = cairo_pdf) +message("Saved: ", out_path) + +# ── 7. Quick console summary ────────────────────────────────────────────────── + +cat("\n── Stage 2 summary ──────────────────────────────────────────────────────\n") +cat("Files loaded: ", length(stage2_files), "\n") +cat("Total rows: ", format(nrow(combined), big.mark = ","), "\n") +cat("Non-phantom rows: ", format(nrow(real), big.mark = ","), "\n") +cat("Countries: ", n_distinct(combined$country_iso3), "\n") +cat("WHO regions: ", paste(sort(unique(combined$who_region)), collapse = ", "), "\n") +cat("Date range: ", + as.character(min(combined$TL, na.rm = TRUE)), "to", + as.character(max(combined$TR, na.rm = TRUE)), "\n") +cat("Outbreak-period rows: ", format(sum(real$in_outbreak, na.rm = TRUE), big.mark = ","), "\n") +cat("Total sCh (all): ", format(sum(combined$sCh, na.rm = TRUE), big.mark = ","), "\n") +cat("Total sCh (outbreaks):", + format(sum(real$sCh[real$in_outbreak], na.rm = TRUE), big.mark = ","), "\n") +cat("─────────────────────────────────────────────────────────────────────────\n") + +print( + country_summary |> + group_by(who_region) |> + summarise( + n_countries = n(), + with_outbreaks = sum(n_outbreaks > 0), + med_pct_ob = median(pct_outbreak, na.rm = TRUE), + total_sCh = sum(total_sCh), + .groups = "drop" + ) |> + arrange(desc(total_sCh)) +) From 92a3c03f482f6f5e03df60d6e8b40bd7f0b57621 Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 17:24:52 +0200 Subject: [PATCH 49/69] update config defaults to retained outbreak definition --- analysis/config_defaults.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index d2e4654..2f143af 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -59,10 +59,10 @@ use_cumulative_trigger: true # "cumulative_case_threshold" # "cumulative_case_threshold_and_min_cases" # "cumulative_case_threshold_and_nonzero_weeks" -cumulative_trigger_type: "cumulative_case_threshold" +cumulative_trigger_type: "cumulative_case_threshold_and_min_cases" cumulative_windows: 3 cumulative_case_threshold_ratio: 1.5 -cumulative_min_cases: ~ +cumulative_min_cases: 50 nonzero_windows: ~ # --- Population estimation --- From d3fbed141fdadc0b950af6527f06fe8bbf78df2f Mon Sep 17 00:00:00 2001 From: javier Date: Wed, 10 Jun 2026 23:20:42 +0200 Subject: [PATCH 50/69] Fix population lookup for compound ISO3 codes (TZA::Mainland, TZA::Zanzibar) add_population() was passing the raw country_iso3 (e.g. "TZA::MAINLAND") to download_worldpop_constrained() and the WPP2024 lookup, both of which require a plain 3-letter ISO3 code. The raster download failed silently, leaving pop = NA for all TZA rows and causing identify_outbreaks() to mark all weeks as low-risk (no outbreaks detected). Fix reuses the already-computed iso3_for_boundary variable (line 105) in both callsites. Also adds facet_grid(who_region ~ .) to Panel B of the stage2 summary figure. Co-Authored-By: Claude Sonnet 4.6 --- R/add_population.R | 4 ++-- analysis/scratch_stage2_summary.R | 15 ++++++++++----- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/R/add_population.R b/R/add_population.R index 25651aa..177033f 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -146,7 +146,7 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # -- a. Download / cache raster (no-op if already on disk) -------------- raster_path <- tryCatch( - download_worldpop_constrained(country_iso3, yr, dest_dir = raster_dir), + download_worldpop_constrained(iso3_for_boundary, yr, dest_dir = raster_dir), error = function(e) { message(" Raster download failed: ", conditionMessage(e)) NULL @@ -171,7 +171,7 @@ add_population <- function(normalized_data, raw_sf, country_iso3, na.rm = TRUE ) tot_UN <- WPP2024$PopTotal[ - WPP2024$Time == yr & WPP2024$ISO3_code == country_iso3 + WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary ] * 1e3 adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) { diff --git a/analysis/scratch_stage2_summary.R b/analysis/scratch_stage2_summary.R index 1b4fbe5..f32d0f8 100644 --- a/analysis/scratch_stage2_summary.R +++ b/analysis/scratch_stage2_summary.R @@ -124,14 +124,17 @@ pa <- country_summary |> year_range <- range(combined$year, na.rm = TRUE) all_years <- seq(year_range[1], year_range[2]) -# Country-level rows only: one row per (country, week) — cleanest proxy for -# "is this country covered in this year?" +# Use ALL spatial scales (non-phantom) so that countries whose early years +# only have admin2/admin3 data (e.g. COD 2010-2013) are not falsely shown as +# gaps. outbreak_weeks = distinct calendar weeks where ANY location was in +# outbreak — n_distinct(TL) avoids double-counting a week covered by multiple +# admin levels. country_yr <- combined |> - filter(spatial_scale == "country") |> + filter(!phantom) |> group_by(who_region, country_iso3, year) |> summarise( has_data = TRUE, - outbreak_weeks = sum(in_outbreak, na.rm = TRUE), + outbreak_weeks = n_distinct(TL[in_outbreak]), .groups = "drop" ) @@ -163,6 +166,7 @@ pb <- year_grid |> name = "log1p(outbreak-weeks)" ) + scale_x_continuous(breaks = seq(2010, 2024, 2)) + + facet_grid(who_region ~ ., scales = "free_y", space = "free_y") + labs( title = "B Outbreak activity over time", subtitle = "Yellow = data, no outbreak | Red = outbreak | Grey = data gap", @@ -172,7 +176,8 @@ pb <- year_grid |> theme( axis.text.y = element_text(size = 6), legend.position = "bottom", - legend.key.width = unit(1.2, "cm") + legend.key.width = unit(1.2, "cm"), + strip.text.y = element_text(face = "bold", angle = 0) ) # ── 4. Panel C — Outbreak prevalence by spatial scale ──────────────────────── From c59eb10969e6d2b628c77116924d7178491e1381 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 11 Jun 2026 11:55:10 +0200 Subject: [PATCH 51/69] Add Shiny outbreak explorer and fix centroid coverage for COD/TZA MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - shiny/app.R: full single-file Shiny app (map, stats table, heatmap, weekly time series) with bslib layout and reactive sidebar filters - shiny/data_prep.R: centroid build script; now samples one GeoJSON per 4-year window per country (captures admin boundary changes over time), applies st_make_valid() before st_centroid, and back-propagates parent centroids for aggregate location strings (e.g. AFR::TZA::Mainland) - shiny/data/centroids.rds: rebuilt lookup (5320 locations, up from 2850) - Fix TZA scale labelling: Mainland/Zanzibar are ADM0 analogs; shift admin1→Country, admin2→Admin 1, admin3→Admin 2 in new_ob_admin - Fix choropleth CFR: was summing per-location ratios; now aggregates deaths/cases before dividing - Add Admin 3 to SCALE_LEVELS (25K admin3 rows in data) - Fix completion detection in parse_detect_logs.R: fall back to "Stage 2 complete." when "Batch 2 end:" sentinel is absent Co-Authored-By: Claude Sonnet 4.6 --- analysis/parse_detect_logs.R | 6 +- shiny/app.R | 817 +++++++++++++++++++++++++++++++++++ shiny/data_prep.R | 153 +++++++ 3 files changed, 975 insertions(+), 1 deletion(-) create mode 100644 shiny/app.R create mode 100644 shiny/data_prep.R diff --git a/analysis/parse_detect_logs.R b/analysis/parse_detect_logs.R index 1a06464..d9f6af3 100644 --- a/analysis/parse_detect_logs.R +++ b/analysis/parse_detect_logs.R @@ -113,7 +113,11 @@ parse_log <- function(path) { } # ── Outcome ─────────────────────────────────────────────────────────────────── - completed <- any(grepl("Batch 2 end:", lines, fixed = TRUE)) + # "Batch 2 end:" is the shell wrapper sentinel — may be missing if the log was + # downloaded while the job was still writing or got truncated. Fall back to + # "Stage 2 complete." printed by the R script itself as a secondary signal. + completed <- any(grepl("Batch 2 end:", lines, fixed = TRUE)) || + any(grepl("Stage 2 complete.", lines, fixed = TRUE)) no_results <- any(grepl("No outbreak results to save", lines, fixed = TRUE)) skipped <- any(grepl("Stage 2 output already exists, skipping", lines, fixed = TRUE)) halted <- any(grepl("Execution halted", lines, fixed = TRUE)) diff --git a/shiny/app.R b/shiny/app.R new file mode 100644 index 0000000..aed6dfe --- /dev/null +++ b/shiny/app.R @@ -0,0 +1,817 @@ +# shiny/app.R ───────────────────────────────────────────────────────────────── +# Cholera Outbreak Explorer +# +# Launch from project root: +# shiny::runApp("shiny") +# +# Requires (install once): +# install.packages(c("leaflet", "plotly", "bsicons", "leaflet.extras")) +# ───────────────────────────────────────────────────────────────────────────── + +# ── 0. Check hard dependencies ──────────────────────────────────────────────── +needed <- c("leaflet", "plotly", "bslib", "bsicons") +missing <- needed[!sapply(needed, requireNamespace, quietly = TRUE)] +if (length(missing) > 0) + stop(paste0("Missing packages — run:\n install.packages(c(", + paste0('"', missing, '"', collapse = ", "), "))"), + call. = FALSE) + +# ── 1. Libraries ────────────────────────────────────────────────────────────── +suppressPackageStartupMessages({ + library(shiny) + library(bslib) + library(bsicons) + library(leaflet) + library(leaflet.extras) + library(plotly) + library(DT) + library(dplyr) + library(tidyr) + library(ggplot2) + library(scales) + library(stringr) + library(lubridate) + library(forcats) + library(rnaturalearth) + library(sf) + library(here) +}) + +# ── 2. Load & pre-process data (runs once at startup) ───────────────────────── +message("[ 1/4 ] Loading combined_outbreaks_cholera.csv ...") + +new_raw <- read.csv( + here("analysis/generated_data/combined_outbreaks_cholera.csv"), + stringsAsFactors = FALSE +) %>% + mutate( + TL = as.Date(TL), + TR = as.Date(TR), + year = year(TL), + # Normalise country name + country_name = case_when( + str_detect(country, "\\.") ~ str_replace(country, "^[A-Z0-9:]+\\.", ""), + country_iso3 == "TZA::Mainland" ~ "Tanzania (Mainland)", + country_iso3 == "TZA::Zanzibar" ~ "Tanzania (Zanzibar)", + TRUE ~ country + ), + # Merge TZA sub-territories for join compatibility + country_iso3_cmp = ifelse(str_detect(country_iso3, "TZA"), "TZA", country_iso3) + ) + +# Scale normalisation (mirrors notebook) +normalise_scale <- function(x) { + case_when( + x == "country" ~ "Country", + str_detect(x, "^admin1") ~ "Admin 1", + str_detect(x, "^admin2") ~ "Admin 2", + str_detect(x, "^admin3") ~ "Admin 3", + TRUE ~ NA_character_ + ) +} + +message("[ 2/4 ] Deriving outbreak summaries ...") +new_ob_admin <- new_raw %>% + filter(outbreak_number > 0) %>% + mutate(scale = normalise_scale(spatial_scale)) %>% + # TZA special case: Mainland / Zanzibar are ADM0 analogues (union territories), + # not true provinces. Shift every TZA scale down by one level so that: + # admin1 (Mainland / Zanzibar) → "Country" + # admin2 (regions, e.g. Arusha) → "Admin 1" + # admin3 (districts) → "Admin 2" + mutate(scale = case_when( + str_detect(country_iso3, "^TZA::") & scale == "Admin 1" ~ "Country", + str_detect(country_iso3, "^TZA::") & scale == "Admin 2" ~ "Admin 1", + str_detect(country_iso3, "^TZA::") & scale == "Admin 3" ~ "Admin 2", + TRUE ~ scale + )) %>% + filter(!is.na(scale)) %>% + group_by(location, scale, country_iso3, who_region, + run_id, time_lower_bound, time_upper_bound, outbreak_number) %>% + summarise( + ob_start = min(TL), + ob_end = max(TR), + total_cases = sum(sCh, na.rm = TRUE), + total_deaths = sum(deaths, na.rm = TRUE), + n_weeks = n(), + pop = first(pop), + peak_cases = max(sCh, na.rm = TRUE), + .groups = "drop" + ) %>% + mutate( + year = year(ob_start), + cfr_pct = ifelse(total_cases > 0 & !is.na(total_deaths) & total_deaths > 0, + total_deaths / total_cases * 100, NA_real_), + attack_rate = ifelse(!is.na(pop) & pop > 0, total_cases / pop * 1e3, NA_real_), + country_iso3_cmp = ifelse(str_detect(country_iso3, "TZA"), "TZA", country_iso3), + scale = factor(scale, levels = c("Country", "Admin 1", "Admin 2", "Admin 3")) + ) + +# Country name lookup (one canonical name per ISO3-cmp) +name_lut <- new_raw %>% + mutate(cname = case_when( + str_detect(country_iso3, "TZA") ~ "Tanzania", + str_detect(country, "\\.") ~ str_replace(country, "^[A-Z0-9:]+\\.", ""), + TRUE ~ country + )) %>% + filter(str_detect(cname, "[a-z]")) %>% + distinct(country_iso3_cmp, .keep_all = FALSE) %>% # just the keys + left_join( + new_raw %>% + mutate(cname = case_when( + str_detect(country_iso3, "TZA") ~ "Tanzania", + str_detect(country, "\\.") ~ str_replace(country, "^[A-Z0-9:]+\\.", ""), + TRUE ~ country + )) %>% + filter(str_detect(cname, "[a-z]")) %>% + distinct(country_iso3_cmp, cname), + by = "country_iso3_cmp" + ) %>% + rename(country_name = cname) %>% + group_by(country_iso3_cmp) %>% + slice(1) %>% + ungroup() + +message("[ 3/4 ] Loading spatial data ...") + +# Centroid lookup (built by data_prep.R) +centroids <- tryCatch( + readRDS(here("shiny/data/centroids.rds")), + error = function(e) { + message(" [WARN] centroids.rds not found — run `Rscript shiny/data_prep.R` first. ", + "Admin markers will be unavailable until then.") + tibble(location = character(), lon = numeric(), lat = numeric()) + } +) + +# World polygons (country outlines) +world_sf <- rnaturalearth::ne_countries(scale = "medium", returnclass = "sf") %>% + select(iso_a3, name_long, continent) + +message("[ 4/4 ] Ready.") + +# ── 3. App-wide constants ───────────────────────────────────────────────────── +REGIONS <- sort(unique(new_ob_admin$who_region)) + +REGION_LABELS <- c( + AFR = "African Region (AFR)", + AMR = "Americas (AMR)", + EMR = "Eastern Mediterranean (EMR)", + SEAR = "South-East Asia (SEAR)" +) + +# Matches Set2 palette used throughout the notebook +REGION_COLOURS <- c( + AFR = "#66C2A5", + AMR = "#FC8D62", + EMR = "#8DA0CB", + SEAR = "#E78AC3" +) + +all_countries <- new_ob_admin %>% + distinct(country_iso3_cmp, who_region) %>% + left_join(name_lut, by = "country_iso3_cmp") %>% + mutate(label = coalesce(country_name, country_iso3_cmp)) %>% + arrange(label) + +ALL_YEARS <- range(new_ob_admin$year, na.rm = TRUE) + +SCALE_LEVELS <- c("Country", "Admin 1", "Admin 2", "Admin 3") + +# ── 4. UI ───────────────────────────────────────────────────────────────────── +ui <- page_sidebar( + title = tagList( + bs_icon("virus2", size = "1.1em", class = "me-2"), + "Cholera Outbreak Explorer 2010–2024" + ), + theme = bs_theme( + bootswatch = "flatly", + base_font = font_google("Source Sans Pro") + ), + + # ── Sidebar ───────────────────────────────────────────────────────────────── + sidebar = sidebar( + width = 285, + open = TRUE, + title = "Filters", + + checkboxGroupInput( + "who_region", "WHO Region", + choices = setNames(REGIONS, REGION_LABELS[REGIONS]), + selected = REGIONS + ), + + selectizeInput( + "countries", "Countries", + choices = setNames(all_countries$country_iso3_cmp, all_countries$label), + selected = all_countries$country_iso3_cmp, + multiple = TRUE, + options = list( + plugins = list("remove_button"), + placeholder = "Select countries …", + maxOptions = 200 + ) + ), + + radioButtons( + "admin_level", "Admin level", + choices = SCALE_LEVELS, + selected = "Country" + ), + + sliderInput( + "year_range", "Year range", + min = ALL_YEARS[1], max = ALL_YEARS[2], + value = ALL_YEARS, step = 1, sep = "" + ), + + numericInput( + "min_cases", "Min. cases per outbreak", + value = 0, min = 0, step = 10 + ), + + hr(style = "margin: 8px 0"), + + actionButton( + "reset_filters", "Reset all filters", + icon = icon("rotate-left"), + class = "btn-sm btn-outline-secondary w-100" + ), + + hr(style = "margin: 8px 0"), + p(tags$small(tags$em( + "Click a country / marker on the map to show its weekly time series below." + )), style = "color: #888; font-size: 0.8em;") + ), + + # ── KPI value boxes ────────────────────────────────────────────────────────── + layout_columns( + fill = FALSE, + col_widths = c(3, 3, 3, 3), + + value_box( + title = "Outbreaks", + value = textOutput("kpi_ob", inline = TRUE), + showcase = bs_icon("virus"), + theme = "primary" + ), + value_box( + title = "Total cases", + value = textOutput("kpi_cases", inline = TRUE), + showcase = bs_icon("people-fill"), + theme = "info" + ), + value_box( + title = "Total deaths", + value = textOutput("kpi_deaths", inline = TRUE), + showcase = bs_icon("heartbreak-fill"), + theme = "danger" + ), + value_box( + title = "Locations affected", + value = textOutput("kpi_locs", inline = TRUE), + showcase = bs_icon("geo-alt-fill"), + theme = "success" + ) + ), + + # ── Main tabs ──────────────────────────────────────────────────────────────── + navset_card_underline( + + # ── Tab 1: Map ───────────────────────────────────────────────────────────── + nav_panel( + title = tagList(bs_icon("map"), " Map"), + leafletOutput("map", height = "460px"), + hr(style = "margin: 5px 0"), + div( + style = "color: #555; font-size: 0.85em; margin-bottom: 3px;", + textOutput("ts_header", inline = TRUE) + ), + plotlyOutput("ts_plot", height = "195px") + ), + + # ── Tab 2: Statistics ────────────────────────────────────────────────────── + nav_panel( + title = tagList(bs_icon("table"), " Statistics"), + layout_columns( + col_widths = c(7, 5), + card( + card_header("Outbreak characteristics by country"), + full_screen = TRUE, + DTOutput("stats_table") + ), + card( + card_header("Top 15 locations by total cases"), + plotOutput("top_locs_plot", height = "420px") + ) + ) + ), + + # ── Tab 3: Heatmap ───────────────────────────────────────────────────────── + nav_panel( + title = tagList(bs_icon("grid-3x3-gap-fill"), " Heatmap"), + layout_columns( + col_widths = c(2, 10), + card( + card_header("Options"), + radioButtons( + "heatmap_metric", "Metric", + choices = c("Outbreaks (n)" = "n_outbreaks", + "Total cases" = "total_cases"), + selected = "n_outbreaks" + ), + hr(style = "margin: 6px 0"), + p(tags$small("Rows sorted by total at the selected admin level."), + style = "color:#888; font-size:0.8em;") + ), + card( + card_header(textOutput("heatmap_title", inline = TRUE)), + full_screen = TRUE, + plotlyOutput("heatmap", height = "530px") + ) + ) + ) + ) +) + +# ── 5. Server ───────────────────────────────────────────────────────────────── +server <- function(input, output, session) { + + # ── Country choices follow WHO region selection ──────────────────────────── + observeEvent(input$who_region, { + sub <- all_countries %>% filter(who_region %in% input$who_region) + keep <- intersect(input$countries, sub$country_iso3_cmp) + if (length(keep) == 0) keep <- sub$country_iso3_cmp + updateSelectizeInput( + session, "countries", + choices = setNames(sub$country_iso3_cmp, sub$label), + selected = keep + ) + }, ignoreInit = TRUE) + + observeEvent(input$reset_filters, { + updateCheckboxGroupInput(session, "who_region", selected = REGIONS) + updateSelectizeInput( + session, "countries", + choices = setNames(all_countries$country_iso3_cmp, all_countries$label), + selected = all_countries$country_iso3_cmp + ) + updateRadioButtons(session, "admin_level", selected = "Country") + updateSliderInput(session, "year_range", value = ALL_YEARS) + updateNumericInput(session, "min_cases", value = 0) + selected_loc(NULL) + }) + + # ── Core reactive: filtered outbreak data ────────────────────────────────── + filtered_ob <- reactive({ + req(length(input$who_region) > 0, length(input$countries) > 0) + new_ob_admin %>% + filter( + who_region %in% input$who_region, + country_iso3_cmp %in% input$countries, + as.character(scale) == input$admin_level, + year >= input$year_range[1], + year <= input$year_range[2], + total_cases >= input$min_cases + ) + }) + + # ── KPIs ────────────────────────────────────────────────────────────────── + output$kpi_ob <- renderText(format(nrow(filtered_ob()), big.mark = ",")) + output$kpi_cases <- renderText(format(sum(filtered_ob()$total_cases, na.rm = TRUE), big.mark = ",")) + output$kpi_deaths <- renderText(format(sum(filtered_ob()$total_deaths, na.rm = TRUE), big.mark = ",")) + output$kpi_locs <- renderText(format(n_distinct(filtered_ob()$location), big.mark = ",")) + + # ── Map ─────────────────────────────────────────────────────────────────── + selected_loc <- reactiveVal(NULL) # iso_a3 (country) or location string (admin) + + # Per-location aggregation for the map + map_sum <- reactive({ + filtered_ob() %>% + group_by(location, country_iso3_cmp, who_region) %>% + summarise( + n_outbreaks = n(), + total_cases = sum(total_cases, na.rm = TRUE), + total_deaths = sum(total_deaths, na.rm = TRUE), + cfr_pct = ifelse(sum(total_cases, na.rm = TRUE) > 0, + sum(total_deaths, na.rm = TRUE) / + sum(total_cases, na.rm = TRUE) * 100, NA_real_), + med_attack = median(attack_rate, na.rm = TRUE), + .groups = "drop" + ) %>% + left_join(name_lut, by = "country_iso3_cmp") + }) + + # Initialise the leaflet widget once + output$map <- renderLeaflet({ + leaflet(options = leafletOptions(minZoom = 2)) %>% + addProviderTiles(providers$CartoDB.Positron, + options = tileOptions(maxZoom = 12)) %>% + setView(lng = 18, lat = 3, zoom = 3) + }) + + # Update map layers when filters / admin level change + observe({ + ms <- map_sum() + level <- input$admin_level + proxy <- leafletProxy("map") %>% + clearShapes() %>% clearMarkers() %>% clearControls() + + if (nrow(ms) == 0) return() + + if (level == "Country") { + # ── Choropleth ───────────────────────────────────────────────────────── + map_sf <- world_sf %>% + left_join( + ms %>% group_by(country_iso3_cmp) %>% + summarise( + n_outbreaks = sum(n_outbreaks, na.rm = TRUE), + total_cases = sum(total_cases, na.rm = TRUE), + total_deaths = sum(total_deaths, na.rm = TRUE), + cfr_pct = ifelse(sum(total_cases, na.rm = TRUE) > 0, + sum(total_deaths, na.rm = TRUE) / + sum(total_cases, na.rm = TRUE) * 100, + NA_real_), + who_region = first(who_region), + country_name = first(country_name), + .groups = "drop" + ), + by = c("iso_a3" = "country_iso3_cmp") + ) + + has_data <- !is.na(map_sf$n_outbreaks) + pal_choro <- colorNumeric("viridis", domain = ms$n_outbreaks, na.color = "#e4e4e4") + + proxy %>% + addPolygons( + data = map_sf[!has_data, ], + fillColor = "#e8e8e8", fillOpacity = 0.4, + color = "#cccccc", weight = 0.5, options = pathOptions(interactive = FALSE) + ) %>% + addPolygons( + data = map_sf[has_data, ], + fillColor = ~pal_choro(n_outbreaks), + fillOpacity = 0.78, + color = "white", weight = 0.8, + highlightOptions = highlightOptions( + weight = 2.5, color = "#444", fillOpacity = 0.95, bringToFront = TRUE + ), + popup = ~paste0( + "", name_long, "
", + "", who_region, "
", + "Outbreaks: ", n_outbreaks, "
", + "Cases: ", format(total_cases, big.mark = ","), "
", + "Deaths: ", ifelse(total_deaths > 0, + format(total_deaths, big.mark = ","), "—"), "
", + "CFR: ", ifelse(is.na(cfr_pct) | cfr_pct == 0, "—", + sprintf("%.1f%%", cfr_pct)), "" + ), + layerId = ~iso_a3 + ) %>% + addLegend( + pal = pal_choro, + values = ms$n_outbreaks, + title = "Outbreaks (n)", + position = "bottomright", + opacity = 0.9 + ) + + } else { + # ── Admin circle markers ──────────────────────────────────────────────── + ms_pts <- ms %>% + inner_join(centroids, by = "location") %>% + filter(is.finite(lon), is.finite(lat)) + + # Grey base outlines + proxy %>% + addPolygons( + data = world_sf, + fillColor = "#f4f4f4", fillOpacity = 0.5, + color = "#bbbbbb", weight = 0.5, + options = pathOptions(interactive = FALSE) + ) + + if (nrow(ms_pts) == 0) { + showNotification( + tagList(icon("triangle-exclamation"), + " No centroid data — run: Rscript shiny/data_prep.R"), + type = "warning", duration = 8 + ) + return() + } + + pal_region <- colorFactor( + palette = unname(REGION_COLOURS), + domain = names(REGION_COLOURS) + ) + + proxy %>% + addCircleMarkers( + data = ms_pts, + lng = ~lon, lat = ~lat, + radius = ~pmax(4, pmin(24, 4 + sqrt(total_cases / 400))), + fillColor = ~pal_region(who_region), + fillOpacity = 0.75, + color = "white", weight = 1, + popup = ~paste0( + "", location, "
", + "", who_region, " | ", level, "
", + "Outbreaks: ", n_outbreaks, "
", + "Cases: ", format(total_cases, big.mark = ","), "
", + "Deaths: ", ifelse(is.na(total_deaths) | total_deaths == 0, + "—", format(total_deaths, big.mark = ",")), "
", + "CFR: ", ifelse(is.na(cfr_pct), "—", + sprintf("%.1f%%", cfr_pct)), "
", + "Attack rate: ", ifelse(is.na(med_attack), "—", + sprintf("%.2f /1,000", med_attack)), "" + ), + layerId = ~location + ) %>% + addLegend( + colors = unname(REGION_COLOURS[names(REGION_COLOURS) %in% + unique(ms_pts$who_region)]), + labels = unname(REGION_LABELS[names(REGION_COLOURS) %in% + unique(ms_pts$who_region)]), + title = "WHO Region", + position = "bottomright", + opacity = 0.9 + ) + } + }) + + # Capture map click → update selected location + observeEvent(input$map_shape_click, selected_loc(input$map_shape_click$id)) + observeEvent(input$map_marker_click, selected_loc(input$map_marker_click$id)) + + # ── Weekly time series ────────────────────────────────────────────────────── + output$ts_header <- renderText({ + loc <- selected_loc() + if (is.null(loc)) return("Weekly time series — click a location on the map") + lbl <- if (input$admin_level == "Country") { + nm <- name_lut$country_name[name_lut$country_iso3_cmp == loc] + if (length(nm)) nm[1] else loc + } else loc + paste0("Weekly time series — ", lbl) + }) + + ts_raw <- reactive({ + loc <- selected_loc() + if (is.null(loc)) return(NULL) + + if (input$admin_level == "Country") { + # TZA has no "country" spatial_scale rows; its ADM0-equivalent data is at + # "admin1" (Mainland + Zanzibar). For all other countries use "country". + ts_scale <- if (loc == "TZA") "admin1" else "country" + new_raw %>% + filter(spatial_scale == ts_scale, + country_iso3_cmp == loc, + year >= input$year_range[1], + year <= input$year_range[2]) %>% + group_by(TL) %>% + summarise(sCh = sum(sCh, na.rm = TRUE), + deaths = sum(deaths, na.rm = TRUE), + outbreak_flag = as.integer(any(outbreak_number > 0)), + .groups = "drop") + } else { + new_raw %>% + filter(location == loc, + year >= input$year_range[1], + year <= input$year_range[2]) %>% + mutate(outbreak_flag = as.integer(outbreak_number > 0)) %>% + select(TL, sCh, deaths, outbreak_flag) + } + }) + + output$ts_plot <- renderPlotly({ + empty_msg <- function(txt) { + ggplotly( + ggplot() + + annotate("text", x = 0.5, y = 0.5, label = txt, hjust = 0.5, vjust = 0.5, + size = 3.5, colour = "grey60") + + theme_void() + ) %>% layout(margin = list(t = 5, b = 5)) + } + + ts <- ts_raw() + if (is.null(ts) || nrow(ts) == 0) + return(empty_msg("Click a location on the map to see its weekly time series")) + + # Outbreak shading bands: group consecutive outbreak weeks + ts <- ts %>% arrange(TL) %>% + mutate(grp = cumsum(c(1, diff(outbreak_flag) != 0))) + bands <- ts %>% + filter(outbreak_flag == 1) %>% + group_by(grp) %>% + summarise(xmin = min(TL), xmax = max(TL), .groups = "drop") + + p <- ggplot(ts, aes(x = TL, y = sCh)) + + geom_rect( + data = bands, + aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf), + fill = "#fc8d62", alpha = 0.25, inherit.aes = FALSE + ) + + geom_line(colour = "#2c7bb6", linewidth = 0.7, na.rm = TRUE) + + geom_point(size = 0.5, colour = "#2c7bb6", na.rm = TRUE) + + scale_y_continuous(labels = comma_format(), + expand = expansion(mult = c(0, 0.08))) + + scale_x_date(date_breaks = "1 year", date_labels = "%Y") + + labs(x = NULL, y = "Cases / week", + caption = "Orange bands = outbreak periods") + + theme_bw(base_size = 10) + + theme(axis.text.x = element_text(angle = 45, hjust = 1), + plot.caption = element_text(size = 7, colour = "#888")) + + ggplotly(p, tooltip = c("x", "y")) %>% + layout(showlegend = FALSE, margin = list(t = 10, b = 10, l = 50, r = 20)) + }) + + # ── Statistics table ──────────────────────────────────────────────────────── + table_df <- reactive({ + filtered_ob() %>% + left_join(name_lut, by = "country_iso3_cmp") %>% + mutate(country_label = coalesce(country_name, country_iso3_cmp)) %>% + group_by(scale, country_label, who_region) %>% + summarise( + n_locations = n_distinct(location), + n_outbreaks = n(), + total_cases = sum(total_cases, na.rm = TRUE), + total_deaths = sum(total_deaths, na.rm = TRUE), + cfr_pct = ifelse(sum(total_cases, na.rm = TRUE) > 0, + sum(total_deaths, na.rm = TRUE) / + sum(total_cases, na.rm = TRUE) * 100, NA_real_), + med_dur = median(n_weeks, na.rm = TRUE), + q1_dur = quantile(n_weeks, 0.25, na.rm = TRUE), + q3_dur = quantile(n_weeks, 0.75, na.rm = TRUE), + med_cases_ob = median(total_cases, na.rm = TRUE), + q1_cases_ob = quantile(total_cases, 0.25, na.rm = TRUE), + q3_cases_ob = quantile(total_cases, 0.75, na.rm = TRUE), + med_ar = median(attack_rate, na.rm = TRUE), + .groups = "drop" + ) %>% + mutate( + dur_iqr = sprintf("%.0f (%.0f–%.0f)", med_dur, q1_dur, q3_dur), + ob_iqr = sprintf("%s (%s–%s)", + format(round(med_cases_ob), big.mark = ","), + format(round(q1_cases_ob), big.mark = ","), + format(round(q3_cases_ob), big.mark = ",")), + cfr_str = ifelse(!is.na(cfr_pct) & cfr_pct > 0, + sprintf("%.1f", cfr_pct), "—"), + ar_str = ifelse(!is.na(med_ar), sprintf("%.2f", med_ar), "—"), + cases_f = format(total_cases, big.mark = ","), + deaths_f = ifelse(total_deaths > 0, + format(total_deaths, big.mark = ","), "—") + ) %>% + arrange(scale, desc(n_outbreaks)) %>% + select(scale, country_label, who_region, n_locations, n_outbreaks, + cases_f, deaths_f, cfr_str, dur_iqr, ob_iqr, ar_str) + }) + + output$stats_table <- renderDT({ + df <- table_df() + datatable( + df, + colnames = c( + "Level", "Country", "WHO Region", "Locations", + "Outbreaks", "Total cases", "Total deaths", "CFR (%)", + "Duration wk (IQR)", "Cases/outbreak (IQR)", "Attack rate /1k (med)" + ), + rownames = FALSE, + extensions = c("Buttons", "Scroller"), + options = list( + dom = "Bfrtip", + buttons = list(list(extend = "csv", filename = "cholera_outbreaks", + text = "⬇ Download CSV")), + scrollX = TRUE, + deferRender = TRUE, + scrollY = "420px", + scroller = TRUE, + pageLength = 50 + ) + ) %>% + formatStyle( + "n_outbreaks", + background = styleColorBar(c(0, max(df$n_outbreaks)), "#a8c7e8"), + backgroundSize = "90% 70%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + }) + + # ── Top locations bar chart ───────────────────────────────────────────────── + output$top_locs_plot <- renderPlot({ + top15 <- filtered_ob() %>% + group_by(location, who_region) %>% + summarise(total_cases = sum(total_cases, na.rm = TRUE), .groups = "drop") %>% + slice_max(total_cases, n = 15, with_ties = FALSE) %>% + mutate( + loc_short = str_trunc(location, 32), + loc_short = fct_reorder(loc_short, total_cases) + ) + + if (nrow(top15) == 0) { + return(ggplot() + annotate("text", x=0.5, y=0.5, label="No data", colour="grey60") + + theme_void()) + } + + ggplot(top15, aes(x = total_cases, y = loc_short, fill = who_region)) + + geom_col(alpha = 0.85, width = 0.7) + + geom_text(aes(label = format(total_cases, big.mark = ",")), + hjust = -0.1, size = 2.6, colour = "#333") + + scale_fill_manual(values = REGION_COLOURS, labels = REGION_LABELS, name = NULL) + + scale_x_continuous(labels = comma_format(), + expand = expansion(mult = c(0, 0.18))) + + labs(x = "Total cases", y = NULL) + + theme_bw(base_size = 10) + + theme(legend.position = "bottom", + legend.text = element_text(size = 7), + axis.text.y = element_text(size = 8), + panel.grid.major.y = element_blank()) + }) + + # ── Heatmap ────────────────────────────────────────────────────────────────── + output$heatmap_title <- renderText({ + m <- switch(input$heatmap_metric, + "n_outbreaks" = "Outbreak count", + "total_cases" = "Total cases") + paste0(m, " by country × year — ", input$admin_level, " level") + }) + + heatmap_df <- reactive({ + metric <- input$heatmap_metric + yr <- input$year_range + + base <- filtered_ob() %>% + left_join(name_lut, by = "country_iso3_cmp") %>% + mutate(country_label = coalesce(country_name, country_iso3_cmp)) %>% + group_by(country_label, year) %>% + summarise( + n_outbreaks = n(), + total_cases = sum(total_cases, na.rm = TRUE), + .groups = "drop" + ) + + # Full year × country grid so absent years appear as NA (grey) + full_grid <- expand.grid( + country_label = unique(base$country_label), + year = seq(yr[1], yr[2]), + stringsAsFactors = FALSE + ) + left_join(full_grid, base, by = c("country_label", "year")) + }) + + output$heatmap <- renderPlotly({ + hd <- heatmap_df() + metric <- input$heatmap_metric + mlabel <- switch(metric, n_outbreaks = "Outbreaks (n)", total_cases = "Total cases") + + if (nrow(hd) == 0) + return(plotly_empty(type = "scatter") %>% layout(title = "No data for current filters")) + + # Sort countries: most active at the top of the plot (highest y-axis value) + country_order <- hd %>% + group_by(country_label) %>% + summarise(total = sum(.data[[metric]], na.rm = TRUE), .groups = "drop") %>% + arrange(total) %>% # ascending → top of y-axis is the largest + pull(country_label) + + hd <- hd %>% + mutate( + country_label = factor(country_label, levels = country_order), + val_disp = ifelse(is.na(.data[[metric]]), "—", + format(.data[[metric]], big.mark = ",")), + tooltip = paste0("", country_label, " (", year, ")
", + mlabel, ": ", val_disp) + ) + + p <- ggplot(hd, aes(x = year, y = country_label, + fill = .data[[metric]], text = tooltip)) + + geom_tile(colour = "white", linewidth = 0.25) + + scale_fill_viridis_c( + option = "viridis", + na.value = "#f0f0f0", + name = mlabel, + labels = comma_format() + ) + + scale_x_continuous( + breaks = seq(input$year_range[1], input$year_range[2], + by = max(1L, as.integer((diff(input$year_range) + 1L) / 8L))) + ) + + labs(x = "Year", y = NULL) + + theme_bw(base_size = 10) + + theme( + axis.text.x = element_text(angle = 45, hjust = 1), + axis.text.y = element_text(size = 8), + panel.grid = element_blank(), + legend.title = element_text(size = 9) + ) + + ggplotly(p, tooltip = "text") %>% + layout( + margin = list(l = 130, b = 60, t = 10, r = 20), + yaxis = list(tickfont = list(size = 9)) + ) + }) +} + +# ── 6. Run ──────────────────────────────────────────────────────────────────── +shinyApp(ui, server) diff --git a/shiny/data_prep.R b/shiny/data_prep.R new file mode 100644 index 0000000..02b8166 --- /dev/null +++ b/shiny/data_prep.R @@ -0,0 +1,153 @@ +#!/usr/bin/env Rscript +# shiny/data_prep.R ───────────────────────────────────────────────────────── +# Run ONCE from the project root to build the centroid lookup used by the app. +# +# Rscript shiny/data_prep.R +# +# Output: shiny/data/centroids.rds +# A data frame: location (chr) | lon (dbl) | lat (dbl) +# One row per unique location string found across all stage1_geo GeoJSONs. +# ───────────────────────────────────────────────────────────────────────────── + +suppressPackageStartupMessages({ + library(sf) + library(dplyr) + library(stringr) + library(here) +}) + +cat("=== Cholera Outbreak Explorer — centroid build ===\n") +t0 <- proc.time() + +geojson_dir <- here("analysis/generated_data") +geojson_files <- list.files(geojson_dir, + pattern = "^stage1_geo_.*\\.geojson$", + full.names = TRUE) +cat(sprintf("Found %d GeoJSON files in %s\n", length(geojson_files), geojson_dir)) + +if (length(geojson_files) == 0) { + stop("No stage1_geo_*.geojson files found. Run 01_pull_data.R first.") +} + +# ── One representative file per country prefix ──────────────────────────────── +# Naming: stage1_geo_{REGION}_{ISO3}_TL{date}_TR{date}_thresh-*.geojson +# Extract everything up to the first "_TL" as the "country key". +country_key <- str_extract(basename(geojson_files), "^stage1_geo_.+?(?=_TL\\d)") +country_key[is.na(country_key)] <- basename(geojson_files)[is.na(country_key)] + +# Pick the largest file per key — larger files tend to have more admin levels +files_df <- tibble(path = geojson_files, key = country_key, + size = file.size(geojson_files)) + +# For each country-key, pick the largest file in each 4-year time window. +# This ensures that administrative boundary changes over time are captured +# (e.g. DRC reorganised from 11 → 26 provinces in 2015; older files carry the +# old names, 2017-2018 files carry the new names, recent files may only have +# admin3 data). Within-window deduplication, then global dedup, collapses +# overlapping centroids without double-counting. +rep_files_by_key <- files_df %>% + filter(!is.na(key)) %>% + mutate( + tl_year = as.integer(str_extract(basename(path), "(?<=_TL)[0-9]{4}")), + window = (tl_year %/% 4L) * 4L # 2010, 2014, 2018, 2022, … + ) %>% + group_by(key, window) %>% + slice_max(size, n = 1, with_ties = FALSE) %>% + ungroup() %>% + arrange(key, desc(size)) %>% + group_by(key) %>% + summarise(candidates = list(path), .groups = "drop") %>% + { setNames(.$candidates, .$key) } + +rep_files <- sapply(rep_files_by_key, `[[`, 1) # still used for progress counter + +cat(sprintf("Reading %d representative files (one per country, with fallback on error)...\n", length(rep_files))) + +# ── Extract (location, centroid) from each file ─────────────────────────────── +read_centroids <- function(path) { + tryCatch({ + obj <- suppressWarnings(sf::st_read(path, quiet = TRUE)) + if (!inherits(obj, "sf") || nrow(obj) == 0) return(NULL) + if (!"location" %in% names(obj)) return(NULL) + + # Deduplicate on location BEFORE centroid computation. + # Large files (e.g. COD 380 MB / 306K rows) have many time-repeated geometries + # for the same location; deduplication makes st_centroid tractable. + obj <- obj[!duplicated(obj$location), ] + + # Repair any invalid geometries (e.g. duplicate vertices, self-intersections) + # before computing centroids. + obj <- suppressWarnings(sf::st_make_valid(obj)) + + suppressWarnings(cents <- sf::st_centroid(obj)) + coords <- sf::st_coordinates(cents) + + tibble( + location = as.character(obj$location), + lon = coords[, "X"], + lat = coords[, "Y"] + ) + }, error = function(e) { + message(sprintf(" [WARN] %s: %s", basename(path), conditionMessage(e))) + NULL + }) +} + +# Process one file per 4-year window per country; merge results. +# All windows are attempted; failures are skipped without aborting the country. +keys <- names(rep_files_by_key) +results <- vector("list", length(keys)) +for (i in seq_along(keys)) { + if (i %% 10 == 0 || i == length(keys)) + cat(sprintf(" [%d/%d] %s (%d window files)\n", + i, length(keys), keys[i], length(rep_files_by_key[[keys[i]]]))) + per_country <- lapply(rep_files_by_key[[keys[i]]], function(cand) { + res <- read_centroids(cand) + if (is.null(res) || nrow(res) == 0) { + message(sprintf(" [skip] %s", basename(cand))) + return(NULL) + } + res + }) + combined <- bind_rows(per_country) + results[[i]] <- if (nrow(combined) > 0) combined else NULL +} + +centroids <- bind_rows(results) %>% + filter(!is.na(lon), !is.na(lat), is.finite(lon), is.finite(lat)) %>% + distinct(location, .keep_all = TRUE) + +cat(sprintf("\nUnique locations with centroids (from GeoJSONs): %d\n", nrow(centroids))) + +# ── Back-propagate parent centroids ────────────────────────────────────────── +# Some location strings used in the outbreak CSV are *aggregate* nodes that +# have no direct geometry in the GeoJSONs (e.g. "AFR::TZA::Mainland"). +# We approximate their centroid as the mean of their children's centroids, +# repeating up the hierarchy until no new parents can be inferred. +add_parent_centroids <- function(df) { + repeat { + existing <- df$location + parents <- df %>% + mutate(parent = str_replace(location, "::[^:]+$", "")) %>% + filter(parent != location, !parent %in% existing) %>% + group_by(parent) %>% + summarise(lon = mean(lon, na.rm = TRUE), + lat = mean(lat, na.rm = TRUE), + .groups = "drop") %>% + rename(location = parent) + + if (nrow(parents) == 0) break + df <- bind_rows(df, parents) + } + df +} + +centroids <- add_parent_centroids(centroids) +cat(sprintf("Unique locations after parent back-propagation: %d\n", nrow(centroids))) + +# ── Save ────────────────────────────────────────────────────────────────────── +out_path <- here("shiny/data/centroids.rds") +saveRDS(centroids, out_path) + +elapsed <- (proc.time() - t0)[["elapsed"]] +cat(sprintf("Saved to %s (%.0f s)\n", out_path, elapsed)) From b3b6906e419c243e978ed74de89b0e0dad46b383 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 11 Jun 2026 12:06:59 +0200 Subject: [PATCH 52/69] Fix outbreak period shading in weekly time series ggplotly() converts Date axes to type "linear" (numeric days since epoch), so ISO date strings passed as plotly shape coordinates silently collapsed to x=0, making all bands invisible. Switch the time series to native plot_ly() so the x-axis is explicitly type "date" and shape coordinates work correctly. Additional fixes: - xmax = max(TL) + 7 days so single-week outbreaks have non-zero width - Aggregate admin-level ts_raw by TL before band computation (multiple run_ids could produce duplicate TL rows, corrupting the diff() logic) - Fix x-axis range to 2010-01-01 -- 2024-12-31 (fixed across all locations) - Replace ggplotly-based empty placeholder with native plot_ly Co-Authored-By: Claude Sonnet 4.6 --- shiny/app.R | 107 ++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 75 insertions(+), 32 deletions(-) diff --git a/shiny/app.R b/shiny/app.R index aed6dfe..13caf60 100644 --- a/shiny/app.R +++ b/shiny/app.R @@ -573,56 +573,99 @@ server <- function(input, output, session) { outbreak_flag = as.integer(any(outbreak_number > 0)), .groups = "drop") } else { + # Aggregate to one row per TL (a location can have multiple rows from + # overlapping analysis runs; sum cases and flag as outbreak if any run + # detects one for that week). new_raw %>% filter(location == loc, year >= input$year_range[1], year <= input$year_range[2]) %>% - mutate(outbreak_flag = as.integer(outbreak_number > 0)) %>% - select(TL, sCh, deaths, outbreak_flag) + group_by(TL) %>% + summarise(sCh = sum(sCh, na.rm = TRUE), + deaths = sum(deaths, na.rm = TRUE), + outbreak_flag = as.integer(any(outbreak_number > 0)), + .groups = "drop") } }) output$ts_plot <- renderPlotly({ - empty_msg <- function(txt) { - ggplotly( - ggplot() + - annotate("text", x = 0.5, y = 0.5, label = txt, hjust = 0.5, vjust = 0.5, - size = 3.5, colour = "grey60") + - theme_void() - ) %>% layout(margin = list(t = 5, b = 5)) + # Empty-state placeholder (native plotly avoids the ggplotly date-axis issue) + empty_pl <- function(txt) { + plot_ly(type = "scatter", mode = "text") %>% + add_text(x = 0.5, y = 0.5, text = txt, + textfont = list(size = 11, color = "#888")) %>% + layout( + xaxis = list(visible = FALSE, range = c(0, 1)), + yaxis = list(visible = FALSE, range = c(0, 1)), + margin = list(t = 5, b = 5) + ) } ts <- ts_raw() if (is.null(ts) || nrow(ts) == 0) - return(empty_msg("Click a location on the map to see its weekly time series")) + return(empty_pl("Click a location on the map to see its weekly time series")) - # Outbreak shading bands: group consecutive outbreak weeks ts <- ts %>% arrange(TL) %>% mutate(grp = cumsum(c(1, diff(outbreak_flag) != 0))) + + # xmax + 7 so a single-week outbreak has visible (non-zero) width bands <- ts %>% filter(outbreak_flag == 1) %>% group_by(grp) %>% - summarise(xmin = min(TL), xmax = max(TL), .groups = "drop") - - p <- ggplot(ts, aes(x = TL, y = sCh)) + - geom_rect( - data = bands, - aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf), - fill = "#fc8d62", alpha = 0.25, inherit.aes = FALSE - ) + - geom_line(colour = "#2c7bb6", linewidth = 0.7, na.rm = TRUE) + - geom_point(size = 0.5, colour = "#2c7bb6", na.rm = TRUE) + - scale_y_continuous(labels = comma_format(), - expand = expansion(mult = c(0, 0.08))) + - scale_x_date(date_breaks = "1 year", date_labels = "%Y") + - labs(x = NULL, y = "Cases / week", - caption = "Orange bands = outbreak periods") + - theme_bw(base_size = 10) + - theme(axis.text.x = element_text(angle = 45, hjust = 1), - plot.caption = element_text(size = 7, colour = "#888")) - - ggplotly(p, tooltip = c("x", "y")) %>% - layout(showlegend = FALSE, margin = list(t = 10, b = 10, l = 50, r = 20)) + summarise(xmin = min(TL), xmax = max(TL) + 7L, .groups = "drop") + + # ── Native plot_ly (not ggplotly) so the x-axis is type "date" and shapes + # with ISO date strings land at the correct positions. ggplotly() converts + # date axes to type "linear" (numeric days since epoch), making date-string + # shape coordinates silently collapse to x = 0. + shapes <- lapply(seq_len(nrow(bands)), function(i) { + list( + type = "rect", + fillcolor = "rgba(252,141,98,0.22)", + line = list(width = 0), + xref = "x", yref = "paper", + x0 = format(bands$xmin[i], "%Y-%m-%d"), + x1 = format(bands$xmax[i], "%Y-%m-%d"), + y0 = 0, y1 = 1, + layer = "below" + ) + }) + + plot_ly( + ts, + x = ~TL, + y = ~sCh, + type = "scatter", + mode = "lines+markers", + line = list(color = "#2c7bb6", width = 1.5), + marker = list(color = "#2c7bb6", size = 3), + text = ~paste0("", format(TL, "%b %d %Y"), "
", + scales::comma(sCh), " cases"), + hovertemplate = "%{text}", + showlegend = FALSE + ) %>% + layout( + xaxis = list( + title = "", + type = "date", + range = c("2010-01-01", "2024-12-31"), + tickformat = "%Y", + dtick = "M12" + ), + yaxis = list( + title = "Cases / week", + tickformat = "," + ), + shapes = shapes, + margin = list(t = 10, b = 40, l = 60, r = 20), + annotations = if (nrow(bands) > 0) list(list( + text = "Shaded = outbreak periods", + xref = "paper", yref = "paper", + x = 1, y = 1.02, xanchor = "right", yanchor = "bottom", + showarrow = FALSE, + font = list(size = 9, color = "#888") + )) else list() + ) }) # ── Statistics table ──────────────────────────────────────────────────────── From 7e1eb2d4ccbadaa4beaaaefc8a973091c493eef7 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 11 Jun 2026 13:43:04 +0200 Subject: [PATCH 53/69] Switch app data source to parquet; add shinyapps.io deploy config MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Convert combined_outbreaks_cholera.csv to parquet (snappy): 66 MB → 1 MB - Replace read.csv + here() with arrow::read_parquet() using paths relative to the app directory (required for shinyapps.io; Shiny sets working directory to the app dir on both local and hosted runs) - Replace here("shiny/data/centroids.rds") with "data/centroids.rds" - Swap library(here) for library(arrow); add "arrow" to dep check - Add shiny/manifest.json (rsconnect::writeManifest) capturing 101 package dependencies for one-command deploy: rsconnect::deployApp("shiny/") Co-Authored-By: Claude Sonnet 4.6 --- shiny/app.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/shiny/app.R b/shiny/app.R index 13caf60..2186529 100644 --- a/shiny/app.R +++ b/shiny/app.R @@ -9,7 +9,7 @@ # ───────────────────────────────────────────────────────────────────────────── # ── 0. Check hard dependencies ──────────────────────────────────────────────── -needed <- c("leaflet", "plotly", "bslib", "bsicons") +needed <- c("leaflet", "plotly", "bslib", "bsicons", "arrow") missing <- needed[!sapply(needed, requireNamespace, quietly = TRUE)] if (length(missing) > 0) stop(paste0("Missing packages — run:\n install.packages(c(", @@ -34,16 +34,16 @@ suppressPackageStartupMessages({ library(forcats) library(rnaturalearth) library(sf) - library(here) + library(arrow) }) # ── 2. Load & pre-process data (runs once at startup) ───────────────────────── -message("[ 1/4 ] Loading combined_outbreaks_cholera.csv ...") +message("[ 1/4 ] Loading combined_outbreaks_cholera.parquet ...") -new_raw <- read.csv( - here("analysis/generated_data/combined_outbreaks_cholera.csv"), - stringsAsFactors = FALSE -) %>% +# Paths are relative to the app directory so the app works both locally +# (Shiny sets wd to the app dir) and on shinyapps.io. +new_raw <- arrow::read_parquet("data/combined_outbreaks_cholera.parquet") %>% + as.data.frame() %>% mutate( TL = as.Date(TL), TR = as.Date(TR), @@ -136,7 +136,7 @@ message("[ 3/4 ] Loading spatial data ...") # Centroid lookup (built by data_prep.R) centroids <- tryCatch( - readRDS(here("shiny/data/centroids.rds")), + readRDS("data/centroids.rds"), error = function(e) { message(" [WARN] centroids.rds not found — run `Rscript shiny/data_prep.R` first. ", "Admin markers will be unavailable until then.") From de06dd60f5aea3def97b179cc2803b806a768aa4 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 11 Jun 2026 13:53:26 +0200 Subject: [PATCH 54/69] Replace parquet with RDS to fix shinyapps.io build failure arrow's bit dependency (4.0.5) fails to compile on shinyapps.io R 4.5.2. Switch to native RDS format: no extra packages, no compilation, and slightly smaller on disk (0.7 MB vs 1.0 MB parquet). - Convert data to combined_outbreaks_cholera.rds (xz-compressed) - Replace arrow::read_parquet() with readRDS() - Remove arrow from library list and dependency check - Regenerate manifest.json (97 deps, down from 101) Co-Authored-By: Claude Sonnet 4.6 --- shiny/app.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/shiny/app.R b/shiny/app.R index 2186529..f49a4d5 100644 --- a/shiny/app.R +++ b/shiny/app.R @@ -9,7 +9,7 @@ # ───────────────────────────────────────────────────────────────────────────── # ── 0. Check hard dependencies ──────────────────────────────────────────────── -needed <- c("leaflet", "plotly", "bslib", "bsicons", "arrow") +needed <- c("leaflet", "plotly", "bslib", "bsicons") missing <- needed[!sapply(needed, requireNamespace, quietly = TRUE)] if (length(missing) > 0) stop(paste0("Missing packages — run:\n install.packages(c(", @@ -34,16 +34,14 @@ suppressPackageStartupMessages({ library(forcats) library(rnaturalearth) library(sf) - library(arrow) }) # ── 2. Load & pre-process data (runs once at startup) ───────────────────────── -message("[ 1/4 ] Loading combined_outbreaks_cholera.parquet ...") +message("[ 1/4 ] Loading combined_outbreaks_cholera.rds ...") # Paths are relative to the app directory so the app works both locally # (Shiny sets wd to the app dir) and on shinyapps.io. -new_raw <- arrow::read_parquet("data/combined_outbreaks_cholera.parquet") %>% - as.data.frame() %>% +new_raw <- readRDS("data/combined_outbreaks_cholera.rds") %>% mutate( TL = as.Date(TL), TR = as.Date(TR), From f781b3c5bb18c548714588798d50dd048e96368e Mon Sep 17 00:00:00 2001 From: javier Date: Fri, 12 Jun 2026 08:31:13 +0200 Subject: [PATCH 55/69] Add verify_outbreak_definitions() for post-hoc consistency checking New exported function that accepts identify_outbreaks() output and verifies it is consistent with the definition parameters used to produce it. Runs 12 checks across location and outbreak levels: risk classification, epidemic start validity (consecutive and dual-window modes), cumulative cases at start, tail structure, within-outbreak continuity, and inter-outbreak spacing. Includes 44 testthat tests covering PASS, FAIL, SKIP, and edge cases. Co-Authored-By: Claude Sonnet 4.6 --- NAMESPACE | 1 + R/verify_outbreak_definitions.R | 549 ++++++++++++++++++ man/verify_outbreak_definitions.Rd | 154 +++++ .../test-verify_outbreak_definitions.R | 413 +++++++++++++ 4 files changed, 1117 insertions(+) create mode 100644 R/verify_outbreak_definitions.R create mode 100644 man/verify_outbreak_definitions.Rd create mode 100644 tests/testthat/test-verify_outbreak_definitions.R diff --git a/NAMESPACE b/NAMESPACE index 4c9b905..2ec6d76 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -54,5 +54,6 @@ export(trigger_alert_caseratio) export(trigger_alert_cases) export(trigger_alert_rate) export(trigger_alert_trends) +export(verify_outbreak_definitions) import(magrittr) importFrom(magrittr,"%>%") diff --git a/R/verify_outbreak_definitions.R b/R/verify_outbreak_definitions.R new file mode 100644 index 0000000..ab3da30 --- /dev/null +++ b/R/verify_outbreak_definitions.R @@ -0,0 +1,549 @@ +#' @title verify_outbreak_definitions +#' @description Post-hoc verification that the output of +#' \code{\link{identify_outbreaks}()} is internally consistent with the +#' outbreak-definition parameters used to produce it. +#' +#' @details +#' The function accepts the list returned by \code{identify_outbreaks()} (or a +#' pre-bound dataframe) and runs the following checks, returning one tidy row +#' per check per location (or per outbreak, for outbreak-level checks): +#' +#' \strong{Location-level checks} +#' \describe{ +#' \item{\code{risk_classification_consistency}}{Every row: \code{risk == +#' "high"} iff \code{sCh > 0} and \code{sCh / pop >= threshold}.} +#' \item{\code{no_zero_case_epidemic_start}}{All \code{epidemic_start = TRUE} +#' rows have \code{sCh > 0}.} +#' \item{\code{epidemic_start_in_outbreak_period}}{Every epidemic start is +#' assigned a positive \code{outbreak_number}.} +#' \item{\code{consecutive_start_validity}}{(\code{consecutive} mode) Each +#' epidemic start begins a run of at least \code{min_weeks_above} +#' consecutive \code{"high"}-risk weeks.} +#' \item{\code{dual_window_start_validity}}{(\code{dual_window} mode) Each +#' epidemic start satisfies the sliding-window trigger, the cumulative +#' trigger, or both.} +#' \item{\code{epidemic_tail_validity}}{For every row where +#' \code{epidemic_tail = TRUE}, the subsequent \code{tail_period} +#' consecutive rows (including the flagged row itself) are all +#' \code{risk == "low"} and \code{epidemic_start == FALSE}.} +#' \item{\code{inter_outbreak_gap_weeks}}{The gap in weeks between +#' consecutive outbreak periods is at least \code{tail_period}. +#' One row per consecutive pair (\code{outbreak_number} column stores +#' \code{"k-k+1"}).} +#' } +#' +#' \strong{Outbreak-level checks (one row per location × outbreak_number)} +#' \describe{ +#' \item{\code{min_high_risk_weeks_per_outbreak}}{Each outbreak period +#' contains at least \code{min_weeks_above} high-risk weeks.} +#' \item{\code{cumulative_cases_at_start}}{The sum of \code{sCh} over the +#' first \code{cumulative_windows} weeks of the outbreak meets +#' \code{cumulative_min_cases}. Skipped when \code{cumulative_min_cases} +#' is \code{NULL}.} +#' \item{\code{outbreak_weekly_continuity}}{All consecutive week-start dates +#' within the outbreak are exactly 7 days apart (no internal gaps).} +#' \item{\code{tail_period_after_outbreak}}{After the last row of the +#' outbreak period, the immediately following non-outbreak weeks are all +#' low-risk. SKIP is returned when no data follows the outbreak.} +#' \item{\code{outbreak_summary}}{Informational (\code{status = "INFO"}): +#' total cases, duration in weeks, and peak weekly cases.} +#' } +#' +#' @param outbreak_list Named list of dataframes returned by +#' \code{\link{identify_outbreaks}()}, or a single dataframe produced by +#' \code{purrr::list_rbind(outbreak_list)}. +#' @param outbreak_start_definition \code{"consecutive"} (default) or +#' \code{"dual_window"}. +#' @param min_weeks_above Integer. Minimum consecutive / sliding-window +#' high-risk weeks required to trigger an epidemic start (default 2). +#' @param tail_period Integer. Consecutive below-threshold weeks required to +#' close an outbreak (default 6). +#' @param cumulative_min_cases Numeric or \code{NULL}. When non-NULL, each +#' outbreak's first \code{cumulative_windows} weeks must sum to at least this +#' many cases. Applies in any \code{outbreak_start_definition} mode. +#' @param cumulative_windows Integer. Width of the cumulative case window used +#' in \code{dual_window} mode and in the \code{cumulative_cases_at_start} +#' check (default 3). +#' @param window_weeks Integer. Width of the sliding high-risk-week window +#' (\code{dual_window} mode, default 3). +#' @param cumulative_case_threshold_ratio Numeric. Multiplier on +#' \code{threshold * pop} for the cumulative case trigger (default 1.5). +#' @param use_cumulative_trigger Logical. Whether the cumulative trigger is +#' active in \code{dual_window} mode (default \code{TRUE}). +#' @param cumulative_trigger_type Character. One of +#' \code{"cumulative_case_threshold"}, +#' \code{"cumulative_case_threshold_and_min_cases"}, or +#' \code{"cumulative_case_threshold_and_nonzero_weeks"}. +#' @param nonzero_windows Integer or \code{NULL}. Minimum non-zero-case weeks +#' in the cumulative window (used with +#' \code{"cumulative_case_threshold_and_nonzero_weeks"}). +#' +#' @return A \code{tibble} with columns: +#' \describe{ +#' \item{\code{location}}{Location string.} +#' \item{\code{outbreak_number}}{Outbreak identifier. \code{NA} for +#' location-level checks; a string like \code{"1-2"} for inter-outbreak +#' gap checks; a positive integer (as character) for outbreak-level +#' checks.} +#' \item{\code{check}}{Name of the verification check.} +#' \item{\code{status}}{\code{"PASS"}, \code{"FAIL"}, \code{"SKIP"}, or +#' \code{"INFO"}.} +#' \item{\code{value}}{Measured quantity for the check (e.g. number of +#' violations, total cases, gap in weeks).} +#' \item{\code{detail}}{Human-readable description of the result, including +#' specifics for failures.} +#' } +#' +#' @examples +#' \dontrun{ +#' # Run outbreak detection +#' outbreak_list <- identify_outbreaks( +#' threshold_type = "mean weekly incidence rate", +#' original_data = my_data, +#' outbreak_start_definition = "consecutive", +#' min_weeks_above = 2, +#' tail_period = 6 +#' ) +#' +#' # Verify the definitions were applied consistently +#' results <- verify_outbreak_definitions( +#' outbreak_list = outbreak_list, +#' outbreak_start_definition = "consecutive", +#' min_weeks_above = 2, +#' tail_period = 6, +#' cumulative_min_cases = 50 +#' ) +#' +#' # Inspect failures +#' results[results$status == "FAIL", ] +#' } +#' @export +verify_outbreak_definitions <- function( + outbreak_list, + outbreak_start_definition = c("consecutive", "dual_window"), + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = NULL, + cumulative_windows = 3L, + window_weeks = 3L, + cumulative_case_threshold_ratio = 1.5, + use_cumulative_trigger = TRUE, + cumulative_trigger_type = c( + "cumulative_case_threshold", + "cumulative_case_threshold_and_min_cases", + "cumulative_case_threshold_and_nonzero_weeks" + ), + nonzero_windows = NULL +) { + outbreak_start_definition <- match.arg(outbreak_start_definition) + cumulative_trigger_type <- match.arg(cumulative_trigger_type) + min_weeks_above <- as.integer(min_weeks_above) + tail_period <- as.integer(tail_period) + cumulative_windows <- as.integer(cumulative_windows) + window_weeks <- as.integer(window_weeks) + + # --------------------------------------------------------------------------- + # Normalise input: accept list-of-dataframes or single bound dataframe + # --------------------------------------------------------------------------- + if (is.data.frame(outbreak_list)) { + df_all <- outbreak_list + } else { + df_all <- purrr::list_rbind( + purrr::keep(outbreak_list, \(x) is.data.frame(x) && nrow(x) > 0) + ) + } + + if (nrow(df_all) == 0) { + message("verify_outbreak_definitions: no data to verify — returning empty result.") + return(tibble::tibble( + location = character(), + outbreak_number = character(), + check = character(), + status = character(), + value = numeric(), + detail = character() + )) + } + + df_all <- df_all %>% + dplyr::mutate(TL = as.Date(TL), TR = as.Date(TR)) + + # --------------------------------------------------------------------------- + # Helper: build one result row + # --------------------------------------------------------------------------- + make_row <- function(location, + outbreak_number = NA_character_, + check, + status, + value = NA_real_, + detail = "") { + tibble::tibble( + location = as.character(location), + outbreak_number = as.character(outbreak_number), + check = as.character(check), + status = as.character(status), + value = as.numeric(value), + detail = as.character(detail) + ) + } + + # Pre-allocate result list (grows as needed) + results <- vector("list", 2000L) + ri <- 0L + push <- function(row) { ri <<- ri + 1L; results[[ri]] <<- row } + + # =========================================================================== + # Loop over locations + # =========================================================================== + for (loc in unique(df_all$location)) { + + d <- df_all %>% + dplyr::filter(location == loc) %>% + dplyr::arrange(TL) + + has_cols <- function(...) all(c(...) %in% names(d)) + + # ------------------------------------------------------------------------- + # CHECK 1 — risk_classification_consistency + # risk == "high" iff (sCh > 0) AND (sCh / pop >= threshold) + # ------------------------------------------------------------------------- + if (has_cols("sCh", "pop", "threshold", "risk")) { + computable <- !is.na(d$pop) & !is.na(d$threshold) & d$pop > 0 + d_c <- d[computable, ] + if (nrow(d_c) > 0) { + expected_risk <- dplyr::if_else( + d_c$sCh > 0 & (d_c$sCh / d_c$pop) >= d_c$threshold, + "high", "low" + ) + n_bad <- sum(d_c$risk != expected_risk, na.rm = TRUE) + push(make_row(loc, NA_character_, "risk_classification_consistency", + if (n_bad == 0) "PASS" else "FAIL", + n_bad, + if (n_bad == 0) + paste0("All ", nrow(d_c), " row(s) have risk labels consistent with ", + "sCh/pop >= threshold & sCh > 0.") + else + paste0(n_bad, " of ", nrow(d_c), + " row(s) have a risk label inconsistent with sCh/pop vs threshold. ", + "Check for population or threshold anomalies."))) + } + } + + # ------------------------------------------------------------------------- + # CHECK 2 — no_zero_case_epidemic_start + # All epidemic_start == TRUE rows must have sCh > 0 + # ------------------------------------------------------------------------- + if (has_cols("epidemic_start", "sCh")) { + starts <- d[d$epidemic_start %in% TRUE, ] + if (nrow(starts) > 0) { + n_zero <- sum(is.na(starts$sCh) | starts$sCh == 0) + push(make_row(loc, NA_character_, "no_zero_case_epidemic_start", + if (n_zero == 0) "PASS" else "FAIL", + n_zero, + if (n_zero == 0) + paste0("All ", nrow(starts), " epidemic start(s) have sCh > 0.") + else + paste0(n_zero, " of ", nrow(starts), + " epidemic start(s) have zero or missing case count (sCh == 0 or NA). ", + "Dates: ", + paste(head(as.character(starts$TL[is.na(starts$sCh) | starts$sCh == 0]), 5), + collapse = ", "), + if (n_zero > 5) " ..." else ""))) + } + } + + # ------------------------------------------------------------------------- + # CHECK 3 — epidemic_start_in_outbreak_period + # All epidemic_start == TRUE rows must have outbreak_number > 0 + # ------------------------------------------------------------------------- + if (has_cols("epidemic_start", "outbreak_number")) { + starts <- d[d$epidemic_start %in% TRUE, ] + if (nrow(starts) > 0) { + n_out <- sum(is.na(starts$outbreak_number) | starts$outbreak_number == 0) + push(make_row(loc, NA_character_, "epidemic_start_in_outbreak_period", + if (n_out == 0) "PASS" else "FAIL", + n_out, + if (n_out == 0) + "All epidemic starts are within a labeled outbreak period (outbreak_number > 0)." + else + paste0(n_out, " epidemic start(s) are not assigned to any outbreak period. ", + "Dates: ", + paste(head(as.character(starts$TL[is.na(starts$outbreak_number) | + starts$outbreak_number == 0]), 5), + collapse = ", "), + if (n_out > 5) " ..." else ""))) + } + } + + # ------------------------------------------------------------------------- + # CHECK 4 — consecutive_start_validity (consecutive mode only) + # Each epidemic_start begins a run of >= min_weeks_above "high"-risk weeks. + # ------------------------------------------------------------------------- + if (outbreak_start_definition == "consecutive" && + has_cols("epidemic_start", "risk")) { + start_idx <- which(d$epidemic_start %in% TRUE) + n_fail <- 0L + fail_tl <- character() + for (i in start_idx) { + run_end <- min(i + min_weeks_above - 1L, nrow(d)) + run_len <- run_end - i + 1L + if (run_len < min_weeks_above || !all(d$risk[i:run_end] == "high")) { + n_fail <- n_fail + 1L + fail_tl <- c(fail_tl, as.character(d$TL[i])) + } + } + push(make_row(loc, NA_character_, "consecutive_start_validity", + if (n_fail == 0) "PASS" else "FAIL", + n_fail, + if (n_fail == 0) + paste0("All ", length(start_idx), " epidemic start(s) are followed by >= ", + min_weeks_above, " consecutive high-risk weeks.") + else + paste0(n_fail, " epidemic start(s) are NOT followed by ", min_weeks_above, + " consecutive high-risk weeks. ", + "First offending TL: ", + paste(head(fail_tl, 5), collapse = ", "), + if (n_fail > 5) " ..." else ""))) + } + + # ------------------------------------------------------------------------- + # CHECK 5 — dual_window_start_validity (dual_window mode only) + # Each epidemic_start satisfies the sliding-window trigger (>= min_weeks_above + # high-risk weeks in the forward window_weeks window) OR the cumulative + # trigger (cumulative sCh over cumulative_windows weeks meets the threshold). + # ------------------------------------------------------------------------- + if (outbreak_start_definition == "dual_window" && + has_cols("epidemic_start", "risk", "sCh", "pop", "threshold")) { + start_idx <- which(d$epidemic_start %in% TRUE) + n_fail <- 0L + fail_tl <- character() + for (i in start_idx) { + # --- Sliding-window trigger --- + w_end <- min(i + window_weeks - 1L, nrow(d)) + n_high_win <- sum(d$risk[i:w_end] == "high", na.rm = TRUE) + sliding_ok <- n_high_win >= min_weeks_above + + # --- Cumulative trigger --- + c_end <- min(i + cumulative_windows - 1L, nrow(d)) + cum_cases <- sum(d$sCh[i:c_end], na.rm = TRUE) + cum_thresh <- if (!is.na(d$threshold[i]) && !is.na(d$pop[i]) && d$pop[i] > 0) + d$threshold[i] * d$pop[i] * cumulative_case_threshold_ratio + else + Inf + thresh_met <- is.finite(cum_thresh) && cum_cases >= cum_thresh + + cum_ok <- if (!use_cumulative_trigger) { + FALSE + } else if (cumulative_trigger_type == "cumulative_case_threshold") { + thresh_met + } else if (cumulative_trigger_type == "cumulative_case_threshold_and_min_cases") { + thresh_met && !is.null(cumulative_min_cases) && cum_cases >= cumulative_min_cases + } else if (cumulative_trigger_type == "cumulative_case_threshold_and_nonzero_weeks") { + n_nz <- sum(d$sCh[i:c_end] > 0, na.rm = TRUE) + thresh_met && !is.null(nonzero_windows) && n_nz >= nonzero_windows + } else { + FALSE + } + + if (!sliding_ok && !cum_ok) { + n_fail <- n_fail + 1L + fail_tl <- c(fail_tl, as.character(d$TL[i])) + } + } + push(make_row(loc, NA_character_, "dual_window_start_validity", + if (n_fail == 0) "PASS" else "FAIL", + n_fail, + if (n_fail == 0) + paste0("All ", length(start_idx), + " epidemic start(s) satisfy at least one dual-window trigger ", + "(sliding window or cumulative).") + else + paste0(n_fail, " epidemic start(s) satisfy neither the sliding-window trigger ", + "(>= ", min_weeks_above, " high-risk weeks in ", window_weeks, " weeks) ", + "nor the cumulative trigger. ", + "First offending TL: ", + paste(head(fail_tl, 5), collapse = ", "), + if (n_fail > 5) " ..." else ""))) + } + + # ------------------------------------------------------------------------- + # CHECK 6 — epidemic_tail_validity + # For every epidemic_tail == TRUE row at position i, + # rows i through i + tail_period - 1 must all be risk == "low" and + # epidemic_start == FALSE. This verifies the tail flag semantics. + # ------------------------------------------------------------------------- + if (has_cols("epidemic_tail", "risk", "epidemic_start")) { + tail_idx <- which(d$epidemic_tail %in% TRUE) + if (length(tail_idx) > 0) { + n_fail <- 0L + fail_tl <- character() + for (i in tail_idx) { + run_end <- min(i + tail_period - 1L, nrow(d)) + run_rows <- d[i:run_end, ] + if (!all(run_rows$risk == "low") || any(run_rows$epidemic_start %in% TRUE)) { + n_fail <- n_fail + 1L + fail_tl <- c(fail_tl, as.character(d$TL[i])) + } + } + push(make_row(loc, NA_character_, "epidemic_tail_validity", + if (n_fail == 0) "PASS" else "FAIL", + n_fail, + if (n_fail == 0) + paste0("All ", length(tail_idx), " epidemic_tail flag(s) correctly mark ", + "the start of a ", tail_period, "-week low-risk run.") + else + paste0(n_fail, " epidemic_tail row(s) are NOT followed by ", + tail_period, " consecutive low-risk non-epidemic-start weeks. ", + "First offending TL: ", + paste(head(fail_tl, 5), collapse = ", "), + if (n_fail > 5) " ..." else ""))) + } + } + + # ========================================================================= + # OUTBREAK-LEVEL CHECKS + # ========================================================================= + if ("outbreak_number" %in% names(d)) { + ob_ids <- sort(unique( + d$outbreak_number[!is.na(d$outbreak_number) & d$outbreak_number > 0] + )) + + for (ob_id in ob_ids) { + ob <- d[!is.na(d$outbreak_number) & d$outbreak_number == ob_id, ] %>% + dplyr::arrange(TL) + + # ---------------------------------------------------------------------- + # CHECK 7 — min_high_risk_weeks_per_outbreak + # Each outbreak must contain at least min_weeks_above high-risk weeks. + # ---------------------------------------------------------------------- + if ("risk" %in% names(ob)) { + n_high <- sum(ob$risk == "high", na.rm = TRUE) + push(make_row(loc, ob_id, "min_high_risk_weeks_per_outbreak", + if (n_high >= min_weeks_above) "PASS" else "FAIL", + n_high, + paste0("Outbreak ", ob_id, ": ", n_high, " high-risk week(s) in ", + nrow(ob), " total week(s) ", + "(minimum required: ", min_weeks_above, ")."))) + } + + # ---------------------------------------------------------------------- + # CHECK 8 — cumulative_cases_at_start + # Sum of sCh over the first cumulative_windows weeks >= cumulative_min_cases. + # Skipped when cumulative_min_cases is NULL. + # ---------------------------------------------------------------------- + if (!is.null(cumulative_min_cases) && "sCh" %in% names(ob)) { + n_win <- min(cumulative_windows, nrow(ob)) + cum_sum <- sum(ob$sCh[seq_len(n_win)], na.rm = TRUE) + push(make_row(loc, ob_id, "cumulative_cases_at_start", + if (cum_sum >= cumulative_min_cases) "PASS" else "FAIL", + cum_sum, + paste0("Outbreak ", ob_id, ": first ", n_win, " week(s) sum to ", + round(cum_sum, 1), " cases ", + "(minimum required: ", cumulative_min_cases, ")."))) + } + + # ---------------------------------------------------------------------- + # CHECK 9 — outbreak_weekly_continuity + # Consecutive TL values within an outbreak must be exactly 7 days apart. + # ---------------------------------------------------------------------- + if (nrow(ob) > 1) { + gaps <- as.integer(diff(ob$TL)) + n_gap_v <- sum(gaps != 7L) + push(make_row(loc, ob_id, "outbreak_weekly_continuity", + if (n_gap_v == 0) "PASS" else "FAIL", + n_gap_v, + if (n_gap_v == 0) + paste0("Outbreak ", ob_id, ": all ", nrow(ob), + " weeks are consecutive (7-day spacing).") + else + paste0("Outbreak ", ob_id, ": ", n_gap_v, + " non-7-day gap(s) within the outbreak period. ", + "Min gap: ", min(gaps), " days, max gap: ", max(gaps), " days."))) + } + + # ---------------------------------------------------------------------- + # CHECK 10 — tail_period_after_outbreak + # Immediately after each outbreak period, the following non-outbreak + # weeks should be low-risk (forming the washout / tail period). + # The minimum number of such weeks depends on how the tail is split + # between the outbreak period and the non-outbreak period; this check + # simply verifies that the immediately-following weeks are not high-risk. + # Returns SKIP when no data follows the outbreak. + # ---------------------------------------------------------------------- + if ("risk" %in% names(d)) { + ob_end_tl <- max(ob$TL) + after <- d[d$TL > ob_end_tl, ] %>% dplyr::arrange(TL) + + if (nrow(after) == 0) { + push(make_row(loc, ob_id, "tail_period_after_outbreak", + "SKIP", NA_real_, + paste0("Outbreak ", ob_id, + ": no observations after this outbreak period — ", + "tail structure cannot be verified."))) + } else { + # Count how many consecutive non-outbreak low-risk weeks follow + non_ob <- (is.na(after$outbreak_number) | after$outbreak_number == 0) + low <- after$risk == "low" + non_ob_low <- non_ob & low + + rle_res <- rle(non_ob_low) + n_leading_low <- if (rle_res$values[1]) rle_res$lengths[1] else 0L + + # The algorithm places ~2 tail rows inside the outbreak period; + # expect at least tail_period - 2 consecutive non-outbreak low-risk + # weeks immediately after. + min_expected <- max(0L, tail_period - 2L) + push(make_row(loc, ob_id, "tail_period_after_outbreak", + if (n_leading_low >= min_expected) "PASS" else "FAIL", + n_leading_low, + paste0("Outbreak ", ob_id, ": ", + n_leading_low, " consecutive non-outbreak low-risk week(s) ", + "immediately follow (expected >= ", min_expected, + " given tail_period = ", tail_period, ")."))) + } + } + + # ---------------------------------------------------------------------- + # CHECK 11 — outbreak_summary (INFO) + # Informational summary: total cases, duration, peak weekly cases. + # ---------------------------------------------------------------------- + if ("sCh" %in% names(ob)) { + total_c <- sum(ob$sCh, na.rm = TRUE) + peak_c <- max(ob$sCh, na.rm = TRUE) + push(make_row(loc, ob_id, "outbreak_summary", + "INFO", total_c, + paste0("Outbreak ", ob_id, ": ", nrow(ob), " week(s), ", + round(total_c, 1), " total suspected cases, ", + round(peak_c, 1), " peak weekly cases."))) + } + } # end outbreak-level loop + + # ----------------------------------------------------------------------- + # CHECK 12 — inter_outbreak_gap_weeks + # The gap in time between consecutive outbreaks must be >= tail_period + # weeks (otherwise the algorithm would have merged them). + # One result row per consecutive outbreak pair. + # ----------------------------------------------------------------------- + if (length(ob_ids) > 1) { + for (k in seq_len(length(ob_ids) - 1L)) { + ob_a <- d[!is.na(d$outbreak_number) & d$outbreak_number == ob_ids[k], ] + ob_b <- d[!is.na(d$outbreak_number) & d$outbreak_number == ob_ids[k + 1L], ] + end_a <- max(ob_a$TR) + start_b <- min(ob_b$TL) + gap_w <- as.numeric(start_b - end_a) / 7 + pair_id <- paste0(ob_ids[k], "-", ob_ids[k + 1L]) + push(make_row(loc, pair_id, "inter_outbreak_gap_weeks", + if (gap_w >= tail_period) "PASS" else "FAIL", + gap_w, + paste0("Outbreaks ", ob_ids[k], " \u2192 ", ob_ids[k + 1L], ": ", + "gap = ", round(gap_w, 1), " week(s) ", + "(minimum required: ", tail_period, ")."))) + } + } + + } # end "outbreak_number" block + } # end location loop + + # Combine and return + dplyr::bind_rows(results[seq_len(ri)]) +} diff --git a/man/verify_outbreak_definitions.Rd b/man/verify_outbreak_definitions.Rd new file mode 100644 index 0000000..6f2dc2c --- /dev/null +++ b/man/verify_outbreak_definitions.Rd @@ -0,0 +1,154 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/verify_outbreak_definitions.R +\name{verify_outbreak_definitions} +\alias{verify_outbreak_definitions} +\title{verify_outbreak_definitions} +\usage{ +verify_outbreak_definitions( + outbreak_list, + outbreak_start_definition = c("consecutive", "dual_window"), + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = NULL, + cumulative_windows = 3L, + window_weeks = 3L, + cumulative_case_threshold_ratio = 1.5, + use_cumulative_trigger = TRUE, + cumulative_trigger_type = c("cumulative_case_threshold", + "cumulative_case_threshold_and_min_cases", + "cumulative_case_threshold_and_nonzero_weeks"), + nonzero_windows = NULL +) +} +\arguments{ +\item{outbreak_list}{Named list of dataframes returned by +\code{\link{identify_outbreaks}()}, or a single dataframe produced by +\code{purrr::list_rbind(outbreak_list)}.} + +\item{outbreak_start_definition}{\code{"consecutive"} (default) or +\code{"dual_window"}.} + +\item{min_weeks_above}{Integer. Minimum consecutive / sliding-window +high-risk weeks required to trigger an epidemic start (default 2).} + +\item{tail_period}{Integer. Consecutive below-threshold weeks required to +close an outbreak (default 6).} + +\item{cumulative_min_cases}{Numeric or \code{NULL}. When non-NULL, each +outbreak's first \code{cumulative_windows} weeks must sum to at least this +many cases. Applies in any \code{outbreak_start_definition} mode.} + +\item{cumulative_windows}{Integer. Width of the cumulative case window used +in \code{dual_window} mode and in the \code{cumulative_cases_at_start} +check (default 3).} + +\item{window_weeks}{Integer. Width of the sliding high-risk-week window +(\code{dual_window} mode, default 3).} + +\item{cumulative_case_threshold_ratio}{Numeric. Multiplier on +\code{threshold * pop} for the cumulative case trigger (default 1.5).} + +\item{use_cumulative_trigger}{Logical. Whether the cumulative trigger is +active in \code{dual_window} mode (default \code{TRUE}).} + +\item{cumulative_trigger_type}{Character. One of +\code{"cumulative_case_threshold"}, +\code{"cumulative_case_threshold_and_min_cases"}, or +\code{"cumulative_case_threshold_and_nonzero_weeks"}.} + +\item{nonzero_windows}{Integer or \code{NULL}. Minimum non-zero-case weeks +in the cumulative window (used with +\code{"cumulative_case_threshold_and_nonzero_weeks"}).} +} +\value{ +A \code{tibble} with columns: +\describe{ +\item{\code{location}}{Location string.} +\item{\code{outbreak_number}}{Outbreak identifier. \code{NA} for +location-level checks; a string like \code{"1-2"} for inter-outbreak +gap checks; a positive integer (as character) for outbreak-level +checks.} +\item{\code{check}}{Name of the verification check.} +\item{\code{status}}{\code{"PASS"}, \code{"FAIL"}, \code{"SKIP"}, or +\code{"INFO"}.} +\item{\code{value}}{Measured quantity for the check (e.g. number of +violations, total cases, gap in weeks).} +\item{\code{detail}}{Human-readable description of the result, including +specifics for failures.} +} +} +\description{ +Post-hoc verification that the output of +\code{\link{identify_outbreaks}()} is internally consistent with the +outbreak-definition parameters used to produce it. +} +\details{ +The function accepts the list returned by \code{identify_outbreaks()} (or a +pre-bound dataframe) and runs the following checks, returning one tidy row +per check per location (or per outbreak, for outbreak-level checks): + +\strong{Location-level checks} +\describe{ +\item{\code{risk_classification_consistency}}{Every row: \code{risk == + "high"} iff \code{sCh > 0} and \code{sCh / pop >= threshold}.} +\item{\code{no_zero_case_epidemic_start}}{All \code{epidemic_start = TRUE} +rows have \code{sCh > 0}.} +\item{\code{epidemic_start_in_outbreak_period}}{Every epidemic start is +assigned a positive \code{outbreak_number}.} +\item{\code{consecutive_start_validity}}{(\code{consecutive} mode) Each +epidemic start begins a run of at least \code{min_weeks_above} +consecutive \code{"high"}-risk weeks.} +\item{\code{dual_window_start_validity}}{(\code{dual_window} mode) Each +epidemic start satisfies the sliding-window trigger, the cumulative +trigger, or both.} +\item{\code{epidemic_tail_validity}}{For every row where +\code{epidemic_tail = TRUE}, the subsequent \code{tail_period} +consecutive rows (including the flagged row itself) are all +\code{risk == "low"} and \code{epidemic_start == FALSE}.} +\item{\code{inter_outbreak_gap_weeks}}{The gap in weeks between +consecutive outbreak periods is at least \code{tail_period}. +One row per consecutive pair (\code{outbreak_number} column stores +\code{"k-k+1"}).} +} + +\strong{Outbreak-level checks (one row per location × outbreak_number)} +\describe{ +\item{\code{min_high_risk_weeks_per_outbreak}}{Each outbreak period +contains at least \code{min_weeks_above} high-risk weeks.} +\item{\code{cumulative_cases_at_start}}{The sum of \code{sCh} over the +first \code{cumulative_windows} weeks of the outbreak meets +\code{cumulative_min_cases}. Skipped when \code{cumulative_min_cases} +is \code{NULL}.} +\item{\code{outbreak_weekly_continuity}}{All consecutive week-start dates +within the outbreak are exactly 7 days apart (no internal gaps).} +\item{\code{tail_period_after_outbreak}}{After the last row of the +outbreak period, the immediately following non-outbreak weeks are all +low-risk. SKIP is returned when no data follows the outbreak.} +\item{\code{outbreak_summary}}{Informational (\code{status = "INFO"}): +total cases, duration in weeks, and peak weekly cases.} +} +} +\examples{ +\dontrun{ +# Run outbreak detection +outbreak_list <- identify_outbreaks( + threshold_type = "mean weekly incidence rate", + original_data = my_data, + outbreak_start_definition = "consecutive", + min_weeks_above = 2, + tail_period = 6 +) + +# Verify the definitions were applied consistently +results <- verify_outbreak_definitions( + outbreak_list = outbreak_list, + outbreak_start_definition = "consecutive", + min_weeks_above = 2, + tail_period = 6, + cumulative_min_cases = 50 +) + +# Inspect failures +results[results$status == "FAIL", ] +} +} diff --git a/tests/testthat/test-verify_outbreak_definitions.R b/tests/testthat/test-verify_outbreak_definitions.R new file mode 100644 index 0000000..491c52e --- /dev/null +++ b/tests/testthat/test-verify_outbreak_definitions.R @@ -0,0 +1,413 @@ +library(dplyr) +library(lubridate) + +# --------------------------------------------------------------------------- +# Helpers +# --------------------------------------------------------------------------- + +# Build a minimal weekly outbreak dataframe with known structure. +# 14 weeks: weeks 1-8 high-risk, 9-10 low-risk tail (in outbreak), 11-14 washout. +# By default, all definition checks should PASS with: +# outbreak_start_definition = "consecutive", min_weeks_above = 2, tail_period = 6 +make_valid_df <- function( + location = "TestCountry", + pop = 1000, + threshold = 0.005, # risk = "high" when sCh/pop >= threshold (sCh >= 5) + sCh_outbreak = c(10, 15, 12, 20, 18, 14, 8, 6, 3, 2), # weeks 1-10 + sCh_washout = c(1, 0, 2, 1) # weeks 11-14 +) { + n_out <- length(sCh_outbreak) + n_wash <- length(sCh_washout) + n <- n_out + n_wash + tl <- as.Date("2014-01-06") + 7L * seq(0L, n - 1L) + + sCh <- c(sCh_outbreak, sCh_washout) + + tibble::tibble( + location = location, + TL = tl, + TR = tl + 6L, + sCh = sCh, + pop = pop, + threshold = threshold, + risk = ifelse(sCh > 0 & sCh / pop >= threshold, "high", "low"), + epidemic_start = c(TRUE, rep(FALSE, n - 1L)), + epidemic_tail = c(rep(FALSE, n_out - 2L), TRUE, FALSE, rep(FALSE, n_wash)), + outbreak_number = c(rep(1L, n_out), rep(0L, n_wash)), + `Time Period` = factor( + ifelse(c(rep(1L, n_out), rep(0L, n_wash)) > 0, + "outbreak period", "non-outbreak period"), + levels = c("outbreak period", "non-outbreak period") + ) + ) +} + +# Shortcut: run verify and filter to one check name +check_status <- function(results, check_name) { + results$status[results$check == check_name] +} + +# --------------------------------------------------------------------------- +# Baseline: all checks pass +# --------------------------------------------------------------------------- + +test_that("all checks pass on a structurally valid dataset (consecutive mode)", { + df <- make_valid_df() + results <- verify_outbreak_definitions( + outbreak_list = df, + outbreak_start_definition = "consecutive", + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = 10 + ) + + non_info <- results[results$status != "INFO" & results$status != "SKIP", ] + expect_true(all(non_info$status == "PASS"), + info = paste("Unexpected FAIL rows:\n", + paste(non_info[non_info$status == "FAIL", ]$detail, collapse = "\n"))) +}) + +test_that("function accepts a pre-bound dataframe (not a list)", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_s3_class(results, "tbl_df") + expect_true(nrow(results) > 0) +}) + +test_that("function returns an empty tibble when given no data", { + results <- verify_outbreak_definitions(data.frame()) + expect_s3_class(results, "tbl_df") + expect_equal(nrow(results), 0L) +}) + +test_that("result tibble has expected columns", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_true(all(c("location", "outbreak_number", "check", "status", "value", "detail") + %in% names(results))) +}) + +# --------------------------------------------------------------------------- +# CHECK 1 — risk_classification_consistency +# --------------------------------------------------------------------------- + +test_that("risk_classification_consistency FAILS when risk label contradicts sCh/pop >= threshold", { + df <- make_valid_df() + df$risk[3] <- "low" # row 3 has sCh=12, sCh/pop=0.012 >= threshold=0.005 → should be "high" + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "risk_classification_consistency"), "FAIL") + expect_equal(results$value[results$check == "risk_classification_consistency"], 1) +}) + +test_that("risk_classification_consistency PASSES when all labels are correct", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "risk_classification_consistency"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 2 — no_zero_case_epidemic_start +# --------------------------------------------------------------------------- + +test_that("no_zero_case_epidemic_start FAILS when epidemic start has sCh == 0", { + df <- make_valid_df() + df$sCh[1] <- 0L + df$risk[1] <- "low" # adjust risk to match sCh=0 + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "no_zero_case_epidemic_start"), "FAIL") + expect_equal(results$value[results$check == "no_zero_case_epidemic_start"], 1) +}) + +test_that("no_zero_case_epidemic_start PASSES when epidemic start has sCh > 0", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "no_zero_case_epidemic_start"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 3 — epidemic_start_in_outbreak_period +# --------------------------------------------------------------------------- + +test_that("epidemic_start_in_outbreak_period FAILS when start is outside outbreak", { + df <- make_valid_df() + df$outbreak_number[1] <- 0L # epidemic_start=TRUE but outbreak_number=0 + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "epidemic_start_in_outbreak_period"), "FAIL") +}) + +test_that("epidemic_start_in_outbreak_period PASSES when all starts are inside outbreak", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "epidemic_start_in_outbreak_period"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 4 — consecutive_start_validity +# --------------------------------------------------------------------------- + +test_that("consecutive_start_validity FAILS when the week after start is low-risk", { + df <- make_valid_df() + # Break week 2 so the start (week 1) is not followed by 2 consecutive high-risk weeks + df$sCh[2] <- 1L + df$risk[2] <- "low" + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "consecutive", + min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "consecutive_start_validity"), "FAIL") +}) + +test_that("consecutive_start_validity PASSES with min_weeks_above consecutive high-risk starts", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "consecutive", + min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "consecutive_start_validity"), "PASS") +}) + +test_that("consecutive_start_validity PASSES with min_weeks_above = 3", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "consecutive", + min_weeks_above = 3L, tail_period = 6L) + # Weeks 1-3 are all high-risk + expect_equal(check_status(results, "consecutive_start_validity"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 5 — dual_window_start_validity (dual_window mode) +# --------------------------------------------------------------------------- + +test_that("dual_window_start_validity PASSES when sliding window trigger is satisfied", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "dual_window", + min_weeks_above = 2L, + window_weeks = 3L, + use_cumulative_trigger = FALSE, + tail_period = 6L) + # Weeks 1-3: all high → sliding window (3 weeks, min 2 high) satisfied + expect_equal(check_status(results, "dual_window_start_validity"), "PASS") +}) + +test_that("dual_window_start_validity FAILS when neither trigger is satisfied", { + df <- make_valid_df() + # Make all weeks low-risk but keep epidemic_start flag — force a contradiction + df$risk[1:3] <- "low" + df$sCh[1:3] <- 1L + # No cumulative trigger either (sCh too low) + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "dual_window", + min_weeks_above = 2L, + window_weeks = 3L, + use_cumulative_trigger = TRUE, + cumulative_trigger_type = "cumulative_case_threshold", + cumulative_windows = 3L, + cumulative_case_threshold_ratio = 1.5, + tail_period = 6L) + expect_equal(check_status(results, "dual_window_start_validity"), "FAIL") +}) + +test_that("dual_window_start_validity PASSES when only the cumulative trigger is satisfied", { + df <- make_valid_df() + # Make weeks 2-3 low-risk so sliding window fails (only 1 high in 3) + df$risk[2:3] <- "low" + df$sCh[2:3] <- 2L + # But make cumulative cases in weeks 1-3 = 10+2+2 = 14, threshold = 0.005*1000*1.5 = 7.5 → meets it + results <- verify_outbreak_definitions(df, + outbreak_start_definition = "dual_window", + min_weeks_above = 2L, + window_weeks = 3L, + use_cumulative_trigger = TRUE, + cumulative_trigger_type = "cumulative_case_threshold", + cumulative_windows = 3L, + cumulative_case_threshold_ratio = 1.5, + tail_period = 6L) + expect_equal(check_status(results, "dual_window_start_validity"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 6 — epidemic_tail_validity +# --------------------------------------------------------------------------- + +test_that("epidemic_tail_validity PASSES when tail rows are followed by tail_period low-risk weeks", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "epidemic_tail_validity"), "PASS") +}) + +test_that("epidemic_tail_validity FAILS when a tail row is followed by a high-risk week", { + df <- make_valid_df() + # epidemic_tail is TRUE at row 9; make row 10 high-risk (violates the 6-week low-risk run) + df$sCh[10] <- 50L + df$risk[10] <- "high" + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "epidemic_tail_validity"), "FAIL") +}) + +# --------------------------------------------------------------------------- +# CHECK 7 — min_high_risk_weeks_per_outbreak +# --------------------------------------------------------------------------- + +test_that("min_high_risk_weeks_per_outbreak FAILS when outbreak has too few high-risk weeks", { + df <- make_valid_df() + # Keep only 1 high-risk week in the outbreak (< min_weeks_above = 2) + df$risk[2:8] <- "low" + df$sCh[2:8] <- 1L + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "min_high_risk_weeks_per_outbreak"), "FAIL") + expect_equal(results$value[results$check == "min_high_risk_weeks_per_outbreak"], 1) +}) + +test_that("min_high_risk_weeks_per_outbreak PASSES when outbreak has enough high-risk weeks", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "min_high_risk_weeks_per_outbreak"), "PASS") +}) + +# --------------------------------------------------------------------------- +# CHECK 8 — cumulative_cases_at_start +# --------------------------------------------------------------------------- + +test_that("cumulative_cases_at_start PASSES when first cumulative_windows weeks >= cumulative_min_cases", { + df <- make_valid_df() # first 3 weeks: 10+15+12 = 37 >= 30 + results <- verify_outbreak_definitions(df, + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = 30, + cumulative_windows = 3L) + expect_equal(check_status(results, "cumulative_cases_at_start"), "PASS") + expect_equal(results$value[results$check == "cumulative_cases_at_start"], 37) +}) + +test_that("cumulative_cases_at_start FAILS when first weeks sum below cumulative_min_cases", { + df <- make_valid_df() # first 3 weeks: 10+15+12 = 37 < 50 + results <- verify_outbreak_definitions(df, + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = 50, + cumulative_windows = 3L) + expect_equal(check_status(results, "cumulative_cases_at_start"), "FAIL") +}) + +test_that("cumulative_cases_at_start is absent from results when cumulative_min_cases is NULL", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, + min_weeks_above = 2L, + tail_period = 6L, + cumulative_min_cases = NULL) + expect_false("cumulative_cases_at_start" %in% results$check) +}) + +# --------------------------------------------------------------------------- +# CHECK 9 — outbreak_weekly_continuity +# --------------------------------------------------------------------------- + +test_that("outbreak_weekly_continuity PASSES when all within-outbreak weeks are 7 days apart", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "outbreak_weekly_continuity"), "PASS") +}) + +test_that("outbreak_weekly_continuity FAILS when a gap exists within an outbreak", { + df <- make_valid_df() + # Jump week 5 forward by 14 days instead of 7. + # This creates two violations: gap before row 5 (14 d) and after row 5 (0 d). + df$TL[5] <- df$TL[5] + 7L + df$TR[5] <- df$TR[5] + 7L + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "outbreak_weekly_continuity"), "FAIL") + expect_equal(results$value[results$check == "outbreak_weekly_continuity"], 2) +}) + +# --------------------------------------------------------------------------- +# CHECK 10 — tail_period_after_outbreak +# --------------------------------------------------------------------------- + +test_that("tail_period_after_outbreak PASS when enough low-risk non-outbreak weeks follow", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "tail_period_after_outbreak"), "PASS") +}) + +test_that("tail_period_after_outbreak is SKIP when no data follows the outbreak", { + df <- make_valid_df() + # Remove washout rows so outbreak is the last observation + df <- df[df$outbreak_number > 0, ] + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "tail_period_after_outbreak"), "SKIP") +}) + +test_that("tail_period_after_outbreak FAILS when week immediately after outbreak is high-risk", { + df <- make_valid_df() + # Make the first non-outbreak week high-risk (week 11 → sCh=50) + df$sCh[11] <- 50L + df$risk[11] <- "high" + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_equal(check_status(results, "tail_period_after_outbreak"), "FAIL") + expect_equal(results$value[results$check == "tail_period_after_outbreak"], 0) +}) + +# --------------------------------------------------------------------------- +# CHECK 12 — inter_outbreak_gap_weeks +# --------------------------------------------------------------------------- + +test_that("inter_outbreak_gap_weeks PASSES when gap between two outbreaks >= tail_period", { + ob1 <- make_valid_df() + # Place ob2 so that TL[1] of ob2 is 8 weeks + 1 day after max(TR) of ob1's outbreak + ob2 <- make_valid_df() + ob1_end_tr <- max(ob1$TR[ob1$outbreak_number > 0]) + shift <- as.integer(ob1_end_tr - min(ob2$TL)) + 7L * 8L + 1L + ob2$TL <- ob2$TL + shift + ob2$TR <- ob2$TR + shift + ob2$outbreak_number[ob2$outbreak_number > 0] <- 2L + + df <- dplyr::bind_rows(ob1, ob2) %>% dplyr::arrange(TL) + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + gap_rows <- results[results$check == "inter_outbreak_gap_weeks", ] + expect_equal(nrow(gap_rows), 1L) + expect_equal(gap_rows$status, "PASS") +}) + +test_that("inter_outbreak_gap_weeks FAILS when gap between outbreaks < tail_period", { + ob1 <- make_valid_df() + # Place ob2 so that TL[1] of ob2 is 2 weeks + 1 day after max(TR) of ob1's outbreak ( 0]) + shift <- as.integer(ob1_end_tr - min(ob2$TL)) + 7L * 2L + 1L + ob2$TL <- ob2$TL + shift + ob2$TR <- ob2$TR + shift + ob2$outbreak_number[ob2$outbreak_number > 0] <- 2L + + df <- dplyr::bind_rows(ob1, ob2) %>% dplyr::arrange(TL) + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + gap_rows <- results[results$check == "inter_outbreak_gap_weeks", ] + expect_equal(nrow(gap_rows), 1L) + expect_equal(gap_rows$status, "FAIL") +}) + +# --------------------------------------------------------------------------- +# CHECK — outbreak_summary (INFO rows) +# --------------------------------------------------------------------------- + +test_that("outbreak_summary INFO row is present and correct for a single outbreak", { + df <- make_valid_df() + results <- verify_outbreak_definitions(df, + min_weeks_above = 2L, tail_period = 6L, cumulative_min_cases = NULL) + info_row <- results[results$check == "outbreak_summary" & results$status == "INFO", ] + expect_equal(nrow(info_row), 1L) + # Total cases in outbreak (weeks 1-10): 10+15+12+20+18+14+8+6+3+2 = 108 + expect_equal(info_row$value, 108) +}) + +# --------------------------------------------------------------------------- +# Multi-location +# --------------------------------------------------------------------------- + +test_that("function handles multiple locations and returns results for each", { + df1 <- make_valid_df(location = "CountryA") + df2 <- make_valid_df(location = "CountryB") + df <- dplyr::bind_rows(df1, df2) + results <- verify_outbreak_definitions(df, min_weeks_above = 2L, tail_period = 6L) + expect_true("CountryA" %in% results$location) + expect_true("CountryB" %in% results$location) +}) From 5f3151e842cef98167e7cd507710efdeebabbb71 Mon Sep 17 00:00:00 2001 From: javier Date: Fri, 12 Jun 2026 09:36:59 +0200 Subject: [PATCH 56/69] Align analysis pipeline with reference Step2_Extract_outbreak.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 01_pull_data.R (Batch 1): reduced to pull + clean_psql_data() only. stage1_flat_* now holds per-window cleaned observations (geometry dropped) rather than normalized weekly data. Normalization, population attachment, and outbreak detection have moved to Batch 2. 02_run_outbreak_detection.R (Batch 2): restructured from per-window detection to full-series per-country processing, matching the reference pipeline (GenevaIDD/global-cholera-surveillance-timeseries): - Concatenates all stage1_flat_* + stage1_geo_* files per country - Applies reference normalization: fill_missing_lps ×3, average_duplicate_observations, set_uniform_wday_start, filter(n_obs > 1), fill_phantom_zeroes - add_population() over the full assembled series - identify_outbreaks() with no customized_TL/TR so the mean weekly incidence threshold is computed over all years (not per 4-month window) Co-Authored-By: Claude Sonnet 4.6 --- analysis/01_pull_data.R | 61 +---- analysis/02_run_outbreak_detection.R | 328 ++++++++++++++++++--------- 2 files changed, 235 insertions(+), 154 deletions(-) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 49b1e5f..6b1c999 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -2,8 +2,8 @@ # # Reads a YAML config, calls the Cholera Taxonomy API via taxdat, runs the # full OutbreakExtractR normalization pipeline, and writes two GeoParquet files: -# stage1_geo_{run_id}.parquet — sf object (retains geometry, for spatial use) -# stage1_flat_{run_id}.parquet — flat dataframe (no geometry, input to Batch 2) +# stage1_geo_{run_id}.{geojson,parquet} — sf object (retains geometry, for spatial use) +# stage1_flat_{run_id}.{rds,parquet} — cleaned observations, geometry dropped (input to Batch 2) # # Skips gracefully if outputs already exist (re-run with --redo TRUE to force). # @@ -18,7 +18,6 @@ library(here) library(optparse) library(dplyr) -library(lubridate) library(sf) sf_use_s2(FALSE) source(here("analysis/utils.R")) @@ -204,7 +203,11 @@ write_spatial(raw_sf, out_geo, opt$use_geoparquet) message("Saved raw geo file: ", basename(out_geo)) # --------------------------------------------------------------------------- -# Stage 1b: normalize through the OutbreakExtractR pipeline +# Stage 1b: clean raw observations and save per-window flat file +# +# Filtering, aggregation, normalization, and population attachment all happen +# in Batch 2 (02_run_outbreak_detection.R) once the full per-country series +# has been assembled from all windows, matching the reference pipeline. # --------------------------------------------------------------------------- # Drop geometry — OutbreakExtractR functions operate on flat dataframes @@ -213,55 +216,13 @@ raw_df <- sf::st_drop_geometry(raw_sf) # Clean: standardize types, identify spatial/temporal scale, clean location names clean_data <- OutbreakExtractR::clean_psql_data(raw_df) -# Filter by time, scale, and case thresholds -filtered_data <- OutbreakExtractR::observation_filter( - outbreak_data = clean_data, - time_lower_bound_filter = lubridate::ymd(opt$time_lower_bound), - time_upper_bound_filter = lubridate::ymd(opt$time_upper_bound), - temporal_scale_filter = opt$temporal_scale_filter, - who_regions = opt$who_region, - spatial_scale_filter = opt$spatial_scale_filter, - remove_na_sCh = opt$remove_na_sCh, - remove_na_cCh = opt$remove_na_cCh, - remove_na_locationperiod = opt$remove_na_locationperiod, - minimum_daily_cases = opt$minimum_daily_cases -) - -# Separate daily and weekly; aggregate daily → weekly -daily_data <- dplyr::filter(filtered_data, temporal_scale == "daily") -weekly_data <- dplyr::filter(filtered_data, temporal_scale == "weekly") - -if (nrow(daily_data) > 0) { - aggregated_daily <- OutbreakExtractR::observation_aggregator(daily_data) - weekly_data <- dplyr::bind_rows(weekly_data, aggregated_daily) -} - -# Normalize weekly data: deduplicate, align week-start day, fill zeros -normalized <- weekly_data %>% - dplyr::ungroup() %>% - OutbreakExtractR::average_duplicate_observations() %>% - OutbreakExtractR::set_uniform_wday_start() %>% - OutbreakExtractR::fill_phantom_zeroes() %>% - OutbreakExtractR::fill_missing_lps() - -# Attach WorldPop population estimates (one value per location_period_id). -# Required downstream by get_outbreak_threshold() and identify_epidemic_start() -# for incidence-based threshold modes. -# Rasters are downloaded once into opt$raster_dir and cached for subsequent runs. -normalized <- OutbreakExtractR::add_population( - normalized_data = normalized, - raw_sf = raw_sf, # has location_period_id + geometry (sf select preserves geom) - country_iso3 = opt$country_iso3, - raster_dir = here::here(opt$raster_dir) -) - # --------------------------------------------------------------------------- -# Save flat parquet for Batch 2 +# Save cleaned flat file for Batch 2 # --------------------------------------------------------------------------- -write_tabular(normalized, out_flat, opt$use_geoparquet) +write_tabular(clean_data, out_flat, opt$use_geoparquet) message("Stage 1 complete.") -message(" Rows: ", nrow(normalized)) -message(" Locations: ", length(unique(normalized$location))) +message(" Rows: ", nrow(clean_data)) +message(" Locations: ", length(unique(clean_data$location))) message(" Saved: ", basename(out_flat)) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index 9cd7238..dfc7ddf 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -1,14 +1,21 @@ # 02_run_outbreak_detection.R — Batch 2: outbreak detection for one country # -# Reads a per-country YAML config (detection_set), discovers all Stage 1 flat -# parquet files for that country (across all time windows), and runs -# identify_outbreaks() + trigger_alert() for each time window sequentially. +# Reads a per-country YAML config (detection_set), concatenates all Stage 1 +# flat files for that country (one per 4-month pull window), and runs the +# full reference processing pipeline + identify_outbreaks() + trigger_alert() +# once over the entire per-country time series. # -# Outputs one parquet file per country containing results across all windows: -# stage2_{who_region}_{country_iso3}.parquet +# Processing pipeline matches Step2_Extract_outbreak.R from +# GenevaIDD/global-cholera-surveillance-timeseries: +# filter (daily → aggregate; weekly) → fill_missing_lps ×3 → +# average_duplicate_observations → set_uniform_wday_start → +# filter(n_obs > 1) → fill_phantom_zeroes → add_population → +# identify_outbreaks (threshold over full series, no customized_TL/TR) # -# This script is intentionally single-threaded — the per-country loop is fast -# relative to data pull. SLURM parallelism happens at the country level. +# Outputs one file per country: +# stage2_{who_region}_{country_iso3}.{rds,parquet} +# +# SLURM parallelism happens at the country level (one job per country). # # Usage: # Rscript analysis/02_run_outbreak_detection.R \ @@ -20,6 +27,8 @@ library(dplyr) library(purrr) library(lubridate) library(stringr) +library(sf) +sf_use_s2(FALSE) source(here("analysis/utils.R")) @@ -70,128 +79,239 @@ if (file.exists(out_file) && !isTRUE(opt$redo)) { } # --------------------------------------------------------------------------- -# Run outbreak detection for each time window +# Concatenate all per-window cleaned observations for this country # --------------------------------------------------------------------------- -results_list <- lapply(stage1_files, function(f) { +clean_list <- lapply(stage1_files, function(f) { + tryCatch({ + df <- read_tabular(f, opt$use_geoparquet) + if (nrow(df) == 0) return(NULL) + df + }, error = function(e) { + warning("Failed to read Stage 1 flat file: ", basename(f), " — ", conditionMessage(e)) + NULL + }) +}) - # Parse time bounds from the filename (encoded as TL{YYYYMMDD}_TR{YYYYMMDD}) - fname <- basename(f) - tl_str <- str_extract(fname, "(?<=_TL)\\d{8}") - tr_str <- str_extract(fname, "(?<=_TR)\\d{8}") +clean_all <- purrr::list_rbind(purrr::keep(clean_list, \(x) !is.null(x))) - if (is.na(tl_str) || is.na(tr_str)) { - warning("Could not parse time bounds from filename: ", fname, " — skipping.") - return(NULL) - } +if (nrow(clean_all) == 0) { + warning("No Stage 1 observations for: ", opt$who_region, "::", opt$country_iso3) + write_tabular(data.frame(), out_file, opt$use_geoparquet) + quit(status = 0) +} - tl <- lubridate::ymd(tl_str) - tr <- lubridate::ymd(tr_str) - run_id <- str_remove(str_remove(fname, "^stage1_flat_"), "\\.(parquet|rds)$") +message("Loaded ", nrow(clean_all), " cleaned observations across ", + length(stage1_files), " window(s).") - message("Processing: ", run_id) +# --------------------------------------------------------------------------- +# Load per-window geo files → raw_sf for population attachment +# --------------------------------------------------------------------------- - normalized <- read_tabular(f, opt$use_geoparquet) - if (nrow(normalized) == 0) { - message(" Empty Stage 1 file — skipping.") - return(NULL) - } +geo_ext <- if (isTRUE(opt$use_geoparquet)) "\\.parquet" else "\\.geojson" +geo_pattern <- paste0("^stage1_geo_", opt$who_region, "_", + gsub("::", "_", opt$country_iso3), "_.*", geo_ext, "$") +geo_files <- list.files(stage1_dir, pattern = geo_pattern, full.names = TRUE) + +if (length(geo_files) == 0) { + warning("No Stage 1 geo files found for population attachment — pop will be NA.") + raw_sf <- NULL +} else { + geo_list <- lapply(geo_files, function(f) { + tryCatch( + if (isTRUE(opt$use_geoparquet)) sfarrow::st_read_parquet(f) + else sf::st_read(f, quiet = TRUE), + error = function(e) { + warning("Failed to read geo file: ", basename(f), " — ", conditionMessage(e)) + NULL + } + ) + }) + raw_sf <- do.call(rbind, Filter(Negate(is.null), geo_list)) + message("Loaded geometry from ", length(geo_files), " geo file(s).") +} - # --- identify_outbreaks() --- - outbreak_list <- tryCatch( - OutbreakExtractR::identify_outbreaks( - threshold_type = opt$threshold_type, - original_data = normalized, - zero_case_assumption = opt$zero_case_assumption, - customized_TL = tl, - customized_TR = tr, - outbreak_start_definition = opt$outbreak_start_definition, - min_weeks_above = opt$min_weeks_above, - require_increasing_trend = opt$require_increasing_trend, - window_weeks = opt$window_weeks, - cumulative_windows = opt$cumulative_windows, - cumulative_case_threshold_ratio = opt$cumulative_case_threshold_ratio, - cumulative_trigger_type = opt$cumulative_trigger_type, - use_cumulative_trigger = opt$use_cumulative_trigger, - cumulative_min_cases = opt$cumulative_min_cases, - nonzero_windows = opt$nonzero_windows, - tail_period = opt$tail_period - ), - error = function(e) { - warning("identify_outbreaks() failed for ", run_id, ": ", conditionMessage(e)) - NULL - } - ) +# --------------------------------------------------------------------------- +# Derive full time range from window filenames +# --------------------------------------------------------------------------- - if (is.null(outbreak_list)) return(NULL) +tl_strings <- str_extract(basename(stage1_files), "(?<=_TL)\\d{8}") +tr_strings <- str_extract(basename(stage1_files), "(?<=_TR)\\d{8}") +tl_all <- min(lubridate::ymd(tl_strings), na.rm = TRUE) +tr_all <- max(lubridate::ymd(tr_strings), na.rm = TRUE) - # Flatten list → dataframe (one row per location-week) - outbreaks_df <- purrr::list_rbind( - purrr::keep(outbreak_list, \(x) is.data.frame(x) && nrow(x) > 0) - ) +message("Full time range: ", tl_all, " → ", tr_all) - if (nrow(outbreaks_df) == 0) { - message(" No outbreaks detected.") - return(NULL) - } +# --------------------------------------------------------------------------- +# Reference processing pipeline (matches Step2_Extract_outbreak.R:26-67) +# --------------------------------------------------------------------------- - # --- trigger_alert() --- - alerts_df <- tryCatch( - OutbreakExtractR::trigger_alert(original_data = normalized), - error = function(e) { - warning("trigger_alert() failed for ", run_id, ": ", conditionMessage(e)) - NULL - } +# Daily branch: filter then aggregate to weekly +daily_data <- OutbreakExtractR::observation_filter( + outbreak_data = clean_all, + time_lower_bound_filter = tl_all, + time_upper_bound_filter = tr_all, + temporal_scale_filter = "daily", + who_regions = opt$who_region, + spatial_scale_filter = opt$spatial_scale_filter, + remove_na_sCh = opt$remove_na_sCh, + remove_na_cCh = opt$remove_na_cCh, + remove_na_locationperiod = opt$remove_na_locationperiod, + minimum_daily_cases = opt$minimum_daily_cases +) +if (nrow(daily_data) > 0) { + daily_data <- OutbreakExtractR::observation_aggregator(daily_data) +} + +# Weekly branch: filter then coerce id columns to character (avoids bind_rows type conflicts) +weekly_data <- OutbreakExtractR::observation_filter( + outbreak_data = clean_all, + time_lower_bound_filter = tl_all, + time_upper_bound_filter = tr_all, + temporal_scale_filter = "weekly", + who_regions = opt$who_region, + spatial_scale_filter = opt$spatial_scale_filter, + remove_na_sCh = opt$remove_na_sCh, + remove_na_cCh = opt$remove_na_cCh, + remove_na_locationperiod = opt$remove_na_locationperiod, + minimum_daily_cases = opt$minimum_daily_cases +) %>% + dplyr::mutate( + observation_collection_id = as.character(observation_collection_id), + dplyr::across(dplyr::any_of("original_location_name"), as.character) ) - # Attach alert columns if available - if (!is.null(alerts_df) && nrow(alerts_df) > 0) { - alert_cols <- names(alerts_df)[str_detect(names(alerts_df), "^alert")] - join_keys <- intersect(c("location", "TL", "TR"), names(alerts_df)) - if (length(join_keys) > 0 && length(alert_cols) > 0) { - outbreaks_df <- dplyr::left_join( - outbreaks_df, - dplyr::select(alerts_df, dplyr::all_of(c(join_keys, alert_cols))), - by = join_keys - ) - } - } +combined_filtered <- dplyr::bind_rows(weekly_data, daily_data) - # Attach run metadata for later aggregation - outbreaks_df <- dplyr::mutate( - outbreaks_df, - who_region = opt$who_region, - country_iso3 = opt$country_iso3, - time_lower_bound = as.character(tl), - time_upper_bound = as.character(tr), - run_id = run_id - ) +if (nrow(combined_filtered) == 0) { + warning("No observations after filtering for: ", opt$who_region, "::", opt$country_iso3) + write_tabular(data.frame(), out_file, opt$use_geoparquet) + quit(status = 0) +} - n_outbreak_rows <- sum(outbreaks_df$outbreak_number > 0, na.rm = TRUE) - message(" Rows: ", nrow(outbreaks_df), - " | Outbreak-period rows: ", n_outbreak_rows) +# Normalization: fill_missing_lps (×3), dedup, wday alignment, singleton drop, phantom zeros +normalized <- combined_filtered %>% + OutbreakExtractR::fill_missing_lps() %>% + OutbreakExtractR::average_duplicate_observations() %>% + OutbreakExtractR::fill_missing_lps() %>% + OutbreakExtractR::set_uniform_wday_start() %>% + dplyr::group_by(location) %>% + dplyr::add_count(name = "n_obs") %>% + dplyr::ungroup() %>% + dplyr::filter(n_obs > 1) %>% + dplyr::select(-n_obs) %>% + OutbreakExtractR::fill_phantom_zeroes() %>% + OutbreakExtractR::fill_missing_lps() + +message("Normalized: ", nrow(normalized), " rows, ", + length(unique(normalized$location)), " location(s).") + +if (nrow(normalized) == 0) { + warning("No data after normalization for: ", opt$who_region, "::", opt$country_iso3) + write_tabular(data.frame(), out_file, opt$use_geoparquet) + quit(status = 0) +} - outbreaks_df -}) +# Population attachment (WorldPop, keyed by location_period_id + geometry from geo files) +if (!is.null(raw_sf)) { + normalized <- OutbreakExtractR::add_population( + normalized_data = normalized, + raw_sf = raw_sf, + country_iso3 = opt$country_iso3, + raster_dir = here::here(opt$raster_dir) + ) +} else { + normalized$pop <- NA_real_ + message("Skipping add_population() — no geo files found; pop set to NA.") +} # --------------------------------------------------------------------------- -# Combine and save +# Outbreak detection over full per-country series (no customized_TL/TR) +# Threshold = mean weekly incidence over the entire time series, matching reference # --------------------------------------------------------------------------- -combined <- purrr::list_rbind(purrr::keep(results_list, \(x) !is.null(x))) +outbreak_list <- tryCatch( + OutbreakExtractR::identify_outbreaks( + threshold_type = opt$threshold_type, + original_data = normalized, + zero_case_assumption = opt$zero_case_assumption, + outbreak_start_definition = opt$outbreak_start_definition, + min_weeks_above = opt$min_weeks_above, + require_increasing_trend = opt$require_increasing_trend, + window_weeks = opt$window_weeks, + cumulative_windows = opt$cumulative_windows, + cumulative_case_threshold_ratio = opt$cumulative_case_threshold_ratio, + cumulative_trigger_type = opt$cumulative_trigger_type, + use_cumulative_trigger = opt$use_cumulative_trigger, + cumulative_min_cases = opt$cumulative_min_cases, + nonzero_windows = opt$nonzero_windows, + tail_period = opt$tail_period + ), + error = function(e) { + warning("identify_outbreaks() failed for ", + opt$who_region, "::", opt$country_iso3, ": ", conditionMessage(e)) + NULL + } +) + +if (is.null(outbreak_list)) { + write_tabular(data.frame(), out_file, opt$use_geoparquet) + quit(status = 0) +} -if (nrow(combined) == 0) { - warning("No outbreak results to save for: ", - opt$who_region, "::", opt$country_iso3) - # Write empty sentinel so post-processor can detect this gracefully +outbreaks_df <- purrr::list_rbind( + purrr::keep(outbreak_list, \(x) is.data.frame(x) && nrow(x) > 0) +) + +if (nrow(outbreaks_df) == 0) { + message("No outbreaks detected for: ", opt$who_region, "::", opt$country_iso3) write_tabular(data.frame(), out_file, opt$use_geoparquet) quit(status = 0) } -write_tabular(combined, out_file, opt$use_geoparquet) +# --------------------------------------------------------------------------- +# Alerts +# --------------------------------------------------------------------------- + +alerts_df <- tryCatch( + OutbreakExtractR::trigger_alert(original_data = normalized), + error = function(e) { + warning("trigger_alert() failed: ", conditionMessage(e)) + NULL + } +) + +if (!is.null(alerts_df) && nrow(alerts_df) > 0) { + alert_cols <- names(alerts_df)[str_detect(names(alerts_df), "^alert")] + join_keys <- intersect(c("location", "TL", "TR"), names(alerts_df)) + if (length(join_keys) > 0 && length(alert_cols) > 0) { + outbreaks_df <- dplyr::left_join( + outbreaks_df, + dplyr::select(alerts_df, dplyr::all_of(c(join_keys, alert_cols))), + by = join_keys + ) + } +} + +# --------------------------------------------------------------------------- +# Add metadata and save +# --------------------------------------------------------------------------- + +outbreaks_df <- dplyr::mutate( + outbreaks_df, + who_region = opt$who_region, + country_iso3 = opt$country_iso3, + time_lower_bound = as.character(tl_all), + time_upper_bound = as.character(tr_all) +) + +n_outbreak_rows <- sum(outbreaks_df$outbreak_number > 0, na.rm = TRUE) + +write_tabular(outbreaks_df, out_file, opt$use_geoparquet) message("\nStage 2 complete.") -message(" Country: ", opt$who_region, "::", opt$country_iso3) -message(" Time windows: ", length(stage1_files)) -message(" Total rows: ", nrow(combined)) -message(" Saved: ", basename(out_file)) +message(" Country: ", opt$who_region, "::", opt$country_iso3) +message(" Full time range: ", tl_all, " → ", tr_all) +message(" Total rows: ", nrow(outbreaks_df)) +message(" Outbreak-period rows: ", n_outbreak_rows) +message(" Saved: ", basename(out_file)) From f473047c5a83e54bbbd4545bfb0f7e52eddc3b9b Mon Sep 17 00:00:00 2001 From: javier Date: Fri, 12 Jun 2026 14:35:37 +0200 Subject: [PATCH 57/69] Update parse_detect_logs.R for new single-pass pipeline format New batch 44869016 runs a redesigned Stage 2 that processes all windows together rather than per-window, producing different log output. Key changes: - Detect log format via "Linking to GEOS" / "Loaded N observations" signal - Fix no_results detection for new messages: "No Stage 1 observations for:", "No observations after filtering for:", "No data after normalization for:", "No outbreaks detected for:" - Add outbreak_rows, n_obs_loaded, no_results_reason columns - Add error_class column with exactextractr_error / purrr_map_error classes - Add success_with_warnings / success_no_results_with_warnings outcomes (distinguishes clean completions from those with per-window failures) - Add --latest-only flag to restrict parsing to the most recent batch - Retain backward-compatible per-window fields (NA for new-format logs) Co-Authored-By: Claude Sonnet 4.6 --- analysis/parse_detect_logs.R | 330 ++++++++++++++++++++++++----------- 1 file changed, 228 insertions(+), 102 deletions(-) diff --git a/analysis/parse_detect_logs.R b/analysis/parse_detect_logs.R index d9f6af3..ceb429d 100644 --- a/analysis/parse_detect_logs.R +++ b/analysis/parse_detect_logs.R @@ -1,16 +1,16 @@ #!/usr/bin/env Rscript # parse_detect_logs.R # Parses all Stage 2 (detection) SLURM logs, classifies outcomes, and writes -# summary CSVs parallel to parse_pull_logs.R. +# summary CSVs. # -# Key differences from pull logs: -# - One log = one country (not one country × window) -# - Outcomes are at country level; per-window failures surface as warnings -# - Extracts Stage 2 row counts and window tallies from log body +# Supports two log formats: +# OLD (batch ≤ 44825740): per-window Processing: lines with Rows: summaries +# NEW (batch ≥ 44869016): single-pass pipeline with Loaded N observations … # # Usage: -# Rscript analysis/parse_detect_logs.R [--log-dir logs] \ -# [--out analysis/detect_log_summary.csv] +# Rscript analysis/parse_detect_logs.R [--log-dir analysis/logs] \ +# [--out analysis/detect_log_summary.csv] \ +# [--latest-only] suppressPackageStartupMessages({ library(dplyr) @@ -28,11 +28,27 @@ get_arg <- function(flag, default) { if (length(idx) && length(args) >= idx + 1) args[[idx + 1]] else default } -log_dir <- get_arg("--log-dir", "logs") -out_csv <- get_arg("--out", "analysis/detect_log_summary.csv") +log_dir <- get_arg("--log-dir", "analysis/logs") +out_csv <- get_arg("--out", "analysis/detect_log_summary.csv") +latest_only <- any(args == "--latest-only") -# ── Per-window warning error classification ─────────────────────────────────── -# Matches the warning body emitted by identify_outbreaks() / trigger_alert() +# ── Fatal-error classification (new format) ─────────────────────────────────── +# Applied to the tail of logs whose outcome is "error". +fatal_error_classes <- list( + exactextractr_error = "exactextractr|CPP_stats", + purrr_map_error = "Error in `purrr::map", + r_error_generic = "^Error in |^Error:" +) + +classify_fatal_error <- function(tail_lines) { + combined <- paste(tail_lines, collapse = "\n") + for (cls in names(fatal_error_classes)) { + if (grepl(fatal_error_classes[[cls]], combined, perl = TRUE)) return(cls) + } + "unknown_error" +} + +# ── Per-window warning classification (old format) ──────────────────────────── window_error_classes <- list( missing_value_logical = "missing value where TRUE/FALSE needed", too_long_vector = "result would be too long a vector", @@ -55,100 +71,158 @@ parse_log <- function(path) { lines <- tryCatch(readLines(path, warn = FALSE), error = function(e) character(0)) empty_row <- tibble( - log_file = basename(path), - array_task_id = NA_integer_, - config = NA_character_, - who_region = NA_character_, - country_iso3 = NA_character_, - outcome = "unreadable", - n_stage1_files = NA_integer_, - n_windows_empty = NA_integer_, - n_windows_no_ob = NA_integer_, - n_windows_ob = NA_integer_, - n_windows_failed = NA_integer_, - total_rows = NA_integer_, - window_error_types = NA_character_ + log_file = basename(path), + slurm_job_id = NA_character_, + array_task_id = NA_integer_, + config = NA_character_, + who_region = NA_character_, + country_iso3 = NA_character_, + outcome = "unreadable", + error_class = NA_character_, + # --- new-format fields --- + n_obs_loaded = NA_integer_, + total_rows = NA_integer_, + outbreak_rows = NA_integer_, + no_results_reason = NA_character_, + # --- old-format per-window fields (NA for new-format logs) --- + n_stage1_files = NA_integer_, + n_windows_empty = NA_integer_, + n_windows_no_ob = NA_integer_, + n_windows_ran = NA_integer_, + n_windows_failed = NA_integer_, + window_error_types = NA_character_, + failed_run_ids = NA_character_ ) if (length(lines) == 0) return(empty_row) - # ── Header fields ──────────────────────────────────────────────────────────── + # ── Helper ─────────────────────────────────────────────────────────────────── grab <- function(pattern) { m <- str_match(lines, pattern) hit <- m[!is.na(m[, 2]), 2, drop = TRUE] if (length(hit)) hit[[1]] else NA_character_ } + # ── Header fields ──────────────────────────────────────────────────────────── + slurm_job_id <- str_match(basename(path), "^cholera_detect_(\\d+)_")[, 2] array_task_id <- as.integer(grab("SLURM_ARRAY_TASK_ID:\\s*(\\d+)")) config <- grab("^Config:\\s*(.+)") who_region <- grab("\\$\\s*who_region\\s*:\\s*chr\\s*\"([^\"]+)\"") country_iso3 <- grab("\\$\\s*country_iso3\\s*:\\s*chr\\s*\"([^\"]+)\"") - # ── Window-level counts ────────────────────────────────────────────────────── - n_stage1_files <- as.integer(grab("Found (\\d+) Stage 1 file")) - n_windows_empty <- sum(grepl("Empty Stage 1 file", lines, fixed = TRUE)) - n_windows_no_ob <- sum(grepl("No outbreaks detected", lines, fixed = TRUE)) - n_windows_ob <- sum(grepl("Rows:\\s*\\d+\\s*\\|\\s*Outbreak-period rows", lines)) - total_rows <- { + # ── Detect log format ──────────────────────────────────────────────────────── + # New format loads sf (→ "Linking to GEOS" appears even for early-exit logs). + # Old format never loads sf. + new_format <- any(grepl("Linking to GEOS", lines, fixed = TRUE)) || + any(grepl("Loaded \\d+ cleaned observations", lines)) + + # ── New-format fields ──────────────────────────────────────────────────────── + n_obs_loaded <- as.integer(grab("Loaded (\\d+) cleaned observations")) + + total_rows <- { m <- str_match(lines, "Total rows:\\s*(\\d+)") hit <- m[!is.na(m[, 2]), 2] if (length(hit)) as.integer(hit[[1]]) else NA_integer_ } + outbreak_rows <- { + m <- str_match(lines, "Outbreak-period rows:\\s*(\\d+)") + hit <- m[!is.na(m[, 2]), 2] + if (length(hit)) as.integer(hit[[1]]) else NA_integer_ + } + + # ── Old-format per-window fields ───────────────────────────────────────────── + n_stage1_files <- as.integer(grab("Found (\\d+) Stage 1 file")) + n_windows_empty <- if (!new_format) sum(grepl("Empty Stage 1 file", lines, fixed = TRUE)) else NA_integer_ + n_windows_no_ob <- if (!new_format) sum(grepl("No outbreaks detected", lines, fixed = TRUE)) else NA_integer_ + n_windows_ran <- if (!new_format) sum(grepl("Rows:\\s*\\d+\\s*\\|\\s*Outbreak-period rows", lines)) else NA_integer_ - # ── Per-window failure warnings ────────────────────────────────────────────── - # Warning lines look like: - # identify_outbreaks() failed for : - # trigger_alert() failed for : - warn_lines <- lines[grepl("(identify_outbreaks|trigger_alert)\\(\\) failed for", lines)] - n_windows_failed <- length(warn_lines) - - window_error_types <- if (n_windows_failed > 0) { - warn_lines |> - map_chr(classify_window_error) |> - unique() |> - sort() |> - paste(collapse = ";") + warn_lines <- lines[grepl("(identify_outbreaks|trigger_alert)\\(\\) failed for", lines)] + n_windows_failed <- if (!new_format) length(warn_lines) else NA_integer_ + + window_error_types <- if (!new_format && length(warn_lines) > 0) { + warn_lines |> map_chr(classify_window_error) |> unique() |> sort() |> paste(collapse = ";") } else { NA_character_ } + failed_run_ids <- if (!new_format && length(warn_lines) > 0) { + m <- str_match(warn_lines, + "(?:identify_outbreaks|trigger_alert)\\(\\) failed for ([^:]+):") + m[!is.na(m[, 2]), 2] |> paste(collapse = ";") + } else { + NA_character_ + } + + # ── Outcome sentinels ───────────────────────────────────────────────────────── + halted <- any(grepl("Execution halted", lines, fixed = TRUE)) + error_line <- any(grepl("^ERROR:", lines)) + skipped <- any(grepl("Stage 2 output already exists", lines, fixed = TRUE)) + stage2_ok <- any(grepl("Stage 2 complete.", lines, fixed = TRUE)) + batch_end <- any(grepl("Batch 2 end:", lines, fixed = TRUE)) + completed <- stage2_ok || batch_end + + # "no results" covers both old and new warning messages + no_results <- any(grepl("No outbreak results to save", lines, fixed = TRUE)) || + any(grepl("No outbreaks detected for:", lines, fixed = TRUE)) || + any(grepl("No Stage 1 observations for:", lines, fixed = TRUE)) || + any(grepl("No observations after filtering for:", lines, fixed = TRUE)) || + any(grepl("No data after normalization for:", lines, fixed = TRUE)) + + # Extract the specific reason (first match wins; ordered most-specific first) + no_results_reason <- NA_character_ + if (no_results) { + for (pat in c( + "No Stage 1 observations for:", + "No observations after filtering for:", + "No data after normalization for:", + "No outbreaks detected for:", + "No outbreak results to save" + )) { + hit <- lines[grepl(pat, lines, fixed = TRUE)] + if (length(hit)) { no_results_reason <- str_trim(hit[[1]]); break } + } + } + # ── Outcome ─────────────────────────────────────────────────────────────────── - # "Batch 2 end:" is the shell wrapper sentinel — may be missing if the log was - # downloaded while the job was still writing or got truncated. Fall back to - # "Stage 2 complete." printed by the R script itself as a secondary signal. - completed <- any(grepl("Batch 2 end:", lines, fixed = TRUE)) || - any(grepl("Stage 2 complete.", lines, fixed = TRUE)) - no_results <- any(grepl("No outbreak results to save", lines, fixed = TRUE)) - skipped <- any(grepl("Stage 2 output already exists, skipping", lines, fixed = TRUE)) - halted <- any(grepl("Execution halted", lines, fixed = TRUE)) - error_line <- any(grepl("^ERROR:", lines)) + n_failed <- if (!is.na(n_windows_failed)) n_windows_failed else 0L outcome <- case_when( - halted | error_line ~ "error", - skipped & !completed ~ "skipped", - completed & no_results ~ "success_no_results", - completed ~ "success", - TRUE ~ "incomplete" + halted | error_line ~ "error", + skipped & !completed ~ "skipped", + completed & no_results & n_failed > 0 ~ "success_no_results_with_warnings", + completed & no_results ~ "success_no_results", + completed & n_failed > 0 ~ "success_with_warnings", + completed ~ "success", + TRUE ~ "incomplete" ) - # Extract SLURM job ID from filename (cholera_detect_{job_id}_{task}.log) - slurm_job_id <- str_match(basename(path), "^cholera_detect_(\\d+)_")[, 2] + # ── Fatal-error classification ──────────────────────────────────────────────── + error_class <- if (outcome == "error") { + classify_fatal_error(tail(lines, 80)) + } else { + NA_character_ + } tibble( - log_file = basename(path), - slurm_job_id = slurm_job_id, - array_task_id = array_task_id, - config = config, - who_region = who_region, - country_iso3 = country_iso3, - outcome = outcome, - n_stage1_files = n_stage1_files, - n_windows_empty = n_windows_empty, - n_windows_no_ob = n_windows_no_ob, - n_windows_ob = n_windows_ob, - n_windows_failed = n_windows_failed, - total_rows = total_rows, - window_error_types = window_error_types + log_file = basename(path), + slurm_job_id = slurm_job_id, + array_task_id = array_task_id, + config = config, + who_region = who_region, + country_iso3 = country_iso3, + outcome = outcome, + error_class = error_class, + n_obs_loaded = n_obs_loaded, + total_rows = total_rows, + outbreak_rows = outbreak_rows, + no_results_reason = no_results_reason, + n_stage1_files = n_stage1_files, + n_windows_empty = n_windows_empty, + n_windows_no_ob = n_windows_no_ob, + n_windows_ran = n_windows_ran, + n_windows_failed = n_windows_failed, + window_error_types = window_error_types, + failed_run_ids = failed_run_ids ) } @@ -159,6 +233,14 @@ log_files <- list.files(log_dir, if (length(log_files) == 0) stop("No detection .log files found in: ", log_dir) +if (latest_only) { + batch_ids <- str_match(basename(log_files), "^cholera_detect_(\\d+)_")[, 2] + latest_id <- max(batch_ids, na.rm = TRUE) + log_files <- log_files[!is.na(batch_ids) & batch_ids == latest_id] + message(sprintf("--latest-only: restricting to batch %s (%d files)", + latest_id, length(log_files))) +} + message(sprintf("Parsing %d detection log files from '%s' ...", length(log_files), log_dir)) @@ -177,43 +259,87 @@ print_batch_summary <- function(df, label) { mutate(pct = sprintf("%.1f%%", 100 * n / sum(n))) |> print(n = Inf) - cat("--- Window counts ---\n") - df |> - summarise( - countries_run = sum(outcome %in% c("success", "success_no_results")), - total_stage1_files = sum(n_stage1_files, na.rm = TRUE), - windows_empty = sum(n_windows_empty, na.rm = TRUE), - windows_no_ob = sum(n_windows_no_ob, na.rm = TRUE), - windows_with_ob = sum(n_windows_ob, na.rm = TRUE), - windows_failed = sum(n_windows_failed, na.rm = TRUE), - total_output_rows = sum(total_rows, na.rm = TRUE) - ) |> print() - - failed_df <- df |> filter(n_windows_failed > 0) - if (nrow(failed_df) > 0) { - cat(sprintf("--- Per-window error types (%d countries affected) ---\n", - nrow(failed_df))) - failed_df |> - mutate(error_type = str_split(window_error_types, ";")) |> - unnest(error_type) |> - count(error_type, sort = TRUE) |> + # Error details + err_df <- df |> filter(outcome == "error") + if (nrow(err_df) > 0) { + cat(sprintf("--- Error class (%d job(s)) ---\n", nrow(err_df))) + err_df |> + count(error_class, sort = TRUE) |> mutate(pct = sprintf("%.1f%%", 100 * n / sum(n))) |> print(n = Inf) + cat("--- Errored jobs ---\n") + err_df |> + select(log_file, array_task_id, who_region, country_iso3, error_class) |> + print(n = Inf) + } + + # No-results breakdown + nr_df <- df |> filter(str_starts(outcome, "success_no_results")) + if (nrow(nr_df) > 0) { + cat(sprintf("--- No-results reasons (%d country/ies) ---\n", nrow(nr_df))) + nr_df |> + # trim to just the prefix before ":" to group by type + mutate(reason_type = str_extract(no_results_reason, + "^No [^:]+")) |> + count(reason_type, sort = TRUE) |> + print(n = Inf) + } + + # Row counts (new format) + new_fmt <- df |> filter(!is.na(n_obs_loaded)) + if (nrow(new_fmt) > 0) { + cat("--- Output rows (new-format jobs) ---\n") + new_fmt |> + summarise( + countries_ok = sum(outcome == "success"), + total_obs_loaded = sum(n_obs_loaded, na.rm = TRUE), + total_output_rows = sum(total_rows, na.rm = TRUE), + total_outbreak_rows = sum(outbreak_rows, na.rm = TRUE) + ) |> print() + } - cat("--- Countries with failures ---\n") - failed_df |> - select(who_region, country_iso3, n_windows_failed, window_error_types, - n_windows_ob, total_rows) |> - arrange(desc(n_windows_failed)) |> - print(n = 40) + # Window counts (old format) + old_fmt <- df |> filter(!is.na(n_windows_ran)) + if (nrow(old_fmt) > 0) { + cat("--- Window counts (old-format jobs) ---\n") + old_fmt |> + summarise( + countries_run = sum(outcome %in% c("success", "success_with_warnings", + "success_no_results", + "success_no_results_with_warnings")), + total_stage1_files = sum(n_stage1_files, na.rm = TRUE), + windows_empty = sum(n_windows_empty, na.rm = TRUE), + windows_no_ob = sum(n_windows_no_ob, na.rm = TRUE), + windows_ran = sum(n_windows_ran, na.rm = TRUE), + windows_failed = sum(n_windows_failed, na.rm = TRUE), + total_output_rows = sum(total_rows, na.rm = TRUE) + ) |> print() + + failed_df <- old_fmt |> filter(!is.na(n_windows_failed) & n_windows_failed > 0) + if (nrow(failed_df) > 0) { + cat(sprintf("--- Per-window error types (%d countries affected) ---\n", + nrow(failed_df))) + failed_df |> + mutate(error_type = str_split(window_error_types, ";")) |> + unnest(error_type) |> + count(error_type, sort = TRUE) |> + mutate(pct = sprintf("%.1f%%", 100 * n / sum(n))) |> + print(n = Inf) + + cat("--- Countries with per-window failures ---\n") + failed_df |> + select(who_region, country_iso3, n_windows_failed, window_error_types, + n_windows_ran, total_rows) |> + arrange(desc(n_windows_failed)) |> + print(n = 40) + } } incomplete <- df |> filter(outcome == "incomplete") if (nrow(incomplete) > 0) { cat(sprintf("--- Incomplete jobs (%d) ---\n", nrow(incomplete))) incomplete |> - select(log_file, array_task_id, who_region, country_iso3, - n_windows_ob, n_windows_failed) |> + select(log_file, array_task_id, who_region, country_iso3) |> print(n = Inf) } } From 1956f7e4f96bc275a2bf7fcdc495b0dd8cfbcd8a Mon Sep 17 00:00:00 2001 From: javier Date: Mon, 15 Jun 2026 22:48:04 +0200 Subject: [PATCH 58/69] Fix mixed-geometry crash in add_population() for large countries (COD) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit exactextractr::exact_extract() throws "Mixed-type geometries not supported" when the valid_sfc passed to it contains a mix of POLYGON and MULTIPOLYGON features — as occurs in COD (DRC) which has 784 LPs spanning multiple admin levels and eras. Fix: after the existing empty/non-polygon filter, cast valid_sfc to a uniform MULTIPOLYGON type before the exact_extract call. Conversion from POLYGON → MULTIPOLYGON is always safe after the dimension==2 guard; GEOMETRYCOLLECTION features are handled by sf::st_cast (first polygon part retained, with an sf warning). Also wraps the country-boundary adj-factor extraction in tryCatch so a geometry error there falls through to adj_factor = 1.0 rather than halting the job. Verified locally: COD now completes with 158 424 rows / 25 487 outbreak- period rows and 233 661 / 287 092 rows with population estimates. Co-Authored-By: Claude Sonnet 4.6 --- R/add_population.R | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/R/add_population.R b/R/add_population.R index 177033f..28e30a4 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -164,11 +164,22 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # -- b. Adj factor: one exact_extract call on the country boundary ------ # Inlined from estimate_adj_factors() to reuse the already-loaded # raster instead of having that function load it a second time. - country_raw <- sum( - exactextractr::exact_extract( - pop_raster, sf::st_geometry(country_shp), "sum" + # Wrapped in tryCatch: the fallback country boundary (LP-geometry union, + # used when rgeoboundaries is unavailable) can produce a geometry that + # exactextractr cannot resolve ("Error getting geometry extent") — in + # that case we fall through to adj_factor = 1.0. + country_raw <- tryCatch( + sum( + exactextractr::exact_extract( + pop_raster, sf::st_geometry(country_shp), "sum" + ), + na.rm = TRUE ), - na.rm = TRUE + error = function(e) { + message(" adj factor extraction failed: ", conditionMessage(e), + " — using 1.0 (population will be unadjusted).") + 0 + } ) tot_UN <- WPP2024$PopTotal[ WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary @@ -218,6 +229,18 @@ add_population <- function(normalized_data, raw_sf, country_iso3, valid_sfc <- valid_sfc[!bad_geom] } + # Normalize to a uniform geometry type. + # exactextractr::exact_extract() errors with "Mixed-type geometries not + # supported" when valid_sfc contains a mix of POLYGON and MULTIPOLYGON. + # After the bad_geom filter all remaining features have dimension == 2 + # (polygon-type), so casting to MULTIPOLYGON is always safe. + if (length(valid_sfc) > 0L) { + geom_types <- unique(as.character(sf::st_geometry_type(valid_sfc))) + if (length(geom_types) > 1L || identical(geom_types, "POLYGON")) { + valid_sfc <- sf::st_cast(valid_sfc, "MULTIPOLYGON", warn = FALSE) + } + } + if (length(valid_idx) > 0L) { raw_pops <- exactextractr::exact_extract( pop_raster, valid_sfc, "sum" From 81e346361ec32a1631085dbb6953e763a2369004 Mon Sep 17 00:00:00 2001 From: javier Date: Fri, 19 Jun 2026 13:53:22 +0200 Subject: [PATCH 59/69] Add post-detection outbreak size filter; fix hardcoded tail extension; fix pre-existing test failures MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ## New feature: filter_outbreaks_by_size Add `filter_outbreaks_by_size` (default FALSE) to `identify_outbreaks()`. When TRUE, drops any detected outbreak whose total cases (summed over the full outbreak window) fall below `cumulative_min_cases`. This makes the existing `cumulative_min_cases = 50` config value act as a genuine size floor rather than just gating one side of the dual_window cumulative alert trigger. Enabled by default in `config_defaults.yml` (`filter_outbreaks_by_size: true`). Wired through `02_run_outbreak_detection.R`. Implemented via an internal `filter_small_outbreaks()` helper inserted before the Time Period labelling step so dropped outbreaks are automatically reclassified as non-outbreak period. Docs and `man/identify_outbreaks.Rd` updated. ## Bug fix: hardcoded +1 tail extension Replace hardcoded `+2-1` with `+tail_period-1` in the outbreak window assignment loop in `identify_outbreaks()`. The hardcoded extension forced a 4-week minimum duration regardless of `tail_period = 6`; 87% of those minimum-duration events had < 50 total cases (documented in `analysis/data_issue_short_outbreak_spike.md`). ## Test fixes (pre-existing failures) - `R/fill_missing_lps.R`: add missing `dplyr::` prefix to `arrange`, `group_by`, `mutate`, `case_when`, and `ungroup` calls (NAMESPACE only imports magrittr). - `R/clean_psql_data.R`: fix `case_when` type mismatch — `is.logical(primary) ~ primary` produced a RHS when the primary column was character; changed to `~ as.logical(primary)` so all arms return , compatible with dplyr >= 1.1. Test suite: 103 pass, 0 fail. Co-Authored-By: Claude Sonnet 4.6 --- R/clean_psql_data.R | 4 +- R/fill_missing_lps.R | 24 +++++----- R/identify_outbreaks.R | 47 +++++++++++++++---- analysis/02_run_outbreak_detection.R | 3 +- analysis/config_defaults.yml | 2 + man/identify_outbreaks.Rd | 7 ++- tests/testthat/test-identify_outbreaks.R | 59 ++++++++++++++++++++++++ 7 files changed, 120 insertions(+), 26 deletions(-) create mode 100644 tests/testthat/test-identify_outbreaks.R diff --git a/R/clean_psql_data.R b/R/clean_psql_data.R index 919ffcf..946b545 100644 --- a/R/clean_psql_data.R +++ b/R/clean_psql_data.R @@ -50,8 +50,8 @@ clean_psql_data <- function( TL = lubridate::ymd(TL), TR = lubridate::ymd(TR), primary = dplyr::case_when( - is.logical(primary) ~ primary, # API source: already TRUE/FALSE - primary == "f" ~ FALSE, # psql source: "f"/"t" strings + is.logical(primary) ~ as.logical(primary), # API source: already TRUE/FALSE + primary == "f" ~ FALSE, # psql source: "f"/"t" strings primary == "t" ~ TRUE) ) %>% dplyr::filter(primary) %>% ## always only keep primary data diff --git a/R/fill_missing_lps.R b/R/fill_missing_lps.R index b19cca9..1633eaa 100644 --- a/R/fill_missing_lps.R +++ b/R/fill_missing_lps.R @@ -5,9 +5,9 @@ #' @param original_data dataframe with location, epiweek, TL, TR, sCh, cCh, deaths fill_missing_lps <- function(original_data){ - possible_to_fill_locs <- original_data %>% - dplyr::filter(is.na(location_period_id)) %>% - arrange(location, TR) + possible_to_fill_locs <- original_data %>% + dplyr::filter(is.na(location_period_id)) %>% + dplyr::arrange(location, TR) dictionary <- original_data %>% dplyr::select(location, location_period_id, TR) %>% @@ -18,30 +18,30 @@ fill_missing_lps <- function(original_data){ if(nrow(dictionary)>0){ message(paste("Some observations in these locations had missing LPs. They will be filled in with LPs from other observations in the same location:", paste(unique(possible_to_fill_locs$location), collapse = ", "))) - rc <- original_data %>% - arrange(location, TR) %>% - group_by(location) %>% - mutate( + rc <- original_data %>% + dplyr::arrange(location, TR) %>% + dplyr::group_by(location) %>% + dplyr::mutate( # Locate the closest previous and next non-NA location_period_id previous_id = zoo::na.locf(location_period_id, na.rm = FALSE), # Closest previous non-NA value next_id = zoo::na.locf(location_period_id, fromLast = TRUE, na.rm = FALSE), # Closest next non-NA value - + # Apply the logic to fill NA location_period_id based on closest previous and next values location_period_id = ifelse( is.na(location_period_id), - case_when( + dplyr::case_when( # If both previous and next location_period_id are the same, use that value previous_id == next_id ~ previous_id, - + # If previous and next are different, choose the one with the later TR !is.na(next_id) & (is.na(previous_id) | TR[match(next_id, location_period_id)] > TR[match(previous_id, location_period_id)]) ~ next_id, - + TRUE ~ previous_id ), location_period_id ) ) %>% - ungroup() %>% + dplyr::ungroup() %>% dplyr::select(-previous_id, -next_id) # Remove helper columns } else{ message("0 empty location periods were successfully filled in.") diff --git a/R/identify_outbreaks.R b/R/identify_outbreaks.R index b72f0a3..5e27336 100644 --- a/R/identify_outbreaks.R +++ b/R/identify_outbreaks.R @@ -1,5 +1,20 @@ # Function to identify outbreaks +# Internal helper (not exported): zero out outbreak_number for any outbreak whose +# total cases (summed over the full numbered outbreak window) fall below +# min_total_cases. +filter_small_outbreaks <- function(df, min_total_cases) { + small <- df %>% + dplyr::filter(outbreak_number > 0) %>% + dplyr::group_by(outbreak_number) %>% + dplyr::summarise(total = sum(sCh, na.rm = TRUE), .groups = "drop") %>% + dplyr::filter(total < min_total_cases) %>% + dplyr::pull(outbreak_number) + if (length(small) > 0) + df$outbreak_number[df$outbreak_number %in% small] <- 0 + df +} + #' @title identify_outbreaks #' @param threahold_type: character: 1. fixed threshold: a fixed value as outbreak threshold. 2. mean weekly incidence: use the mean weekly incidence as the outbreak threshold. 3. outbreak_dependent threshold: use the mean weekly cholera incidence for the first three weeks as the threshold for that outbreak @@ -8,6 +23,8 @@ #' @param zero_case_assumption: logic: whether to assume weeks without reports have zero case #' @param customized_TL: customize the lower bound of time for outbreak estimation #' @param customized_TR: customize the upper bound of time for outbreak estimation +#' @param cumulative_min_cases: numeric: minimum cumulative cases. Used by the dual_window cumulative trigger and, when \code{filter_outbreaks_by_size = TRUE}, as the minimum total-case threshold for the post-detection size filter. +#' @param filter_outbreaks_by_size: logical: when TRUE, drop detected outbreaks whose total cases (summed over the full outbreak window) fall below \code{cumulative_min_cases}. Default FALSE (no filtering, backward compatible). #' @export #' @return list of dataframes @@ -17,7 +34,7 @@ identify_outbreaks <- function( zero_case_assumption = T, customized_TL = NULL, customized_TR = NULL, - outbreak_start_definition = c("consecutive","dual_window"), + outbreak_start_definition = c("consecutive","dual_window"), min_weeks_above = 2, require_increasing_trend = FALSE, window_weeks = window_weeks, @@ -27,9 +44,10 @@ identify_outbreaks <- function( use_cumulative_trigger=use_cumulative_trigger, cumulative_min_cases=cumulative_min_cases, nonzero_windows = nonzero_windows, - tail_period =6 + tail_period =6, + filter_outbreaks_by_size = FALSE ){ - + # Identify cholera outbreak thresholds original_data_threshold <- OutbreakExtractR::get_outbreak_threshold( threshold_type = threshold_type, @@ -75,8 +93,8 @@ identify_outbreaks <- function( data_between_epidemic_start = preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:epidemic_start_row_idx[idx+1],] if(any(data_between_epidemic_start$epidemic_tail) & nrow(data_between_epidemic_start)>=tail_period+2){ outbreak_end = min(as.numeric(data_between_epidemic_start[data_between_epidemic_start$epidemic_tail,]$row_idx)) - preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number = - min(outbreak_number_idx,preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number[preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number>0]) + preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number = + min(outbreak_number_idx,preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number[preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number>0]) outbreak_number_idx = outbreak_number_idx +1 } else { preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[idx]:epidemic_start_row_idx[idx+1],]$outbreak_number = @@ -98,7 +116,7 @@ identify_outbreaks <- function( } else { last_outbreak_end_idx = nrow(preoutbreak_by_location_start_end_washout) } - end_idx = min(as.numeric(last_outbreak_end_idx) + 2 - 1, + end_idx = min(as.numeric(last_outbreak_end_idx) + tail_period - 1, nrow(preoutbreak_by_location_start_end_washout)) preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:end_idx,]$outbreak_number = last_epidemic_start$outbreak_number } else { @@ -106,18 +124,27 @@ identify_outbreaks <- function( data_between_epidemic_start = preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:nrow(preoutbreak_by_location_start_end_washout),] if(any(data_between_epidemic_start$epidemic_tail)){ outbreak_end = min(as.numeric(data_between_epidemic_start[data_between_epidemic_start$epidemic_tail,]$row_idx)) - preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number = - min(outbreak_number_idx,preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number[preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+2-1),]$outbreak_number>0]) + preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number = + min(outbreak_number_idx,preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number[preoutbreak_by_location_start_end_washout[epidemic_start_row_idx[length(epidemic_start_row_idx)]:as.numeric(as.numeric(outbreak_end)+tail_period-1),]$outbreak_number>0]) outbreak_number_idx = outbreak_number_idx +1 } } - preoutbreak_by_location_start_end_washout <- preoutbreak_by_location_start_end_washout %>% + # Post-detection size filter: drop outbreaks whose total cases (summed over + # the full outbreak window) fall below cumulative_min_cases. Applied before + # the Time Period labelling so dropped outbreaks become "non-outbreak period". + if (isTRUE(filter_outbreaks_by_size) && !is.null(cumulative_min_cases)) { + preoutbreak_by_location_start_end_washout <- + filter_small_outbreaks(preoutbreak_by_location_start_end_washout, + cumulative_min_cases) + } + + preoutbreak_by_location_start_end_washout <- preoutbreak_by_location_start_end_washout %>% mutate(`Time Period` = ifelse( outbreak_number>0, "outbreak period", "non-outbreak period" - )) %>% + )) %>% mutate( `Time Period` = factor(`Time Period`,levels =c("outbreak period",'non-outbreak period')) ) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index dfc7ddf..bd53020 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -245,7 +245,8 @@ outbreak_list <- tryCatch( use_cumulative_trigger = opt$use_cumulative_trigger, cumulative_min_cases = opt$cumulative_min_cases, nonzero_windows = opt$nonzero_windows, - tail_period = opt$tail_period + tail_period = opt$tail_period, + filter_outbreaks_by_size = isTRUE(opt$filter_outbreaks_by_size) ), error = function(e) { warning("identify_outbreaks() failed for ", diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index 2f143af..02079b5 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -64,6 +64,8 @@ cumulative_windows: 3 cumulative_case_threshold_ratio: 1.5 cumulative_min_cases: 50 nonzero_windows: ~ +# When true, drop detected outbreaks whose total cases < cumulative_min_cases +filter_outbreaks_by_size: true # --- Population estimation --- # Directory to cache WorldPop constrained rasters (100m, 2015-2030, per country/year). diff --git a/man/identify_outbreaks.Rd b/man/identify_outbreaks.Rd index a6f1ae5..5e61495 100644 --- a/man/identify_outbreaks.Rd +++ b/man/identify_outbreaks.Rd @@ -20,7 +20,8 @@ identify_outbreaks( use_cumulative_trigger = use_cumulative_trigger, cumulative_min_cases = cumulative_min_cases, nonzero_windows = nonzero_windows, - tail_period = 6 + tail_period = 6, + filter_outbreaks_by_size = FALSE ) } \arguments{ @@ -35,6 +36,10 @@ identify_outbreaks( \item{customized_TL:}{customize the lower bound of time for outbreak estimation} \item{customized_TR:}{customize the upper bound of time for outbreak estimation} + +\item{cumulative_min_cases:}{numeric: minimum cumulative cases. Used by the dual_window cumulative trigger and, when \code{filter_outbreaks_by_size = TRUE}, as the minimum total-case threshold for the post-detection size filter.} + +\item{filter_outbreaks_by_size:}{logical: when TRUE, drop detected outbreaks whose total cases (summed over the full outbreak window) fall below \code{cumulative_min_cases}. Default FALSE (no filtering, backward compatible).} } \value{ list of dataframes diff --git a/tests/testthat/test-identify_outbreaks.R b/tests/testthat/test-identify_outbreaks.R new file mode 100644 index 0000000..a29feae --- /dev/null +++ b/tests/testthat/test-identify_outbreaks.R @@ -0,0 +1,59 @@ +# Tests for the post-detection outbreak size filter (filter_small_outbreaks), +# the internal helper used by identify_outbreaks() when +# filter_outbreaks_by_size = TRUE. + +make_outbreak_df <- function() { + # Two numbered outbreaks plus surrounding non-outbreak (0) weeks. + # outbreak 1: 40 + 50 + 30 = 120 cases (large) + # outbreak 2: 5 + 4 + 3 = 12 cases (small) + data.frame( + location = "TestCountry", + outbreak_number = c(0, 1, 1, 1, 0, 0, 2, 2, 2, 0), + sCh = c(0, 40, 50, 30, 0, 0, 5, 4, 3, 0), + stringsAsFactors = FALSE + ) +} + +test_that("filter_small_outbreaks drops only outbreaks below the threshold", { + df <- make_outbreak_df() + out <- filter_small_outbreaks(df, min_total_cases = 50) + + # Outbreak 1 (120 cases) retained, outbreak 2 (12 cases) zeroed. + expect_equal(out$outbreak_number, c(0, 1, 1, 1, 0, 0, 0, 0, 0, 0)) + # sCh column is untouched. + expect_equal(out$sCh, df$sCh) +}) + +test_that("filter_small_outbreaks keeps all outbreaks when threshold is below both", { + df <- make_outbreak_df() + out <- filter_small_outbreaks(df, min_total_cases = 10) + expect_equal(out$outbreak_number, df$outbreak_number) +}) + +test_that("filter_small_outbreaks drops all outbreaks when threshold exceeds both", { + df <- make_outbreak_df() + out <- filter_small_outbreaks(df, min_total_cases = 1000) + expect_true(all(out$outbreak_number == 0)) +}) + +test_that("filter_small_outbreaks returns all-zero input unchanged", { + df <- data.frame( + location = "TestCountry", + outbreak_number = c(0, 0, 0), + sCh = c(0, 2, 1), + stringsAsFactors = FALSE + ) + out <- filter_small_outbreaks(df, min_total_cases = 50) + expect_equal(out$outbreak_number, df$outbreak_number) +}) + +test_that("filter_small_outbreaks handles NA cases via na.rm", { + df <- data.frame( + location = "TestCountry", + outbreak_number = c(1, 1, 1, 2, 2), + sCh = c(60, NA, 70, 1, NA), # ob1 = 130 (keep), ob2 = 1 (drop) + stringsAsFactors = FALSE + ) + out <- filter_small_outbreaks(df, min_total_cases = 50) + expect_equal(out$outbreak_number, c(1, 1, 1, 0, 0)) +}) From 98fb9c3d59059f4b2dcd4292c37282c69fe963ab Mon Sep 17 00:00:00 2001 From: javier Date: Sat, 20 Jun 2026 13:42:28 +0200 Subject: [PATCH 60/69] fix(detect): match geo files by raw country_iso3 so pop attaches for :: countries The geo-file discovery regex applied gsub("::", "_", country_iso3), but stage1_geo_*.geojson filenames retain the :: separator (e.g. stage1_geo_AFR_TZA::Mainland_...). The substituted pattern never matched, so geo_files was empty, raw_sf was NULL, pop was set to NA, every week classified as low risk, and no outbreaks were detected (TZA returned 0). Use country_iso3 as-is to match the actual filenames. Co-Authored-By: Claude Sonnet 4.6 --- analysis/02_run_outbreak_detection.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index bd53020..90fd2f8 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -109,8 +109,11 @@ message("Loaded ", nrow(clean_all), " cleaned observations across ", # --------------------------------------------------------------------------- geo_ext <- if (isTRUE(opt$use_geoparquet)) "\\.parquet" else "\\.geojson" +# Use opt$country_iso3 directly (with :: as-is) to match actual filenames. +# gsub("::", "_", ...) was a bug: geo files retain :: in their names just like +# stage1 flat files, so the underscore-substituted pattern never matched. geo_pattern <- paste0("^stage1_geo_", opt$who_region, "_", - gsub("::", "_", opt$country_iso3), "_.*", geo_ext, "$") + opt$country_iso3, "_.*", geo_ext, "$") geo_files <- list.files(stage1_dir, pattern = geo_pattern, full.names = TRUE) if (length(geo_files) == 0) { From 92a5e0024d82bdcb3a4450056fb3f5b8a4b465c3 Mon Sep 17 00:00:00 2001 From: javier Date: Mon, 22 Jun 2026 14:06:56 +0200 Subject: [PATCH 61/69] feat(detection_set): add filter_outbreaks_by_size + extend TZA to 2024 - All 68 detection_set configs: add filter_outbreaks_by_size: yes so that outbreaks with < 50 cumulative cases are zeroed post-detection (cumulative_min_cases already set to 50; flag was missing from all but TZA configs, allowing sub-50 outbreaks to propagate into the combined CSV) - detection_set_40 (TZA::Mainland) + detection_set_46 (TZA::Zanzibar): extend time_upper_bound from 2015-12-31 to 2024-12-31 to capture full available API data range (database coverage confirmed through 2019 for both locations) Co-Authored-By: Claude Sonnet 4.6 --- .../configs/detection_set/detection_set_1.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_10.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_11.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_12.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_13.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_14.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_15.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_16.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_17.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_18.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_19.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_2.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_20.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_21.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_22.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_23.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_24.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_25.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_26.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_27.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_28.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_29.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_3.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_30.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_31.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_32.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_33.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_34.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_35.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_36.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_37.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_38.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_39.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_4.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_40.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_41.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_42.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_43.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_44.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_45.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_46.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_47.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_48.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_49.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_5.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_50.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_51.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_52.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_53.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_54.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_55.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_56.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_57.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_58.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_59.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_6.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_60.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_61.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_62.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_63.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_64.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_65.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_66.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_67.yml | 36 +++++++++++++++++++ .../detection_set/detection_set_68.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_7.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_8.yml | 36 +++++++++++++++++++ .../configs/detection_set/detection_set_9.yml | 36 +++++++++++++++++++ 68 files changed, 2448 insertions(+) create mode 100644 analysis/configs/detection_set/detection_set_1.yml create mode 100644 analysis/configs/detection_set/detection_set_10.yml create mode 100644 analysis/configs/detection_set/detection_set_11.yml create mode 100644 analysis/configs/detection_set/detection_set_12.yml create mode 100644 analysis/configs/detection_set/detection_set_13.yml create mode 100644 analysis/configs/detection_set/detection_set_14.yml create mode 100644 analysis/configs/detection_set/detection_set_15.yml create mode 100644 analysis/configs/detection_set/detection_set_16.yml create mode 100644 analysis/configs/detection_set/detection_set_17.yml create mode 100644 analysis/configs/detection_set/detection_set_18.yml create mode 100644 analysis/configs/detection_set/detection_set_19.yml create mode 100644 analysis/configs/detection_set/detection_set_2.yml create mode 100644 analysis/configs/detection_set/detection_set_20.yml create mode 100644 analysis/configs/detection_set/detection_set_21.yml create mode 100644 analysis/configs/detection_set/detection_set_22.yml create mode 100644 analysis/configs/detection_set/detection_set_23.yml create mode 100644 analysis/configs/detection_set/detection_set_24.yml create mode 100644 analysis/configs/detection_set/detection_set_25.yml create mode 100644 analysis/configs/detection_set/detection_set_26.yml create mode 100644 analysis/configs/detection_set/detection_set_27.yml create mode 100644 analysis/configs/detection_set/detection_set_28.yml create mode 100644 analysis/configs/detection_set/detection_set_29.yml create mode 100644 analysis/configs/detection_set/detection_set_3.yml create mode 100644 analysis/configs/detection_set/detection_set_30.yml create mode 100644 analysis/configs/detection_set/detection_set_31.yml create mode 100644 analysis/configs/detection_set/detection_set_32.yml create mode 100644 analysis/configs/detection_set/detection_set_33.yml create mode 100644 analysis/configs/detection_set/detection_set_34.yml create mode 100644 analysis/configs/detection_set/detection_set_35.yml create mode 100644 analysis/configs/detection_set/detection_set_36.yml create mode 100644 analysis/configs/detection_set/detection_set_37.yml create mode 100644 analysis/configs/detection_set/detection_set_38.yml create mode 100644 analysis/configs/detection_set/detection_set_39.yml create mode 100644 analysis/configs/detection_set/detection_set_4.yml create mode 100644 analysis/configs/detection_set/detection_set_40.yml create mode 100644 analysis/configs/detection_set/detection_set_41.yml create mode 100644 analysis/configs/detection_set/detection_set_42.yml create mode 100644 analysis/configs/detection_set/detection_set_43.yml create mode 100644 analysis/configs/detection_set/detection_set_44.yml create mode 100644 analysis/configs/detection_set/detection_set_45.yml create mode 100644 analysis/configs/detection_set/detection_set_46.yml create mode 100644 analysis/configs/detection_set/detection_set_47.yml create mode 100644 analysis/configs/detection_set/detection_set_48.yml create mode 100644 analysis/configs/detection_set/detection_set_49.yml create mode 100644 analysis/configs/detection_set/detection_set_5.yml create mode 100644 analysis/configs/detection_set/detection_set_50.yml create mode 100644 analysis/configs/detection_set/detection_set_51.yml create mode 100644 analysis/configs/detection_set/detection_set_52.yml create mode 100644 analysis/configs/detection_set/detection_set_53.yml create mode 100644 analysis/configs/detection_set/detection_set_54.yml create mode 100644 analysis/configs/detection_set/detection_set_55.yml create mode 100644 analysis/configs/detection_set/detection_set_56.yml create mode 100644 analysis/configs/detection_set/detection_set_57.yml create mode 100644 analysis/configs/detection_set/detection_set_58.yml create mode 100644 analysis/configs/detection_set/detection_set_59.yml create mode 100644 analysis/configs/detection_set/detection_set_6.yml create mode 100644 analysis/configs/detection_set/detection_set_60.yml create mode 100644 analysis/configs/detection_set/detection_set_61.yml create mode 100644 analysis/configs/detection_set/detection_set_62.yml create mode 100644 analysis/configs/detection_set/detection_set_63.yml create mode 100644 analysis/configs/detection_set/detection_set_64.yml create mode 100644 analysis/configs/detection_set/detection_set_65.yml create mode 100644 analysis/configs/detection_set/detection_set_66.yml create mode 100644 analysis/configs/detection_set/detection_set_67.yml create mode 100644 analysis/configs/detection_set/detection_set_68.yml create mode 100644 analysis/configs/detection_set/detection_set_7.yml create mode 100644 analysis/configs/detection_set/detection_set_8.yml create mode 100644 analysis/configs/detection_set/detection_set_9.yml diff --git a/analysis/configs/detection_set/detection_set_1.yml b/analysis/configs/detection_set/detection_set_1.yml new file mode 100644 index 0000000..fecce2e --- /dev/null +++ b/analysis/configs/detection_set/detection_set_1.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: AGO +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_10.yml b/analysis/configs/detection_set/detection_set_10.yml new file mode 100644 index 0000000..3cdb1a7 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_10.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: COG +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_11.yml b/analysis/configs/detection_set/detection_set_11.yml new file mode 100644 index 0000000..7d8584a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_11.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: DJI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_12.yml b/analysis/configs/detection_set/detection_set_12.yml new file mode 100644 index 0000000..6e5db58 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_12.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: ERI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_13.yml b/analysis/configs/detection_set/detection_set_13.yml new file mode 100644 index 0000000..64824ff --- /dev/null +++ b/analysis/configs/detection_set/detection_set_13.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: ETH +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_14.yml b/analysis/configs/detection_set/detection_set_14.yml new file mode 100644 index 0000000..75a9d20 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_14.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GAB +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_15.yml b/analysis/configs/detection_set/detection_set_15.yml new file mode 100644 index 0000000..315bff0 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_15.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GHA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_16.yml b/analysis/configs/detection_set/detection_set_16.yml new file mode 100644 index 0000000..ffbcb7c --- /dev/null +++ b/analysis/configs/detection_set/detection_set_16.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GIN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_17.yml b/analysis/configs/detection_set/detection_set_17.yml new file mode 100644 index 0000000..44637a3 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_17.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GMB +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_18.yml b/analysis/configs/detection_set/detection_set_18.yml new file mode 100644 index 0000000..9534f67 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_18.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GNB +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_19.yml b/analysis/configs/detection_set/detection_set_19.yml new file mode 100644 index 0000000..bedaf39 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_19.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: GNQ +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_2.yml b/analysis/configs/detection_set/detection_set_2.yml new file mode 100644 index 0000000..90a4617 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_2.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: BDI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_20.yml b/analysis/configs/detection_set/detection_set_20.yml new file mode 100644 index 0000000..87de834 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_20.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: KEN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_21.yml b/analysis/configs/detection_set/detection_set_21.yml new file mode 100644 index 0000000..dc38112 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_21.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: LBR +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_22.yml b/analysis/configs/detection_set/detection_set_22.yml new file mode 100644 index 0000000..f8b51a9 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_22.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: LSO +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_23.yml b/analysis/configs/detection_set/detection_set_23.yml new file mode 100644 index 0000000..3f1722a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_23.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: MDG +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_24.yml b/analysis/configs/detection_set/detection_set_24.yml new file mode 100644 index 0000000..bb947a4 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_24.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: MLI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_25.yml b/analysis/configs/detection_set/detection_set_25.yml new file mode 100644 index 0000000..57fbade --- /dev/null +++ b/analysis/configs/detection_set/detection_set_25.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: MOZ +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_26.yml b/analysis/configs/detection_set/detection_set_26.yml new file mode 100644 index 0000000..5e514eb --- /dev/null +++ b/analysis/configs/detection_set/detection_set_26.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: MRT +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_27.yml b/analysis/configs/detection_set/detection_set_27.yml new file mode 100644 index 0000000..e93d008 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_27.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: MWI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_28.yml b/analysis/configs/detection_set/detection_set_28.yml new file mode 100644 index 0000000..8921e30 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_28.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: NAM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_29.yml b/analysis/configs/detection_set/detection_set_29.yml new file mode 100644 index 0000000..609c221 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_29.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: NER +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_3.yml b/analysis/configs/detection_set/detection_set_3.yml new file mode 100644 index 0000000..5ef0cca --- /dev/null +++ b/analysis/configs/detection_set/detection_set_3.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: BEN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_30.yml b/analysis/configs/detection_set/detection_set_30.yml new file mode 100644 index 0000000..ab30ae8 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_30.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: NGA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_31.yml b/analysis/configs/detection_set/detection_set_31.yml new file mode 100644 index 0000000..62a622b --- /dev/null +++ b/analysis/configs/detection_set/detection_set_31.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: RWA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_32.yml b/analysis/configs/detection_set/detection_set_32.yml new file mode 100644 index 0000000..8e6e995 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_32.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: SDN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_33.yml b/analysis/configs/detection_set/detection_set_33.yml new file mode 100644 index 0000000..1fb6917 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_33.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: SEN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_34.yml b/analysis/configs/detection_set/detection_set_34.yml new file mode 100644 index 0000000..c1a128b --- /dev/null +++ b/analysis/configs/detection_set/detection_set_34.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: SLE +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_35.yml b/analysis/configs/detection_set/detection_set_35.yml new file mode 100644 index 0000000..83981d3 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_35.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: SOM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_36.yml b/analysis/configs/detection_set/detection_set_36.yml new file mode 100644 index 0000000..fec21b2 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_36.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: SSD +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_37.yml b/analysis/configs/detection_set/detection_set_37.yml new file mode 100644 index 0000000..83e5ebb --- /dev/null +++ b/analysis/configs/detection_set/detection_set_37.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: SWZ +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_38.yml b/analysis/configs/detection_set/detection_set_38.yml new file mode 100644 index 0000000..e19598a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_38.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: TCD +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_39.yml b/analysis/configs/detection_set/detection_set_39.yml new file mode 100644 index 0000000..cc39fa9 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_39.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: TGO +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_4.yml b/analysis/configs/detection_set/detection_set_4.yml new file mode 100644 index 0000000..69cda22 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_4.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: BFA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_40.yml b/analysis/configs/detection_set/detection_set_40.yml new file mode 100644 index 0000000..ffa1e58 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_40.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: TZA::Mainland +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2024-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_41.yml b/analysis/configs/detection_set/detection_set_41.yml new file mode 100644 index 0000000..017573a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_41.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: UGA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_42.yml b/analysis/configs/detection_set/detection_set_42.yml new file mode 100644 index 0000000..120e5cd --- /dev/null +++ b/analysis/configs/detection_set/detection_set_42.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: YEM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_43.yml b/analysis/configs/detection_set/detection_set_43.yml new file mode 100644 index 0000000..25947ae --- /dev/null +++ b/analysis/configs/detection_set/detection_set_43.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: ZAF +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_44.yml b/analysis/configs/detection_set/detection_set_44.yml new file mode 100644 index 0000000..77dfffb --- /dev/null +++ b/analysis/configs/detection_set/detection_set_44.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: ZMB +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_45.yml b/analysis/configs/detection_set/detection_set_45.yml new file mode 100644 index 0000000..8daf50e --- /dev/null +++ b/analysis/configs/detection_set/detection_set_45.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: ZWE +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_46.yml b/analysis/configs/detection_set/detection_set_46.yml new file mode 100644 index 0000000..f862ad8 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_46.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: TZA::Zanzibar +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2024-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_47.yml b/analysis/configs/detection_set/detection_set_47.yml new file mode 100644 index 0000000..3860437 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_47.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: COM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_48.yml b/analysis/configs/detection_set/detection_set_48.yml new file mode 100644 index 0000000..1858565 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_48.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EUR +country_iso3: MYT +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_49.yml b/analysis/configs/detection_set/detection_set_49.yml new file mode 100644 index 0000000..f9819fa --- /dev/null +++ b/analysis/configs/detection_set/detection_set_49.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AMR +country_iso3: HTI +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_5.yml b/analysis/configs/detection_set/detection_set_5.yml new file mode 100644 index 0000000..287bb85 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_5.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: BWA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_50.yml b/analysis/configs/detection_set/detection_set_50.yml new file mode 100644 index 0000000..da488a5 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_50.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: LBN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_51.yml b/analysis/configs/detection_set/detection_set_51.yml new file mode 100644 index 0000000..c6ee77a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_51.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: SEAR +country_iso3: BGD +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_52.yml b/analysis/configs/detection_set/detection_set_52.yml new file mode 100644 index 0000000..f613c85 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_52.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: AFG +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_53.yml b/analysis/configs/detection_set/detection_set_53.yml new file mode 100644 index 0000000..bd61e99 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_53.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: PAK +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_54.yml b/analysis/configs/detection_set/detection_set_54.yml new file mode 100644 index 0000000..a0bb593 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_54.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: SEAR +country_iso3: IND +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_55.yml b/analysis/configs/detection_set/detection_set_55.yml new file mode 100644 index 0000000..4c026be --- /dev/null +++ b/analysis/configs/detection_set/detection_set_55.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: SEAR +country_iso3: MMR +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_56.yml b/analysis/configs/detection_set/detection_set_56.yml new file mode 100644 index 0000000..85e22d5 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_56.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: SEAR +country_iso3: NPL +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_57.yml b/analysis/configs/detection_set/detection_set_57.yml new file mode 100644 index 0000000..797361c --- /dev/null +++ b/analysis/configs/detection_set/detection_set_57.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: SYR +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_58.yml b/analysis/configs/detection_set/detection_set_58.yml new file mode 100644 index 0000000..6c6b21a --- /dev/null +++ b/analysis/configs/detection_set/detection_set_58.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: IRQ +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_59.yml b/analysis/configs/detection_set/detection_set_59.yml new file mode 100644 index 0000000..7b78286 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_59.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: WPR +country_iso3: PHL +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_6.yml b/analysis/configs/detection_set/detection_set_6.yml new file mode 100644 index 0000000..13a4870 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_6.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: CAF +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_60.yml b/analysis/configs/detection_set/detection_set_60.yml new file mode 100644 index 0000000..94df559 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_60.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AMR +country_iso3: DOM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_61.yml b/analysis/configs/detection_set/detection_set_61.yml new file mode 100644 index 0000000..55bbb6d --- /dev/null +++ b/analysis/configs/detection_set/detection_set_61.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: SEAR +country_iso3: THA +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_62.yml b/analysis/configs/detection_set/detection_set_62.yml new file mode 100644 index 0000000..f0b3a1d --- /dev/null +++ b/analysis/configs/detection_set/detection_set_62.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: WPR +country_iso3: CHN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_63.yml b/analysis/configs/detection_set/detection_set_63.yml new file mode 100644 index 0000000..9f7fa30 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_63.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: WPR +country_iso3: KHM +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_64.yml b/analysis/configs/detection_set/detection_set_64.yml new file mode 100644 index 0000000..929f0b9 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_64.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: WPR +country_iso3: MYS +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_65.yml b/analysis/configs/detection_set/detection_set_65.yml new file mode 100644 index 0000000..8163c8d --- /dev/null +++ b/analysis/configs/detection_set/detection_set_65.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: IRN +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_66.yml b/analysis/configs/detection_set/detection_set_66.yml new file mode 100644 index 0000000..63a9320 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_66.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: WPR +country_iso3: PNG +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_67.yml b/analysis/configs/detection_set/detection_set_67.yml new file mode 100644 index 0000000..c76ea01 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_67.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: SAU +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_68.yml b/analysis/configs/detection_set/detection_set_68.yml new file mode 100644 index 0000000..238e65c --- /dev/null +++ b/analysis/configs/detection_set/detection_set_68.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: EMR +country_iso3: ARE +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_7.yml b/analysis/configs/detection_set/detection_set_7.yml new file mode 100644 index 0000000..d308225 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_7.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: CIV +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_8.yml b/analysis/configs/detection_set/detection_set_8.yml new file mode 100644 index 0000000..5a81955 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_8.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: CMR +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no diff --git a/analysis/configs/detection_set/detection_set_9.yml b/analysis/configs/detection_set/detection_set_9.yml new file mode 100644 index 0000000..4944f78 --- /dev/null +++ b/analysis/configs/detection_set/detection_set_9.yml @@ -0,0 +1,36 @@ +api_website: https://cholera-taxonomy.middle-distance.com +who_region: AFR +country_iso3: COD +spatial_scale_filter: +- country +- admin1 +- admin2 +- admin3 +time_lower_bound: '2010-01-01' +time_upper_bound: '2015-12-31' +temporal_scale_filter: +- daily +- weekly +remove_na_sCh: yes +remove_na_cCh: no +remove_na_locationperiod: no +minimum_daily_cases: 0 +threshold_type: mean weekly incidence rate +fixed_outbreak_threshold: ~ +zero_case_assumption: yes +outbreak_start_definition: consecutive +min_weeks_above: 2 +require_increasing_trend: no +tail_period: 6 +window_weeks: 3 +use_cumulative_trigger: yes +cumulative_trigger_type: cumulative_case_threshold_and_min_cases +cumulative_windows: 3 +cumulative_case_threshold_ratio: 1.5 +cumulative_min_cases: 50 +nonzero_windows: ~ +filter_outbreaks_by_size: yes +raster_dir: analysis/worldpop +set_name: default +output_dir: analysis/generated_data +use_geoparquet: no From 9627e07800c1ef89749a230b49efd0216c5df2a5 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 23 Jun 2026 11:21:35 +0200 Subject: [PATCH 62/69] fix(pull_data): patch taxdat::read_taxonomy_data_api to handle missing shape IDs Some API responses omit shapes from the `included` list for certain location periods. match() returns NA/NULL for the missing shape_id, and the subsequent [[NA]] index crashes with "attempt to select less than one element in get1index" before the existing is.null(unformatted_geojson) guard can fire. Adds an assignInNamespace patch alongside the existing flatten_json_result patch, guarding against NA/NULL this_shape_index and falling back to an empty point geometry. Also qualifies flatten_json_result calls inside the patch body as taxdat:::flatten_json_result so they resolve correctly from the global environment. Co-Authored-By: Claude Opus 4 --- analysis/01_pull_data.R | 138 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) diff --git a/analysis/01_pull_data.R b/analysis/01_pull_data.R index 6b1c999..5fe7c53 100644 --- a/analysis/01_pull_data.R +++ b/analysis/01_pull_data.R @@ -119,6 +119,144 @@ utils::assignInNamespace( ns = "taxdat" ) +# Patch taxdat::read_taxonomy_data_api to guard against shape IDs that are +# absent from the API response's `included` list. match() returns NA/NULL when +# the shape isn't found, and the subsequent [[NA]] index crashes with +# "attempt to select less than one element in get1index" before the existing +# is.null(unformatted_geojson) guard can fire. The fix skips to the empty- +# point fallback whenever this_shape_index is missing, mirroring what the +# original null-check was already trying to do. +utils::assignInNamespace( + "read_taxonomy_data_api", + function(username, api_key, locations = NULL, time_left = NULL, + time_right = NULL, uids = NULL, + website = "https://cholera-taxonomy.middle-distance.com/") { + api_type <- "" + if (is.null(uids)) { + api_type <- "by_location" + if (length(locations == 1)) { + locations <- c(locations, locations) + } + if (any(!grepl("::", locations))) { + stop("Trying to pull data for a continent is not allowed") + } + if ((sum(stringr::str_count(string = unique(locations), pattern = "::") == 1) > 2)) { + stop("Trying to pull data for more than 2 countries at a time is not allowed") + } + https_post_argument_list <- list( + email = username, api_key = api_key, + locations = gsub("::", " ", locations), + time_left = time_left, time_right = time_right + ) + } else if (is.null(locations) && is.null(time_left) && is.null(time_right)) { + api_type <- "by_observation_collections" + https_post_argument_list <- list( + email = username, api_key = api_key, + observation_collection_ids = uids + ) + } else { + stop("Not supported") + } + website <- paste0(website, "/api/v1/observations/", api_type) + json <- jsonlite::toJSON(https_post_argument_list, auto_unbox = T) + message("Fetching results from JSON API") + results <- httr::POST(website, + httr::add_headers(`Content-Type` = "application/json"), + body = json, encode = "form") + code <- httr::status_code(results) + if (code != 200) stop(paste("Error: Status Code", code)) + + original_results_data <- httr::content(results) + jsondata <- rjson::toJSON(original_results_data) + if (!jsonlite::validate(jsondata)) stop("Could not validate json response") + results_data <- jsonlite::fromJSON(jsondata) + + if ((!("observations" %in% names(results_data))) | + (!("data" %in% names(results_data[["observations"]]))) | + (length(results_data[["observations"]]) > 1)) { + stop("Could not parse results properly. Contact package maintainer") + } + results_data[["observations"]] <- taxdat:::flatten_json_result(results_data[["observations"]][["data"]]) + + observation_collections_present <- FALSE + if (("observation_collections" %in% names(results_data)) && + ("data" %in% names(results_data[["observation_collections"]])) && + (length(results_data[["observation_collections"]]) == 1)) { + results_data[["observation_collections"]] <- taxdat:::flatten_json_result( + results_data[["observation_collections"]][["data"]] + ) + observation_collections_present <- TRUE + } + + if (!length(unique(results_data$observations$id)) == nrow(results_data$observations)) { + stop("Could not parse results properly. Contact package maintainer") + } + + tmp_results <- original_results_data[["location_periods"]][["data"]] + all_shape_ids <- sapply(original_results_data$location_periods$included, function(x) x$id) + all_locations <- list() + + if (length(tmp_results) > 0) { + for (idx in 1:length(tmp_results)) { + message(paste(idx, "/", length(tmp_results))) + shape_id <- tmp_results[[idx]][["relationships"]][["shape"]][["data"]][["id"]] + this_shape_index <- match(shape_id, all_shape_ids) + # PATCH: guard — match() returns NA/NULL when shape_id is absent from + # `included`; [[NA]] crashes before the is.null check below can fire. + if (is.null(this_shape_index) || length(this_shape_index) == 0 || is.na(this_shape_index)) { + message(" [read_taxonomy_data_api patch] shape ID not found in included, skipping geometry: ", shape_id) + all_locations[[idx]] <- sf::st_sf(geometry = sf::st_sfc(sf::st_point())) + next + } + unformatted_geojson <- original_results_data[["location_periods"]][["included"]][[this_shape_index]][["attributes"]][["simple_shape"]] + if (is.null(unformatted_geojson)) { + all_locations[[idx]] <- sf::st_sf(geometry = sf::st_sfc(sf::st_point())) + next + } + sf_geojson <- geojsonsf::geojson_sf(unformatted_geojson) + all_locations[[idx]] <- sf_geojson + } + } + + locations_sf <- taxdat::reduce_sf_vector(all_locations) + results_data$location_periods$data$geojson <- NULL + results_data$location_periods$data$attributes$geojson <- NULL + results_data$location_periods <- taxdat:::flatten_json_result(results_data$location_periods$data) + if (nrow(results_data$location_periods) > 0) { + results_data$location_periods$sf_id <- seq_len(nrow(results_data$location_periods)) + } + + results_data$observations$attributes.location_period_id <- as( + results_data$observations$attributes.location_period_id, + class(results_data$location_periods$id) + ) + all_results <- results_data$observations + if (observation_collections_present && + (nrow(all_results) > 0) && + (nrow(results_data$observation_collections) > 0)) { + all_results <- dplyr::left_join( + results_data$observations, results_data$observation_collections, + by = c(relationships.observation_collection.data.id = "id") + ) + } + if ((nrow(all_results) > 0) && (nrow(results_data$location_periods) > 0)) { + all_results <- dplyr::left_join( + all_results, results_data$location_periods, + by = c(attributes.location_period_id = "id") + ) + } + + geoinput <- sf::st_sf(geometry = sf::st_sfc(sf::st_point(1 * c(NA, NA))))$geometry + if (nrow(all_results) == 0) geoinput <- geoinput[0] + all_results$geojson <- geoinput + all_results$geojson[!is.na(all_results$sf_id)] <- + locations_sf$geometry[all_results[!is.na(all_results$sf_id), ][["sf_id"]]] + + return(sf::st_sf(all_results, sf_column_name = "geojson")) + }, + ns = "taxdat" +) + location_str <- make_taxdat_location(opt$who_region, opt$country_iso3) # Pull raw data from API — use cache if available to skip the network call on From 4a3ab3df09114281c412cc9678d7c15c1e669d7b Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 23 Jun 2026 11:41:11 +0200 Subject: [PATCH 63/69] fix(add_population): st_make_valid() before st_union() in geoboundaries fallback When rgeoboundaries::gb_adm0() fails (e.g. TZA::Mainland not a valid name), the fallback unions all LP geometries as the country boundary. GEOS 3.12.0 on Yggdrasil throws a TopologyException on the TZA polygon at this step even though individual LP geometries are already validated. Applying st_make_valid() to the transformed sfc before st_union() prevents the crash. Co-Authored-By: Claude Opus 4 --- R/add_population.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/add_population.R b/R/add_population.R index 28e30a4..eabf9cf 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -114,7 +114,7 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # c.sfc dispatch which tries to compute st_bbox on the crs object. sf::st_crs(all_geoms_sfc) <- if (!is.na(source_crs)) source_crs else 4326 sf::st_sf( - geometry = sf::st_union(sf::st_transform(all_geoms_sfc, 4326)) + geometry = sf::st_union(sf::st_make_valid(sf::st_transform(all_geoms_sfc, 4326))) ) } ) From 08bd97e59c5037f2ebe18d67b2ff073dd5a771f6 Mon Sep 17 00:00:00 2001 From: javier Date: Tue, 23 Jun 2026 11:51:17 +0200 Subject: [PATCH 64/69] feat(detect): restore composite-location outbreak detection (Stage 2) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Composite locations ("|"-joined admin names, NA location_period_id) were silently dropped during outbreak detection because add_population() skips NA LPs → pop = NA → threshold forced to "low" → no epidemic start. Reproduces the handling from GenevaIDD Step2_Extract_outbreak.R: - New R/build_composite_locations.R (exported): de-composites "|"-joined location names into child admin units, maps each child to its atomic location_period_id + WorldPop population (already attached by add_population()), assigns composite_loc__ pseudo-LP ids with summed child population and unioned child geometries from raw_sf. - Fallback when children are not observed atomically (e.g. BDI sanitary districts): use the parent admin location's population and geometry as an approximation (denominator covers the full parent area). - loc_lookup_extended strips ".CountryName" dot-suffixes on country-level location strings so that admin1-level composites (parent = "AFR::BDI") match the "AFR::BDI.Burundi" entry in normalized. - 02_run_outbreak_detection.R: wire build_composite_locations() between add_population and identify_outbreaks; write a composite-geometry sidecar stage1_geo___composite.geojson so the downstream converter picks up composite LP geometries via its existing glob. - Exclude *_composite.geojson sidecars from the raw_sf geo-file load to prevent schema-mismatch rbind errors on re-runs. Verified on BDI: 0 → 4 composite LPs in stage2 output, 50 outbreak rows, 6-feature sidecar with valid WGS84 geometries. AGO (no composites) unchanged (3691 rows, 253 outbreak rows). Countries still needing --redo: ETH, SOM, SDN, CMR, COD, NGA, SSD, TCD, TZA. Co-Authored-By: Claude Sonnet 4.6 --- NAMESPACE | 1 + R/build_composite_locations.R | 331 +++++++++++++++++++++++++++ analysis/02_run_outbreak_detection.R | 59 +++++ man/build_composite_locations.Rd | 31 +++ 4 files changed, 422 insertions(+) create mode 100644 R/build_composite_locations.R create mode 100644 man/build_composite_locations.Rd diff --git a/NAMESPACE b/NAMESPACE index 2ec6d76..092fbcb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(add_pop6_adm_columns) export(add_population) export(add_unique_alert_ids) export(average_duplicate_observations) +export(build_composite_locations) export(calculate_cases) export(calculate_population_density) export(clean_location_names) diff --git a/R/build_composite_locations.R b/R/build_composite_locations.R new file mode 100644 index 0000000..9d4a1ee --- /dev/null +++ b/R/build_composite_locations.R @@ -0,0 +1,331 @@ +# Composite-location handling for Stage 2 outbreak detection. +# +# A "composite location" is an observation whose location name joins several +# admin units with "|" (e.g. "AFR::BDI::Cankuzo::Cankuzo|Cendajuru|Kigamba") +# and which the taxonomy API returns with location_period_id = NA and no +# geometry. Such rows survive Stage 1 but are silently dropped during Stage 2: +# add_population() skips NA location_period_id, so pop = NA, so +# get_outbreak_threshold() forces risk = "low" and identify_outbreaks() never +# flags an epidemic start. +# +# build_composite_locations() reproduces the handling previously done in +# GenevaIDD/global-cholera-surveillance-timeseries Step2_Extract_outbreak.R: +# de-composite the joined name into its child admin units, look up each child's +# location_period_id and population from the atomic rows already present in the +# normalized data, assign the composite a synthetic "composite_loc__" +# id with summed child population, and build the composite geometry as the +# union of its children's geometries. The rewritten rows then flow through +# identify_outbreaks() like any ordinary location. +# +# Fallback (parent-location approximation): +# When composite children are not observed atomically (e.g. BDI sanitary +# districts that only ever appear in aggregate), no matched-child pop or +# geometry is available. In that case the function falls back to the parent +# admin location (the prefix before the first "|" token) for both pop and +# geometry. This is an approximation: the incidence denominator covers the full +# parent area rather than just the composite subunits. Detection thresholds are +# correspondingly lower (incidence underestimated), which may increase +# sensitivity. This is documented for the caller's awareness. + +# Internal: split composite names into one (composite_name, location) row per +# child admin unit. Mirrors Step2_Extract_outbreak.R:105-134 — handles a "|" at +# any admin depth and decodes the "##" deeper-admin separator into "::". +decompose_composite_names <- function(composite_names) { + out <- vector("list", length(composite_names)) + + for (i in seq_along(composite_names)) { + nm <- composite_names[i] + tokens <- strsplit(nm, "::", fixed = TRUE)[[1]] + rows <- list() + + # Reproduce the original per-column loop: every admin token that contains a + # "|" yields a set of children (paths up to and including that token). + for (k in seq_along(tokens)) { + if (!grepl("|", tokens[k], fixed = TRUE)) next + + prefix <- if (k > 1L) paste(tokens[seq_len(k - 1L)], collapse = "::") else "" + pieces <- strsplit(tokens[k], "|", fixed = TRUE)[[1]] + child_locs <- vapply(pieces, function(p) { + full <- if (nzchar(prefix)) paste(prefix, p, sep = "::") else p + gsub("##", "::", full, fixed = TRUE) + }, character(1)) + + rows[[length(rows) + 1L]] <- data.frame( + composite_name = nm, + location = child_locs, + stringsAsFactors = FALSE + ) + } + + if (length(rows) > 0L) out[[i]] <- do.call(rbind, rows) + } + + res <- do.call(rbind, out) + if (is.null(res)) { + return(data.frame(composite_name = character(0L), + location = character(0L), + stringsAsFactors = FALSE)) + } + res +} + +# Internal: return the parent location string (all tokens before the first +# pipe-containing token). Returns NA_character_ when the pipe is in the first +# or second token (country level — no meaningful parent available). +get_composite_parent <- function(composite_name) { + tokens <- strsplit(composite_name, "::", fixed = TRUE)[[1]] + first_pipe <- which(vapply(tokens, function(t) grepl("|", t, fixed = TRUE), + logical(1L)))[1L] + if (is.na(first_pipe) || first_pipe <= 2L) return(NA_character_) + paste(tokens[seq_len(first_pipe - 1L)], collapse = "::") +} + +#' @export +#' @title build_composite_locations +#' @name build_composite_locations +#' @description Resolve composite locations (NA location_period_id, "|"-joined +#' names) into synthetic "composite_loc__" pseudo location periods so +#' that Stage 2 outbreak detection can run on them. Population for each +#' composite is the sum of its children's WorldPop populations (already +#' attached by add_population()); geometry is the union of its children's +#' geometries from raw_sf. When composite children are not individually +#' observed, a parent-location fallback provides pop and geometry. +#' @param normalized data.frame: the normalized weekly data AFTER +#' add_population(), so atomic location_period_ids carry a pop column. +#' @param raw_sf sf: geometry-bearing data from the Stage 1 geo files, keyed by +#' location_period_id. +#' @param iso3 character: ISO3 country code, used to namespace composite ids and +#' to gate the known-LP corrections for SSD/SOM. +#' @return list(data = normalized with composites resolved, +#' geometry = sf(lctn_pr, area_per_1km2, geometry) for composites, +#' or NULL when there are none). +build_composite_locations <- function(normalized, raw_sf, iso3) { + + iso3 <- toupper(regmatches(iso3, regexpr("[A-Z]{3}", iso3))) + + normalized <- normalized %>% + dplyr::mutate(location_period_id = as.character(location_period_id)) + + # 1. Identify composite rows ----------------------------------------------- + is_composite <- is.na(normalized$location_period_id) & + stringr::str_detect(normalized$location, "\\|") + + if (!any(is_composite)) { + return(list(data = apply_known_lp_fixes(normalized, iso3), geometry = NULL)) + } + + composite_names <- unique(normalized$location[is_composite]) + message("build_composite_locations(): ", length(composite_names), + " composite location(s) in ", iso3) + + # 2. De-composite names into child location strings ------------------------ + child_tbl <- decompose_composite_names(composite_names) + + # 3. Map child location -> location_period_id + pop (from atomic rows) ------ + loc_lookup <- normalized %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::distinct(location, location_period_id, pop) + + # Extend loc_lookup with dot-stripped country keys: "AFR::BDI.Burundi" is + # stored in normalized but the parent prefix derived from composite names is + # "AFR::BDI". Adding the stripped variant allows parent lookups to match. + loc_lookup_extended <- dplyr::bind_rows( + loc_lookup, + loc_lookup %>% + dplyr::mutate(location = sub("\\.[^:]+$", "", location)) %>% + dplyr::anti_join(loc_lookup, by = "location") + ) + + cp <- dplyr::left_join(child_tbl, loc_lookup, by = "location") + + n_missing <- sum(is.na(cp$location_period_id)) + if (n_missing > 0L) { + miss <- unique(cp$location[is.na(cp$location_period_id)]) + message(" ", n_missing, " child location(s) had no atomic match: ", + paste(utils::head(miss, 5L), collapse = "; "), + if (length(miss) > 5L) " ..." else "") + } + + # 4. Assign composite ids --------------------------------------------------- + comp_ids <- data.frame( + composite_name = composite_names, + composite_id = paste0("composite_loc_", iso3, "_", seq_along(composite_names)), + stringsAsFactors = FALSE + ) + + # 5. Composite population = sum of distinct matched child-LP populations ---- + comp_pop_raw <- cp %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::distinct(composite_name, location_period_id, pop) %>% + dplyr::group_by(composite_name) %>% + dplyr::summarise(composite_pop = sum(pop, na.rm = TRUE), .groups = "drop") + + # Ensure every composite name is represented (zero when no children matched). + comp_pop <- comp_ids %>% + dplyr::select(composite_name, composite_id) %>% + dplyr::left_join(comp_pop_raw, by = "composite_name") %>% + dplyr::mutate( + composite_pop = dplyr::if_else(is.na(composite_pop), 0, composite_pop) + ) + + # 5b. Parent-location fallback: replace 0-pop composites with their parent's + # pop (all children were unobserved — e.g. BDI sanitary-district composites). + zero_pop_composites <- comp_pop$composite_name[comp_pop$composite_pop == 0] + if (length(zero_pop_composites) > 0L) { + parent_pop_df <- data.frame( + composite_name = zero_pop_composites, + parent_location = vapply(zero_pop_composites, get_composite_parent, + character(1L)), + stringsAsFactors = FALSE + ) %>% + dplyr::filter(!is.na(parent_location)) %>% + dplyr::left_join( + dplyr::select(loc_lookup_extended, + parent_location = location, + parent_pop = pop), + by = "parent_location" + ) + + n_ok <- sum(!is.na(parent_pop_df$parent_pop)) + n_bad <- length(zero_pop_composites) - n_ok + if (n_ok > 0L) + message(" ", n_ok, + " composite(s) using parent-location pop as fallback ", + "(children not observed atomically — denominator approximated).") + if (n_bad > 0L) + message(" ", n_bad, + " composite(s) have no pop (children + parent both absent); ", + "detection thresholds will be NaN.") + + comp_pop <- comp_pop %>% + dplyr::left_join( + dplyr::select(parent_pop_df, composite_name, parent_pop), + by = "composite_name" + ) %>% + dplyr::mutate( + composite_pop = dplyr::if_else( + composite_pop == 0 & !is.na(parent_pop), + parent_pop, + composite_pop + ) + ) %>% + dplyr::select(-parent_pop) + } + + # 6. Composite geometry: union of matched child geometries (sf left table) -- + geom_lookup <- raw_sf %>% + dplyr::mutate(location_period_id = as.character(location_period_id)) %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::group_by(location_period_id) %>% + dplyr::slice(1L) %>% + dplyr::ungroup() %>% + sf::st_make_valid() + + child_lp_map <- cp %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::mutate(location_period_id = as.character(location_period_id)) %>% + dplyr::distinct(composite_name, location_period_id) %>% + dplyr::left_join(comp_ids, by = "composite_name") + + # geom_lookup is sf (left table) → result is sf with geometry + composite_geom <- geom_lookup %>% + dplyr::inner_join(child_lp_map, by = "location_period_id") %>% + dplyr::filter(!sf::st_is_empty(geometry)) %>% + dplyr::group_by(composite_id) %>% + dplyr::summarise(geometry = sf::st_union(geometry), .groups = "drop") %>% + dplyr::mutate( + lctn_pr = composite_id, + area_per_1km2 = as.numeric(sf::st_area(geometry)) / 1e6 + ) %>% + dplyr::select(lctn_pr, area_per_1km2) + + # 6b. Parent-location geometry fallback for composites still without geom --- + composites_with_geom <- composite_geom$lctn_pr # character(0) when 0 rows + needs_parent_geom <- comp_ids$composite_id[ + !comp_ids$composite_id %in% composites_with_geom + ] + + if (length(needs_parent_geom) > 0L) { + names_needing <- comp_ids$composite_name[ + comp_ids$composite_id %in% needs_parent_geom + ] + parent_lp_df <- data.frame( + composite_id = needs_parent_geom, + parent_location = vapply(names_needing, get_composite_parent, + character(1L)), + stringsAsFactors = FALSE + ) %>% + dplyr::filter(!is.na(parent_location)) %>% + dplyr::left_join( + dplyr::select(loc_lookup_extended, + parent_location = location, + location_period_id = location_period_id), + by = "parent_location" + ) %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::mutate(location_period_id = as.character(location_period_id)) %>% + dplyr::distinct(composite_id, location_period_id) + + if (nrow(parent_lp_df) > 0L) { + # geom_lookup is sf (left table) → inner_join keeps sf semantics + parent_geom <- geom_lookup %>% + dplyr::inner_join(parent_lp_df, by = "location_period_id") %>% + dplyr::filter(!sf::st_is_empty(geometry)) %>% + dplyr::mutate( + lctn_pr = composite_id, + area_per_1km2 = as.numeric(sf::st_area(geometry)) / 1e6 + ) %>% + dplyr::select(lctn_pr, area_per_1km2) + + if (nrow(parent_geom) > 0L) { + message(" ", nrow(parent_geom), + " composite(s) using parent geometry as fallback.") + composite_geom <- rbind(composite_geom, parent_geom) + } + } + } + + if (nrow(composite_geom) > 0L) { + sf::st_crs(composite_geom) <- sf::st_crs(raw_sf) + } else { + composite_geom <- NULL + } + + # 7. Rewrite composite rows in the normalized data ------------------------- + data_out <- normalized %>% + dplyr::left_join(comp_ids, by = c("location" = "composite_name")) %>% + dplyr::left_join( + dplyr::select(comp_pop, composite_name, composite_pop), + by = c("location" = "composite_name") + ) %>% + dplyr::mutate( + location_period_id = dplyr::coalesce(composite_id, location_period_id), + pop = dplyr::if_else(!is.na(composite_id), composite_pop, pop), + # 8. Tag spatial_scale for composite rows. + spatial_scale = dplyr::if_else( + !is.na(composite_id), + paste(as.character(spatial_scale), "composite"), + as.character(spatial_scale) + ) + ) %>% + dplyr::select(-composite_id, -composite_pop) + + # 9. Known atomic-LP corrections (SSD/SOM only) ---------------------------- + data_out <- apply_known_lp_fixes(data_out, iso3) + + list(data = data_out, geometry = composite_geom) +} + +# Internal: hardcoded location_period_id corrections carried over from +# Step2_Extract_outbreak.R:199-211. These are atomic-LP fixes (not composite +# logic) and only affect SSD/SOM, so they are a no-op elsewhere. +apply_known_lp_fixes <- function(df, iso3) { + if (!iso3 %in% c("SSD", "SOM")) return(df) + df %>% + dplyr::mutate(location_period_id = dplyr::case_when( + location == "AFR::SSD::Unity::Rubkona" ~ "5624", + location == "AFR::SSD::Upper Nile::Renk" ~ "7859", + location == "EMR::SOM::Hiiraan" ~ "9373", + TRUE ~ location_period_id + )) +} diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index 90fd2f8..a522055 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -115,6 +115,11 @@ geo_ext <- if (isTRUE(opt$use_geoparquet)) "\\.parquet" else "\\.geojson" geo_pattern <- paste0("^stage1_geo_", opt$who_region, "_", opt$country_iso3, "_.*", geo_ext, "$") geo_files <- list.files(stage1_dir, pattern = geo_pattern, full.names = TRUE) +# Exclude composite sidecars written by a prior run of this script — they have +# a different schema (only location_period_id + area_per_1km2 + geometry) and +# must not be rbind-ed with the full Stage 1 geo files. +geo_files <- geo_files[!grepl("_composite\\.geojson$|_composite\\.parquet$", + basename(geo_files))] if (length(geo_files) == 0) { warning("No Stage 1 geo files found for population attachment — pop will be NA.") @@ -228,6 +233,32 @@ if (!is.null(raw_sf)) { message("Skipping add_population() — no geo files found; pop set to NA.") } +# --------------------------------------------------------------------------- +# Resolve composite locations (NA location_period_id, "|"-joined names) into +# composite_loc__* pseudo-LPs with summed child population and unioned +# child geometry, so they survive detection (otherwise NA pop drops them). +# --------------------------------------------------------------------------- + +composite_geom <- NULL +if (!is.null(raw_sf)) { + comp <- tryCatch( + OutbreakExtractR::build_composite_locations( + normalized = normalized, + raw_sf = raw_sf, + iso3 = opt$country_iso3 + ), + error = function(e) { + warning("build_composite_locations() failed for ", + opt$who_region, "::", opt$country_iso3, ": ", conditionMessage(e)) + NULL + } + ) + if (!is.null(comp)) { + normalized <- comp$data + composite_geom <- comp$geometry + } +} + # --------------------------------------------------------------------------- # Outbreak detection over full per-country series (no customized_TL/TR) # Threshold = mean weekly incidence over the entire time series, matching reference @@ -313,6 +344,34 @@ n_outbreak_rows <- sum(outbreaks_df$outbreak_number > 0, na.rm = TRUE) write_tabular(outbreaks_df, out_file, opt$use_geoparquet) +# --------------------------------------------------------------------------- +# Composite geometry sidecar +# +# The converter (00_ingest_outbreakextractr.R) builds outbreak_shapefiles.rds +# by globbing stage1_geo_(AFR|EMR)_*.geojson and computing area itself. Composite +# pseudo-LPs have no geometry in the per-window geo files, so emit a sidecar that +# matches that glob, keyed by location_period_id = composite_loc__*. +# --------------------------------------------------------------------------- + +if (!is.null(composite_geom) && nrow(composite_geom) > 0) { + composite_geo_file <- file.path( + stage1_dir, + paste0("stage1_geo_", opt$who_region, "_", opt$country_iso3, "_composite.geojson") + ) + tryCatch({ + sf::st_write( + composite_geom %>% dplyr::rename(location_period_id = lctn_pr), + composite_geo_file, + delete_dsn = TRUE, + quiet = TRUE + ) + message(" Composite geometries: ", nrow(composite_geom), + " → ", basename(composite_geo_file)) + }, error = function(e) { + warning("Failed to write composite geometry sidecar: ", conditionMessage(e)) + }) +} + message("\nStage 2 complete.") message(" Country: ", opt$who_region, "::", opt$country_iso3) message(" Full time range: ", tl_all, " → ", tr_all) diff --git a/man/build_composite_locations.Rd b/man/build_composite_locations.Rd new file mode 100644 index 0000000..929521c --- /dev/null +++ b/man/build_composite_locations.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/build_composite_locations.R +\name{build_composite_locations} +\alias{build_composite_locations} +\title{build_composite_locations} +\usage{ +build_composite_locations(normalized, raw_sf, iso3) +} +\arguments{ +\item{normalized}{data.frame: the normalized weekly data AFTER +add_population(), so atomic location_period_ids carry a pop column.} + +\item{raw_sf}{sf: geometry-bearing data from the Stage 1 geo files, keyed by +location_period_id (raw API ids — same id space as normalized).} + +\item{iso3}{character: ISO3 country code, used to namespace composite ids and +to gate the known-LP corrections.} +} +\value{ +list(data = normalized with composites resolved, +geometry = sf(lctn_pr, area_per_1km2, geometry) for composites, +or NULL when there are none). +} +\description{ +Resolve composite locations (NA location_period_id, "|"-joined +names) into synthetic "composite_loc_\if{html}{\out{}}_\if{html}{\out{}}" pseudo location periods so +that Stage 2 outbreak detection can run on them. Population for each +composite is the sum of its children's WorldPop populations (already +attached by add_population()); geometry is the union of its children's +geometries. +} From 537d6ba0418eb2e80c64d933344d81059643ff0b Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 9 Jul 2026 16:19:48 +0200 Subject: [PATCH 65/69] fix(shiny): remove stale run_id from group_by in outbreak summary Batch 2 was refactored to stitch all pull windows into one continuous per-country series (commit 5f3151e), dropping the per-window run_id column in favor of a single time_lower_bound/time_upper_bound pair. The Shiny app still grouped by run_id, causing a group_by() error on load since the column no longer exists in current pipeline output. Co-Authored-By: Claude Opus 4.6 --- shiny/app.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shiny/app.R b/shiny/app.R index f49a4d5..4c0a49a 100644 --- a/shiny/app.R +++ b/shiny/app.R @@ -85,7 +85,7 @@ new_ob_admin <- new_raw %>% )) %>% filter(!is.na(scale)) %>% group_by(location, scale, country_iso3, who_region, - run_id, time_lower_bound, time_upper_bound, outbreak_number) %>% + time_lower_bound, time_upper_bound, outbreak_number) %>% summarise( ob_start = min(TL), ob_end = max(TR), From faadb7a9e3bac7245b04ddb75eb4afd40b439a1c Mon Sep 17 00:00:00 2001 From: javier Date: Fri, 24 Jul 2026 15:50:09 +0200 Subject: [PATCH 66/69] feat(composite): geometry-derived population + child resolution for composite locations Composite locations ("|"-joined admin names) are returned by the API with location_period_id = NA and no geometry, so they were silently dropped from Stage 2 (NA pop -> "low" risk -> no outbreak flagged). - clean_psql_data(): retain all-non-primary composites through cleaning instead of dropping them at the primary filter (composite_loc is only flagged later). - build_composite_locations(): add optional raster_dir. When supplied, each composite's population is estimated directly from WorldPop on its (child-union or parent-fallback) geometry via estimate_pop_for_geometries() -- the true sub-area denominator used by the colleague's reference -- with the summed-child / parent-polygon pops kept only as fallbacks. Backward compatible (summed-child pop when raster_dir is NULL). - add_population(): new exported estimate_pop_for_geometries(), reusing the same per-year raster load, UN adjustment factor, vectorized exact_extract, and geometry sanitation. - resolve_composite_children(): new exported directed per-child API pull (wide 2000-2024 window, cached, injectable pull_fn) to recover child LP + geometry when children are not observed atomically. - 02_run_outbreak_detection.R: pass raster_dir into build_composite_locations(). - Tests: geometry-derived pop override + fallback (mocked, offline); non-primary composite retention; offline resolve_composite_children coverage. Co-Authored-By: Claude Opus 4 --- NAMESPACE | 2 + R/add_population.R | 116 +++++++++++ R/build_composite_locations.R | 168 ++++++++++++++-- R/clean_psql_data.R | 9 +- R/resolve_composite_children.R | 187 ++++++++++++++++++ analysis/02_run_outbreak_detection.R | 8 +- man/build_composite_locations.Rd | 26 ++- man/estimate_pop_for_geometries.Rd | 43 ++++ man/resolve_composite_children.Rd | 53 +++++ .../testthat/test-build_composite_locations.R | 163 +++++++++++++++ tests/testthat/test-clean_psql_data.R | 52 +++++ .../test-resolve_composite_children.R | 94 +++++++++ 12 files changed, 893 insertions(+), 28 deletions(-) create mode 100644 R/resolve_composite_children.R create mode 100644 man/estimate_pop_for_geometries.Rd create mode 100644 man/resolve_composite_children.Rd create mode 100644 tests/testthat/test-build_composite_locations.R create mode 100644 tests/testthat/test-resolve_composite_children.R diff --git a/NAMESPACE b/NAMESPACE index 092fbcb..f7de0d8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,7 @@ export(create_alert_groups) export(create_alert_groups2) export(custom_paste) export(define_postprocessed_alerts) +export(estimate_pop_for_geometries) export(extract_agroup_case_outcomes) export(extract_agroup_pers_outcomes) export(extract_alert_outcomes) @@ -49,6 +50,7 @@ export(label_dimensions) export(observation_aggregator) export(observation_filter) export(remove_consecutive_alerts) +export(resolve_composite_children) export(set_uniform_wday_start) export(trigger_alert) export(trigger_alert_caseratio) diff --git a/R/add_population.R b/R/add_population.R index eabf9cf..5231ff3 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -273,3 +273,119 @@ add_population <- function(normalized_data, raw_sf, country_iso3, normalized_data } + +#' @export +#' @title estimate_pop_for_geometries +#' @name estimate_pop_for_geometries +#' @description Estimate a UN-adjusted WorldPop population for each polygon in an +#' sf object by extracting the constrained WorldPop raster directly on the +#' geometry. Intended for composite locations, whose denominator should be the +#' population of the actual (child-union) sub-area rather than the sum of +#' child populations or the parent-admin polygon. Mirrors the WorldPop machinery +#' in \code{add_population()} (one raster load per year, one adjustment-factor +#' \code{exact_extract} on the country boundary, one vectorized +#' \code{exact_extract} for all geometries in that year) and reuses the same +#' geometry sanitation (\code{st_make_valid}, drop empty/non-polygon, cast to +#' MULTIPOLYGON) so mixed-type / POINT / empty geometries do not crash the +#' extraction. +#' @param geom_sf sf: polygons to estimate population for. One value is returned +#' per row, in input order. +#' @param country_iso3 character: ISO3 country code (e.g. "BDI"); a sub-national +#' suffix is tolerated (the leading 3-letter code is extracted). +#' @param year integer: representative year(s), length 1 (recycled) or +#' \code{nrow(geom_sf)}. Clamped to the WorldPop constrained range 2015-2030. +#' @param raster_dir character: directory for caching WorldPop rasters. +#' @return numeric vector of length \code{nrow(geom_sf)} with the UN-adjusted +#' population per geometry (NA where the raster is unavailable or the geometry +#' is unusable). +estimate_pop_for_geometries <- function(geom_sf, country_iso3, year, + raster_dir = "worldpop") { + + n <- nrow(geom_sf) + if (n == 0L) return(numeric(0L)) + + country_iso3 <- toupper(country_iso3) + iso3_for_boundary <- regmatches(country_iso3, regexpr("[A-Z]{3}", country_iso3)) + + # Representative year per geometry, clamped to the WorldPop range. + if (length(year) == 1L) year <- rep(year, n) + if (length(year) != n) { + stop("estimate_pop_for_geometries(): 'year' must have length 1 or nrow(geom_sf).") + } + year <- pmax(2015L, pmin(2030L, as.integer(year))) + + # Work in EPSG:4326 (WorldPop CRS); keep an explicit row index for reassembly. + geoms_sfc <- sf::st_geometry(sf::st_make_valid(geom_sf)) + if (is.na(sf::st_crs(geoms_sfc))) sf::st_crs(geoms_sfc) <- 4326 + geoms_sfc <- sf::st_transform(geoms_sfc, 4326) + + # Country boundary for the UN adjustment factor (fetched once). + country_shp <- tryCatch( + sf::st_transform(rgeoboundaries::gb_adm0(country = iso3_for_boundary), 4326), + error = function(e) { + message("estimate_pop_for_geometries(): gb_adm0() failed: ", + conditionMessage(e), " — using union of input geometries as boundary.") + sf::st_sf(geometry = sf::st_union(geoms_sfc)) + } + ) + + data("WPP2024", package = "OutbreakExtractR", envir = environment()) + + pop_out <- rep(NA_real_, n) + + for (yr in sort(unique(year))) { + idx <- which(year == yr) + + raster_path <- tryCatch( + download_worldpop_constrained(iso3_for_boundary, yr, dest_dir = raster_dir), + error = function(e) { + message(" estimate_pop_for_geometries(): raster download failed for ", + yr, ": ", conditionMessage(e)) + NULL + } + ) + if (is.null(raster_path)) next + + pop_raster <- raster::raster(raster_path) + + # Adjustment factor: one exact_extract on the country boundary. + country_raw <- tryCatch( + sum(exactextractr::exact_extract(pop_raster, sf::st_geometry(country_shp), "sum"), + na.rm = TRUE), + error = function(e) 0 + ) + tot_UN <- WPP2024$PopTotal[ + WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary + ] * 1e3 + adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) tot_UN / country_raw else 1.0 + + # Sanitize this year's geometries (same guards as add_population()). + this_sfc <- geoms_sfc[idx] + dims <- sf::st_dimension(this_sfc) + good <- !is.na(dims) & dims == 2L + if (!any(good)) { + rm(pop_raster); gc(verbose = FALSE); next + } + keep_idx <- idx[good] + this_sfc <- this_sfc[good] + + geom_types <- unique(as.character(sf::st_geometry_type(this_sfc))) + if (length(geom_types) > 1L || identical(geom_types, "POLYGON")) { + this_sfc <- sf::st_cast(this_sfc, "MULTIPOLYGON", warn = FALSE) + } + + raw_pops <- tryCatch( + exactextractr::exact_extract(pop_raster, this_sfc, "sum"), + error = function(e) { + message(" estimate_pop_for_geometries(): extraction failed for year ", + yr, ": ", conditionMessage(e)) + rep(NA_real_, length(this_sfc)) + } + ) + pop_out[keep_idx] <- as.numeric(raw_pops) * adj_factor + + rm(pop_raster); gc(verbose = FALSE) + } + + pop_out +} diff --git a/R/build_composite_locations.R b/R/build_composite_locations.R index 9d4a1ee..70e62dc 100644 --- a/R/build_composite_locations.R +++ b/R/build_composite_locations.R @@ -12,20 +12,33 @@ # GenevaIDD/global-cholera-surveillance-timeseries Step2_Extract_outbreak.R: # de-composite the joined name into its child admin units, look up each child's # location_period_id and population from the atomic rows already present in the -# normalized data, assign the composite a synthetic "composite_loc__" +# normalized data (matching exactly, then on a name normalized to strip the +# " Sanitary District" suffix the taxonomy appends to health-system units), +# assign the composite a synthetic "composite_loc__" # id with summed child population, and build the composite geometry as the # union of its children's geometries. The rewritten rows then flow through # identify_outbreaks() like any ordinary location. # +# Population (geometry-derived, matching the colleague's reference): +# When a raster_dir is supplied, the composite's population is estimated +# directly from the constrained WorldPop raster on its (child-union or +# parent-fallback) geometry via estimate_pop_for_geometries(). This is the true +# sub-area denominator the reference script computed with get_pop() on the +# unioned shapefile, and it gives accurate incidence for composites whose +# children resolve to real geometry. The summed-child pop and parent-polygon pop +# are retained only as fallbacks (for composites whose geometry the raster could +# not resolve). Without a raster_dir the older summed-child / parent pop is used. +# # Fallback (parent-location approximation): # When composite children are not observed atomically (e.g. BDI sanitary -# districts that only ever appear in aggregate), no matched-child pop or -# geometry is available. In that case the function falls back to the parent -# admin location (the prefix before the first "|" token) for both pop and -# geometry. This is an approximation: the incidence denominator covers the full -# parent area rather than just the composite subunits. Detection thresholds are -# correspondingly lower (incidence underestimated), which may increase -# sensitivity. This is documented for the caller's awareness. +# districts that only ever appear in aggregate), no matched-child geometry is +# available. In that case the function falls back to the parent admin location +# (the prefix before the first "|" token) for geometry (and, without a +# raster_dir, for pop). This is an approximation: the incidence denominator then +# covers the full parent area rather than just the composite subunits, so +# detection thresholds are correspondingly lower (incidence underestimated). +# With a raster_dir, WorldPop-on-the-parent-geometry is still used, but it +# remains a parent-area (over-estimated) denominator for these composites. # Internal: split composite names into one (composite_name, location) row per # child admin unit. Mirrors Step2_Extract_outbreak.R:105-134 — handles a "|" at @@ -69,6 +82,46 @@ decompose_composite_names <- function(composite_names) { res } +# Internal: resolve each composite-child location to at most one atomic +# location_period_id + pop. It matches on the exact location string first, then +# falls back to a normalized key that strips a trailing " Sanitary District" +# from the terminal admin token. The taxonomy stores many BDI health-system +# units as " Sanitary District" while composite children carry the bare +# admin name, so the exact join alone leaves most children unmatched even though +# the like-named district LP (and its geometry) is present in the country pull. +# Each child is resolved to a SINGLE LP (deterministic: prefer non-NA pop, then +# lowest location_period_id) so that downstream population sums over distinct +# child LPs never double-count multiple location periods of the same place. +match_children_to_lps <- function(child_tbl, loc_lookup) { + strip_sd <- function(x) sub(" Sanitary District$", "", x) + + atomic <- loc_lookup %>% + dplyr::mutate(.key_norm = strip_sd(location)) %>% + dplyr::arrange(is.na(pop), location_period_id) + + exact <- atomic %>% + dplyr::distinct(location, .keep_all = TRUE) %>% + dplyr::select(location, + lp_exact = location_period_id, + pop_exact = pop) + + norm <- atomic %>% + dplyr::distinct(.key_norm, .keep_all = TRUE) %>% + dplyr::select(.key_norm, + lp_norm = location_period_id, + pop_norm = pop) + + child_tbl %>% + dplyr::mutate(.key_norm = strip_sd(location)) %>% + dplyr::left_join(exact, by = "location") %>% + dplyr::left_join(norm, by = ".key_norm") %>% + dplyr::mutate( + location_period_id = dplyr::coalesce(lp_exact, lp_norm), + pop = dplyr::if_else(!is.na(lp_exact), pop_exact, pop_norm) + ) %>% + dplyr::select(composite_name, location, location_period_id, pop) +} + # Internal: return the parent location string (all tokens before the first # pipe-containing token). Returns NA_character_ when the pipe is in the first # or second token (country level — no meaningful parent available). @@ -85,21 +138,32 @@ get_composite_parent <- function(composite_name) { #' @name build_composite_locations #' @description Resolve composite locations (NA location_period_id, "|"-joined #' names) into synthetic "composite_loc__" pseudo location periods so -#' that Stage 2 outbreak detection can run on them. Population for each -#' composite is the sum of its children's WorldPop populations (already -#' attached by add_population()); geometry is the union of its children's -#' geometries from raw_sf. When composite children are not individually -#' observed, a parent-location fallback provides pop and geometry. +#' that Stage 2 outbreak detection can run on them. Geometry is the union of a +#' composite's children's geometries from raw_sf (parent-location fallback when +#' children are not individually observed). Population: when \code{raster_dir} +#' is supplied, it is estimated directly from WorldPop on that composite +#' geometry (the true sub-area denominator); otherwise it is the sum of the +#' children's WorldPop populations (attached by add_population()), with a +#' parent-location pop fallback. #' @param normalized data.frame: the normalized weekly data AFTER #' add_population(), so atomic location_period_ids carry a pop column. #' @param raw_sf sf: geometry-bearing data from the Stage 1 geo files, keyed by #' location_period_id. #' @param iso3 character: ISO3 country code, used to namespace composite ids and #' to gate the known-LP corrections for SSD/SOM. +#' @param raster_dir character or NULL: when supplied, each composite's +#' population is estimated directly from the constrained WorldPop raster on the +#' composite (child-union or parent-fallback) geometry via +#' \code{estimate_pop_for_geometries()}. This geometry-derived denominator is +#' the true sub-area population and is the primary source; the summed-child and +#' parent-polygon populations (steps 5/5b) are retained only as fallbacks for +#' composites whose geometry the raster extraction could not resolve. When NULL +#' (default), the previous summed-child / parent-polygon behaviour is used. #' @return list(data = normalized with composites resolved, #' geometry = sf(lctn_pr, area_per_1km2, geometry) for composites, #' or NULL when there are none). -build_composite_locations <- function(normalized, raw_sf, iso3) { +build_composite_locations <- function(normalized, raw_sf, iso3, + raster_dir = NULL) { iso3 <- toupper(regmatches(iso3, regexpr("[A-Z]{3}", iso3))) @@ -136,7 +200,7 @@ build_composite_locations <- function(normalized, raw_sf, iso3) { dplyr::anti_join(loc_lookup, by = "location") ) - cp <- dplyr::left_join(child_tbl, loc_lookup, by = "location") + cp <- match_children_to_lps(child_tbl, loc_lookup) n_missing <- sum(is.na(cp$location_period_id)) if (n_missing > 0L) { @@ -235,7 +299,9 @@ build_composite_locations <- function(normalized, raw_sf, iso3) { dplyr::summarise(geometry = sf::st_union(geometry), .groups = "drop") %>% dplyr::mutate( lctn_pr = composite_id, - area_per_1km2 = as.numeric(sf::st_area(geometry)) / 1e6 + area_per_1km2 = as.numeric(sf::st_area( + sf::st_transform(geometry, "+proj=moll") + )) / 1e6 ) %>% dplyr::select(lctn_pr, area_per_1km2) @@ -273,7 +339,9 @@ build_composite_locations <- function(normalized, raw_sf, iso3) { dplyr::filter(!sf::st_is_empty(geometry)) %>% dplyr::mutate( lctn_pr = composite_id, - area_per_1km2 = as.numeric(sf::st_area(geometry)) / 1e6 + area_per_1km2 = as.numeric(sf::st_area( + sf::st_transform(geometry, "+proj=moll") + )) / 1e6 ) %>% dplyr::select(lctn_pr, area_per_1km2) @@ -291,6 +359,72 @@ build_composite_locations <- function(normalized, raw_sf, iso3) { composite_geom <- NULL } + # 6c. Geometry-derived population (primary source when raster_dir given) ---- + # Estimate each composite's population directly from WorldPop on its + # (child-union or parent-fallback) geometry. This is the true sub-area + # denominator; it overrides the summed-child / parent-polygon pop from step 5 + # wherever the raster extraction resolves. Composites whose geometry could not + # be resolved keep the step-5 fallback pop. + if (!is.null(raster_dir) && !is.null(composite_geom) && + nrow(composite_geom) > 0L) { + + # Representative year per composite = median year(TL) over its rows. + comp_year <- normalized %>% + dplyr::filter(location %in% comp_ids$composite_name) %>% + dplyr::left_join(comp_ids, by = c("location" = "composite_name")) %>% + dplyr::group_by(composite_id) %>% + dplyr::summarise( + year = as.integer(stats::median(lubridate::year(TL))), + .groups = "drop" + ) + + geom_years <- data.frame(lctn_pr = composite_geom$lctn_pr, + stringsAsFactors = FALSE) %>% + dplyr::left_join(comp_year, by = c("lctn_pr" = "composite_id")) + geom_years$year[is.na(geom_years$year)] <- + as.integer(stats::median(geom_years$year, na.rm = TRUE)) + + geom_pop_vals <- tryCatch( + estimate_pop_for_geometries( + geom_sf = composite_geom, + country_iso3 = iso3, + year = geom_years$year, + raster_dir = raster_dir + ), + error = function(e) { + message(" build_composite_locations(): geometry-derived pop failed (", + conditionMessage(e), ") — keeping summed-child/parent pop.") + rep(NA_real_, nrow(composite_geom)) + } + ) + + geom_pop_df <- comp_ids %>% + dplyr::left_join( + data.frame(composite_id = composite_geom$lctn_pr, + geom_pop = as.numeric(geom_pop_vals), + stringsAsFactors = FALSE), + by = "composite_id" + ) %>% + dplyr::select(composite_name, geom_pop) + + n_geom_pop <- sum(!is.na(geom_pop_df$geom_pop) & geom_pop_df$geom_pop > 0) + if (n_geom_pop > 0L) + message(" ", n_geom_pop, + " composite(s) using WorldPop-on-geometry as population ", + "(true sub-area denominator).") + + comp_pop <- comp_pop %>% + dplyr::left_join(geom_pop_df, by = "composite_name") %>% + dplyr::mutate( + composite_pop = dplyr::if_else( + !is.na(geom_pop) & geom_pop > 0, + geom_pop, + composite_pop + ) + ) %>% + dplyr::select(-geom_pop) + } + # 7. Rewrite composite rows in the normalized data ------------------------- data_out <- normalized %>% dplyr::left_join(comp_ids, by = c("location" = "composite_name")) %>% diff --git a/R/clean_psql_data.R b/R/clean_psql_data.R index 946b545..d1ef8eb 100644 --- a/R/clean_psql_data.R +++ b/R/clean_psql_data.R @@ -54,7 +54,14 @@ clean_psql_data <- function( primary == "f" ~ FALSE, # psql source: "f"/"t" strings primary == "t" ~ TRUE) ) %>% - dplyr::filter(primary) %>% ## always only keep primary data + ## Keep primary data, but retain composite locations ("|"-joined names) that + ## only ever appear as non-primary; otherwise they are silently dropped here, + ## before Stage 2 (e.g. SEN "AFR::SEN::Saint-Louis::Dagana::Mbane|Ross-Bethio", + ## which is primary = FALSE for every row). A composite that also has a + ## primary version still keeps only its primary rows (no double-counting). + dplyr::group_by(location) %>% + dplyr::filter(primary | (stringr::str_detect(location, "\\|") & !any(primary %in% TRUE))) %>% + dplyr::ungroup() %>% dplyr::mutate( date_range = TR-TL+1, temporal_scale = dplyr::case_when( diff --git a/R/resolve_composite_children.R b/R/resolve_composite_children.R new file mode 100644 index 0000000..66e62eb --- /dev/null +++ b/R/resolve_composite_children.R @@ -0,0 +1,187 @@ +# Directed per-child location-period + geometry retrieval for composite +# locations. +# +# A "composite location" is a surveillance observation whose location name joins +# several admin units with "|" (e.g. "AFR::SEN::Saint-Louis::Dagana::Mbane|Ross-Bethio"). +# The Cholera Taxonomy `by_location` API returns such observations with +# location_period_id = NA and no geometry, so their constituent children carry no +# shape in the country-wide pull. build_composite_locations() therefore cannot +# always reconstruct a composite from atomic rows already present in the country +# pull (the children may never be observed atomically, or only under a different +# vocabulary such as " Sanitary District"). +# +# resolve_composite_children() makes a *directed* per-child API call: for every +# unique child location string it queries the API for that child alone and keeps +# the child's own location_period_id + polygon geometry when the API returns one. +# The resulting child LP/geometry can then be fed to build_composite_locations() +# (via raw_sf / a child-LP lookup) so previously-unresolved composites recover a +# real child-union geometry. +# +# The default time window is deliberately WIDE (2000-01-01 -> 2024-12-31): +# composites and their children frequently sit in early years (e.g. SEN's only +# composite is ~2002-2010), so a narrow detection window would miss them. The API +# requires a date range, so an unbounded pull is not possible. +# +# The pull function is injected (pull_fn) so the function is unit-testable without +# any network access, and each child pull is wrapped in tryCatch() so a single +# failing / empty child never aborts the whole batch. Optionally, a cache_dir +# memoizes each child's raw pull to a window-independent key so repeated runs +# (and overlapping detection windows) do not re-hit the API. + +# Internal: an empty child-LP sf with the canonical schema. +empty_child_lp_sf <- function() { + sf::st_sf( + location = character(0L), + location_period_id = character(0L), + geometry = sf::st_sfc(crs = 4326L) + ) +} + +# Internal: sanitize a location string into a filesystem-safe cache key. +child_cache_key <- function(child_location) { + key <- gsub("[^A-Za-z0-9]+", "_", child_location) + key <- gsub("^_+|_+$", "", key) + paste0("raw_api_cache_child_", key, ".rds") +} + +# Internal: resolve a single child location to its (location, LP, geometry) rows. +# Returns an sf with the canonical schema (possibly 0 rows). Never throws. +resolve_one_child <- function(child_location, time_left, time_right, + api_user, api_key, pull_fn, cache_dir, + location_prefix) { + raw <- NULL + + cache_file <- if (!is.null(cache_dir)) { + file.path(cache_dir, child_cache_key(child_location)) + } else { + NULL + } + + if (!is.null(cache_file) && file.exists(cache_file)) { + raw <- tryCatch(readRDS(cache_file), error = function(e) NULL) + } + + if (is.null(raw)) { + raw <- tryCatch( + pull_fn( + username = api_user, + api_key = api_key, + locations = paste0(location_prefix, child_location), + time_left = time_left, + time_right = time_right + ), + error = function(e) { + message(" resolve_composite_children(): child pull failed for ", + child_location, " -- ", conditionMessage(e)) + NULL + } + ) + if (!is.null(raw) && !is.null(cache_file)) { + tryCatch(saveRDS(raw, cache_file), error = function(e) NULL) + } + } + + if (is.null(raw) || !inherits(raw, "sf") || nrow(raw) == 0L) { + return(empty_child_lp_sf()) + } + + # Locate the LP-id column (API naming) robustly. + lp_col <- intersect( + c("attributes.location_period_id", "location_period_id"), + names(raw) + )[1] + if (is.na(lp_col)) return(empty_child_lp_sf()) + + raw$.lp <- as.character(raw[[lp_col]]) + + # Keep only rows with a real LP and a real (dimension-2) polygon. + dims <- suppressWarnings(sf::st_dimension(sf::st_geometry(raw))) + keep <- !is.na(raw$.lp) & !is.na(dims) & dims == 2L + raw <- raw[keep, , drop = FALSE] + if (nrow(raw) == 0L) return(empty_child_lp_sf()) + + # One row per distinct LP (deterministic: lowest id first). + raw <- raw[order(raw$.lp), , drop = FALSE] + raw <- raw[!duplicated(raw$.lp), , drop = FALSE] + + sf::st_sf( + location = rep(child_location, nrow(raw)), + location_period_id = raw$.lp, + geometry = sf::st_geometry(raw) + ) +} + +#' @export +#' @title resolve_composite_children +#' @name resolve_composite_children +#' @description Make a directed per-child Cholera Taxonomy API call for every +#' constituent child of a set of composite ("|"-joined) location names, and +#' return each child's own location_period_id and polygon geometry. Intended +#' for the Batch 1 pull step: the resulting child LP/geometry lets Stage 2 +#' \code{build_composite_locations()} reconstruct composites whose children are +#' not observed atomically in the country-wide pull. +#' @param composite_names character: composite location names (containing "|"). +#' Names are de-composited with \code{decompose_composite_names()} to obtain the +#' unique child location strings that are queried. +#' @param time_left,time_right Date: the (wide) pull window. Defaults to +#' 2000-01-01 .. 2024-12-31 because composites and their children often sit in +#' early years; the API requires a bounded range. +#' @param api_user,api_key character: API credentials. Default to the +#' \code{CHOLERA_API_USERNAME} / \code{CHOLERA_API_KEY} environment variables. +#' @param pull_fn function: the API pull function, injected for testability. +#' Must accept \code{username, api_key, locations, time_left, time_right} and +#' return an sf. Defaults to \code{taxdat::read_taxonomy_data_api}. +#' @param cache_dir character or NULL: if given, each child's raw pull is +#' memoized to a window-independent key in this directory (deduplicating across +#' overlapping windows and avoiding repeat API calls). +#' @param location_prefix character: prepended to each child location for the +#' API query (default "CT-World::"). +#' @return an sf keyed by location_period_id with columns +#' \code{location} (the queried child string), \code{location_period_id}, and +#' \code{geometry}. Returns a 0-row sf (canonical schema) when nothing resolves. +resolve_composite_children <- function(composite_names, + time_left = as.Date("2000-01-01"), + time_right = as.Date("2024-12-31"), + api_user = Sys.getenv("CHOLERA_API_USERNAME"), + api_key = Sys.getenv("CHOLERA_API_KEY"), + pull_fn = taxdat::read_taxonomy_data_api, + cache_dir = NULL, + location_prefix = "CT-World::") { + + composite_names <- unique(composite_names[!is.na(composite_names) & + grepl("\\|", composite_names)]) + if (length(composite_names) == 0L) return(empty_child_lp_sf()) + + children <- unique(decompose_composite_names(composite_names)$location) + children <- children[!is.na(children) & nzchar(children)] + if (length(children) == 0L) return(empty_child_lp_sf()) + + if (!is.null(cache_dir) && !dir.exists(cache_dir)) { + dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) + } + + resolved <- lapply(children, function(ch) { + tryCatch( + resolve_one_child( + child_location = ch, + time_left = time_left, + time_right = time_right, + api_user = api_user, + api_key = api_key, + pull_fn = pull_fn, + cache_dir = cache_dir, + location_prefix = location_prefix + ), + error = function(e) { + message(" resolve_composite_children(): failed to resolve ", ch, + " -- ", conditionMessage(e)) + empty_child_lp_sf() + } + ) + }) + + resolved <- Filter(function(x) !is.null(x) && nrow(x) > 0L, resolved) + if (length(resolved) == 0L) return(empty_child_lp_sf()) + + do.call(rbind, resolved) +} diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index a522055..f4fc12b 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -235,8 +235,9 @@ if (!is.null(raw_sf)) { # --------------------------------------------------------------------------- # Resolve composite locations (NA location_period_id, "|"-joined names) into -# composite_loc__* pseudo-LPs with summed child population and unioned -# child geometry, so they survive detection (otherwise NA pop drops them). +# composite_loc__* pseudo-LPs with unioned child geometry and a +# WorldPop-on-geometry population (raster_dir passed below), so they survive +# detection (otherwise NA pop drops them). # --------------------------------------------------------------------------- composite_geom <- NULL @@ -245,7 +246,8 @@ if (!is.null(raw_sf)) { OutbreakExtractR::build_composite_locations( normalized = normalized, raw_sf = raw_sf, - iso3 = opt$country_iso3 + iso3 = opt$country_iso3, + raster_dir = here::here(opt$raster_dir) ), error = function(e) { warning("build_composite_locations() failed for ", diff --git a/man/build_composite_locations.Rd b/man/build_composite_locations.Rd index 929521c..1d5a5f3 100644 --- a/man/build_composite_locations.Rd +++ b/man/build_composite_locations.Rd @@ -4,17 +4,26 @@ \alias{build_composite_locations} \title{build_composite_locations} \usage{ -build_composite_locations(normalized, raw_sf, iso3) +build_composite_locations(normalized, raw_sf, iso3, raster_dir = NULL) } \arguments{ \item{normalized}{data.frame: the normalized weekly data AFTER add_population(), so atomic location_period_ids carry a pop column.} \item{raw_sf}{sf: geometry-bearing data from the Stage 1 geo files, keyed by -location_period_id (raw API ids — same id space as normalized).} +location_period_id.} \item{iso3}{character: ISO3 country code, used to namespace composite ids and -to gate the known-LP corrections.} +to gate the known-LP corrections for SSD/SOM.} + +\item{raster_dir}{character or NULL: when supplied, each composite's +population is estimated directly from the constrained WorldPop raster on the +composite (child-union or parent-fallback) geometry via +\code{estimate_pop_for_geometries()}. This geometry-derived denominator is +the true sub-area population and is the primary source; the summed-child and +parent-polygon populations (steps 5/5b) are retained only as fallbacks for +composites whose geometry the raster extraction could not resolve. When NULL +(default), the previous summed-child / parent-polygon behaviour is used.} } \value{ list(data = normalized with composites resolved, @@ -24,8 +33,11 @@ or NULL when there are none). \description{ Resolve composite locations (NA location_period_id, "|"-joined names) into synthetic "composite_loc_\if{html}{\out{}}_\if{html}{\out{}}" pseudo location periods so -that Stage 2 outbreak detection can run on them. Population for each -composite is the sum of its children's WorldPop populations (already -attached by add_population()); geometry is the union of its children's -geometries. +that Stage 2 outbreak detection can run on them. Geometry is the union of a +composite's children's geometries from raw_sf (parent-location fallback when +children are not individually observed). Population: when \code{raster_dir} +is supplied, it is estimated directly from WorldPop on that composite +geometry (the true sub-area denominator); otherwise it is the sum of the +children's WorldPop populations (attached by add_population()), with a +parent-location pop fallback. } diff --git a/man/estimate_pop_for_geometries.Rd b/man/estimate_pop_for_geometries.Rd new file mode 100644 index 0000000..f9882e6 --- /dev/null +++ b/man/estimate_pop_for_geometries.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_population.R +\name{estimate_pop_for_geometries} +\alias{estimate_pop_for_geometries} +\title{estimate_pop_for_geometries} +\usage{ +estimate_pop_for_geometries( + geom_sf, + country_iso3, + year, + raster_dir = "worldpop" +) +} +\arguments{ +\item{geom_sf}{sf: polygons to estimate population for. One value is returned +per row, in input order.} + +\item{country_iso3}{character: ISO3 country code (e.g. "BDI"); a sub-national +suffix is tolerated (the leading 3-letter code is extracted).} + +\item{year}{integer: representative year(s), length 1 (recycled) or +\code{nrow(geom_sf)}. Clamped to the WorldPop constrained range 2015-2030.} + +\item{raster_dir}{character: directory for caching WorldPop rasters.} +} +\value{ +numeric vector of length \code{nrow(geom_sf)} with the UN-adjusted +population per geometry (NA where the raster is unavailable or the geometry +is unusable). +} +\description{ +Estimate a UN-adjusted WorldPop population for each polygon in an +sf object by extracting the constrained WorldPop raster directly on the +geometry. Intended for composite locations, whose denominator should be the +population of the actual (child-union) sub-area rather than the sum of +child populations or the parent-admin polygon. Mirrors the WorldPop machinery +in \code{add_population()} (one raster load per year, one adjustment-factor +\code{exact_extract} on the country boundary, one vectorized +\code{exact_extract} for all geometries in that year) and reuses the same +geometry sanitation (\code{st_make_valid}, drop empty/non-polygon, cast to +MULTIPOLYGON) so mixed-type / POINT / empty geometries do not crash the +extraction. +} diff --git a/man/resolve_composite_children.Rd b/man/resolve_composite_children.Rd new file mode 100644 index 0000000..bb58945 --- /dev/null +++ b/man/resolve_composite_children.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resolve_composite_children.R +\name{resolve_composite_children} +\alias{resolve_composite_children} +\title{resolve_composite_children} +\usage{ +resolve_composite_children( + composite_names, + time_left = as.Date("2000-01-01"), + time_right = as.Date("2024-12-31"), + api_user = Sys.getenv("CHOLERA_API_USERNAME"), + api_key = Sys.getenv("CHOLERA_API_KEY"), + pull_fn = taxdat::read_taxonomy_data_api, + cache_dir = NULL, + location_prefix = "CT-World::" +) +} +\arguments{ +\item{composite_names}{character: composite location names (containing "|"). +Names are de-composited with \code{decompose_composite_names()} to obtain the +unique child location strings that are queried.} + +\item{time_left, time_right}{Date: the (wide) pull window. Defaults to +2000-01-01 .. 2024-12-31 because composites and their children often sit in +early years; the API requires a bounded range.} + +\item{api_user, api_key}{character: API credentials. Default to the +\code{CHOLERA_API_USERNAME} / \code{CHOLERA_API_KEY} environment variables.} + +\item{pull_fn}{function: the API pull function, injected for testability. +Must accept \code{username, api_key, locations, time_left, time_right} and +return an sf. Defaults to \code{taxdat::read_taxonomy_data_api}.} + +\item{cache_dir}{character or NULL: if given, each child's raw pull is +memoized to a window-independent key in this directory (deduplicating across +overlapping windows and avoiding repeat API calls).} + +\item{location_prefix}{character: prepended to each child location for the +API query (default "CT-World::").} +} +\value{ +an sf keyed by location_period_id with columns +\code{location} (the queried child string), \code{location_period_id}, and +\code{geometry}. Returns a 0-row sf (canonical schema) when nothing resolves. +} +\description{ +Make a directed per-child Cholera Taxonomy API call for every +constituent child of a set of composite ("|"-joined) location names, and +return each child's own location_period_id and polygon geometry. Intended +for the Batch 1 pull step: the resulting child LP/geometry lets Stage 2 +\code{build_composite_locations()} reconstruct composites whose children are +not observed atomically in the country-wide pull. +} diff --git a/tests/testthat/test-build_composite_locations.R b/tests/testthat/test-build_composite_locations.R new file mode 100644 index 0000000..93147e8 --- /dev/null +++ b/tests/testthat/test-build_composite_locations.R @@ -0,0 +1,163 @@ +testthat::test_that("match_children_to_lps strips ' Sanitary District' and keeps one LP per child", { + child_tbl <- data.frame( + composite_name = "AFR::BDI::Cankuzo::Cankuzo|Murore", + location = c("AFR::BDI::Cankuzo::Cankuzo", "AFR::BDI::Cankuzo::Murore"), + stringsAsFactors = FALSE + ) + loc_lookup <- data.frame( + location = c("AFR::BDI::Cankuzo::Cankuzo Sanitary District", + "AFR::BDI::Cankuzo::Murore Sanitary District"), + location_period_id = c("15468", "15469"), + pop = c(100, 200), + stringsAsFactors = FALSE + ) + res <- OutbreakExtractR:::match_children_to_lps(child_tbl, loc_lookup) + + testthat::expect_equal(nrow(res), 2L) + testthat::expect_equal( + res$location_period_id[res$location == "AFR::BDI::Cankuzo::Cankuzo"], "15468") + testthat::expect_equal( + res$location_period_id[res$location == "AFR::BDI::Cankuzo::Murore"], "15469") + testthat::expect_equal( + res$pop[res$location == "AFR::BDI::Cankuzo::Cankuzo"], 100) +}) + +testthat::test_that("match_children_to_lps prefers an exact match over the normalized fallback", { + child_tbl <- data.frame(composite_name = "c", location = "AFR::X::Foo", + stringsAsFactors = FALSE) + loc_lookup <- data.frame( + location = c("AFR::X::Foo", "AFR::X::Foo Sanitary District"), + location_period_id = c("1", "2"), + pop = c(9, 9), + stringsAsFactors = FALSE + ) + res <- OutbreakExtractR:::match_children_to_lps(child_tbl, loc_lookup) + testthat::expect_equal(res$location_period_id, "1") +}) + +testthat::test_that("match_children_to_lps resolves one child to a single LP (prefer non-NA pop, lowest id)", { + child_tbl <- data.frame(composite_name = "c", location = "AFR::X::Bar", + stringsAsFactors = FALSE) + loc_lookup <- data.frame( + location = rep("AFR::X::Bar Sanitary District", 3L), + location_period_id = c("30", "20", "25"), + pop = c(NA, 5, 5), + stringsAsFactors = FALSE + ) + res <- OutbreakExtractR:::match_children_to_lps(child_tbl, loc_lookup) + testthat::expect_equal(nrow(res), 1L) + testthat::expect_equal(res$location_period_id, "20") +}) + +testthat::test_that("match_children_to_lps returns NA LP for unmatched children", { + child_tbl <- data.frame(composite_name = "c", location = "AFR::X::Ghost", + stringsAsFactors = FALSE) + loc_lookup <- data.frame(location = "AFR::X::Other", location_period_id = "1", + pop = 1, stringsAsFactors = FALSE) + res <- OutbreakExtractR:::match_children_to_lps(child_tbl, loc_lookup) + testthat::expect_true(is.na(res$location_period_id)) +}) + +testthat::test_that("build_composite_locations recovers child geometry + pop via suffix normalization", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha Sanitary District", + "AFR::ZZZ::Prov::Beta Sanitary District", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(1000, 2000, NA), + spatial_scale = c("admin2", "admin2", "admin2"), + stringsAsFactors = FALSE + ) + + res <- build_composite_locations(normalized, raw_sf, "ZZZ") + + comp_row <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + testthat::expect_equal(nrow(comp_row), 1L) + testthat::expect_equal(comp_row$pop, 3000) # summed child pops, no double count + + testthat::expect_false(is.null(res$geometry)) + testthat::expect_equal(nrow(res$geometry), 1L) # union of the two child squares +}) + +testthat::test_that("build_composite_locations uses WorldPop-on-geometry pop when raster_dir given", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha Sanitary District", + "AFR::ZZZ::Prov::Beta Sanitary District", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(1000, 2000, NA), + spatial_scale = c("admin2", "admin2", "admin2"), + TL = as.Date(c("2018-01-01", "2018-01-01", "2018-01-01")), + stringsAsFactors = FALSE + ) + + # Offline: mock the raster extraction to return a fixed sub-area denominator. + testthat::local_mocked_bindings( + estimate_pop_for_geometries = function(geom_sf, country_iso3, year, + raster_dir = "worldpop") { + rep(5555, nrow(geom_sf)) + } + ) + + res <- build_composite_locations(normalized, raw_sf, "ZZZ", + raster_dir = "ignored") + + comp_row <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + testthat::expect_equal(nrow(comp_row), 1L) + # Geometry-derived pop (5555) overrides the summed-child pop (3000). + testthat::expect_equal(comp_row$pop, 5555) +}) + +testthat::test_that("build_composite_locations keeps summed-child pop when geometry pop is NA/0", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha Sanitary District", + "AFR::ZZZ::Prov::Beta Sanitary District", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(1000, 2000, NA), + spatial_scale = c("admin2", "admin2", "admin2"), + TL = as.Date(c("2018-01-01", "2018-01-01", "2018-01-01")), + stringsAsFactors = FALSE + ) + + testthat::local_mocked_bindings( + estimate_pop_for_geometries = function(geom_sf, country_iso3, year, + raster_dir = "worldpop") { + rep(NA_real_, nrow(geom_sf)) + } + ) + + res <- build_composite_locations(normalized, raw_sf, "ZZZ", + raster_dir = "ignored") + comp_row <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + testthat::expect_equal(comp_row$pop, 3000) # falls back to summed child pop +}) diff --git a/tests/testthat/test-clean_psql_data.R b/tests/testthat/test-clean_psql_data.R index e282ff1..5d50b10 100644 --- a/tests/testthat/test-clean_psql_data.R +++ b/tests/testthat/test-clean_psql_data.R @@ -20,3 +20,55 @@ test_that("clean_psql_data works", { testthat::expect_true(all(unique(clean_outbreak_ts$spatial_scale) %in% c("country", "admin1", "admin2", "admin3", "admin4 or lower"))) testthat::expect_true(all(!is.na(clean_outbreak_ts$spatial_scale))) }) + +# Composite locations ("|"-joined names) that only ever appear as non-primary +# must be retained; non-composite non-primary rows are still dropped. +test_that("clean_psql_data retains non-primary composite locations", { + df <- data.frame( + TL = c("2018-01-01", "2018-01-08", "2018-01-01", "2018-01-01"), + TR = c("2018-01-07", "2018-01-14", "2018-01-07", "2018-01-07"), + sCh = c(5, 3, 10, 7), + cCh = c(NA, NA, NA, NA), + deaths = c(0, 0, 0, 0), + location_period_id = c(NA, NA, 100, 101), + primary = c("f", "f", "f", "t"), + phantom = c(FALSE, FALSE, FALSE, FALSE), + location = c( + "AFR::SEN::Saint-Louis::Dagana::Mbane|Ross-Bethio", # composite, non-primary -> keep + "AFR::SEN::Saint-Louis::Dagana::Mbane|Ross-Bethio", # composite, non-primary -> keep + "AFR::SEN::Saint-Louis::Podor", # atomic, non-primary -> drop + "AFR::SEN::Saint-Louis::Dagana" # atomic, primary -> keep + ), + observation_collection_id = c("a", "b", "c", "d"), + stringsAsFactors = FALSE + ) + cleaned <- clean_psql_data(original_data = df) + testthat::expect_equal(sum(cleaned$composite_loc), 2) + testthat::expect_true(all(grepl("\\|", cleaned$location[cleaned$composite_loc]))) + testthat::expect_false(any(cleaned$location == "AFR::SEN::Saint-Louis::Podor")) + testthat::expect_true(any(cleaned$location == "AFR::SEN::Saint-Louis::Dagana")) +}) + +# A composite that also appears as primary keeps ONLY its primary rows +# (no double-counting of the non-primary duplicate). +test_that("clean_psql_data does not duplicate composites that have a primary version", { + df <- data.frame( + TL = c("2018-01-01", "2018-01-01"), + TR = c("2018-01-07", "2018-01-07"), + sCh = c(5, 5), + cCh = c(NA, NA), + deaths = c(0, 0), + location_period_id = c(NA, 200), + primary = c("f", "t"), + phantom = c(FALSE, FALSE), + location = c( + "AFR::BDI::Cankuzo::Cankuzo|Cendajuru", + "AFR::BDI::Cankuzo::Cankuzo|Cendajuru" + ), + observation_collection_id = c("a", "b"), + stringsAsFactors = FALSE + ) + cleaned <- clean_psql_data(original_data = df) + testthat::expect_equal(nrow(cleaned), 1) + testthat::expect_true(all(cleaned$composite_loc)) +}) diff --git a/tests/testthat/test-resolve_composite_children.R b/tests/testthat/test-resolve_composite_children.R new file mode 100644 index 0000000..12948bf --- /dev/null +++ b/tests/testthat/test-resolve_composite_children.R @@ -0,0 +1,94 @@ +# Unit tests for resolve_composite_children(). All network access is replaced by +# an injected pull_fn, so these run offline and deterministically. + +# Build a fake API sf response for a single child location. `geom` is one of +# "polygon", "point", or "empty"; `lp` is the location_period_id (or NA). +fake_api_row <- function(lp, geom = "polygon", loc_name = "child") { + g <- switch( + geom, + polygon = sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))), + point = sf::st_point(c(0, 0)), + empty = sf::st_point() + ) + sf::st_sf( + attributes.location_name = loc_name, + attributes.location_period_id = lp, + geometry = sf::st_sfc(g, crs = 4326L) + ) +} + +test_that("resolve_composite_children returns child LP + polygon geometry", { + empty_resp <- sf::st_sf(attributes.location_name = character(0), + attributes.location_period_id = character(0), + geometry = sf::st_sfc(crs = 4326L)) + # pull_fn keyed on the requested location string. + pull_fn <- function(username, api_key, locations, time_left, time_right) { + if (grepl("Mbane", locations)) { + return(fake_api_row("111", "polygon", "AFR::SEN::Saint-Louis::Dagana::Mbane")) + } + if (grepl("Ross-Bethio", locations)) { + return(fake_api_row("222", "polygon", "AFR::SEN::Saint-Louis::Dagana::Ross-Bethio")) + } + empty_resp + } + + res <- resolve_composite_children( + composite_names = "AFR::SEN::Saint-Louis::Dagana::Mbane|Ross-Bethio", + pull_fn = pull_fn, api_user = "x", api_key = "y" + ) + testthat::expect_s3_class(res, "sf") + testthat::expect_equal(nrow(res), 2L) + testthat::expect_setequal(res$location_period_id, c("111", "222")) + testthat::expect_true(all(sf::st_dimension(sf::st_geometry(res)) == 2L)) +}) + +test_that("resolve_composite_children drops NA-LP and non-polygon rows", { + pull_fn <- function(username, api_key, locations, time_left, time_right) { + if (grepl("::a$", locations)) return(fake_api_row(NA, "polygon")) # no LP -> drop + if (grepl("::b$", locations)) return(fake_api_row("9", "point")) # point -> drop + sf::st_sf(attributes.location_name = character(0), + attributes.location_period_id = character(0), + geometry = sf::st_sfc(crs = 4326L)) + } + res <- resolve_composite_children("AFR::X::Y::a|b", pull_fn = pull_fn, + api_user = "x", api_key = "y") + testthat::expect_s3_class(res, "sf") + testthat::expect_equal(nrow(res), 0L) +}) + +test_that("resolve_composite_children returns 0-row sf when no composites", { + never_called <- function(...) stop("pull_fn should not be called") + res <- resolve_composite_children(c("AFR::X::atomic", NA_character_), + pull_fn = never_called) + testthat::expect_s3_class(res, "sf") + testthat::expect_equal(nrow(res), 0L) +}) + +test_that("resolve_composite_children survives a failing child pull", { + pull_fn <- function(username, api_key, locations, time_left, time_right) { + if (grepl("::good$", locations)) return(fake_api_row("42", "polygon")) + stop("API 500") + } + res <- resolve_composite_children("AFR::X::Y::good|bad", pull_fn = pull_fn, + api_user = "x", api_key = "y") + testthat::expect_equal(nrow(res), 1L) + testthat::expect_equal(res$location_period_id, "42") +}) + +test_that("resolve_composite_children caches raw pulls per child", { + tmp <- tempfile("childcache"); dir.create(tmp) + calls <- 0L + pull_fn <- function(username, api_key, locations, time_left, time_right) { + calls <<- calls + 1L + fake_api_row("7", "polygon") + } + comp <- "AFR::X::Y::solo|other" + r1 <- resolve_composite_children(comp, pull_fn = pull_fn, cache_dir = tmp, + api_user = "x", api_key = "y") + calls_after_first <- calls + r2 <- resolve_composite_children(comp, pull_fn = pull_fn, cache_dir = tmp, + api_user = "x", api_key = "y") + testthat::expect_equal(calls, calls_after_first) # no new API calls + testthat::expect_equal(nrow(r1), nrow(r2)) + testthat::expect_gt(length(list.files(tmp, pattern = "^raw_api_cache_child_")), 0L) +}) From 53f91c089630e192518d2ab193bd4de5086062f1 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 6 Aug 2026 10:51:53 +0200 Subject: [PATCH 67/69] fix(population): eliminate zero-population denominators, detect duplicate LP geometry, validate corpus-wide get_outbreak_threshold() routes is.na(pop) to the "low" surveillance class but pop == 0 gives sCh/pop == Inf, which classifies as "high" -- a zero denominator silently flips the detection threshold rather than being merely missing. add_population() and build_composite_locations() now emit NA in every path that previously could produce a zero. - new detect_duplicate_geometries() flags location periods sharing an identical polygon and classifies why (alias / parent_inherited / cross_unit); confirmed against live API data as a Taxonomy geometry defect, not a package join defect - new get_country_boundary() + band_adj_factor() replace the undeclared rgeoboundaries dependency and the union-of-LPs adjustment-factor fallback, which understated country_raw and inflated adj_factor whenever the boundary package was missing - composite population precedence reordered (child union > child sum > parent), with the parent-population fallback gated behind allow_parent_pop_fallback = FALSE by default - new provenance columns: pop_source, pop_geom_dup_n, pop_geom_dup_class, pop_year_obs, pop_year_raster, pop_natl_ref, adj_factor, adj_factor_flag - new validate_population() QC gates wired into Stage 2 detection and the corpus-wide aggregation step - 251 new/updated test assertions across 4 new and 1 extended test file Co-Authored-By: Claude Opus 4.6 --- DESCRIPTION | 7 +- NAMESPACE | 4 + R/add_population.R | 272 +++++++++++++----- R/build_composite_locations.R | 226 ++++++++++----- R/detect_duplicate_geometries.R | 114 ++++++++ R/get_country_boundary.R | 120 ++++++++ R/identify_outbreaks.R | 14 +- R/validate_population.R | 172 +++++++++++ analysis/02_run_outbreak_detection.R | 31 ++ analysis/03_aggregate_results.R | 37 +++ ...ata_issue_composite_geometry_2026-07-17.md | 114 ++++++++ man/add_population.Rd | 27 +- man/attach_empty_pop_provenance.Rd | 20 ++ man/band_adj_factor.Rd | 25 ++ man/build_composite_locations.Rd | 49 +++- man/detect_duplicate_geometries.Rd | 55 ++++ man/estimate_pop_for_geometries.Rd | 11 +- man/get_country_boundary.Rd | 38 +++ man/identify_outbreaks.Rd | 5 +- man/validate_population.Rd | 48 ++++ tests/testthat/test-add_population.R | 213 ++++++++++++++ .../testthat/test-build_composite_locations.R | 180 ++++++++++++ .../test-detect_duplicate_geometries.R | 99 +++++++ tests/testthat/test-get_country_boundary.R | 97 +++++++ tests/testthat/test-validate_population.R | 146 ++++++++++ 25 files changed, 1965 insertions(+), 159 deletions(-) create mode 100644 R/detect_duplicate_geometries.R create mode 100644 R/get_country_boundary.R create mode 100644 R/validate_population.R create mode 100644 analysis/data_issue_composite_geometry_2026-07-17.md create mode 100644 man/attach_empty_pop_provenance.Rd create mode 100644 man/band_adj_factor.Rd create mode 100644 man/detect_duplicate_geometries.Rd create mode 100644 man/get_country_boundary.Rd create mode 100644 man/validate_population.Rd create mode 100644 tests/testthat/test-add_population.R create mode 100644 tests/testthat/test-detect_duplicate_geometries.R create mode 100644 tests/testthat/test-get_country_boundary.R create mode 100644 tests/testthat/test-validate_population.R diff --git a/DESCRIPTION b/DESCRIPTION index cbc04b3..ba05f20 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,9 +35,12 @@ Suggests: furrr, future, here, - taxdat + taxdat, + rgeoboundaries, + digest, + withr Config/testthat/edition: 3 Depends: R (>= 2.10) LazyData: true -Config/roxygen2/version: 8.0.0 +Config/roxygen2/version: 8.1.0 diff --git a/NAMESPACE b/NAMESPACE index f7de0d8..bd2c1f4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(add_pop6_adm_columns) export(add_population) export(add_unique_alert_ids) export(average_duplicate_observations) +export(band_adj_factor) export(build_composite_locations) export(calculate_cases) export(calculate_population_density) @@ -21,6 +22,7 @@ export(create_alert_groups) export(create_alert_groups2) export(custom_paste) export(define_postprocessed_alerts) +export(detect_duplicate_geometries) export(estimate_pop_for_geometries) export(extract_agroup_case_outcomes) export(extract_agroup_pers_outcomes) @@ -30,6 +32,7 @@ export(fill_missing_lps) export(fill_phantom_zeroes) export(filter_ms_data) export(format_alerts) +export(get_country_boundary) export(get_epiweek) export(get_ghs_pop) export(get_outbreak_threshold) @@ -57,6 +60,7 @@ export(trigger_alert_caseratio) export(trigger_alert_cases) export(trigger_alert_rate) export(trigger_alert_trends) +export(validate_population) export(verify_outbreak_definitions) import(magrittr) importFrom(magrittr,"%>%") diff --git a/R/add_population.R b/R/add_population.R index 5231ff3..fd6bc5e 100644 --- a/R/add_population.R +++ b/R/add_population.R @@ -36,11 +36,26 @@ #' for the UN population adjustment factor. #' @param raster_dir character: directory for caching WorldPop raster files. #' Defaults to "worldpop". Created if it does not exist. +#' @param boundary_cache_dir character or NULL: directory for caching national +#' boundaries used by the UN adjustment. Passed to +#' \code{get_country_boundary()}. #' -#' @return normalized_data with a numeric pop column added. Rows whose -#' location_period_id has no matching geometry in raw_sf receive NA. +#' @return normalized_data with a numeric \code{pop} column added, plus +#' provenance columns: \code{pop_source}, \code{pop_geom_dup_n}, +#' \code{pop_geom_dup_class}, \code{pop_year_obs}, \code{pop_year_raster}, +#' \code{pop_natl_ref}, \code{adj_factor} and \code{adj_factor_flag}. +#' Rows whose location_period_id has no matching geometry in raw_sf receive +#' \code{pop = NA} (never 0 — see the note on zero denominators below). +#' +#' \code{pop} is \code{NA}, never 0, whenever a population cannot be +#' established. \code{get_outbreak_threshold()} routes \code{is.na(pop)} to +#' the "low" surveillance class, but \code{pop == 0} yields +#' \code{sCh / pop == Inf}, which classifies as "high" — so a zero denominator +#' silently flips the outbreak-detection threshold rather than merely +#' producing a bad rate. add_population <- function(normalized_data, raw_sf, country_iso3, - raster_dir = "worldpop") { + raster_dir = "worldpop", + boundary_cache_dir = "country_boundaries") { country_iso3 <- toupper(country_iso3) @@ -77,47 +92,44 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # --------------------------------------------------------------------------- # 2. Representative year per LP (clamped to WorldPop range 2015-2030) # --------------------------------------------------------------------------- + # pop_year_obs keeps the *unclamped* median observation year; pop_year_raster + # is the year actually rastered. Downstream can rescale a static population to + # an arbitrary year with pop * WPP(iso3, t) / pop_natl_ref, which needs both. lp_years <- normalized_data %>% dplyr::filter(!is.na(location_period_id)) %>% dplyr::group_by(location_period_id) %>% dplyr::summarise( - year = pmax(2015L, pmin(2030L, - as.integer(stats::median(lubridate::year(TL))))), + pop_year_obs = as.integer(stats::median(lubridate::year(TL))), .groups = "drop" - ) + ) %>% + dplyr::mutate(year = pmax(2015L, pmin(2030L, pop_year_obs))) # All location_period_ids are NA (absent from API response or filtered out). # purrr::list_rbind() on an empty map returns a 0-column tibble, which breaks # the left_join below. Return early with pop = NA for all rows. if (nrow(lp_years) == 0) { message("add_population(): no valid location_period_ids — pop set to NA for all rows.") - normalized_data$pop <- NA_real_ - return(normalized_data) + return(attach_empty_pop_provenance(normalized_data)) } # --------------------------------------------------------------------------- # 3. Country boundary for the UN adjustment factor (fetched once) # --------------------------------------------------------------------------- - # Primary: rgeoboundaries network call. - # Fallback: union of all LP geometries (approximation, avoids network dep). - # Strip any sub-national suffix (e.g. "TZA::Mainland" -> "TZA") so that - # gb_adm0() receives a plain ISO3 code it can resolve. + # Resolved by get_country_boundary(): disk cache -> gb_adm0() -> NULL. + # + # There is deliberately NO union-of-LP-geometries fallback. That union covers + # only the surveilled sub-areas, so extracting the raster on it understates + # country_raw and inflates adj_factor = tot_UN / country_raw, scaling every + # population in the country upward. When the boundary cannot be resolved we + # skip the adjustment (adj_factor = 1.0), leaving populations unadjusted + # rather than wrong. iso3_for_boundary <- regmatches(country_iso3, regexpr("[A-Z]{3}", country_iso3)) - country_shp <- tryCatch( - sf::st_transform(rgeoboundaries::gb_adm0(country = iso3_for_boundary), 4326), - error = function(e) { - message("rgeoboundaries::gb_adm0() failed: ", conditionMessage(e), - "\nFalling back to union of LP geometries as country boundary.") - all_geoms <- Filter(Negate(is.null), as.list(geom_lookup)) - all_geoms_sfc <- do.call(sf::st_sfc, all_geoms) - # Set CRS separately — passing crs inside the do.call list triggers - # c.sfc dispatch which tries to compute st_bbox on the crs object. - sf::st_crs(all_geoms_sfc) <- if (!is.na(source_crs)) source_crs else 4326 - sf::st_sf( - geometry = sf::st_union(sf::st_make_valid(sf::st_transform(all_geoms_sfc, 4326))) - ) - } - ) + country_shp <- get_country_boundary(iso3_for_boundary, + cache_dir = boundary_cache_dir) + if (is.null(country_shp)) { + message("add_population(): no national boundary for ", iso3_for_boundary, + " — UN adjustment skipped (adj_factor = 1.0).") + } # --------------------------------------------------------------------------- # 4. WPP2024 national totals (loaded once, used for adj factor in every year) @@ -153,9 +165,17 @@ add_population <- function(normalized_data, raw_sf, country_iso3, } ) + tot_UN <- WPP2024$PopTotal[ + WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary + ] * 1e3 + pop_natl_ref <- if (length(tot_UN) == 1L) tot_UN else NA_real_ + if (is.null(raster_path)) { message(" Skipping year ", yr, " — all LPs set to NA.") - return(dplyr::tibble(location_period_id = lp_ids, pop = NA_real_)) + return(dplyr::tibble(location_period_id = lp_ids, pop = NA_real_, + pop_source = "none", adj_factor = NA_real_, + adj_factor_flag = NA_character_, + pop_natl_ref = pop_natl_ref)) } # Load raster ONCE for this year @@ -164,34 +184,33 @@ add_population <- function(normalized_data, raw_sf, country_iso3, # -- b. Adj factor: one exact_extract call on the country boundary ------ # Inlined from estimate_adj_factors() to reuse the already-loaded # raster instead of having that function load it a second time. - # Wrapped in tryCatch: the fallback country boundary (LP-geometry union, - # used when rgeoboundaries is unavailable) can produce a geometry that - # exactextractr cannot resolve ("Error getting geometry extent") — in - # that case we fall through to adj_factor = 1.0. - country_raw <- tryCatch( - sum( - exactextractr::exact_extract( - pop_raster, sf::st_geometry(country_shp), "sum" + country_raw <- if (is.null(country_shp)) { + 0 + } else { + tryCatch( + sum( + exactextractr::exact_extract( + pop_raster, sf::st_geometry(country_shp), "sum" + ), + na.rm = TRUE ), - na.rm = TRUE - ), - error = function(e) { - message(" adj factor extraction failed: ", conditionMessage(e), - " — using 1.0 (population will be unadjusted).") - 0 - } - ) - tot_UN <- WPP2024$PopTotal[ - WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary - ] * 1e3 + error = function(e) { + message(" adj factor extraction failed: ", conditionMessage(e), + " — using 1.0 (population will be unadjusted).") + 0 + } + ) + } - adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) { - tot_UN / country_raw + adj_banded <- if (length(tot_UN) == 1L && country_raw > 0) { + band_adj_factor(tot_UN / country_raw) } else { message(" Could not compute adj factor for year ", yr, " — using 1.0 (population will be unadjusted).") - 1.0 + list(value = 1.0, flag = "unadjusted") } + adj_factor <- adj_banded$value + adj_factor_flag <- adj_banded$flag # -- c. Identify which LPs have geometry in this batch ------------------ geoms <- lapply(as.character(lp_ids), \(id) geom_lookup[[id]]) @@ -203,6 +222,7 @@ add_population <- function(normalized_data, raw_sf, country_iso3, } pop_values <- rep(NA_real_, length(lp_ids)) + pop_source <- rep("none", length(lp_ids)) valid_idx <- which(!missing) if (length(valid_idx) > 0L) { @@ -245,7 +265,25 @@ add_population <- function(normalized_data, raw_sf, country_iso3, raw_pops <- exactextractr::exact_extract( pop_raster, valid_sfc, "sum" ) - pop_values[valid_idx] <- as.numeric(raw_pops) * adj_factor + extracted <- as.numeric(raw_pops) * adj_factor + + # A raster sum of exactly 0 is not a population — it means the + # constrained raster has no built-up cells under this footprint. Emit + # NA so that get_outbreak_threshold() routes the LP to the "low" + # surveillance class instead of computing sCh/0 == Inf and + # classifying it as "high". + zero_pop <- !is.na(extracted) & extracted <= 0 + if (any(zero_pop)) { + message(" WorldPop returned 0 for LP(s): ", + paste(lp_ids[valid_idx[zero_pop]], collapse = ", "), + " — pop = NA (a zero denominator would flip the ", + "detection threshold).") + extracted[zero_pop] <- NA_real_ + } + + pop_values[valid_idx] <- extracted + pop_source[valid_idx] <- ifelse(is.na(extracted), "none", + "worldpop_constrained") } } @@ -253,17 +291,71 @@ add_population <- function(normalized_data, raw_sf, country_iso3, rm(pop_raster) gc(verbose = FALSE) - dplyr::tibble(location_period_id = lp_ids, pop = pop_values, adj_factor) + dplyr::tibble(location_period_id = lp_ids, pop = pop_values, + pop_source = pop_source, adj_factor = adj_factor, + adj_factor_flag = adj_factor_flag, + pop_natl_ref = pop_natl_ref) }) %>% purrr::list_rbind() # --------------------------------------------------------------------------- - # 6. Join pop back onto the normalized data + # 6. Duplicate-geometry detection + # + # Several LPs can carry byte-identical geometry, in which case they are all + # assigned the same population. This originates in the Taxonomy source + # (distinct location_period_ids, distinct shape ids, identical shape + # content), not in the join here, so the response is to mark rather than + # to recompute. See detect_duplicate_geometries() for the class meanings. # --------------------------------------------------------------------------- - if ("pop" %in% names(normalized_data)) { - normalized_data <- dplyr::select(normalized_data, -pop) + lp_locations <- NULL + if ("location" %in% names(normalized_data)) { + loc_map <- normalized_data %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::group_by(location_period_id) %>% + dplyr::summarise(location = dplyr::first(location), .groups = "drop") + lp_locations <- loc_map$location[match(lp_geoms$lp_id, + loc_map$location_period_id)] + } + + dup_info <- detect_duplicate_geometries( + lp_ids = lp_geoms$lp_id, + geoms = sf::st_geometry(lp_geoms), + lp_locations = lp_locations + ) + + n_dup <- sum(dup_info$pop_geom_dup_n > 1L) + if (n_dup > 0L) { + cls <- table(dup_info$pop_geom_dup_class[dup_info$pop_geom_dup_n > 1L]) + message("add_population(): ", n_dup, " LP(s) share geometry with another LP (", + paste(names(cls), cls, sep = "=", collapse = ", "), ").") } + # --------------------------------------------------------------------------- + # 7. Join pop and provenance back onto the normalized data + # --------------------------------------------------------------------------- + prov_cols <- c("pop", "pop_source", "pop_geom_dup_n", "pop_geom_dup_class", + "pop_year_obs", "pop_year_raster", "pop_natl_ref", + "adj_factor", "adj_factor_flag") + normalized_data <- dplyr::select(normalized_data, -dplyr::any_of(prov_cols)) + + lp_pop <- lp_pop %>% + dplyr::left_join( + lp_years %>% + dplyr::select(location_period_id, pop_year_obs, + pop_year_raster = year), + by = "location_period_id" + ) %>% + dplyr::left_join( + dup_info %>% + dplyr::mutate(location_period_id = as(location_period_id, + class(lp_pop$location_period_id))), + by = "location_period_id" + ) %>% + dplyr::mutate( + pop_geom_dup_n = dplyr::coalesce(pop_geom_dup_n, 1L), + pop_geom_dup_class = dplyr::coalesce(pop_geom_dup_class, "unique") + ) + normalized_data <- dplyr::left_join(normalized_data, lp_pop, by = "location_period_id") @@ -274,6 +366,27 @@ add_population <- function(normalized_data, raw_sf, country_iso3, normalized_data } +#' @title attach_empty_pop_provenance +#' @name attach_empty_pop_provenance +#' @description Attach the population provenance schema with empty values, so +#' that early-return paths in \code{add_population()} produce the same columns +#' as the full path. Consumers can then rely on the schema unconditionally. +#' @param d data.frame to attach columns to. +#' @return \code{d} with the provenance columns added. +#' @keywords internal +attach_empty_pop_provenance <- function(d) { + d$pop <- NA_real_ + d$pop_source <- "none" + d$pop_geom_dup_n <- 1L + d$pop_geom_dup_class <- "unique" + d$pop_year_obs <- NA_integer_ + d$pop_year_raster <- NA_integer_ + d$pop_natl_ref <- NA_real_ + d$adj_factor <- NA_real_ + d$adj_factor_flag <- NA_character_ + d +} + #' @export #' @title estimate_pop_for_geometries #' @name estimate_pop_for_geometries @@ -295,11 +408,15 @@ add_population <- function(normalized_data, raw_sf, country_iso3, #' @param year integer: representative year(s), length 1 (recycled) or #' \code{nrow(geom_sf)}. Clamped to the WorldPop constrained range 2015-2030. #' @param raster_dir character: directory for caching WorldPop rasters. +#' @param boundary_cache_dir character or NULL: directory for caching national +#' boundaries, passed to \code{get_country_boundary()}. #' @return numeric vector of length \code{nrow(geom_sf)} with the UN-adjusted -#' population per geometry (NA where the raster is unavailable or the geometry -#' is unusable). +#' population per geometry (NA where the raster is unavailable, the geometry +#' is unusable, or the raster sum is zero — zero is never returned as a +#' population). estimate_pop_for_geometries <- function(geom_sf, country_iso3, year, - raster_dir = "worldpop") { + raster_dir = "worldpop", + boundary_cache_dir = "country_boundaries") { n <- nrow(geom_sf) if (n == 0L) return(numeric(0L)) @@ -320,14 +437,11 @@ estimate_pop_for_geometries <- function(geom_sf, country_iso3, year, geoms_sfc <- sf::st_transform(geoms_sfc, 4326) # Country boundary for the UN adjustment factor (fetched once). - country_shp <- tryCatch( - sf::st_transform(rgeoboundaries::gb_adm0(country = iso3_for_boundary), 4326), - error = function(e) { - message("estimate_pop_for_geometries(): gb_adm0() failed: ", - conditionMessage(e), " — using union of input geometries as boundary.") - sf::st_sf(geometry = sf::st_union(geoms_sfc)) - } - ) + # As in add_population(): no union-of-input-geometries fallback — that + # understates the national raster total and inflates the adjustment factor. + # NULL means "skip the adjustment", not "approximate it". + country_shp <- get_country_boundary(iso3_for_boundary, + cache_dir = boundary_cache_dir) data("WPP2024", package = "OutbreakExtractR", envir = environment()) @@ -349,15 +463,23 @@ estimate_pop_for_geometries <- function(geom_sf, country_iso3, year, pop_raster <- raster::raster(raster_path) # Adjustment factor: one exact_extract on the country boundary. - country_raw <- tryCatch( - sum(exactextractr::exact_extract(pop_raster, sf::st_geometry(country_shp), "sum"), - na.rm = TRUE), - error = function(e) 0 - ) + country_raw <- if (is.null(country_shp)) { + 0 + } else { + tryCatch( + sum(exactextractr::exact_extract(pop_raster, sf::st_geometry(country_shp), "sum"), + na.rm = TRUE), + error = function(e) 0 + ) + } tot_UN <- WPP2024$PopTotal[ WPP2024$Time == yr & WPP2024$ISO3_code == iso3_for_boundary ] * 1e3 - adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) tot_UN / country_raw else 1.0 + adj_factor <- if (length(tot_UN) == 1L && country_raw > 0) { + band_adj_factor(tot_UN / country_raw)$value + } else { + 1.0 + } # Sanitize this year's geometries (same guards as add_population()). this_sfc <- geoms_sfc[idx] @@ -382,7 +504,11 @@ estimate_pop_for_geometries <- function(geom_sf, country_iso3, year, rep(NA_real_, length(this_sfc)) } ) - pop_out[keep_idx] <- as.numeric(raw_pops) * adj_factor + extracted <- as.numeric(raw_pops) * adj_factor + # Zero is not a population — see add_population(). NA keeps the LP in the + # "low" surveillance class instead of producing sCh/0 == Inf. + extracted[!is.na(extracted) & extracted <= 0] <- NA_real_ + pop_out[keep_idx] <- extracted rm(pop_raster); gc(verbose = FALSE) } diff --git a/R/build_composite_locations.R b/R/build_composite_locations.R index 70e62dc..f6d145a 100644 --- a/R/build_composite_locations.R +++ b/R/build_composite_locations.R @@ -153,17 +153,45 @@ get_composite_parent <- function(composite_name) { #' to gate the known-LP corrections for SSD/SOM. #' @param raster_dir character or NULL: when supplied, each composite's #' population is estimated directly from the constrained WorldPop raster on the -#' composite (child-union or parent-fallback) geometry via -#' \code{estimate_pop_for_geometries()}. This geometry-derived denominator is -#' the true sub-area population and is the primary source; the summed-child and -#' parent-polygon populations (steps 5/5b) are retained only as fallbacks for -#' composites whose geometry the raster extraction could not resolve. When NULL -#' (default), the previous summed-child / parent-polygon behaviour is used. +#' composite geometry via \code{estimate_pop_for_geometries()}. +#' @param allow_parent_pop_fallback logical: when TRUE, a composite whose +#' population cannot be established from its own children may inherit its +#' parent location's population. Defaults to FALSE. +#' +#' The parent of a composite is a strictly larger area, so inheriting its +#' population overstates the denominator by however much of the parent the +#' composite does not cover — the same pathology as the parent-inherited +#' geometry duplicates that \code{detect_duplicate_geometries()} flags. The +#' honest default is to leave such a composite with \code{pop = NA}, which +#' routes it to the "low" surveillance class, rather than to silently +#' substitute a value that is wrong in a known direction. +#' +#' @section Population precedence: +#' Sources are tried in this order, and the first that yields a usable +#' (positive, non-NA) value wins: +#' \enumerate{ +#' \item \code{composite_union} — WorldPop extracted on the union of the +#' composite's *children's* geometries. This is the true sub-area +#' denominator. +#' \item \code{child_sum} — the sum of the children's own populations. +#' \item \code{parent_fallback} — the parent location's population, only +#' when \code{allow_parent_pop_fallback = TRUE}. +#' } +#' +#' Ordering matters: the raster extraction is only treated as +#' \code{composite_union} when the geometry it ran on was a genuine child +#' union. When the composite fell back to its *parent's* polygon (step 6b), +#' extracting WorldPop on it returns the parent population, so that result is +#' classified as \code{parent_fallback} and is subject to the same gate. +#' Previously this path could install the parent population while presenting +#' it as a geometry-derived sub-area figure. +#' #' @return list(data = normalized with composites resolved, #' geometry = sf(lctn_pr, area_per_1km2, geometry) for composites, #' or NULL when there are none). build_composite_locations <- function(normalized, raw_sf, iso3, - raster_dir = NULL) { + raster_dir = NULL, + allow_parent_pop_fallback = FALSE) { iso3 <- toupper(regmatches(iso3, regexpr("[A-Z]{3}", iso3))) @@ -217,65 +245,33 @@ build_composite_locations <- function(normalized, raw_sf, iso3, stringsAsFactors = FALSE ) - # 5. Composite population = sum of distinct matched child-LP populations ---- + # 5. Candidate population: sum of distinct matched child-LP populations ----- + # Held as a *candidate* only; precedence is resolved in step 6d once the + # geometry-derived value is known. + # + # sum(na.rm = TRUE) over a group whose children all have pop = NA returns + # 0, and a composite with no matched children at all is absent entirely. + # Both must surface as NA, never 0: get_outbreak_threshold() routes + # is.na(pop) to the "low" surveillance class, but pop == 0 gives + # sCh / pop == Inf, which classifies as "high". A zero denominator would + # therefore flip the detection threshold rather than merely be missing. comp_pop_raw <- cp %>% dplyr::filter(!is.na(location_period_id)) %>% dplyr::distinct(composite_name, location_period_id, pop) %>% dplyr::group_by(composite_name) %>% - dplyr::summarise(composite_pop = sum(pop, na.rm = TRUE), .groups = "drop") + dplyr::summarise( + child_sum_pop = if (all(is.na(pop))) NA_real_ else sum(pop, na.rm = TRUE), + .groups = "drop" + ) - # Ensure every composite name is represented (zero when no children matched). comp_pop <- comp_ids %>% dplyr::select(composite_name, composite_id) %>% dplyr::left_join(comp_pop_raw, by = "composite_name") %>% dplyr::mutate( - composite_pop = dplyr::if_else(is.na(composite_pop), 0, composite_pop) + child_sum_pop = dplyr::if_else(!is.na(child_sum_pop) & child_sum_pop <= 0, + NA_real_, child_sum_pop) ) - # 5b. Parent-location fallback: replace 0-pop composites with their parent's - # pop (all children were unobserved — e.g. BDI sanitary-district composites). - zero_pop_composites <- comp_pop$composite_name[comp_pop$composite_pop == 0] - if (length(zero_pop_composites) > 0L) { - parent_pop_df <- data.frame( - composite_name = zero_pop_composites, - parent_location = vapply(zero_pop_composites, get_composite_parent, - character(1L)), - stringsAsFactors = FALSE - ) %>% - dplyr::filter(!is.na(parent_location)) %>% - dplyr::left_join( - dplyr::select(loc_lookup_extended, - parent_location = location, - parent_pop = pop), - by = "parent_location" - ) - - n_ok <- sum(!is.na(parent_pop_df$parent_pop)) - n_bad <- length(zero_pop_composites) - n_ok - if (n_ok > 0L) - message(" ", n_ok, - " composite(s) using parent-location pop as fallback ", - "(children not observed atomically — denominator approximated).") - if (n_bad > 0L) - message(" ", n_bad, - " composite(s) have no pop (children + parent both absent); ", - "detection thresholds will be NaN.") - - comp_pop <- comp_pop %>% - dplyr::left_join( - dplyr::select(parent_pop_df, composite_name, parent_pop), - by = "composite_name" - ) %>% - dplyr::mutate( - composite_pop = dplyr::if_else( - composite_pop == 0 & !is.na(parent_pop), - parent_pop, - composite_pop - ) - ) %>% - dplyr::select(-parent_pop) - } - # 6. Composite geometry: union of matched child geometries (sf left table) -- geom_lookup <- raw_sf %>% dplyr::mutate(location_period_id = as.character(location_period_id)) %>% @@ -306,6 +302,7 @@ build_composite_locations <- function(normalized, raw_sf, iso3, dplyr::select(lctn_pr, area_per_1km2) # 6b. Parent-location geometry fallback for composites still without geom --- + parent_geom_ids <- character(0) composites_with_geom <- composite_geom$lctn_pr # character(0) when 0 rows needs_parent_geom <- comp_ids$composite_id[ !comp_ids$composite_id %in% composites_with_geom @@ -349,6 +346,11 @@ build_composite_locations <- function(normalized, raw_sf, iso3, message(" ", nrow(parent_geom), " composite(s) using parent geometry as fallback.") composite_geom <- rbind(composite_geom, parent_geom) + # Record which composites are standing on their parent's polygon. A + # raster extraction over such a geometry returns the PARENT's + # population, not the composite's, so it must not be presented as a + # geometry-derived sub-area denominator (step 6c/6d). + parent_geom_ids <- unique(parent_geom$lctn_pr) } } } @@ -407,29 +409,98 @@ build_composite_locations <- function(normalized, raw_sf, iso3, ) %>% dplyr::select(composite_name, geom_pop) - n_geom_pop <- sum(!is.na(geom_pop_df$geom_pop) & geom_pop_df$geom_pop > 0) - if (n_geom_pop > 0L) - message(" ", n_geom_pop, - " composite(s) using WorldPop-on-geometry as population ", - "(true sub-area denominator).") - + # Split the raster result by what polygon it actually ran on. Only a child + # union is a genuine sub-area denominator; a parent polygon yields the + # parent's population and is gated with the other parent fallbacks. comp_pop <- comp_pop %>% dplyr::left_join(geom_pop_df, by = "composite_name") %>% dplyr::mutate( - composite_pop = dplyr::if_else( - !is.na(geom_pop) & geom_pop > 0, - geom_pop, - composite_pop - ) + geom_pop = dplyr::if_else(!is.na(geom_pop) & geom_pop <= 0, + NA_real_, geom_pop), + union_pop = dplyr::if_else(composite_id %in% parent_geom_ids, + NA_real_, geom_pop), + parent_geom_pop = dplyr::if_else(composite_id %in% parent_geom_ids, + geom_pop, NA_real_) ) %>% dplyr::select(-geom_pop) + + n_union <- sum(!is.na(comp_pop$union_pop)) + if (n_union > 0L) + message(" ", n_union, + " composite(s) using WorldPop-on-child-union as population ", + "(true sub-area denominator).") + n_pgeom <- sum(!is.na(comp_pop$parent_geom_pop)) + if (n_pgeom > 0L) + message(" ", n_pgeom, + " composite(s) had only parent geometry — the raster value is a ", + "parent population, not a sub-area one.") + } else { + comp_pop$union_pop <- NA_real_ + comp_pop$parent_geom_pop <- NA_real_ } + # 6d. Parent-location population candidate -------------------------------- + parent_pop_lookup <- data.frame( + composite_name = comp_pop$composite_name, + parent_location = vapply(comp_pop$composite_name, get_composite_parent, + character(1L)), + stringsAsFactors = FALSE + ) %>% + dplyr::left_join( + dplyr::select(loc_lookup_extended, + parent_location = location, + parent_pop = pop), + by = "parent_location" + ) %>% + dplyr::distinct(composite_name, .keep_all = TRUE) %>% + dplyr::select(composite_name, parent_pop) + + comp_pop <- comp_pop %>% + dplyr::left_join(parent_pop_lookup, by = "composite_name") %>% + dplyr::mutate( + parent_pop = dplyr::coalesce(parent_pop, parent_geom_pop), + parent_pop = dplyr::if_else(!is.na(parent_pop) & parent_pop <= 0, + NA_real_, parent_pop) + ) + + # 6e. Resolve precedence: child union > child sum > parent (gated) --------- + comp_pop <- comp_pop %>% + dplyr::mutate( + composite_pop = dplyr::case_when( + !is.na(union_pop) ~ union_pop, + !is.na(child_sum_pop) ~ child_sum_pop, + allow_parent_pop_fallback & !is.na(parent_pop) ~ parent_pop, + TRUE ~ NA_real_ + ), + composite_pop_source = dplyr::case_when( + !is.na(union_pop) ~ "composite_union", + !is.na(child_sum_pop) ~ "child_sum", + allow_parent_pop_fallback & !is.na(parent_pop) ~ "parent_fallback", + TRUE ~ "none" + ) + ) + + n_blocked <- sum(comp_pop$composite_pop_source == "none" & + !is.na(comp_pop$parent_pop)) + if (n_blocked > 0L) { + message(" ", n_blocked, " composite(s) could have inherited a parent ", + "population but allow_parent_pop_fallback = FALSE — pop left NA ", + "(they will fall into the 'low' surveillance class).") + } + n_none <- sum(comp_pop$composite_pop_source == "none") + if (n_none > 0L) { + message(" ", n_none, " composite(s) have no population from any source.") + } + + comp_pop <- dplyr::select(comp_pop, -union_pop, -parent_geom_pop, + -parent_pop, -child_sum_pop) + # 7. Rewrite composite rows in the normalized data ------------------------- data_out <- normalized %>% dplyr::left_join(comp_ids, by = c("location" = "composite_name")) %>% dplyr::left_join( - dplyr::select(comp_pop, composite_name, composite_pop), + dplyr::select(comp_pop, composite_name, composite_pop, + composite_pop_source), by = c("location" = "composite_name") ) %>% dplyr::mutate( @@ -441,8 +512,25 @@ build_composite_locations <- function(normalized, raw_sf, iso3, paste(as.character(spatial_scale), "composite"), as.character(spatial_scale) ) - ) %>% - dplyr::select(-composite_id, -composite_pop) + ) + + # Composite rows carry their own population provenance; atomic rows keep the + # pop_source that add_population() assigned. + if ("pop_source" %in% names(data_out)) { + data_out <- data_out %>% + dplyr::mutate( + pop_source = dplyr::if_else(!is.na(composite_id), + composite_pop_source, pop_source) + ) + } else { + data_out <- data_out %>% + dplyr::mutate(pop_source = dplyr::if_else(!is.na(composite_id), + composite_pop_source, + NA_character_)) + } + + data_out <- dplyr::select(data_out, -composite_id, -composite_pop, + -composite_pop_source) # 9. Known atomic-LP corrections (SSD/SOM only) ---------------------------- data_out <- apply_known_lp_fixes(data_out, iso3) diff --git a/R/detect_duplicate_geometries.R b/R/detect_duplicate_geometries.R new file mode 100644 index 0000000..9a6e7c7 --- /dev/null +++ b/R/detect_duplicate_geometries.R @@ -0,0 +1,114 @@ +#' @export +#' @title detect_duplicate_geometries +#' @name detect_duplicate_geometries +#' @description Identify location periods that share an identical polygon, and +#' classify why. +#' +#' The Cholera Taxonomy database stores a separate shape record per location +#' period, but the *content* of those records is sometimes duplicated: several +#' distinct location_period_ids, each with its own distinct shape id, resolve +#' to byte-identical geometry. \code{add_population()} then extracts the same +#' raster footprint for each of them and assigns them all the same population. +#' This is a defect in the source data, not in the join — every LP receives +#' the geometry the database associates with it. +#' +#' Not every duplicate is harmful, so the cluster is classified: +#' +#' \describe{ +#' \item{\code{unique}}{No other LP in the country shares this geometry.} +#' \item{\code{alias}}{All members sit at the same hierarchy depth and share +#' a base name once an ISO-style code prefix is stripped (e.g. +#' \code{GN-B::Fria} and \code{GN-B::GN-FR.Fria}). These are duplicate +#' records for one real place; the geometry is *correct*. They still +#' double-count if a consumer sums population across LPs.} +#' \item{\code{parent_inherited}}{Members span more than one hierarchy +#' depth, i.e. children carry their parent's polygon (e.g. the Conakry +#' region polygon on six Conakry sub-districts). Severe: each child is +#' assigned the whole parent population.} +#' \item{\code{cross_unit}}{Members sit at the same depth but have different +#' base names, i.e. genuinely distinct units share one polygon (e.g. +#' \code{Lagos::Shomolu} and \code{Nasarawa::Awe}). Severe: at least one +#' unit has an entirely wrong denominator.} +#' \item{\code{unknown}}{Duplicated, but no location names were supplied so +#' the cluster could not be classified.} +#' } +#' +#' @param lp_ids vector: location period identifiers, one per geometry. +#' @param geoms sfc or sf: geometries aligned with \code{lp_ids}. +#' @param lp_locations character or NULL: \code{::}-delimited location name per +#' LP, aligned with \code{lp_ids}. When NULL, duplicated clusters are class +#' \code{"unknown"}. +#' @return a tibble with columns \code{location_period_id}, +#' \code{pop_geom_dup_n} (size of the identical-geometry cluster; 1 means +#' unique) and \code{pop_geom_dup_class}. +detect_duplicate_geometries <- function(lp_ids, geoms, lp_locations = NULL) { + + n <- length(lp_ids) + if (n == 0L) { + return(dplyr::tibble(location_period_id = lp_ids, + pop_geom_dup_n = integer(0), + pop_geom_dup_class = character(0))) + } + + geoms_sfc <- if (inherits(geoms, "sf")) sf::st_geometry(geoms) else geoms + + # Geometry identity key. Empty geometries are never treated as duplicates of + # one another: they carry no footprint, so sharing "emptiness" says nothing. + wkt <- vapply(geoms_sfc, function(g) { + if (is.null(g)) return(NA_character_) + txt <- tryCatch(sf::st_as_text(g), error = function(e) NA_character_) + txt + }, character(1L)) + + empty <- is.na(wkt) | vapply(geoms_sfc, function(g) { + if (is.null(g)) return(TRUE) + isTRUE(tryCatch(sf::st_is_empty(sf::st_sfc(g)), error = function(e) TRUE)) + }, logical(1L)) + + if (requireNamespace("digest", quietly = TRUE)) { + key <- vapply(seq_len(n), function(i) { + if (empty[i]) NA_character_ else digest::digest(wkt[i]) + }, character(1L)) + } else { + key <- ifelse(empty, NA_character_, wkt) + } + + # Cluster size: NA keys (empty geometry) are always singletons. + dup_n <- rep(1L, n) + keyed <- which(!is.na(key)) + if (length(keyed) > 0L) { + tab <- table(key[keyed]) + dup_n[keyed] <- as.integer(tab[key[keyed]]) + } + + dup_class <- rep("unique", n) + + if (is.null(lp_locations)) { + dup_class[dup_n > 1L] <- "unknown" + } else { + depth <- lengths(strsplit(as.character(lp_locations), "::", fixed = TRUE)) + leaf <- vapply(strsplit(as.character(lp_locations), "::", fixed = TRUE), + function(p) if (length(p) == 0L) NA_character_ else p[length(p)], + character(1L)) + # "GN-FR.Fria" and "Fria" name the same unit under two conventions. + base <- tolower(trimws(sub("^[A-Za-z]{2}-[A-Za-z0-9]+\\.", "", leaf))) + + for (k in unique(key[keyed])) { + idx <- which(key == k & !is.na(key)) + if (length(idx) < 2L) next + dup_class[idx] <- if (dplyr::n_distinct(depth[idx]) > 1L) { + "parent_inherited" + } else if (dplyr::n_distinct(base[idx]) == 1L) { + "alias" + } else { + "cross_unit" + } + } + } + + dplyr::tibble( + location_period_id = lp_ids, + pop_geom_dup_n = dup_n, + pop_geom_dup_class = dup_class + ) +} diff --git a/R/get_country_boundary.R b/R/get_country_boundary.R new file mode 100644 index 0000000..ce46098 --- /dev/null +++ b/R/get_country_boundary.R @@ -0,0 +1,120 @@ +#' @export +#' @title get_country_boundary +#' @name get_country_boundary +#' @description Resolve a national boundary polygon for the UN population +#' adjustment factor, deterministically and without ever falling back to the +#' union of location-period geometries. +#' +#' The resolution ladder is: on-disk cache -> \code{rgeoboundaries::gb_adm0()} +#' -> \code{NULL}. There is deliberately no fourth step. A union of the +#' observed LP geometries is *not* a country boundary — it covers only the +#' surveilled sub-areas, so the raster total extracted on it is too small and +#' the resulting adjustment factor (\code{tot_UN / country_raw}) is inflated, +#' scaling every population in the country upward. Callers must treat +#' \code{NULL} as "skip the adjustment" (\code{adj_factor = 1.0}), which +#' leaves populations unadjusted rather than wrong. +#' +#' \code{rgeoboundaries} is an optional dependency (Suggests). It is checked +#' with \code{requireNamespace()} before use so that a missing package +#' produces a legible message instead of being swallowed by a +#' \code{tryCatch()} that cannot distinguish it from a network failure. +#' +#' @param country_iso3 character: ISO3 code, optionally with a sub-national +#' suffix (e.g. "TZA::Mainland"); the leading 3-letter code is extracted. +#' @param cache_dir character or NULL: directory for caching boundary GeoJSON. +#' When NULL, no cache is read or written. +#' @return an sf object with a single boundary geometry in EPSG:4326, or +#' \code{NULL} if the boundary could not be resolved. +get_country_boundary <- function(country_iso3, cache_dir = "country_boundaries") { + + iso3 <- regmatches(toupper(country_iso3), + regexpr("[A-Z]{3}", toupper(country_iso3))) + if (length(iso3) != 1L || is.na(iso3)) { + message("get_country_boundary(): could not extract an ISO3 code from '", + country_iso3, "' — returning NULL.") + return(NULL) + } + + # -- 1. Disk cache --------------------------------------------------------- + cache_file <- NULL + if (!is.null(cache_dir)) { + cache_file <- file.path(cache_dir, paste0(iso3, "_adm0.geojson")) + if (file.exists(cache_file)) { + cached <- tryCatch( + sf::st_transform(sf::st_read(cache_file, quiet = TRUE), 4326), + error = function(e) { + message("get_country_boundary(): cached boundary for ", iso3, + " unreadable (", conditionMessage(e), ") — refetching.") + NULL + } + ) + if (!is.null(cached) && nrow(cached) > 0L) return(cached) + } + } + + # -- 2. rgeoboundaries ----------------------------------------------------- + if (!requireNamespace("rgeoboundaries", quietly = TRUE)) { + message("get_country_boundary(): package 'rgeoboundaries' is not installed, ", + "so the boundary for ", iso3, " cannot be fetched. ", + "The UN adjustment will be skipped (adj_factor = 1.0). ", + "Install it to enable the adjustment.") + return(NULL) + } + + shp <- tryCatch( + sf::st_transform(rgeoboundaries::gb_adm0(country = iso3), 4326), + error = function(e) { + message("get_country_boundary(): gb_adm0() failed for ", iso3, ": ", + conditionMessage(e), + " — the UN adjustment will be skipped (adj_factor = 1.0).") + NULL + } + ) + if (is.null(shp) || nrow(shp) == 0L) return(NULL) + + # -- 3. Populate the cache ------------------------------------------------- + if (!is.null(cache_file)) { + tryCatch({ + dir.create(dirname(cache_file), recursive = TRUE, showWarnings = FALSE) + sf::st_write(shp, cache_file, quiet = TRUE, delete_dsn = TRUE) + }, error = function(e) { + message("get_country_boundary(): could not cache boundary for ", iso3, + ": ", conditionMessage(e)) + }) + } + + shp +} + + +#' @export +#' @title band_adj_factor +#' @name band_adj_factor +#' @description Apply the accept / flag / clamp banding to a UN population +#' adjustment factor. +#' +#' The observed corpus-wide range is 1.005-1.034, so any value far outside +#' 1.0 indicates that the raster total was extracted on the wrong polygon +#' rather than that the country genuinely disagrees with WPP. Rather than +#' propagate such a factor, extreme values are clamped to 1.0 (leaving the +#' population unadjusted) and flagged. +#' +#' @param adj_factor numeric: the raw \code{tot_UN / country_raw} ratio. +#' @return a list with \code{value} (the factor to use) and \code{flag}, one of +#' "ok", "wide", or "clamped". +band_adj_factor <- function(adj_factor) { + if (!is.finite(adj_factor) || adj_factor <= 0) { + return(list(value = 1.0, flag = "clamped")) + } + if (adj_factor >= 0.67 && adj_factor <= 1.5) { + return(list(value = adj_factor, flag = "ok")) + } + if (adj_factor >= 0.5 && adj_factor <= 2.0) { + message(" adj_factor ", signif(adj_factor, 4), + " is outside the expected band [0.67, 1.5] — accepted but flagged.") + return(list(value = adj_factor, flag = "wide")) + } + message(" adj_factor ", signif(adj_factor, 4), + " is outside [0.5, 2.0] — clamped to 1.0 (population left unadjusted).") + list(value = 1.0, flag = "clamped") +} diff --git a/R/identify_outbreaks.R b/R/identify_outbreaks.R index 5e27336..dac0c7d 100644 --- a/R/identify_outbreaks.R +++ b/R/identify_outbreaks.R @@ -25,6 +25,7 @@ filter_small_outbreaks <- function(df, min_total_cases) { #' @param customized_TR: customize the upper bound of time for outbreak estimation #' @param cumulative_min_cases: numeric: minimum cumulative cases. Used by the dual_window cumulative trigger and, when \code{filter_outbreaks_by_size = TRUE}, as the minimum total-case threshold for the post-detection size filter. #' @param filter_outbreaks_by_size: logical: when TRUE, drop detected outbreaks whose total cases (summed over the full outbreak window) fall below \code{cumulative_min_cases}. Default FALSE (no filtering, backward compatible). +#' @param keep_nonoutbreak_locations: logical: when TRUE, locations that never trigger an epidemic start are returned as their full time series labelled \code{outbreak_number = 0} and \code{`Time Period` = "non-outbreak period"}, instead of an empty data.frame. Use this to retain every location in the output rather than silently dropping those without a detected outbreak. Default FALSE (backward compatible). #' @export #' @return list of dataframes @@ -45,7 +46,8 @@ identify_outbreaks <- function( cumulative_min_cases=cumulative_min_cases, nonzero_windows = nonzero_windows, tail_period =6, - filter_outbreaks_by_size = FALSE + filter_outbreaks_by_size = FALSE, + keep_nonoutbreak_locations = FALSE ){ # Identify cholera outbreak thresholds @@ -148,6 +150,16 @@ identify_outbreaks <- function( mutate( `Time Period` = factor(`Time Period`,levels =c("outbreak period",'non-outbreak period')) ) + } else if (isTRUE(keep_nonoutbreak_locations) && + nrow(preoutbreak_by_location_start_end_washout) > 0) { + # No epidemic start for this location. Rather than dropping it, keep the + # full series labelled as a non-outbreak period so downstream consumers + # retain every location. Columns match the if-branch above. + preoutbreak_by_location_start_end_washout$outbreak_number <- 0 + preoutbreak_by_location_start_end_washout$`Time Period` <- factor( + "non-outbreak period", + levels = c("outbreak period", "non-outbreak period") + ) } else{ preoutbreak_by_location_start_end_washout <-data.frame() } diff --git a/R/validate_population.R b/R/validate_population.R new file mode 100644 index 0000000..73a6bbc --- /dev/null +++ b/R/validate_population.R @@ -0,0 +1,172 @@ +#' @export +#' @title validate_population +#' @name validate_population +#' @description Run the population quality gates over one country's +#' location-period populations and return a tidy per-gate report. +#' +#' The gates encode failure modes that were verified against the extraction +#' corpus rather than inferred from reading code, so their thresholds are +#' calibrated to observed behaviour. Gate 3's band, for instance, is loose +#' because the observed adjustment factors span only 1.005-1.034 — anything +#' far outside that indicates the raster total was extracted on the wrong +#' polygon, not a genuine disagreement with WPP. +#' +#' Default \code{on_fail = "warn"}. Gate 4 currently fails corpus-wide (many +#' location periods legitimately share geometry with an alias record), so +#' aborting by default would make a full re-extraction impossible. Use +#' \code{on_fail = "abort"} only for gates you have already driven to zero. +#' +#' @param lp_pop data.frame: one row per location period, with at least +#' \code{location_period_id} and \code{pop}. Optional columns +#' \code{location}, \code{pop_source}, \code{pop_geom_dup_n}, +#' \code{pop_geom_dup_class} and \code{adj_factor} enable additional gates. +#' @param iso3 character: ISO3 country code, recorded in the report. +#' @param on_fail character: "warn" (default) or "abort". +#' @param wpp_total numeric or NULL: the WPP2024 national total to compare +#' against. When NULL it is looked up from the bundled WPP2024 table using +#' the median \code{pop_year_raster} in \code{lp_pop}. +#' @return a tibble with one row per gate: \code{iso3}, \code{gate}, +#' \code{description}, \code{n_violations}, \code{n_checked}, \code{passed}, +#' and \code{detail} (a compact listing of offending location periods). +validate_population <- function(lp_pop, iso3, on_fail = c("warn", "abort"), + wpp_total = NULL) { + + on_fail <- match.arg(on_fail) + iso3 <- toupper(iso3) + + if (!"location_period_id" %in% names(lp_pop) || !"pop" %in% names(lp_pop)) { + stop("validate_population(): lp_pop must have location_period_id and pop columns.") + } + + # One row per location period. Population is a static per-LP attribute, so a + # weekly frame would otherwise inflate every violation count by the number of + # weeks observed. + lp <- lp_pop %>% + dplyr::filter(!is.na(location_period_id)) %>% + dplyr::group_by(location_period_id) %>% + dplyr::slice(1L) %>% + dplyr::ungroup() + + has <- function(col) col %in% names(lp) + report <- list() + + add_gate <- function(gate, description, violations, n_checked, + record_only = FALSE) { + ids <- as.character(violations) + report[[length(report) + 1L]] <<- dplyr::tibble( + iso3 = iso3, + # Character throughout: gates 5a/5b/7/8 are not integers, and a mixed + # integer/character column cannot be bound into one report. + gate = as.character(gate), + description = description, + n_violations = length(ids), + n_checked = n_checked, + passed = record_only | length(ids) == 0L, + record_only = record_only, + detail = if (length(ids) == 0L) NA_character_ else + paste(utils::head(ids, 20L), collapse = ", ") + ) + } + + # -- Gate 1: pop is finite and non-NA -------------------------------------- + # NA is the correct representation of "unknown"; this gate simply counts how + # much of the country lacks a denominator. + g1 <- lp$location_period_id[is.na(lp$pop) | !is.finite(lp$pop)] + add_gate(1L, "pop is present and finite", g1, nrow(lp)) + + # -- Gate 2: pop is never zero --------------------------------------------- + # A zero denominator is worse than a missing one: get_outbreak_threshold() + # sends is.na(pop) to the "low" surveillance class, but pop == 0 yields + # sCh/pop == Inf, which classifies as "high". Zero silently flips the + # detection threshold, so it must never be emitted. + g2 <- lp$location_period_id[!is.na(lp$pop) & lp$pop <= 0] + add_gate(2L, "pop is never zero or negative (zero flips the detection threshold)", + g2, nrow(lp)) + + # -- Gate 3: adjustment factor within a plausible band --------------------- + if (has("adj_factor")) { + g3 <- lp$location_period_id[!is.na(lp$adj_factor) & + (lp$adj_factor < 0.8 | lp$adj_factor > 1.5)] + add_gate(3L, "adj_factor within [0.8, 1.5] (observed corpus range 1.005-1.034)", + g3, sum(!is.na(lp$adj_factor))) + } + + # -- Gate 4: no two LPs share an identical geometry ------------------------ + # Broad net. Includes benign alias records, so this is expected to be + # non-zero; gates 5a/5b isolate the harmful subsets. + if (has("pop_geom_dup_n")) { + g4 <- lp$location_period_id[!is.na(lp$pop_geom_dup_n) & lp$pop_geom_dup_n > 1L] + add_gate(4L, "no two location periods share an identical geometry", + g4, nrow(lp)) + } + + # -- Gates 5a / 5b: the harmful duplicate classes -------------------------- + # Splitting these matters. A single "duplicate pop spanning >1 admin depth" + # gate catches only parent inheritance and misses same-depth cross-unit + # collisions entirely — and in the audited corpus the cross-unit class was + # the larger of the two. + if (has("pop_geom_dup_class")) { + g5a <- lp$location_period_id[lp$pop_geom_dup_class %in% "parent_inherited"] + add_gate("5a", "no child location period carries its parent's geometry", + g5a, nrow(lp)) + + g5b <- lp$location_period_id[lp$pop_geom_dup_class %in% "cross_unit"] + add_gate("5b", "no two distinct units at the same depth share one geometry", + g5b, nrow(lp)) + } + + # -- Gate 6: no LP exceeds the national total ------------------------------ + natl <- wpp_total + if (is.null(natl) && has("pop_natl_ref")) { + natl <- suppressWarnings(stats::median(lp$pop_natl_ref, na.rm = TRUE)) + } + if (!is.null(natl) && is.finite(natl) && natl > 0) { + g6 <- lp$location_period_id[!is.na(lp$pop) & lp$pop > natl] + add_gate(6L, sprintf("no location period exceeds the national total (%s)", + format(round(natl), big.mark = ",")), + g6, nrow(lp)) + } + + # -- Gate 7: country total within 30% of WPP (record only) ----------------- + # Record-only: the frame covers surveilled areas, not the whole country, so a + # shortfall is expected and is not by itself evidence of a defect. + if (!is.null(natl) && is.finite(natl) && natl > 0) { + observed <- sum(lp$pop, na.rm = TRUE) + ratio <- observed / natl + report[[length(report) + 1L]] <- dplyr::tibble( + iso3 = iso3, gate = "7", + description = "country sum vs WPP2024 national total", + n_violations = as.integer(!is.na(ratio) && (ratio < 0.7 || ratio > 1.3)), + n_checked = nrow(lp), passed = TRUE, record_only = TRUE, + detail = sprintf("sum=%s national=%s ratio=%.3f", + format(round(observed), big.mark = ","), + format(round(natl), big.mark = ","), ratio) + ) + } + + # -- Gate 8: pop_source composition (record only) -------------------------- + if (has("pop_source")) { + tab <- table(lp$pop_source, useNA = "ifany") + report[[length(report) + 1L]] <- dplyr::tibble( + iso3 = iso3, gate = "8", description = "population source composition", + n_violations = sum(lp$pop_source %in% "parent_fallback"), + n_checked = nrow(lp), passed = TRUE, record_only = TRUE, + detail = paste(names(tab), as.integer(tab), sep = "=", collapse = ", ") + ) + } + + out <- dplyr::bind_rows(report) + + failed <- out[!out$passed & !out$record_only, , drop = FALSE] + if (nrow(failed) > 0L) { + msg <- paste0( + "validate_population(): ", nrow(failed), " gate(s) failed for ", iso3, ":\n", + paste0(" gate ", failed$gate, ": ", failed$description, + " — ", failed$n_violations, "/", failed$n_checked, + " violation(s) [", failed$detail, "]", collapse = "\n") + ) + if (identical(on_fail, "abort")) stop(msg) else warning(msg, call. = FALSE) + } + + out +} diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index f4fc12b..a35057e 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -261,6 +261,37 @@ if (!is.null(raw_sf)) { } } +# --------------------------------------------------------------------------- +# Population QC gates +# +# Runs AFTER the composite block so that composite pseudo-LPs are covered too. +# on_fail = "warn": gate 4 currently fails corpus-wide (alias records sharing a +# geometry), so aborting here would prevent any full re-extraction from +# completing. The per-country CSV is aggregated by 03_aggregate_results.R into +# one reviewable corpus-wide artefact. +# --------------------------------------------------------------------------- +pop_qa <- tryCatch( + OutbreakExtractR::validate_population( + lp_pop = normalized, + iso3 = opt$country_iso3, + on_fail = "warn" + ), + error = function(e) { + warning("validate_population() failed for ", opt$who_region, "::", + opt$country_iso3, ": ", conditionMessage(e)) + NULL + } +) + +if (!is.null(pop_qa)) { + qa_file <- file.path( + dirname(out_file), + sprintf("stage2_popqa_%s_%s.csv", opt$who_region, opt$country_iso3) + ) + utils::write.csv(pop_qa, qa_file, row.names = FALSE) + message("Population QC written: ", basename(qa_file)) +} + # --------------------------------------------------------------------------- # Outbreak detection over full per-country series (no customized_TL/TR) # Threshold = mean weekly incidence over the entire time series, matching reference diff --git a/analysis/03_aggregate_results.R b/analysis/03_aggregate_results.R index 90ca2dd..4f77d7a 100644 --- a/analysis/03_aggregate_results.R +++ b/analysis/03_aggregate_results.R @@ -92,6 +92,43 @@ plan(sequential) combined <- purrr::list_rbind(purrr::keep(results_list, \(x) !is.null(x))) +# --------------------------------------------------------------------------- +# Aggregate the per-country population QC into one corpus-wide report +# --------------------------------------------------------------------------- + +qa_files <- list.files(dirname(stage2_files[1]), pattern = "^stage2_popqa_.*\\.csv$", + full.names = TRUE) + +if (length(qa_files) > 0) { + pop_qa <- purrr::list_rbind(purrr::map(qa_files, \(f) tryCatch( + read.csv(f, stringsAsFactors = FALSE), + error = function(e) { + warning("Failed to read QC file: ", basename(f), " — ", conditionMessage(e)) + NULL + } + ))) + + if (nrow(pop_qa) > 0) { + qa_out <- file.path(opt$out_dir, + paste0("population_qc_", opt$set_name, ".csv")) + write.csv(pop_qa, qa_out, row.names = FALSE) + message("Saved population QC: ", qa_out) + + cat("\nPopulation QC summary (gates across ", + length(unique(pop_qa$iso3)), " countries):\n", sep = "") + qa_summary <- pop_qa %>% + dplyr::group_by(gate, description) %>% + dplyr::summarise( + countries_failing = sum(!passed & !record_only), + total_violations = sum(n_violations, na.rm = TRUE), + .groups = "drop" + ) %>% + dplyr::arrange(gate) + print(as.data.frame(qa_summary), row.names = FALSE) + cat("\n") + } +} + cat("Combined result:\n") cat(" Total rows: ", nrow(combined), "\n") cat(" Countries: ", length(unique(combined$country_iso3)), "\n") diff --git a/analysis/data_issue_composite_geometry_2026-07-17.md b/analysis/data_issue_composite_geometry_2026-07-17.md new file mode 100644 index 0000000..357ca17 --- /dev/null +++ b/analysis/data_issue_composite_geometry_2026-07-17.md @@ -0,0 +1,114 @@ +# Composite Location Geometry — Investigation State (2026-07-17) + +Fleeting note. Originally paused after Step 0 of plan `resilient-nibbling-noodle` +(fix composite population via WorldPop lookup + keep non-outbreak locations). + +> **Status update (2026-08-06).** Step A and the `identify_outbreaks()` half of +> Step B have since landed; the findings below are still accurate but the +> "Remaining plan steps" section at the bottom was stale and has been corrected. +> See that section for what is actually left. + +## Problem recap + +Colleague's May-2025 pre-outbreak extraction vs June-2026 refactor: missing rows, all +**composite locations** (`|`-joined names). Countries MRT/MDG/SEN vanish entirely. + +Root cause (from prior session): composite `pop = 0` → NaN threshold → risk "low" → +no epidemic start → `identify_outbreaks()` returns empty frame → Stage 2 drops it. + +## Step 0 finding — composites have NO API geometry (triple-confirmed) + +Confirmed via (a) cached `raw_api_cache_AFR_BDI_*.rds`, (b) low-level live POST, +(c) the actual patched `taxdat::read_taxonomy_data_api` production path. + +Live BDI pull, window 2014-01-02 → 2014-05-01: +- 2192 obs = 656 composite + 1536 atomic. +- **All 656 composites: `location_period_id = NULL`, empty POINT geometry.** +- Atomic: 1328 POLYGON + 32 MULTIPOLYGON + 176 empty POINT. + +Why (raw JSON, pre-processing): +- Composite obs carry a real `attributes.location_id` (e.g. 29697) but + `attributes.location_period_id = NULL`. Geometry (shape) hangs off a *location_period*, + not a location_id → no shape returned. +- **The client code does NOT drop geometry** — the source response already lacks the link; + `read_taxonomy_data_api`'s left-join on the missing id faithfully yields empty geometry. + +Raw `location_periods` block has **no hidden geometry**: 43 LPs, 43 shapes, +all referenced by atomic obs, **0 orphan LPs, 0 orphan shapes**. + +No API route resolves a shape from a `location_id` (probed +`locations/{id}`, `locations/{id}/location_periods`, `location_periods?location_id=`, +`shapes?location_id=`, `location_periods/by_location` → all 404/500). + +Only remaining way to know if the DB itself stores a composite shape: **direct-SQL path** +(`taxdat::build_geoms_query` / `get_unique_db_shps` / `read_taxonomy_locationperiods_sql`). +Not yet attempted (needs DB creds). + +## Why reconstruction is hard — vocabulary mismatch + +BDI pull = 91 unique locations (50 atomic + 41 composite). Atomic and composite units live in +**different admin vocabularies**: +- Atomic = health-system **"Sanitary Districts"** (admin3) under **province-name** admin2, + e.g. `AFR::BDI::Ruyigi::Butezi Sanitary District`. +- Composite children = **communes**; many composites use **ISO province codes** at admin2, + e.g. `AFR::BDI::BI-CA::(Cankuzo|Cendajuru|Kigamba)`. + +So `build_composite_locations()` exact-match child lookup mostly fails +(36/47 composites → no child matched; only 5 all-children, 6 partial). Root names DO overlap +(Butezi, Bubanza, Cankuzo…) but exact equality breaks on: +1. `" Sanitary District"` suffix, and +2. `BI-XX` code vs province name at admin2. +Even normalized, communes ≠ sanitary districts (different partitions of a province) — not a +full 1:1. + +## Current pipeline behaviour (existing `stage1_geo_AFR_BDI_composite.geojson`) + +Only 6 composites currently get any geometry, all via **parent-polygon fallback** (areas come +in identical pairs = shared parent province). The rest get summed-child / parent-pop / 0. + +## Open decision (RESOLVED) + +WorldPop-on-geometry gives a **true sub-area denominator only for ~1/4 of BDI composites**; +the rest fall back to the parent area. Options that were on the table: +- (a) Direct-SQL DB check on composite `location_id`s for a server-side shape. +- (b) Proceed with child-union / parent-fallback reconstruction as planned. +- (c) Improve child-name matching first (strip "Sanitary District", map `BI-XX` → + province name) to recover more real child-unions. + +**Chosen: (c) then (b).** `match_children_to_lps()` now strips the +" Sanitary District" suffix and resolves each child to a single LP, and +`build_composite_locations()` reconstructs geometry from the recovered children +with a parent-polygon fallback. + +The premise of the "pop > 0 → fixes the drop bug" argument has since been +**retracted**. Substituting the parent-area population to avoid `pop = 0` trades +one defect for another: the parent is a strictly larger area, so the denominator +is wrong in a known direction. The population fix (2026-08-06) makes NA — not a +parent approximation and not 0 — the honest value, gated behind +`allow_parent_pop_fallback` (default FALSE). Note that `pop = 0` was never merely +"missing": `get_outbreak_threshold()` sends `is.na(pop)` to the "low" surveillance +class, but `pop == 0` gives `sCh/pop == Inf`, which classifies as "high" — a zero +denominator *flips* the threshold. + +## Remaining plan steps + +Done: +- ~~Step A~~ — `raster_dir` param, `estimate_pop_for_geometries()`, geometry-derived + pop as the primary source, header comment corrected. Wired in + `analysis/02_run_outbreak_detection.R:250`. +- ~~`keep_nonoutbreak_locations` param + non-empty else branch~~ — + `R/identify_outbreaks.R:50,153`. +- ~~Docs~~ — `roxygen2::roxygenise()` run 2026-08-06. + +Still open: +- Wire `keep_nonoutbreak_locations = TRUE` into + `analysis/02_run_outbreak_detection.R` (the parameter exists and defaults to + FALSE for backward compatibility, but the analysis layer does not yet pass it, + so Stage 2 still drops locations with no detected outbreak). +- Add a testthat case for `keep_nonoutbreak_locations` in + `tests/testthat/test-identify_outbreaks.R` — there is none. +- Stage 2 dry-run on BDI. + +Test scripts: `/tmp/api_composite_test.R`, `/tmp/api_taxdat_test.R`, +`/tmp/raw_composite_dump.R`, `/tmp/probe_raw_shapes.R`, `/tmp/list_bdi_locations.R` +(raw response cached at `/tmp/bdi_live_raw.rds`). diff --git a/man/add_population.Rd b/man/add_population.Rd index e885e12..7576666 100644 --- a/man/add_population.Rd +++ b/man/add_population.Rd @@ -4,7 +4,13 @@ \alias{add_population} \title{add_population} \usage{ -add_population(normalized_data, raw_sf, country_iso3, raster_dir = "worldpop") +add_population( + normalized_data, + raw_sf, + country_iso3, + raster_dir = "worldpop", + boundary_cache_dir = "country_boundaries" +) } \arguments{ \item{normalized_data}{data.frame: weekly normalized data from the Stage 1 @@ -22,10 +28,25 @@ for the UN population adjustment factor.} \item{raster_dir}{character: directory for caching WorldPop raster files. Defaults to "worldpop". Created if it does not exist.} + +\item{boundary_cache_dir}{character or NULL: directory for caching national +boundaries used by the UN adjustment. Passed to +\code{get_country_boundary()}.} } \value{ -normalized_data with a numeric pop column added. Rows whose -location_period_id has no matching geometry in raw_sf receive NA. +normalized_data with a numeric \code{pop} column added, plus +provenance columns: \code{pop_source}, \code{pop_geom_dup_n}, +\code{pop_geom_dup_class}, \code{pop_year_obs}, \code{pop_year_raster}, +\code{pop_natl_ref}, \code{adj_factor} and \code{adj_factor_flag}. +Rows whose location_period_id has no matching geometry in raw_sf receive +\code{pop = NA} (never 0 — see the note on zero denominators below). + +\code{pop} is \code{NA}, never 0, whenever a population cannot be +established. \code{get_outbreak_threshold()} routes \code{is.na(pop)} to +the "low" surveillance class, but \code{pop == 0} yields +\code{sCh / pop == Inf}, which classifies as "high" — so a zero denominator +silently flips the outbreak-detection threshold rather than merely +producing a bad rate. } \description{ Attach WorldPop population estimates to a normalized weekly diff --git a/man/attach_empty_pop_provenance.Rd b/man/attach_empty_pop_provenance.Rd new file mode 100644 index 0000000..ed475e1 --- /dev/null +++ b/man/attach_empty_pop_provenance.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_population.R +\name{attach_empty_pop_provenance} +\alias{attach_empty_pop_provenance} +\title{attach_empty_pop_provenance} +\usage{ +attach_empty_pop_provenance(d) +} +\arguments{ +\item{d}{data.frame to attach columns to.} +} +\value{ +\code{d} with the provenance columns added. +} +\description{ +Attach the population provenance schema with empty values, so +that early-return paths in \code{add_population()} produce the same columns +as the full path. Consumers can then rely on the schema unconditionally. +} +\keyword{internal} diff --git a/man/band_adj_factor.Rd b/man/band_adj_factor.Rd new file mode 100644 index 0000000..3707ca3 --- /dev/null +++ b/man/band_adj_factor.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_country_boundary.R +\name{band_adj_factor} +\alias{band_adj_factor} +\title{band_adj_factor} +\usage{ +band_adj_factor(adj_factor) +} +\arguments{ +\item{adj_factor}{numeric: the raw \code{tot_UN / country_raw} ratio.} +} +\value{ +a list with \code{value} (the factor to use) and \code{flag}, one of +"ok", "wide", or "clamped". +} +\description{ +Apply the accept / flag / clamp banding to a UN population +adjustment factor. + +The observed corpus-wide range is 1.005-1.034, so any value far outside +1.0 indicates that the raster total was extracted on the wrong polygon +rather than that the country genuinely disagrees with WPP. Rather than +propagate such a factor, extreme values are clamped to 1.0 (leaving the +population unadjusted) and flagged. +} diff --git a/man/build_composite_locations.Rd b/man/build_composite_locations.Rd index 1d5a5f3..04647cc 100644 --- a/man/build_composite_locations.Rd +++ b/man/build_composite_locations.Rd @@ -4,7 +4,13 @@ \alias{build_composite_locations} \title{build_composite_locations} \usage{ -build_composite_locations(normalized, raw_sf, iso3, raster_dir = NULL) +build_composite_locations( + normalized, + raw_sf, + iso3, + raster_dir = NULL, + allow_parent_pop_fallback = FALSE +) } \arguments{ \item{normalized}{data.frame: the normalized weekly data AFTER @@ -18,12 +24,19 @@ to gate the known-LP corrections for SSD/SOM.} \item{raster_dir}{character or NULL: when supplied, each composite's population is estimated directly from the constrained WorldPop raster on the -composite (child-union or parent-fallback) geometry via -\code{estimate_pop_for_geometries()}. This geometry-derived denominator is -the true sub-area population and is the primary source; the summed-child and -parent-polygon populations (steps 5/5b) are retained only as fallbacks for -composites whose geometry the raster extraction could not resolve. When NULL -(default), the previous summed-child / parent-polygon behaviour is used.} +composite geometry via \code{estimate_pop_for_geometries()}.} + +\item{allow_parent_pop_fallback}{logical: when TRUE, a composite whose +population cannot be established from its own children may inherit its +parent location's population. Defaults to FALSE. + +The parent of a composite is a strictly larger area, so inheriting its +population overstates the denominator by however much of the parent the +composite does not cover — the same pathology as the parent-inherited +geometry duplicates that \code{detect_duplicate_geometries()} flags. The +honest default is to leave such a composite with \code{pop = NA}, which +routes it to the "low" surveillance class, rather than to silently +substitute a value that is wrong in a known direction.} } \value{ list(data = normalized with composites resolved, @@ -41,3 +54,25 @@ geometry (the true sub-area denominator); otherwise it is the sum of the children's WorldPop populations (attached by add_population()), with a parent-location pop fallback. } +\section{Population precedence}{ + +Sources are tried in this order, and the first that yields a usable +(positive, non-NA) value wins: +\enumerate{ +\item \code{composite_union} — WorldPop extracted on the union of the +composite's \emph{children's} geometries. This is the true sub-area +denominator. +\item \code{child_sum} — the sum of the children's own populations. +\item \code{parent_fallback} — the parent location's population, only +when \code{allow_parent_pop_fallback = TRUE}. +} + +Ordering matters: the raster extraction is only treated as +\code{composite_union} when the geometry it ran on was a genuine child +union. When the composite fell back to its \emph{parent's} polygon (step 6b), +extracting WorldPop on it returns the parent population, so that result is +classified as \code{parent_fallback} and is subject to the same gate. +Previously this path could install the parent population while presenting +it as a geometry-derived sub-area figure. +} + diff --git a/man/detect_duplicate_geometries.Rd b/man/detect_duplicate_geometries.Rd new file mode 100644 index 0000000..f0f1f80 --- /dev/null +++ b/man/detect_duplicate_geometries.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/detect_duplicate_geometries.R +\name{detect_duplicate_geometries} +\alias{detect_duplicate_geometries} +\title{detect_duplicate_geometries} +\usage{ +detect_duplicate_geometries(lp_ids, geoms, lp_locations = NULL) +} +\arguments{ +\item{lp_ids}{vector: location period identifiers, one per geometry.} + +\item{geoms}{sfc or sf: geometries aligned with \code{lp_ids}.} + +\item{lp_locations}{character or NULL: \code{::}-delimited location name per +LP, aligned with \code{lp_ids}. When NULL, duplicated clusters are class +\code{"unknown"}.} +} +\value{ +a tibble with columns \code{location_period_id}, +\code{pop_geom_dup_n} (size of the identical-geometry cluster; 1 means +unique) and \code{pop_geom_dup_class}. +} +\description{ +Identify location periods that share an identical polygon, and +classify why. + +The Cholera Taxonomy database stores a separate shape record per location +period, but the \emph{content} of those records is sometimes duplicated: several +distinct location_period_ids, each with its own distinct shape id, resolve +to byte-identical geometry. \code{add_population()} then extracts the same +raster footprint for each of them and assigns them all the same population. +This is a defect in the source data, not in the join — every LP receives +the geometry the database associates with it. + +Not every duplicate is harmful, so the cluster is classified: + +\describe{ +\item{\code{unique}}{No other LP in the country shares this geometry.} +\item{\code{alias}}{All members sit at the same hierarchy depth and share +a base name once an ISO-style code prefix is stripped (e.g. +\code{GN-B::Fria} and \code{GN-B::GN-FR.Fria}). These are duplicate +records for one real place; the geometry is \emph{correct}. They still +double-count if a consumer sums population across LPs.} +\item{\code{parent_inherited}}{Members span more than one hierarchy +depth, i.e. children carry their parent's polygon (e.g. the Conakry +region polygon on six Conakry sub-districts). Severe: each child is +assigned the whole parent population.} +\item{\code{cross_unit}}{Members sit at the same depth but have different +base names, i.e. genuinely distinct units share one polygon (e.g. +\code{Lagos::Shomolu} and \code{Nasarawa::Awe}). Severe: at least one +unit has an entirely wrong denominator.} +\item{\code{unknown}}{Duplicated, but no location names were supplied so +the cluster could not be classified.} +} +} diff --git a/man/estimate_pop_for_geometries.Rd b/man/estimate_pop_for_geometries.Rd index f9882e6..5189baa 100644 --- a/man/estimate_pop_for_geometries.Rd +++ b/man/estimate_pop_for_geometries.Rd @@ -8,7 +8,8 @@ estimate_pop_for_geometries( geom_sf, country_iso3, year, - raster_dir = "worldpop" + raster_dir = "worldpop", + boundary_cache_dir = "country_boundaries" ) } \arguments{ @@ -22,11 +23,15 @@ suffix is tolerated (the leading 3-letter code is extracted).} \code{nrow(geom_sf)}. Clamped to the WorldPop constrained range 2015-2030.} \item{raster_dir}{character: directory for caching WorldPop rasters.} + +\item{boundary_cache_dir}{character or NULL: directory for caching national +boundaries, passed to \code{get_country_boundary()}.} } \value{ numeric vector of length \code{nrow(geom_sf)} with the UN-adjusted -population per geometry (NA where the raster is unavailable or the geometry -is unusable). +population per geometry (NA where the raster is unavailable, the geometry +is unusable, or the raster sum is zero — zero is never returned as a +population). } \description{ Estimate a UN-adjusted WorldPop population for each polygon in an diff --git a/man/get_country_boundary.Rd b/man/get_country_boundary.Rd new file mode 100644 index 0000000..a55d6c8 --- /dev/null +++ b/man/get_country_boundary.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_country_boundary.R +\name{get_country_boundary} +\alias{get_country_boundary} +\title{get_country_boundary} +\usage{ +get_country_boundary(country_iso3, cache_dir = "country_boundaries") +} +\arguments{ +\item{country_iso3}{character: ISO3 code, optionally with a sub-national +suffix (e.g. "TZA::Mainland"); the leading 3-letter code is extracted.} + +\item{cache_dir}{character or NULL: directory for caching boundary GeoJSON. +When NULL, no cache is read or written.} +} +\value{ +an sf object with a single boundary geometry in EPSG:4326, or +\code{NULL} if the boundary could not be resolved. +} +\description{ +Resolve a national boundary polygon for the UN population +adjustment factor, deterministically and without ever falling back to the +union of location-period geometries. + +The resolution ladder is: on-disk cache -> \code{rgeoboundaries::gb_adm0()} +-> \code{NULL}. There is deliberately no fourth step. A union of the +observed LP geometries is \emph{not} a country boundary — it covers only the +surveilled sub-areas, so the raster total extracted on it is too small and +the resulting adjustment factor (\code{tot_UN / country_raw}) is inflated, +scaling every population in the country upward. Callers must treat +\code{NULL} as "skip the adjustment" (\code{adj_factor = 1.0}), which +leaves populations unadjusted rather than wrong. + +\code{rgeoboundaries} is an optional dependency (Suggests). It is checked +with \code{requireNamespace()} before use so that a missing package +produces a legible message instead of being swallowed by a +\code{tryCatch()} that cannot distinguish it from a network failure. +} diff --git a/man/identify_outbreaks.Rd b/man/identify_outbreaks.Rd index 5e61495..68832d4 100644 --- a/man/identify_outbreaks.Rd +++ b/man/identify_outbreaks.Rd @@ -21,7 +21,8 @@ identify_outbreaks( cumulative_min_cases = cumulative_min_cases, nonzero_windows = nonzero_windows, tail_period = 6, - filter_outbreaks_by_size = FALSE + filter_outbreaks_by_size = FALSE, + keep_nonoutbreak_locations = FALSE ) } \arguments{ @@ -40,6 +41,8 @@ identify_outbreaks( \item{cumulative_min_cases:}{numeric: minimum cumulative cases. Used by the dual_window cumulative trigger and, when \code{filter_outbreaks_by_size = TRUE}, as the minimum total-case threshold for the post-detection size filter.} \item{filter_outbreaks_by_size:}{logical: when TRUE, drop detected outbreaks whose total cases (summed over the full outbreak window) fall below \code{cumulative_min_cases}. Default FALSE (no filtering, backward compatible).} + +\item{keep_nonoutbreak_locations:}{logical: when TRUE, locations that never trigger an epidemic start are returned as their full time series labelled \code{outbreak_number = 0} and \code{`Time Period` = "non-outbreak period"}, instead of an empty data.frame. Use this to retain every location in the output rather than silently dropping those without a detected outbreak. Default FALSE (backward compatible).} } \value{ list of dataframes diff --git a/man/validate_population.Rd b/man/validate_population.Rd new file mode 100644 index 0000000..690b0c3 --- /dev/null +++ b/man/validate_population.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/validate_population.R +\name{validate_population} +\alias{validate_population} +\title{validate_population} +\usage{ +validate_population( + lp_pop, + iso3, + on_fail = c("warn", "abort"), + wpp_total = NULL +) +} +\arguments{ +\item{lp_pop}{data.frame: one row per location period, with at least +\code{location_period_id} and \code{pop}. Optional columns +\code{location}, \code{pop_source}, \code{pop_geom_dup_n}, +\code{pop_geom_dup_class} and \code{adj_factor} enable additional gates.} + +\item{iso3}{character: ISO3 country code, recorded in the report.} + +\item{on_fail}{character: "warn" (default) or "abort".} + +\item{wpp_total}{numeric or NULL: the WPP2024 national total to compare +against. When NULL it is looked up from the bundled WPP2024 table using +the median \code{pop_year_raster} in \code{lp_pop}.} +} +\value{ +a tibble with one row per gate: \code{iso3}, \code{gate}, +\code{description}, \code{n_violations}, \code{n_checked}, \code{passed}, +and \code{detail} (a compact listing of offending location periods). +} +\description{ +Run the population quality gates over one country's +location-period populations and return a tidy per-gate report. + +The gates encode failure modes that were verified against the extraction +corpus rather than inferred from reading code, so their thresholds are +calibrated to observed behaviour. Gate 3's band, for instance, is loose +because the observed adjustment factors span only 1.005-1.034 — anything +far outside that indicates the raster total was extracted on the wrong +polygon, not a genuine disagreement with WPP. + +Default \code{on_fail = "warn"}. Gate 4 currently fails corpus-wide (many +location periods legitimately share geometry with an alias record), so +aborting by default would make a full re-extraction impossible. Use +\code{on_fail = "abort"} only for gates you have already driven to zero. +} diff --git a/tests/testthat/test-add_population.R b/tests/testthat/test-add_population.R new file mode 100644 index 0000000..fe36e68 --- /dev/null +++ b/tests/testthat/test-add_population.R @@ -0,0 +1,213 @@ +# Offline WorldPop stand-in: a 0.01-degree raster over lon [0,3] x lat [0,1]. +# Each cell carries `value`, so a 1x1-degree square extracts to 10,000 * value. +# download_worldpop_constrained() is mocked to hand this file back, which keeps +# the real raster::raster() and exactextractr::exact_extract() code paths under +# test without any network access. +local_worldpop_stub <- function(value = 1, env = parent.frame()) { + r <- raster::raster(xmn = 0, xmx = 3, ymn = 0, ymx = 1, res = 0.01, + crs = "+proj=longlat +datum=WGS84") + raster::values(r) <- value + path <- withr::local_tempfile(fileext = ".tif", .local_envir = env) + raster::writeRaster(r, path, overwrite = TRUE) + testthat::local_mocked_bindings( + download_worldpop_constrained = function(...) path, + .env = env + ) + path +} + +sq <- function(x0) { + sf::st_polygon(list(rbind(c(x0, 0), c(x0 + 1, 0), c(x0 + 1, 1), + c(x0, 1), c(x0, 0)))) +} + +two_lp_fixture <- function(locations = c("AFR::ZZZ::A", "AFR::ZZZ::B"), + geoms = sf::st_sfc(sq(0), sq(1), crs = 4326), + year = 2018L) { + raw_sf <- sf::st_sf(location_period_id = c("100", "200"), geometry = geoms) + normalized <- data.frame( + location = rep(locations, each = 3L), + location_period_id = rep(c("100", "200"), each = 3L), + TL = as.Date(paste0(year, c("-01-01", "-02-01", "-03-01"))), + stringsAsFactors = FALSE + ) + list(raw_sf = raw_sf, normalized = normalized) +} + +testthat::test_that("add_population extracts pop and attaches the full provenance schema", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + fx <- two_lp_fixture() + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_true(all(c("pop", "pop_source", "pop_geom_dup_n", + "pop_geom_dup_class", "pop_year_obs", + "pop_year_raster", "pop_natl_ref", "adj_factor", + "adj_factor_flag") %in% names(res))) + testthat::expect_equal(nrow(res), nrow(fx$normalized)) + testthat::expect_equal(unique(res$pop), 10000, tolerance = 1e-6) + testthat::expect_equal(unique(res$pop_source), "worldpop_constrained") + testthat::expect_equal(unique(res$pop_geom_dup_n), 1L) + testthat::expect_equal(unique(res$pop_geom_dup_class), "unique") +}) + +testthat::test_that("a missing rgeoboundaries leaves pop unadjusted rather than union-scaled", { + testthat::skip_if_not_installed("sf") + testthat::skip_if(requireNamespace("rgeoboundaries", quietly = TRUE), + "rgeoboundaries is installed; the no-boundary path is untestable here") + local_worldpop_stub(value = 1) + + # COD is present in WPP2024, so tot_UN resolves and the *only* thing standing + # between the code and an adjustment factor is the national boundary. + fx <- two_lp_fixture() + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "COD", + boundary_cache_dir = withr::local_tempdir())) + + # No boundary -> adj_factor 1.0 and flagged "unadjusted". The old LP-union + # fallback would have understated country_raw and scaled every pop upward. + testthat::expect_true(all(res$pop_natl_ref > 0)) + testthat::expect_equal(unique(res$adj_factor), 1.0) + testthat::expect_equal(unique(res$adj_factor_flag), "unadjusted") + testthat::expect_equal(unique(res$pop), 10000, tolerance = 1e-6) +}) + +testthat::test_that("add_population records the observed year and the clamped raster year", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + fx <- two_lp_fixture(year = 2010L) # before the WorldPop constrained range + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_equal(unique(res$pop_year_obs), 2010L) + testthat::expect_equal(unique(res$pop_year_raster), 2015L) + testthat::expect_true(all(res$pop_year_obs != res$pop_year_raster)) +}) + +testthat::test_that("add_population flags LPs that share an identical geometry", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + # Two LPs at different hierarchy depths carrying the same polygon: the child + # is assigned the whole parent population. + fx <- two_lp_fixture( + locations = c("AFR::ZZZ::Conakry", "AFR::ZZZ::Conakry::Dixinn"), + geoms = sf::st_sfc(sq(0), sq(0), crs = 4326) + ) + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_equal(unique(res$pop_geom_dup_n), 2L) + testthat::expect_equal(unique(res$pop_geom_dup_class), "parent_inherited") +}) + +testthat::test_that("add_population emits NA, never 0, when WorldPop has no cells", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 0) + + fx <- two_lp_fixture() + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + # pop == 0 gives sCh/pop == Inf, which get_outbreak_threshold() classifies as + # "high" — a zero denominator flips the threshold instead of being missing. + testthat::expect_true(all(is.na(res$pop))) + testthat::expect_equal(unique(res$pop_source), "none") +}) + +testthat::test_that("add_population sets pop = NA for LPs with no geometry", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + fx <- two_lp_fixture() + fx$normalized$location_period_id[fx$normalized$location_period_id == "200"] <- "999" + + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_true(all(is.na(res$pop[res$location_period_id == "999"]))) + testthat::expect_equal(unique(res$pop_source[res$location_period_id == "999"]), + "none") + testthat::expect_false(any(is.na(res$pop[res$location_period_id == "100"]))) +}) + +testthat::test_that("a failed raster download yields NA pop with the schema intact", { + testthat::skip_if_not_installed("sf") + testthat::local_mocked_bindings( + download_worldpop_constrained = function(...) stop("no network") + ) + + fx <- two_lp_fixture() + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_true(all(is.na(res$pop))) + testthat::expect_equal(unique(res$pop_source), "none") + testthat::expect_equal(unique(res$pop_year_obs), 2018L) + testthat::expect_equal(unique(res$pop_geom_dup_class), "unique") +}) + +testthat::test_that("add_population returns the provenance schema when no LP id is usable", { + testthat::skip_if_not_installed("sf") + + fx <- two_lp_fixture() + fx$normalized$location_period_id <- NA_character_ + + testthat::expect_message( + res <- add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir()), + "no valid location_period_ids") + + testthat::expect_equal(nrow(res), nrow(fx$normalized)) + testthat::expect_true(all(is.na(res$pop))) + testthat::expect_equal(unique(res$pop_source), "none") + testthat::expect_equal(unique(res$pop_geom_dup_n), 1L) + testthat::expect_true(all(is.na(res$pop_year_obs))) +}) + +testthat::test_that("add_population accepts the camelCase and lctn_pr geometry keys", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + fx <- two_lp_fixture() + for (key in c("locationPeriod_id", "lctn_pr")) { + raw <- fx$raw_sf + names(raw)[names(raw) == "location_period_id"] <- key + res <- suppressMessages( + add_population(fx$normalized, raw, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + testthat::expect_equal(unique(res$pop), 10000, tolerance = 1e-6) + } + + raw <- fx$raw_sf + names(raw)[names(raw) == "location_period_id"] <- "nonsense" + testthat::expect_error(add_population(fx$normalized, raw, "ZZZ"), + "location_period_id") +}) + +testthat::test_that("add_population overwrites stale provenance columns instead of suffixing them", { + testthat::skip_if_not_installed("sf") + local_worldpop_stub(value = 1) + + fx <- two_lp_fixture() + fx$normalized$pop <- 42 + fx$normalized$pop_source <- "stale" + fx$normalized$adj_factor <- 99 + + res <- suppressMessages( + add_population(fx$normalized, fx$raw_sf, "ZZZ", + boundary_cache_dir = withr::local_tempdir())) + + testthat::expect_false(any(grepl("\\.x$|\\.y$", names(res)))) + testthat::expect_equal(unique(res$pop), 10000, tolerance = 1e-6) + testthat::expect_equal(unique(res$pop_source), "worldpop_constrained") +}) diff --git a/tests/testthat/test-build_composite_locations.R b/tests/testthat/test-build_composite_locations.R index 93147e8..6ee2c6c 100644 --- a/tests/testthat/test-build_composite_locations.R +++ b/tests/testthat/test-build_composite_locations.R @@ -161,3 +161,183 @@ testthat::test_that("build_composite_locations keeps summed-child pop when geome comp_row <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] testthat::expect_equal(comp_row$pop, 3000) # falls back to summed child pop }) + +# --------------------------------------------------------------------------- +# Population precedence and the parent fallback gate +# --------------------------------------------------------------------------- + +# A composite whose children are never observed atomically: only the parent +# admin unit ("Prov") carries an LP, a geometry and a population. +orphan_composite_fixture <- function() { + parent_poly <- sf::st_polygon( + list(rbind(c(0, 0), c(2, 0), c(2, 1), c(0, 1), c(0, 0)))) + raw_sf <- sf::st_sf( + location_period_id = "900", + geometry = sf::st_sfc(parent_poly), + crs = 4326 + ) + normalized <- data.frame( + location = c("AFR::ZZZ::Prov", "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("900", NA), + pop = c(7000, NA), + spatial_scale = c("admin1", "admin2"), + TL = as.Date(c("2018-01-01", "2018-01-01")), + pop_source = c("worldpop_constrained", NA), + stringsAsFactors = FALSE + ) + list(raw_sf = raw_sf, normalized = normalized) +} + +testthat::test_that("a composite with no child pop is left NA by default, not given its parent's", { + testthat::skip_if_not_installed("sf") + fx <- orphan_composite_fixture() + + res <- suppressMessages( + build_composite_locations(fx$normalized, fx$raw_sf, "ZZZ")) + + comp <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + testthat::expect_equal(nrow(comp), 1L) + # The parent is a strictly larger area, so inheriting 7000 would overstate the + # denominator by however much of Prov the composite does not cover. NA routes + # the composite to the "low" surveillance class instead. + testthat::expect_true(is.na(comp$pop)) + testthat::expect_equal(comp$pop_source, "none") +}) + +testthat::test_that("allow_parent_pop_fallback = TRUE opts into the parent population", { + testthat::skip_if_not_installed("sf") + fx <- orphan_composite_fixture() + + res <- suppressMessages( + build_composite_locations(fx$normalized, fx$raw_sf, "ZZZ", + allow_parent_pop_fallback = TRUE)) + + comp <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + testthat::expect_equal(comp$pop, 7000) + testthat::expect_equal(comp$pop_source, "parent_fallback") +}) + +testthat::test_that("WorldPop run on a parent polygon is classified parent_fallback, not composite_union", { + testthat::skip_if_not_installed("sf") + fx <- orphan_composite_fixture() + + # The composite has no child geometry, so step 6b puts it on the PARENT + # polygon. Extracting the raster there returns the parent's population — it + # must not be presented as a geometry-derived sub-area denominator. + testthat::local_mocked_bindings( + estimate_pop_for_geometries = function(geom_sf, country_iso3, year, ...) { + rep(5555, nrow(geom_sf)) + } + ) + + gated <- suppressMessages( + build_composite_locations(fx$normalized, fx$raw_sf, "ZZZ", + raster_dir = "ignored")) + comp <- gated$data[grepl("composite_loc_ZZZ", gated$data$location_period_id), ] + testthat::expect_true(is.na(comp$pop)) + testthat::expect_equal(comp$pop_source, "none") + + opted_in <- suppressMessages( + build_composite_locations(fx$normalized, fx$raw_sf, "ZZZ", + raster_dir = "ignored", + allow_parent_pop_fallback = TRUE)) + comp2 <- opted_in$data[grepl("composite_loc_ZZZ", opted_in$data$location_period_id), ] + testthat::expect_equal(comp2$pop_source, "parent_fallback") + # The atomic parent pop (7000) is preferred over the raster-on-parent value. + testthat::expect_equal(comp2$pop, 7000) +}) + +testthat::test_that("build_composite_locations never manufactures a zero denominator", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + # Both children have pop = NA. sum(na.rm = TRUE) over them returns 0, which + # would give sCh/0 == Inf and flip the composite into the "high" class. + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha", "AFR::ZZZ::Prov::Beta", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(NA_real_, NA_real_, NA_real_), + spatial_scale = rep("admin2", 3L), + TL = as.Date(rep("2018-01-01", 3L)), + stringsAsFactors = FALSE + ) + + res <- suppressMessages(build_composite_locations(normalized, raw_sf, "ZZZ")) + comp <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + + testthat::expect_true(is.na(comp$pop)) + testthat::expect_false(isTRUE(comp$pop == 0)) + testthat::expect_equal(comp$pop_source, "none") +}) + +testthat::test_that("composite pop_source is recorded and atomic rows keep theirs", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha", "AFR::ZZZ::Prov::Beta", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(1000, 2000, NA), + pop_source = c("worldpop_constrained", "worldpop_constrained", NA), + spatial_scale = rep("admin2", 3L), + TL = as.Date(rep("2018-01-01", 3L)), + stringsAsFactors = FALSE + ) + + res <- suppressMessages(build_composite_locations(normalized, raw_sf, "ZZZ")) + + comp <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + atomic <- res$data[res$data$location_period_id == "100", ] + + testthat::expect_equal(comp$pop_source, "child_sum") + testthat::expect_equal(comp$pop, 3000) + testthat::expect_equal(atomic$pop_source, "worldpop_constrained") +}) + +testthat::test_that("geometry-derived pop on a genuine child union is classified composite_union", { + testthat::skip_if_not_installed("sf") + + p1 <- sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))) + p2 <- sf::st_polygon(list(rbind(c(1, 0), c(2, 0), c(2, 1), c(1, 1), c(1, 0)))) + raw_sf <- sf::st_sf( + location_period_id = c("100", "200"), + geometry = sf::st_sfc(p1, p2), + crs = 4326 + ) + normalized <- data.frame( + location = c("AFR::ZZZ::Prov::Alpha", "AFR::ZZZ::Prov::Beta", + "AFR::ZZZ::Prov::Alpha|Beta"), + location_period_id = c("100", "200", NA), + pop = c(1000, 2000, NA), + spatial_scale = rep("admin2", 3L), + TL = as.Date(rep("2018-01-01", 3L)), + stringsAsFactors = FALSE + ) + + testthat::local_mocked_bindings( + estimate_pop_for_geometries = function(geom_sf, country_iso3, year, ...) { + rep(5555, nrow(geom_sf)) + } + ) + + res <- suppressMessages( + build_composite_locations(normalized, raw_sf, "ZZZ", raster_dir = "ignored")) + comp <- res$data[grepl("composite_loc_ZZZ", res$data$location_period_id), ] + + testthat::expect_equal(comp$pop, 5555) + testthat::expect_equal(comp$pop_source, "composite_union") +}) diff --git a/tests/testthat/test-detect_duplicate_geometries.R b/tests/testthat/test-detect_duplicate_geometries.R new file mode 100644 index 0000000..b47c461 --- /dev/null +++ b/tests/testthat/test-detect_duplicate_geometries.R @@ -0,0 +1,99 @@ +sq <- function(x0, y0, w = 1) { + sf::st_polygon(list(rbind(c(x0, y0), c(x0 + w, y0), c(x0 + w, y0 + w), + c(x0, y0 + w), c(x0, y0)))) +} + +testthat::test_that("distinct geometries are all class 'unique' with dup_n 1", { + testthat::skip_if_not_installed("sf") + + res <- detect_duplicate_geometries( + lp_ids = c("1", "2", "3"), + geoms = sf::st_sfc(sq(0, 0), sq(2, 0), sq(4, 0), crs = 4326), + lp_locations = c("AFR::ZZZ::A", "AFR::ZZZ::B", "AFR::ZZZ::C") + ) + + testthat::expect_equal(res$location_period_id, c("1", "2", "3")) + testthat::expect_equal(res$pop_geom_dup_n, rep(1L, 3L)) + testthat::expect_equal(unique(res$pop_geom_dup_class), "unique") +}) + +testthat::test_that("duplicates spanning >1 admin depth are 'parent_inherited'", { + testthat::skip_if_not_installed("sf") + + res <- detect_duplicate_geometries( + lp_ids = c("parent", "child_a", "child_b"), + geoms = sf::st_sfc(sq(0, 0), sq(0, 0), sq(0, 0), crs = 4326), + lp_locations = c("AFR::GIN::Conakry", + "AFR::GIN::Conakry::Dixinn", + "AFR::GIN::Conakry::Matam") + ) + + testthat::expect_equal(res$pop_geom_dup_n, rep(3L, 3L)) + testthat::expect_equal(unique(res$pop_geom_dup_class), "parent_inherited") +}) + +testthat::test_that("same-depth same-base-name duplicates are 'alias', not 'cross_unit'", { + testthat::skip_if_not_installed("sf") + + # "GN-FR.Fria" and "Fria" name one real place under two conventions. + res <- detect_duplicate_geometries( + lp_ids = c("10", "11"), + geoms = sf::st_sfc(sq(0, 0), sq(0, 0), crs = 4326), + lp_locations = c("AFR::GIN::GN-B::Fria", "AFR::GIN::GN-B::GN-FR.Fria") + ) + + testthat::expect_equal(unique(res$pop_geom_dup_class), "alias") + testthat::expect_equal(res$pop_geom_dup_n, c(2L, 2L)) +}) + +testthat::test_that("same-depth different-name duplicates are 'cross_unit'", { + testthat::skip_if_not_installed("sf") + + res <- detect_duplicate_geometries( + lp_ids = c("20", "21"), + geoms = sf::st_sfc(sq(0, 0), sq(0, 0), crs = 4326), + lp_locations = c("AFR::NGA::Lagos::Shomolu", "AFR::NGA::Nasarawa::Awe") + ) + + testthat::expect_equal(unique(res$pop_geom_dup_class), "cross_unit") +}) + +testthat::test_that("duplicates are 'unknown' when no location names are supplied", { + testthat::skip_if_not_installed("sf") + + res <- detect_duplicate_geometries( + lp_ids = c("1", "2", "3"), + geoms = sf::st_sfc(sq(0, 0), sq(0, 0), sq(5, 5), crs = 4326) + ) + + testthat::expect_equal(res$pop_geom_dup_n, c(2L, 2L, 1L)) + testthat::expect_equal(res$pop_geom_dup_class, c("unknown", "unknown", "unique")) +}) + +testthat::test_that("empty geometries are never duplicates of one another", { + testthat::skip_if_not_installed("sf") + + # Sharing "no footprint" says nothing about sharing a denominator. + res <- detect_duplicate_geometries( + lp_ids = c("e1", "e2", "real"), + geoms = sf::st_sfc(sf::st_polygon(), sf::st_polygon(), sq(0, 0), crs = 4326), + lp_locations = c("AFR::ZZZ::A", "AFR::ZZZ::B", "AFR::ZZZ::C") + ) + + testthat::expect_equal(res$pop_geom_dup_n, rep(1L, 3L)) + testthat::expect_equal(unique(res$pop_geom_dup_class), "unique") +}) + +testthat::test_that("detect_duplicate_geometries accepts an sf object and zero rows", { + testthat::skip_if_not_installed("sf") + + x <- sf::st_sf(location_period_id = c("1", "2"), + geometry = sf::st_sfc(sq(0, 0), sq(0, 0), crs = 4326)) + res <- detect_duplicate_geometries(x$location_period_id, x) + testthat::expect_equal(res$pop_geom_dup_n, c(2L, 2L)) + + empty <- detect_duplicate_geometries(character(0), sf::st_sfc(crs = 4326)) + testthat::expect_equal(nrow(empty), 0L) + testthat::expect_named(empty, c("location_period_id", "pop_geom_dup_n", + "pop_geom_dup_class")) +}) diff --git a/tests/testthat/test-get_country_boundary.R b/tests/testthat/test-get_country_boundary.R new file mode 100644 index 0000000..c11a025 --- /dev/null +++ b/tests/testthat/test-get_country_boundary.R @@ -0,0 +1,97 @@ +testthat::test_that("get_country_boundary returns NULL rather than a union when nothing resolves", { + testthat::skip_if_not_installed("sf") + + # A union of LP geometries is NOT a country boundary: it covers only the + # surveilled sub-areas, so country_raw is understated and adj_factor inflated. + # The contract is that an unresolvable boundary yields NULL ("skip the + # adjustment"), never an approximation. + empty_cache <- withr::local_tempdir() + + testthat::expect_message(res <- get_country_boundary("ZZZ", cache_dir = empty_cache)) + testthat::expect_null(res) +}) + +testthat::test_that("get_country_boundary returns NULL for an unparseable code", { + testthat::expect_message(res <- get_country_boundary("12", cache_dir = NULL), + "could not extract an ISO3 code") + testthat::expect_null(res) +}) + +testthat::test_that("get_country_boundary reads the on-disk cache without fetching", { + testthat::skip_if_not_installed("sf") + + cache <- withr::local_tempdir() + poly <- sf::st_sf( + id = 1L, + geometry = sf::st_sfc( + sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))), + crs = 4326 + ) + ) + sf::st_write(poly, file.path(cache, "ZZZ_adm0.geojson"), quiet = TRUE) + + res <- get_country_boundary("ZZZ", cache_dir = cache) + + testthat::expect_s3_class(res, "sf") + testthat::expect_equal(nrow(res), 1L) + testthat::expect_equal(sf::st_crs(res)$epsg, 4326L) +}) + +testthat::test_that("get_country_boundary tolerates a sub-national suffix", { + testthat::skip_if_not_installed("sf") + + cache <- withr::local_tempdir() + poly <- sf::st_sf( + id = 1L, + geometry = sf::st_sfc( + sf::st_polygon(list(rbind(c(0, 0), c(1, 0), c(1, 1), c(0, 1), c(0, 0)))), + crs = 4326 + ) + ) + sf::st_write(poly, file.path(cache, "TZA_adm0.geojson"), quiet = TRUE) + + res <- get_country_boundary("TZA::Mainland", cache_dir = cache) + testthat::expect_s3_class(res, "sf") +}) + +testthat::test_that("get_country_boundary refetches when the cache file is corrupt", { + testthat::skip_if_not_installed("sf") + + cache <- withr::local_tempdir() + writeLines("not geojson", file.path(cache, "ZZZ_adm0.geojson")) + + testthat::expect_message(res <- get_country_boundary("ZZZ", cache_dir = cache)) + testthat::expect_null(res) # no rgeoboundaries fallback available offline +}) + +testthat::test_that("band_adj_factor accepts the plausible band untouched", { + testthat::expect_equal(band_adj_factor(1.02), list(value = 1.02, flag = "ok")) + testthat::expect_equal(band_adj_factor(0.67)$flag, "ok") + testthat::expect_equal(band_adj_factor(1.5)$flag, "ok") +}) + +testthat::test_that("band_adj_factor accepts-and-flags the wide band", { + testthat::expect_message(wide <- band_adj_factor(1.8), "accepted but flagged") + testthat::expect_equal(wide$value, 1.8) + testthat::expect_equal(wide$flag, "wide") + + testthat::expect_message(low <- band_adj_factor(0.55)) + testthat::expect_equal(low$flag, "wide") +}) + +testthat::test_that("band_adj_factor clamps implausible factors to 1.0", { + # An extreme factor means the raster total was extracted on the wrong polygon, + # not that the country disagrees with WPP. Leave the population unadjusted. + testthat::expect_message(big <- band_adj_factor(12), "clamped to 1.0") + testthat::expect_equal(big$value, 1.0) + testthat::expect_equal(big$flag, "clamped") + + testthat::expect_message(small <- band_adj_factor(0.1)) + testthat::expect_equal(small$value, 1.0) +}) + +testthat::test_that("band_adj_factor clamps non-finite and non-positive factors", { + for (bad in list(NA_real_, NaN, Inf, 0, -1)) { + testthat::expect_equal(band_adj_factor(bad), list(value = 1.0, flag = "clamped")) + } +}) diff --git a/tests/testthat/test-validate_population.R b/tests/testthat/test-validate_population.R new file mode 100644 index 0000000..1ce7a18 --- /dev/null +++ b/tests/testthat/test-validate_population.R @@ -0,0 +1,146 @@ +gate_row <- function(qc, g) qc[as.character(qc$gate) == as.character(g), , drop = FALSE] + +clean_lp <- function() { + data.frame( + location_period_id = as.character(1:4), + location = c("AFR::ZZZ::A", "AFR::ZZZ::B", "AFR::ZZZ::C", "AFR::ZZZ::D"), + pop = c(1000, 2000, 3000, 4000), + pop_source = rep("worldpop_constrained", 4L), + pop_geom_dup_n = rep(1L, 4L), + pop_geom_dup_class = rep("unique", 4L), + adj_factor = rep(1.02, 4L), + pop_natl_ref = rep(10000, 4L), + stringsAsFactors = FALSE + ) +} + +testthat::test_that("validate_population passes every enforced gate on clean input", { + testthat::expect_silent(qc <- validate_population(clean_lp(), "ZZZ")) + + enforced <- qc[!qc$record_only, , drop = FALSE] + testthat::expect_true(all(enforced$passed)) + testthat::expect_true(all(is.na(enforced$detail))) + # Gates 1, 2, 3, 4, 5a, 5b, 6 are enforced; 7 and 8 are record-only. + testthat::expect_setequal(as.character(enforced$gate), + c("1", "2", "3", "4", "5a", "5b", "6")) +}) + +testthat::test_that("validate_population requires location_period_id and pop", { + testthat::expect_error( + validate_population(data.frame(location_period_id = "1"), "ZZZ"), + "location_period_id and pop" + ) +}) + +testthat::test_that("gate 1 fires on missing or non-finite pop", { + lp <- clean_lp() + lp$pop[2] <- NA_real_ + lp$pop[3] <- Inf + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 1") + + g <- gate_row(qc, 1L) + testthat::expect_false(g$passed) + testthat::expect_equal(g$n_violations, 2L) + testthat::expect_equal(g$n_checked, 4L) +}) + +testthat::test_that("gate 2 fires on a zero denominator", { + lp <- clean_lp() + lp$pop[1] <- 0 + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 2") + + testthat::expect_equal(gate_row(qc, 2L)$n_violations, 1L) + testthat::expect_equal(gate_row(qc, 2L)$detail, "1") + # A zero is present, not missing, so gate 1 is unaffected. + testthat::expect_true(gate_row(qc, 1L)$passed) +}) + +testthat::test_that("gate 3 fires outside [0.8, 1.5] and is skipped without adj_factor", { + lp <- clean_lp() + lp$adj_factor[4] <- 3.2 + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 3") + testthat::expect_equal(gate_row(qc, 3L)$n_violations, 1L) + + lp2 <- clean_lp() + lp2$adj_factor <- NULL + qc2 <- validate_population(lp2, "ZZZ") + testthat::expect_equal(nrow(gate_row(qc2, 3L)), 0L) +}) + +testthat::test_that("gates 4, 5a and 5b split the duplicate-geometry classes", { + lp <- clean_lp() + lp$pop_geom_dup_n <- c(2L, 2L, 3L, 1L) + lp$pop_geom_dup_class <- c("alias", "alias", "parent_inherited", "unique") + testthat::expect_warning(qc <- validate_population(lp, "ZZZ")) + + testthat::expect_equal(gate_row(qc, 4L)$n_violations, 3L) # broad net + testthat::expect_equal(gate_row(qc, "5a")$n_violations, 1L) # parent inheritance + testthat::expect_equal(gate_row(qc, "5b")$n_violations, 0L) # no cross-unit here + testthat::expect_true(gate_row(qc, "5b")$passed) +}) + +testthat::test_that("gate 5b catches same-depth cross-unit collisions that 5a misses", { + lp <- clean_lp() + lp$pop_geom_dup_n <- c(2L, 2L, 1L, 1L) + lp$pop_geom_dup_class <- c("cross_unit", "cross_unit", "unique", "unique") + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 5b") + + testthat::expect_equal(gate_row(qc, "5a")$n_violations, 0L) + testthat::expect_equal(gate_row(qc, "5b")$n_violations, 2L) +}) + +testthat::test_that("gate 6 fires when an LP exceeds the national total", { + lp <- clean_lp() + lp$pop[4] <- 50000 + testthat::expect_warning(qc <- validate_population(lp, "ZZZ", wpp_total = 10000), + "gate 6") + testthat::expect_equal(gate_row(qc, 6L)$n_violations, 1L) + testthat::expect_match(gate_row(qc, 6L)$description, "10,000") +}) + +testthat::test_that("gate 6 falls back to the median pop_natl_ref when wpp_total is NULL", { + lp <- clean_lp() + lp$pop[4] <- 50000 + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 6") + testthat::expect_equal(gate_row(qc, 6L)$n_violations, 1L) +}) + +testthat::test_that("gates 7 and 8 are record-only and never fail the run", { + lp <- clean_lp() # sum = 10000 vs national 10000 -> ratio 1.0 + lp$pop <- c(10, 10, 10, 10) + lp$pop_source <- c("worldpop_constrained", "none", "parent_fallback", "child_sum") + + qc <- validate_population(lp, "ZZZ", wpp_total = 1e6) + + g7 <- gate_row(qc, "7") + testthat::expect_true(g7$record_only) + testthat::expect_true(g7$passed) + testthat::expect_equal(g7$n_violations, 1L) # ratio far below 0.7, recorded only + testthat::expect_match(g7$detail, "ratio=") + + g8 <- gate_row(qc, "8") + testthat::expect_true(g8$record_only) + testthat::expect_equal(g8$n_violations, 1L) # one parent_fallback + testthat::expect_match(g8$detail, "worldpop_constrained=1") +}) + +testthat::test_that("validate_population counts each LP once even on a weekly frame", { + lp <- clean_lp() + lp$pop[1] <- 0 + weekly <- lp[rep(seq_len(nrow(lp)), each = 52L), , drop = FALSE] + + testthat::expect_warning(qc <- validate_population(weekly, "ZZZ"), "gate 2") + testthat::expect_equal(gate_row(qc, 2L)$n_checked, 4L) + testthat::expect_equal(gate_row(qc, 2L)$n_violations, 1L) +}) + +testthat::test_that("validate_population aborts instead of warning when asked", { + lp <- clean_lp() + lp$pop[1] <- 0 + testthat::expect_error(validate_population(lp, "ZZZ", on_fail = "abort"), "gate 2") +}) + +testthat::test_that("validate_population records the uppercased iso3", { + qc <- validate_population(clean_lp(), "zzz") + testthat::expect_true(all(qc$iso3 == "ZZZ")) +}) From c0142a95b52cfd32350ad844c62d80821b6a8a20 Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 6 Aug 2026 11:36:32 +0200 Subject: [PATCH 68/69] feat(detect): wire keep_nonoutbreak_locations into Stage 2 config Stage 2 was silently dropping every location with no detected outbreak, even though identify_outbreaks() already supported retaining them via keep_nonoutbreak_locations (added on this branch). Add the config key (default true) and pass it through in 02_run_outbreak_detection.R following the existing filter_outbreaks_by_size isTRUE(opt$...) pattern. Also adds the missing testthat coverage for keep_nonoutbreak_locations itself: default FALSE still drops a no-outbreak location, TRUE retains its full series labelled outbreak_number = 0 / "non-outbreak period", and TRUE leaves a location that does have a detected outbreak unchanged. Full suite: 257 assertions, 0 failures. Co-Authored-By: Claude Opus 4.6 --- analysis/02_run_outbreak_detection.R | 3 +- analysis/config_defaults.yml | 4 + tests/testthat/test-identify_outbreaks.R | 93 ++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 1 deletion(-) diff --git a/analysis/02_run_outbreak_detection.R b/analysis/02_run_outbreak_detection.R index a35057e..7fbaf3e 100644 --- a/analysis/02_run_outbreak_detection.R +++ b/analysis/02_run_outbreak_detection.R @@ -313,7 +313,8 @@ outbreak_list <- tryCatch( cumulative_min_cases = opt$cumulative_min_cases, nonzero_windows = opt$nonzero_windows, tail_period = opt$tail_period, - filter_outbreaks_by_size = isTRUE(opt$filter_outbreaks_by_size) + filter_outbreaks_by_size = isTRUE(opt$filter_outbreaks_by_size), + keep_nonoutbreak_locations = isTRUE(opt$keep_nonoutbreak_locations) ), error = function(e) { warning("identify_outbreaks() failed for ", diff --git a/analysis/config_defaults.yml b/analysis/config_defaults.yml index 02079b5..ead69ef 100644 --- a/analysis/config_defaults.yml +++ b/analysis/config_defaults.yml @@ -51,6 +51,10 @@ outbreak_start_definition: "consecutive" min_weeks_above: 2 require_increasing_trend: false tail_period: 6 +# When true, retain every location's full time series (outbreak_number = 0, +# Time Period = "non-outbreak period") instead of dropping locations with no +# detected outbreak. +keep_nonoutbreak_locations: true # --- dual_window params (ignored when outbreak_start_definition == "consecutive") --- window_weeks: 3 diff --git a/tests/testthat/test-identify_outbreaks.R b/tests/testthat/test-identify_outbreaks.R index a29feae..0a301c3 100644 --- a/tests/testthat/test-identify_outbreaks.R +++ b/tests/testthat/test-identify_outbreaks.R @@ -57,3 +57,96 @@ test_that("filter_small_outbreaks handles NA cases via na.rm", { out <- filter_small_outbreaks(df, min_total_cases = 50) expect_equal(out$outbreak_number, c(1, 1, 1, 0, 0)) }) + +# --------------------------------------------------------------------------- +# identify_outbreaks(): keep_nonoutbreak_locations +# --------------------------------------------------------------------------- + +# A location with zero cases every week never reaches risk == "high" (which +# requires sCh > 0), so it never gets an epidemic_start. This exercises the +# "no epidemic start found for this location" branch directly. +make_no_outbreak_data <- function(location = "QuietCountry", n_weeks = 10, pop = 1000) { + tl <- as.Date("2014-01-06") + 7L * seq(0L, n_weeks - 1L) + data.frame( + location = location, + TL = tl, + TR = tl + 6L, + sCh = rep(0, n_weeks), + pop = pop, + stringsAsFactors = FALSE + ) +} + +test_that("keep_nonoutbreak_locations = FALSE (default) drops locations with no epidemic start", { + df <- make_no_outbreak_data() + out <- identify_outbreaks( + threshold_type = "mean weekly incidence rate", + original_data = df, + zero_case_assumption = TRUE, + outbreak_start_definition = "consecutive", + min_weeks_above = 2, + window_weeks = 3, + cumulative_windows = 3, + cumulative_case_threshold_ratio = 1.5, + cumulative_trigger_type = "cumulative_case_threshold", + use_cumulative_trigger = FALSE, + cumulative_min_cases = NULL, + nonzero_windows = NULL, + tail_period = 6 + ) + expect_equal(nrow(out[["QuietCountry"]]), 0L) +}) + +test_that("keep_nonoutbreak_locations = TRUE retains the full series as a non-outbreak period", { + df <- make_no_outbreak_data() + out <- identify_outbreaks( + threshold_type = "mean weekly incidence rate", + original_data = df, + zero_case_assumption = TRUE, + outbreak_start_definition = "consecutive", + min_weeks_above = 2, + window_weeks = 3, + cumulative_windows = 3, + cumulative_case_threshold_ratio = 1.5, + cumulative_trigger_type = "cumulative_case_threshold", + use_cumulative_trigger = FALSE, + cumulative_min_cases = NULL, + nonzero_windows = NULL, + tail_period = 6, + keep_nonoutbreak_locations = TRUE + ) + loc_out <- out[["QuietCountry"]] + expect_equal(nrow(loc_out), nrow(df)) + expect_true(all(loc_out$outbreak_number == 0)) + expect_true(all(as.character(loc_out$`Time Period`) == "non-outbreak period")) +}) + +test_that("keep_nonoutbreak_locations = TRUE does not affect a location that does have an outbreak", { + outbreak_df <- data.frame( + location = "OutbreakCountry", + TL = as.Date("2014-01-06") + 7L * seq(0L, 9L), + TR = as.Date("2014-01-06") + 7L * seq(0L, 9L) + 6L, + sCh = c(50, 60, 55, 40, 30, 20, 5, 3, 2, 1), + pop = 1000, + stringsAsFactors = FALSE + ) + args <- list( + threshold_type = "mean weekly incidence rate", + original_data = outbreak_df, + zero_case_assumption = TRUE, + outbreak_start_definition = "consecutive", + min_weeks_above = 2, + window_weeks = 3, + cumulative_windows = 3, + cumulative_case_threshold_ratio = 1.5, + cumulative_trigger_type = "cumulative_case_threshold", + use_cumulative_trigger = FALSE, + cumulative_min_cases = NULL, + nonzero_windows = NULL, + tail_period = 6 + ) + out_default <- do.call(identify_outbreaks, args) + out_keep <- do.call(identify_outbreaks, c(args, list(keep_nonoutbreak_locations = TRUE))) + expect_equal(out_default[["OutbreakCountry"]], out_keep[["OutbreakCountry"]]) + expect_true(any(out_keep[["OutbreakCountry"]]$outbreak_number > 0)) +}) From 497074d6d6d961976a6c3f2cc48934fe9b3b537e Mon Sep 17 00:00:00 2001 From: javier Date: Thu, 6 Aug 2026 14:04:57 +0200 Subject: [PATCH 69/69] fix(population): compare each LP to its own year's national total in gate 6 Gate 6 of validate_population() compared every LP's pop against a single corpus-wide median(pop_natl_ref), which false-positives on any LP whose assigned year sits above the median year purely from population growth across the multi-year (2010-2024) extraction window. Caught on a BDI smoke test: the country-level LP (pop=12,404,228, assigned from 2020 WorldPop data) was flagged against a stale median reference (11,506,762) pulled down by earlier-year LPs, while its own year's true national total (12,617,036) correctly exceeded it -- no real violation. Gate 6 now uses each LP's own pop_natl_ref (or a caller-supplied wpp_total applied uniformly, when explicitly passed). Gate 7's corpus-wide aggregate check is unaffected -- a single reference value is still the right comparison basis there. Two regression tests added; full suite passes; re-running the BDI Stage 2 detection confirms gate 6 now checks 54/54 LPs with 0 violations, and no population values or detection output changed. Co-Authored-By: Claude Opus 4.6 --- R/validate_population.R | 44 ++++++++++++++++++----- tests/testthat/test-validate_population.R | 34 ++++++++++++++++++ 2 files changed, 69 insertions(+), 9 deletions(-) diff --git a/R/validate_population.R b/R/validate_population.R index 73a6bbc..e687875 100644 --- a/R/validate_population.R +++ b/R/validate_population.R @@ -116,20 +116,46 @@ validate_population <- function(lp_pop, iso3, on_fail = c("warn", "abort"), } # -- Gate 6: no LP exceeds the national total ------------------------------ - natl <- wpp_total - if (is.null(natl) && has("pop_natl_ref")) { - natl <- suppressWarnings(stats::median(lp$pop_natl_ref, na.rm = TRUE)) + # Compare each LP's pop against ITS OWN pop_natl_ref (the year-specific WPP + # total for the year that LP's population was actually assigned), not a + # single corpus-wide scalar. A country's true national total grows across a + # multi-year extraction window (e.g. 2010-2024), so comparing every LP to + # one fixed reference year produces false positives on any LP assigned a + # later year, purely from population growth, not a defect. Caught on BDI's + # country-level LP: pop=12,404,228 (year 2020) was flagged against the + # corpus-wide median reference (11,506,762, pulled down by earlier-year + # LPs), while its own year's true national total was 12,617,036 -- pop was + # correctly below its own reference; there was no real violation. + # When the caller supplies `wpp_total` explicitly, honor it as a single + # fixed comparison value instead (their deliberate choice, applied to every + # LP uniformly). + if (!is.null(wpp_total) && is.finite(wpp_total) && wpp_total > 0) { + ref6 <- rep(wpp_total, nrow(lp)) + ref6_desc <- format(round(wpp_total), big.mark = ",") + } else if (has("pop_natl_ref")) { + ref6 <- lp$pop_natl_ref + ref6_desc <- "each LP's own year-specific national total" + } else { + ref6 <- NULL } - if (!is.null(natl) && is.finite(natl) && natl > 0) { - g6 <- lp$location_period_id[!is.na(lp$pop) & lp$pop > natl] - add_gate(6L, sprintf("no location period exceeds the national total (%s)", - format(round(natl), big.mark = ",")), - g6, nrow(lp)) + + if (!is.null(ref6)) { + checked6 <- !is.na(lp$pop) & !is.na(ref6) & is.finite(ref6) & ref6 > 0 + g6 <- lp$location_period_id[checked6 & lp$pop > ref6] + add_gate(6L, sprintf("no location period exceeds the national total (%s)", ref6_desc), + g6, sum(checked6)) } # -- Gate 7: country total within 30% of WPP (record only) ----------------- # Record-only: the frame covers surveilled areas, not the whole country, so a - # shortfall is expected and is not by itself evidence of a defect. + # shortfall is expected and is not by itself evidence of a defect. This is a + # corpus-wide aggregate check, so (unlike gate 6) a single reference value is + # the right comparison basis -- median pop_natl_ref across the LPs actually + # summed, or the caller-supplied wpp_total. + natl <- wpp_total + if (is.null(natl) && has("pop_natl_ref")) { + natl <- suppressWarnings(stats::median(lp$pop_natl_ref, na.rm = TRUE)) + } if (!is.null(natl) && is.finite(natl) && natl > 0) { observed <- sum(lp$pop, na.rm = TRUE) ratio <- observed / natl diff --git a/tests/testthat/test-validate_population.R b/tests/testthat/test-validate_population.R index 1ce7a18..5cd62e6 100644 --- a/tests/testthat/test-validate_population.R +++ b/tests/testthat/test-validate_population.R @@ -105,6 +105,40 @@ testthat::test_that("gate 6 falls back to the median pop_natl_ref when wpp_total testthat::expect_equal(gate_row(qc, 6L)$n_violations, 1L) }) +testthat::test_that("gate 6 compares each LP to its own pop_natl_ref, not a corpus-wide median", { + # Regression test for the BDI smoke-test finding: a country's national + # total grows over a multi-year extraction window, so an LP assigned a + # later year (higher pop_natl_ref) must not be flagged against an earlier + # year's median just because other LPs in the same country were assigned + # earlier years. Three LPs simulate three assignment years with growing + # national totals; the fourth LP's pop is deliberately just below its OWN + # year's reference but above the median of the other three -- the old + # median-based gate 6 would have false-positived on it. + lp <- clean_lp() + lp$pop_natl_ref <- c(10000, 11000, 12000, 12600) + lp$pop <- c(1000, 2000, 3000, 12400) # LP 4: below its own ref (12600)... + # ...but above median(pop_natl_ref) = 11500, which the old implementation + # used as a single scalar for every row. + testthat::expect_silent(qc <- validate_population(lp, "ZZZ")) + + g6 <- gate_row(qc, 6L) + testthat::expect_true(g6$passed) + testthat::expect_equal(g6$n_violations, 0L) + testthat::expect_match(g6$description, "own year-specific") +}) + +testthat::test_that("gate 6 still fires when an LP exceeds its OWN pop_natl_ref", { + lp <- clean_lp() + lp$pop_natl_ref <- c(10000, 11000, 12000, 12600) + lp$pop <- c(1000, 2000, 3000, 13000) # LP 4: above its own ref (12600) + testthat::expect_warning(qc <- validate_population(lp, "ZZZ"), "gate 6") + + g6 <- gate_row(qc, 6L) + testthat::expect_false(g6$passed) + testthat::expect_equal(g6$n_violations, 1L) + testthat::expect_equal(g6$detail, "4") +}) + testthat::test_that("gates 7 and 8 are record-only and never fail the run", { lp <- clean_lp() # sum = 10000 vs national 10000 -> ratio 1.0 lp$pop <- c(10, 10, 10, 10)