diff --git a/.github/workflows/docs.yaml b/.github/workflows/docs.yaml new file mode 100644 index 0000000..a685168 --- /dev/null +++ b/.github/workflows/docs.yaml @@ -0,0 +1,75 @@ +# Build the Quarto docs site in docs/ and publish it to GitHub +# Pages. Same pattern as sciSpatialR's pkgdown workflow. +# +# The site is rebuilt from docs/ on every run and handed to Pages +# as a build artifact, so no rendered HTML is ever committed and +# there is no gh-pages branch to keep in sync. Pull requests build +# but do not publish, which surfaces a broken page during review +# rather than after merge. +# +# The pages are plain Markdown, so Quarto renders them without R. +# Which pages are built is set by `project: render` in +# docs/_quarto.yml. +# +# Repository prerequisite: Settings > Pages > Source = "GitHub +# Actions". Without that, the deploy job fails with a 404. + +name: docs + +on: + push: + branches: [main] + paths: + - "docs/**" + - ".github/workflows/docs.yaml" + pull_request: + paths: + - "docs/**" + - ".github/workflows/docs.yaml" + workflow_dispatch: + +# Deny by default; each job requests only the scopes it needs. +permissions: {} + +# Serialize publishing. Queued runs collapse to the newest, but an +# in-flight deployment is allowed to finish so the live site is +# never left half-written. +concurrency: + group: pages + cancel-in-progress: false + +jobs: + build: + runs-on: ubuntu-latest + permissions: + contents: read + steps: + - uses: actions/checkout@v7 + + - uses: quarto-dev/quarto-actions/setup@v2 + + # Renders to docs/_site, as set in docs/_quarto.yml + - name: Build site + run: quarto render docs + + # No configure-pages step: Quarto reads its base URL from + # `site-url` in docs/_quarto.yml, so this job stays on + # contents:read alone. + - uses: actions/upload-pages-artifact@v5 + with: + path: docs/_site + + deploy: + # Publishing is a main-branch-only consequence of a green build. + if: github.event_name != 'pull_request' && github.ref == 'refs/heads/main' + needs: build + runs-on: ubuntu-latest + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + permissions: + pages: write + id-token: write + steps: + - id: deployment + uses: actions/deploy-pages@v5 diff --git a/.gitignore b/.gitignore index 32f0512..3b432fd 100644 --- a/.gitignore +++ b/.gitignore @@ -55,5 +55,19 @@ vignettes/*.pdf !3_output/**/ !3_output/**/.gitkeep +# ...but keep the small, diffable summaries of each experiment: +# the run record, the report and the summary tables. They are +# what lets experiments be compared from the repository alone. +# Per-species detail (coefficient_summary.csv, +# parity_terms.csv) is large and is rebuilt from the +# 2_pipeline/ stores, so it stays ignored. +!3_output/**/run_record.md +!3_output/**/report.md +!3_output/**/tables/parity_summary.csv +!3_output/**/tables/coverage.csv +!3_output/**/tables/metric_summary.csv +!3_output/**/tables/grid_summary.csv +!3_output/**/tables/v2_self_agreement_summary.csv + AGENTS.md CLAUDE.md diff --git a/0_data/v2_scripts/README.md b/0_data/v2_scripts/README.md new file mode 100644 index 0000000..f5f983d --- /dev/null +++ b/0_data/v2_scripts/README.md @@ -0,0 +1,53 @@ +# v2_scripts + +![Status](https://img.shields.io/badge/Status-Reference%20only-lightgrey) +![Languages](https://img.shields.io/badge/Languages-R-blue) + +Cloned snapshots of the v2 modelling code, taken on **2026-09-08**, one +subfolder per taxon. + +These are the code as received, kept unmodified. They are the reference the +rewritten modules in `1_code/modules/` are checked against, and they are +**not run** — nothing in the harness, modules, or experiments sources them. +Subfolder names match those under `1_code/modules/`, so each module has an +obvious reference. + +## Sources + +| Folder | Source | Taken from | Commit | +| --- | --- | --- | --- | +| `birds/` | | whole repository | `1a3e086` (2026-04-22) | +| `mammals/` | | `1_code/2_habitat-modeling/2024/` | `2874dec` (2026-09-01) | +| `plants/` | `\\ABMI-DATA2\science\sc\ToEmily\VegetationModels\1_code\r-scripts` | `1_code/r-scripts/` | `24e97e3` (2025-04-02) | + +Each snapshot was verified against its source on 2026-09-08: + +- `birds/` — 21 files, cloned that day from `main`. +- `mammals/` — 21 files, every blob hash matches the commit above. +- `plants/` — 19 files, byte-identical to the network path. + +The `plants/` source is a working copy on ABMI-DATA2 of +, on `main`. The commit was read +from its `.git` refs; whether that working copy had uncommitted changes was +not checked, so treat the commit as indicative rather than exact. + +Soil mites sit in `plants/` because that is how the vegetation repository +groups them — "plant group" names a file layout, not a taxonomy, and covers +vascular plants, bryophytes, lichens and soil mites alike. + +## No nested repositories + +The `.git/` directories were not kept. An embedded repository is recorded by +the parent as a gitlink rather than as files, which would leave these scripts +untracked here. Re-clone at the commit above to recover history. + +`birds/.gitignore` came with the clone and was kept as received. It applies +to that subtree and would exclude `data/`, `figs/` and `out/` if any were +added there. + +## Refreshing a snapshot + +Replace the folder's contents, update the commit and date in the table above, +and re-check the rewritten module against it. A change here is a change to +the reference the parity gate is measured against, so it should not be made +silently — see [Parity gate](../../README.md#parity-gate). diff --git a/0_data/v2_scripts/birds/.gitkeep b/0_data/v2_scripts/birds/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/0_data/v2_scripts/birds/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/modules/birds/00.ClimateModels.R b/0_data/v2_scripts/birds/00.ClimateModels.R similarity index 100% rename from 1_code/modules/birds/00.ClimateModels.R rename to 0_data/v2_scripts/birds/00.ClimateModels.R diff --git a/1_code/modules/birds/00.Functions.R b/0_data/v2_scripts/birds/00.Functions.R similarity index 100% rename from 1_code/modules/birds/00.Functions.R rename to 0_data/v2_scripts/birds/00.Functions.R diff --git a/1_code/modules/birds/00.NorthModels.R b/0_data/v2_scripts/birds/00.NorthModels.R similarity index 100% rename from 1_code/modules/birds/00.NorthModels.R rename to 0_data/v2_scripts/birds/00.NorthModels.R diff --git a/1_code/modules/birds/00.SouthModels.R b/0_data/v2_scripts/birds/00.SouthModels.R similarity index 100% rename from 1_code/modules/birds/00.SouthModels.R rename to 0_data/v2_scripts/birds/00.SouthModels.R diff --git a/1_code/modules/birds/06.ModelClimate.R b/0_data/v2_scripts/birds/06.ModelClimate.R similarity index 100% rename from 1_code/modules/birds/06.ModelClimate.R rename to 0_data/v2_scripts/birds/06.ModelClimate.R diff --git a/1_code/modules/birds/07.ModelLandcover.R b/0_data/v2_scripts/birds/07.ModelLandcover.R similarity index 100% rename from 1_code/modules/birds/07.ModelLandcover.R rename to 0_data/v2_scripts/birds/07.ModelLandcover.R diff --git a/1_code/modules/birds/08.PackageCoefficients.R b/0_data/v2_scripts/birds/08.PackageCoefficients.R similarity index 100% rename from 1_code/modules/birds/08.PackageCoefficients.R rename to 0_data/v2_scripts/birds/08.PackageCoefficients.R diff --git a/1_code/modules/birds/09.Predict.R b/0_data/v2_scripts/birds/09.Predict.R similarity index 100% rename from 1_code/modules/birds/09.Predict.R rename to 0_data/v2_scripts/birds/09.Predict.R diff --git a/1_code/modules/birds/10.Visualize.R b/0_data/v2_scripts/birds/10.Visualize.R similarity index 100% rename from 1_code/modules/birds/10.Visualize.R rename to 0_data/v2_scripts/birds/10.Visualize.R diff --git a/1_code/modules/birds/11.Compare.R b/0_data/v2_scripts/birds/11.Compare.R similarity index 100% rename from 1_code/modules/birds/11.Compare.R rename to 0_data/v2_scripts/birds/11.Compare.R diff --git a/1_code/.gitkeep b/1_code/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/_scratch.R b/1_code/_scratch.R new file mode 100644 index 0000000..a3df377 --- /dev/null +++ b/1_code/_scratch.R @@ -0,0 +1,28 @@ +# --- +# title: Scratch Work +# author: Brendan Casey +# created: 2026-09-06 +# inputs: +# - ad hoc, temporary inputs as needed +# outputs: +# - none by default +# notes: +# Temporary workspace for testing, exploration, and one-off +# tasks. Keep work grouped under dated headings and move any +# durable code into the appropriate script or module. +# +# Headings run three deep, so the Outline menu reads as a +# day > task > step outline: +# # YYYY-MM-DD ---- one per day of scratch work +# ## Task ---- one per piece of work that day, named +# for what it does, not for the date +# ### Step ---- stages within a task; the first is +# Setup, loading packages and data +# +# Add new code under the current date heading, creating that +# heading if the day does not have one yet. A day with only +# one task still gets both a date and a task heading, so the +# outline stays the same shape throughout. +# --- + +# End of script ---- diff --git a/1_code/_setup/00_mirror_setup_inputs.R b/1_code/_setup/00_mirror_setup_inputs.R new file mode 100644 index 0000000..4a2430a --- /dev/null +++ b/1_code/_setup/00_mirror_setup_inputs.R @@ -0,0 +1,268 @@ +# --- +# title: Mirror the _setup Inputs onto ABMI-DATA2 +# author: Brendan Casey +# created: 2026-10-05 +# inputs: +# the original locations of every external file _setup/ reads, +# listed in section 1.3: +# - //ABMI-DATA2/science/sc/sdmMethodsDev/0_data/ +# data_snapshots/model_ready_v2/ +# - //ABMI-DATA2/science/sc/AB_data_v2023/sites/processed/ +# climate/ +# - //ABMI-DATA2/science/sc/ToEmily/VegetationModels/ +# - the work_abmi, BirdModels and ABMI Mammals Google drives +# outputs: +# in //ABMI-DATA2/science/sdmMethodsDev/0_data/setup_inputs/ +# (SDM_SETUP_INPUT_ROOT overrides it): +# - /..., byte-for-byte copies, under each source's +# own relative paths +# - inputs_manifest.csv: per file, the original path, the +# mirror path, bytes, md5, source modification time and +# the date it was copied +# - README.md: what the folder is and the rules for it +# notes: +# - Makes _setup/ runnable by anyone with ABMI-DATA2 access. +# Originals are never modified. +# - Never overwrites the mirror: mirrored files are md5-checked +# and skipped, and a changed source stops the script (move the +# old copy aside to re-mirror). Copies go via a .partial name. +# - Not mirrored, deliberately: +# - the v2 coefficient outputs on the drives (the bird +# coefficient CSVs, COEFS.RData, the mammal coefficient +# tables). Parity is scored against ABMIexploreR (08), so +# nothing in _setup/ reads them. +# - _setup/08's species-coefs.RData, which 08 downloads from +# the public ABMIexploreR repository at a pinned commit. +# - 0_data/v2_scripts/, which is tracked in git. +# - Run once, from the repository root, by someone who can +# reach every source. Reads are serial: the Google Drive +# mount refuses concurrent reads. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # manifest reading and writing (version: 1.16.4) + +## 1.2 Resolve the mirror ---- +project_root <- normalizePath(getwd(), winslash = "/") +helper <- file.path(project_root, "1_code/_setup/utils/input_paths.R") + +if (!file.exists(helper)) { + stop("Run this from the repository root.", call. = FALSE) +} + +source(helper) + +manifest_path <- setup_input("inputs_manifest.csv") + +## 1.3 The inventory ---- +# One entry per source: where it lives, and the paths below it +# that _setup/ reads. A path that is a folder is copied whole. +# The mirror keeps each path below a folder named for the source, +# so the scripts' roots (SDM_V2_PROJECT and the like) carry over. +sources <- list( + model_ready_v2 = list( + from = paste0( + "//ABMI-DATA2/science/sc/sdmMethodsDev/0_data/", + "data_snapshots/model_ready_v2" + ), + paths = "." + ), + ab_data_v2023 = list( + from = paste0( + "//ABMI-DATA2/science/sc/AB_data_v2023/sites/processed/", + "climate" + ), + paths = "abmi-camera-climate_2023.Rdata" + ), + vegetation_models = list( + from = "//ABMI-DATA2/science/sc/ToEmily/VegetationModels", + paths = c( + "0_data/lookup/prediction-matrix", + "0_data/species/processed/bryophyte-model-data.Rdata", + "0_data/bootstrap/bryophyte-bootstrap-ids.Rdata", + "0_data/bootstrap/lichen-bootstrap-ids.Rdata", + "0_data/bootstrap/mite-bootstrap-ids.Rdata", + "0_data/bootstrap/vascular-plant-bootstrap-ids.Rdata" + ) + ), + birds_data_v2 = list( + from = paste0( + "G:/Shared drives/work_abmi/1_projects/active/", + "sdmMethodsDev/remote/birds_data_v2" + ), + paths = "Stratified.Rdata" + ), + bird_models = list( + from = paste0( + "G:/.shortcut-targets-by-id/", + "17Ymt13eHfKvIiuoMl6x-Kn74Z2uVbbzS/BirdModels" + ), + paths = c( + "Data/lookups/Xn-veg-v2024.Rdata", + "Data/lookups/birdlist.csv" + ) + ), + abmi_mammals = list( + from = "G:/Shared drives/ABMI Mammals", + paths = c( + paste0( + "Results/Habitat Modeling/2024/Climate/Predictions/", + "All Species Climate Predictions.csv" + ), + "Data/Lookup Tables/WildTrax Species Strings.RData" + ) + ) +) + +# 2. List the files ---- +# Stops before copying if any source is unreachable + +## 2.1 Expand each source ---- +files <- rbindlist(lapply(names(sources), function(name) { + src <- sources[[name]] + + rel <- unlist(lapply(src$paths, function(path) { + full <- file.path(src$from, path) + + if (dir.exists(full)) { + inside <- list.files(full, recursive = TRUE) + if (path == ".") inside else file.path(path, inside) + } else { + path + } + })) + + data.table( + source = name, + from = file.path(src$from, rel), + to = file.path(name, rel) + ) +})) + +## 2.2 Check every source is reachable ---- +missing <- files$from[!file.exists(files$from)] + +if (length(missing) > 0) { + stop( + "Source file(s) not found:\n ", + paste(missing, collapse = "\n "), + call. = FALSE + ) +} + +cat( + nrow(files), " files, ", + round(sum(file.size(files$from)) / 1e9, 2), " GB, from ", + length(sources), " sources\n", + sep = "" +) + +# 3. Copy ---- + +## 3.1 The previous manifest, to keep first-copy dates ---- +previous <- if (file.exists(manifest_path)) { + fread(manifest_path, colClasses = "character") +} else { + NULL +} + +## 3.2 Copy each file ---- +rows <- vector("list", nrow(files)) + +for (i in seq_len(nrow(files))) { + from <- files$from[i] + to <- setup_input(files$to[i]) + source_md5 <- unname(tools::md5sum(from)) + + if (file.exists(to)) { + # Already mirrored: the copy must still match its source + if (!identical(unname(tools::md5sum(to)), source_md5)) { + stop( + "The source has changed since it was mirrored:\n ", + from, "\nThe mirror is never overwritten. Move\n ", to, + "\naside first if the new version should replace it.", + call. = FALSE + ) + } + + copied <- if (is.null(previous)) { + NA_character_ + } else { + previous$copied[match(files$to[i], previous$path)] + } + status <- "present" + } else { + dir.create(dirname(to), recursive = TRUE, showWarnings = FALSE) + partial <- paste0(to, ".partial") + + if (!file.copy(from, partial, overwrite = TRUE, + copy.date = TRUE)) { + stop("Copy failed:\n ", from, call. = FALSE) + } + + if (!identical(unname(tools::md5sum(partial)), source_md5)) { + unlink(partial) + stop("md5 mismatch after copying:\n ", from, call. = FALSE) + } + + if (!file.rename(partial, to)) { + stop("Could not rename into place:\n ", to, call. = FALSE) + } + + copied <- NA_character_ + status <- "copied" + } + + rows[[i]] <- data.table( + source = files$source[i], + path = files$to[i], + original = from, + bytes = file.size(from), + md5 = source_md5, + source_modified = format( + file.mtime(from), "%Y-%m-%d %H:%M:%S" + ), + copied = if (is.na(copied)) format(Sys.Date()) else copied + ) + + cat(sprintf("[%d/%d] %s %s\n", i, nrow(files), status, files$to[i])) +} + +# 4. Record ---- + +## 4.1 The manifest ---- +# Rows for files dropped from the inventory are kept as +# provenance for copies still in the mirror +manifest <- rbindlist(rows) + +if (!is.null(previous)) { + kept <- previous[!path %in% manifest$path] + manifest <- rbind(manifest, kept, fill = TRUE) +} + +setorder(manifest, source, path) +fwrite(manifest, manifest_path) + +## 4.2 The README ---- +writeLines(c( + "# _setup inputs for sdmMethodsDev", + "", + "Byte-for-byte copies of every external file that", + "`1_code/_setup/` in the sdmMethodsDev repository reads, so", + "anyone with access to this share can rebuild the test", + "dataset. Written by `1_code/_setup/00_mirror_setup_inputs.R`.", + "", + "- Do not edit, rename or delete anything here. The _setup", + " scripts read these paths by default.", + "- `inputs_manifest.csv` gives each file's original location,", + " size, md5 and the date it was copied.", + "- The originals were left in place; the manifest names them.", + "- 04 and 05's inputs are not here: their output,", + " `v2_results/`, is published frozen under `../v2_results/`." +), setup_input("README.md")) + +cat("\nWrote", manifest_path, "\n") + +# End of script ---- diff --git a/1_code/_setup/01_harmonize_model_ready_v2.R b/1_code/_setup/01_harmonize_model_ready_v2.R index 0695052..523fcd8 100644 --- a/1_code/_setup/01_harmonize_model_ready_v2.R +++ b/1_code/_setup/01_harmonize_model_ready_v2.R @@ -3,6 +3,8 @@ # author: Brendan Casey # created: 2026-09-05 # inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. # from 0_data/data_snapshots/model_ready_v2/ on ABMI-DATA2: # - vascular-plant-model-data.Rdata # - bryophyte-model-data.Rdata @@ -14,6 +16,9 @@ # coefficients 2024.RData # from the ABMI Mammals shared drive: # - Lookup Tables/WildTrax Species Strings.RData +# from the work_abmi shared drive, read-only: +# - 1_projects/active/sdmMethodsDev/remote/birds_data_v2/ +# Stratified.Rdata, the copy v2's birds were fitted on # outputs: # in 0_data/test_dataset/: # - sites.csv one row per survey unit, all sources @@ -22,13 +27,48 @@ # - lichen.csv survey_unit_id + species columns # - mite.csv survey_unit_id + species columns # - mammal.csv survey_unit_id + species columns +# - bird.csv survey_unit_id + species counts +# - bird_offsets.csv survey_unit_id + QPAD log offsets +# - covariates.csv survey_unit_id + taxon + every +# covariate, all taxa in one table +# in 0_data/test_dataset/lookup/: +# - veg_prediction_matrix.csv north habitat prediction grid +# - soil_prediction_matrix.csv south habitat prediction grid +# - modelled_species.csv which species each model set +# is fitted for, per plant taxon +# - mammal__prediction_matrix.csv +# - mammal_modelled_species.csv +# - mammal_climate_predictions.csv +# - bird_modelled_species.csv species x region work queue +# - bird_bootstrap_ids.csv the 100 bootstrap draws +# - bird_factor_levels.csv factor levels, source order +# - covariate_columns.csv which block each covariates +# column came from, per taxon # notes: -# Source files use two incompatible survey designs, so -# they are harmonized into one shared convention rather than -# one table: every taxon CSV is `survey_unit_id` followed by -# that taxon's species columns, and every identity, design and -# location field is factored out into sites.csv. Join any taxon -# CSV to sites.csv on survey_unit_id. +# - Every taxon CSV is survey_unit_id + species columns; +# identity, design and location fields go to sites.csv. The +# covariate and lookup tables let the modules run from +# 0_data/test_dataset/ alone. +# - covariates.csv is keyed on survey_unit_id AND taxon (taxa +# disagree on shared quadrats; see section 5.4). Filter on +# taxon before joining, then drop empty columns. +# - Names in more than one block are block-suffixed (e.g. +# Crop_veg, Crop_soil); lookup/covariate_columns.csv maps +# each column to its block and v2 spelling. +# - The plant-group mite covariates differ from vascular plant +# mostly in the Surr* buffer terms (20 columns carry 67% of +# differing veg cells, 80% of soil), in every year 2007-2022: +# likely a different upstream extraction, unconfirmable here. +# - Mammal covariates and prediction matrices come from the +# SpTable files (matrices checked identical to the ABMI +# Mammals drive CSVs); the climate block is replaced (1.6). +# - Birds come from Stratified.Rdata (1.10), read-only +# (SDM_BIRD_DATA overrides). Prediction matrices come from +# the vegetation models project (1.8; SDM_V2_LOOKUP +# overrides). +# - TODO: the plant-group files are read twice (response, then +# covariates); simpler than threading one environment, and +# this runs once per snapshot. # --- # 1. Setup ---- @@ -39,29 +79,23 @@ library(data.table) ## 1.2 Configure paths ---- project_root <- normalizePath(getwd(), winslash = "/") -# Directory containing the v2 model ready snapshot files on ABMI-DATA2 +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(project_root, "1_code/_setup/utils/input_paths.R")) + snapshot_dir <- Sys.getenv( "SDM_SNAPSHOT_V2", - unset = paste0( - "//ABMI-DATA2/science/sc/sdmMethodsDev/0_data/", - "data_snapshots/model_ready_v2" - ) + unset = setup_input("model_ready_v2") ) -# Output is the frozen test dataset itself, so it lands in -# 0_data/test_dataset/. That folder is otherwise read-only: this -# script is what writes it, by hand and once per snapshot, and -# every experiment then treats the result as fixed. The CSVs are -# gitignored along with the rest of 0_data/. +# The frozen test dataset; only this script writes it output_dir <- file.path(project_root, "0_data/test_dataset") +lookup_dir <- file.path(output_dir, "lookup") + ## 1.3 Name the source files ---- -# Plant-group files share one schema, mammal files another. -# -# "Plant group" names a file layout, not a taxonomy. It covers -# vascular plants, bryophytes, lichens and soil mites, because -# all four are surveyed on the same site-year-quadrant design -# and arrive in the same three-frame layout. +# "Plant group" is a file layout (the site-year-quadrant design), +# not a taxonomy: vascular plants, bryophytes, lichens and soil +# mites. Mammal files have another schema. plant_files <- c( vascular_plant = "vascular-plant-model-data.Rdata", bryophyte = "bryophyte-model-data.Rdata", @@ -81,12 +115,9 @@ mammal_files <- c( ) ## 1.4 Name the plant-group non-species columns ---- -# Plant-group frames are identity + species + site and climate. -# Species are whatever is left once the other two are named, so -# both are listed here rather than found by position: column -# order is an accident of how the files were built, and `Protocol` -# already sits last in two of the four files rather than with the -# site block it belongs to. +# Species are whatever is left once identity and site columns +# are named; column order is not reliable (`Protocol` sits last +# in two of the four files). # The six identity columns every plant-group frame opens with. plant_id_cols <- c( @@ -155,21 +186,235 @@ plant_site_cols <- c( "Protocol" ) -## 1.5 Name the WildTrax species lookup ---- +# Fields sites.csv carries, dropped from the climate table; the +# loader joins them back under their v2 names +plant_site_cols_in_sites <- c( + "Lat", + "Long", + "Elevation", + "NR", + "NSR", + "LufName", + "Easting", + "Northing" +) + +# Products of stored columns, not written: the loader recomputes +# them as 01a_data-standardization.R did. Stored separately they +# would drift apart at CSV precision (Northing2 off by ~0.05). +plant_site_cols_derived <- c( + "Easting2", + "Northing2", + "EastingNorthing", + "MAPPET", + "MAT2", + "CMDMAT", + "MWMT2" +) + +## 1.5 Name the mammal column blocks ---- +# The mammal frame `d`: species from its first_sp_col and +# last_sp_col indices; the two non-habitat blocks are named +# below and habitat is the remainder (checked in 6.6). + +# Design and identity fields. sites.csv already carries these, +# so they are dropped from the covariate tables. +mammal_site_cols <- c( + "project", + "location", + "SummerDays", + "WinterDays", + "Lat", + "Long", + "NearestSite", + "NR", + "NSR", + "LUF", + "Lured" +) + +# Model covariates that are not habitat: climate, the aspen and +# Peace River terms, the subregion factor, the deployment key the +# climate predictions join on, and the seasonal model weights. +# Not every column is in both files - pAspen and PeaceRiver are +# south only, NSR1 north only. +mammal_climate_cols <- c( + "AHM", + "PET", + "FFP", + "MAP", + "MAT", + "MCMT", + "MWMT", + "TrueLat", + "pAspen", + "NSR1", + "PeaceRiver", + "location_project", + "wt_summer", + "wt_winter" +) + +## 1.6 Name the mammal camera climate ---- +# The v2 mammal climate pipeline joins this file, not the +# SpTable's climate block (they differ by up to 531 mm MAP at +# matched deployments), so its columns replace the SpTable's. +# Also the only mammal source of CMD and TD. +mammal_camera_climate_file <- Sys.getenv( + "SDM_MAMMAL_CAMERA_CLIMATE", + unset = setup_input( + "ab_data_v2023", "abmi-camera-climate_2023.Rdata" + ) +) + +# Not pAspen: v2's south models fit the SpTable's own (up to +# 0.92 different at matched deployments) +mammal_camera_climate_cols <- c( + "MAT", "MWMT", "MCMT", "TD", "MAP", "MSP", "AHM", + "SHM", "DD_0", "DD5", "DD_18", "DD18", "NFFD", "bFFP", "eFFP", + "FFP", "PAS", "EMT", "EXT", "Eref", "CMD", "RH", "CMI", + "DD1040", "bio9", "bio15", "HTV" +) + +## 1.7 Name the mammal climate predictions ---- +# The climate prediction 03_basic-models.R reads for both +# regions, from a separate pipeline; copied in +mammal_climate_pred_file <- Sys.getenv( + "SDM_MAMMAL_CLIMATE_PRED", + unset = setup_input( + "abmi_mammals", + "Results/Habitat Modeling/2024/Climate/Predictions", + "All Species Climate Predictions.csv" + ) +) + +## 1.8 Name the v2 prediction-matrix lookups ---- +# The v2 scripts read these CSVs, not the snapshot's veg.pm and +# soil.pm. The veg CSV adds Peatland, Mineral, Upland and +# CCR1234 (needed by four of the twelve veg models) and drops +# MarshSwamp, CCPineR1, CCPine234, CCWhiteSpruceR1 and +# CCDecidMixedR1; shared columns are identical, as are the soil +# matrices. The snapshot is the fallback (reported in 7.4). +v2_lookup_dir <- Sys.getenv( + "SDM_V2_LOOKUP", + unset = setup_input( + "vegetation_models", "0_data/lookup/prediction-matrix" + ) +) + +v2_lookup_files <- c( + veg_prediction_matrix = "veg-prediction-matrix-CC_2024.csv", + soil_prediction_matrix = "soil-prediction-matrix_2024.csv" +) + +## 1.9 Name the WildTrax species lookup ---- # The naming authority for mammal species. wt_species_file <- Sys.getenv( "SDM_WT_SPECIES", - unset = paste0( - "G:/Shared drives/ABMI Mammals/Data/Lookup Tables/", + unset = setup_input( + "abmi_mammals", "Data/Lookup Tables", "WildTrax Species Strings.RData" ) ) -## 1.6 Check the inputs are reachable ---- +## 1.10 Name the bird data package ---- +# `covs`, `bird`, `off`, `boot` and `birdlist`, from a +# stratification stage not in 0_data/v2_scripts/birds/. Use the +# copy v2 was fitted on (remote/birds_data_v2/), NOT the +# BirdModels drive's Archive/2025 file, rebuilt on 2026-08-19 +# with different draws. With this copy the harness reproduces +# v2's per-draw bird coefficients to ~1e-10 (checked +# 2026-10-02). Read-only. +bird_data_file <- Sys.getenv( + "SDM_BIRD_DATA", + unset = setup_input("birds_data_v2", "Stratified.Rdata") +) + +## 1.11 Name the bird covariate blocks ---- +# Every name appears in a formula in 00.ClimateModels.R, +# 00.NorthModels.R or 00.SouthModels.R (checked in 6.8) + +# The climate stage. EMT is carried because it sits with the +# other climate normals in the source, but no formula uses it. +bird_climate_cols <- c( + "MAP", + "TD", + "CMD", + "FFP", + "EMT" +) + +# The north landcover stage. Footprint, method and water terms +# are shared with the south block. +bird_veg_cols <- c( + "vegc", + "wtAge", + "wtAge2", + "wtAge05", + "isCon", + "isUpCon", + "isBogFen", + "isMix", + "isPine", + "isWSpruce", + "fcc2", + "road", + "mWell", + "mSoft", + "mEnSft", + "mTrSft", + "mSeism", + "method", + "pWater_KM", + "pWater2_KM" +) + +# The south soil stage. A narrower footprint set than the north. +bird_soil_cols <- c( + "soilc", + "paspen", + "road", + "mWell", + "mSoft", + "method", + "pWater_KM", + "pWater2_KM" +) + +# Design fields rather than covariates: which region each survey +# is eligible for, the model weights, the train/test split, the +# spatial block, and the keys. `year` here is the recoded model +# term, calendar year minus 1992; sites.csv carries the calendar +# year derived from date_time. +bird_design_cols <- c( + "surveyid", + "useNorth", + "useSouth", + "vegw", + "soilw", + "use", + "block", + "year", + "method", + "locationid", + "gisid", + "organization", + "project_id", + "date_time" +) + +# Carried by sites.csv, so dropped from the covariate tables. +bird_cols_in_sites <- c( + "Easting", + "Northing" +) + +## 1.12 Check the inputs are reachable ---- # Fail before any reading, so a disconnected drive is obvious. all_files <- c( file.path(snapshot_dir, c(plant_files, mammal_files)), - wt_species_file + wt_species_file, + bird_data_file ) missing_files <- all_files[!file.exists(all_files)] @@ -187,17 +432,11 @@ if (length(missing_files) > 0) { dir.create(output_dir, recursive = TRUE, showWarnings = FALSE) # 2. Helper functions ---- -# One reader per source family, plus a name normalizer for the -# mammal crosswalk and a duplicate-key guard shared by both. ## 2.1 load_rdata() ---- #' Load an .RData File into an Isolated Environment #' -#' Reads a saved workspace without touching the global -#' environment, so the six files cannot overwrite each other's -#' objects. -#' #' @param path Character. Path to an .RData file. #' @return An environment holding the file's objects. #' @@ -256,11 +495,8 @@ make_unique_ids <- function(ids, label) { #' Reduce a Species String to a Column-Safe Token #' -#' Collapses a common-name string to CamelCase with no -#' punctuation. -#' Apostrophes are deleted before splitting, so "Richardson's" -#' becomes "Richardsons" and not "Richardson" + "S"; the -#' remaining punctuation and spaces are split points. +#' CamelCase without punctuation; apostrophes are deleted first +#' ("Richardson's" becomes "Richardsons"). #' #' @param x Character. Species strings. #' @return Character. One token per input. @@ -291,11 +527,8 @@ squash_name <- function(x) { #' Resolve Source Species Names against the WildTrax Strings #' -#' Maps each source species name to its WildTrax common-name -#' string, which is the naming authority for mammals. An exact -#' match is tried first, then a punctuation-insensitive one: the -#' North file already uses the WildTrax strings verbatim, while -#' the South file uses their camel-cased form. +#' WildTrax is the mammal naming authority. Exact match first, +#' then punctuation-insensitive (the South file camel-cases). #' #' @param base Character. Source species names, no season suffix. #' @param native_sp Character. WildTrax common-name strings. @@ -391,25 +624,17 @@ normalize_mammal_column <- function(x, native_sp, label) { #' Read One Plant-Group Snapshot File #' -#' Despite the name, "plant group" is a file layout rather than a -#' taxon: this reads the vascular plant, bryophyte, lichen and -#' mite files, which share one site-year-quadrant schema. -#' -#' Splits a plant-group file into its species block and its site -#' block. Species are identified by elimination: every column -#' that is neither an identity column (`plant_id_cols`) nor a -#' site or climate column (`plant_site_cols`) is a species. -#' -#' Two checks keep the rule honest in both directions. Anything -#' wrongly counted as a species fails the 0/1 test, and anything -#' wrongly excluded is caught against the file's own -#' `veg.species.list` and `soil.species.list`. +#' Species are identified by elimination (neither +#' `plant_id_cols` nor `plant_site_cols`), checked both ways: a +#' 0/1 test, and the file's own species lists. #' #' @param path Character. Path to a plant-group .Rdata file. #' @param taxon Character. Taxon slug, used in messages and in #' the site table. #' @return A list with `species` (survey_unit_id + species -#' columns) and `sites` (one row per survey unit). +#' columns), `sites` (one row per survey unit), `climate` and +#' `habitat` (the two covariate blocks), `pred_matrix`, and +#' `species_lists` (the four sp_table vectors as one frame). #' #' @example # Example usage of the function #' # out <- read_plant_taxon("mite-model-data.Rdata", "mite") @@ -432,8 +657,7 @@ read_plant_taxon <- function(path, taxon) { ) } - # Step 2: Species are what remains once identity and site - # columns are removed, so column order does not matter. + # Step 2: Species by elimination species_cols <- setdiff(cols, c(plant_id_cols, plant_site_cols)) # Step 3: Confirm the block really is presence/absence data. @@ -530,12 +754,181 @@ read_plant_taxon <- function(path, taxon) { return(list(species = species, sites = sites)) } -## 2.7 read_mammal_region() ---- +## 2.7 read_plant_covariates() ---- + +#' Read One Plant-Group File's Covariate and Lookup Blocks +#' +#' Habitat blocks are found by difference from `climate.data`, +#' reproducing the column spans the v2 scripts hard-code +#' (`[403:489]` for bryophytes, `[448:534]`, `[328:414]` and +#' `[1408:1494]` for the others) without relying on order. +#' +#' @param path Character. Path to a plant-group .Rdata file. +#' @param taxon Character. Taxon slug, used in messages. +#' @return A list with `climate`, `veg` and `soil` (each +#' survey_unit_id + that block's columns), `veg_pm` and +#' `soil_pm` (the prediction matrices), and `species_lists` +#' (taxon, species, in_veg_models, in_soil_models). +#' +#' @example # Example usage of the function +#' # out <- read_plant_covariates("mite-model-data.Rdata", "mite") +#' # dim(out$veg) +read_plant_covariates <- function(path, taxon) { + env <- load_rdata(path) + clim <- env$climate.data + clim_cols <- names(clim) + + # Step 1: Take the climate block, minus the fields sites.csv + # already carries, in the order plant_site_cols declares. + climate_cols <- setdiff( + intersect(plant_site_cols, clim_cols), + c(plant_site_cols_in_sites, plant_site_cols_derived) + ) + + climate <- data.frame( + survey_unit_id = as.character(clim$SiteYearQu), + clim[, climate_cols, drop = FALSE], + stringsAsFactors = FALSE + ) + + # Step 2: Each habitat block, by difference from climate.data + take_block <- function(frame) { + block_cols <- setdiff(names(frame), clim_cols) + + data.frame( + survey_unit_id = as.character(frame$SiteYearQu), + frame[, block_cols, drop = FALSE], + stringsAsFactors = FALSE + ) + } + + veg <- take_block(env$veg.data) + soil <- take_block(env$soil.data) + + # Step 3: v2 takes the first 87 columns positionally as its + # coefficient template, so check the width + if (ncol(veg) - 1 < 87) { + stop( + taxon, + ": vegetation block has ", + ncol(veg) - 1, + " columns; the coefficient template needs at least 87.", + call. = FALSE + ) + } + + # Step 4: All three frames must list the same units in order + if ( + !identical(climate$survey_unit_id, veg$survey_unit_id) || + !identical(climate$survey_unit_id, soil$survey_unit_id) + ) { + stop( + taxon, + ": climate, veg and soil frames do not share one survey ", + "unit ordering.", + call. = FALSE + ) + } + + # Step 5: Which species each model set is fitted for (the v2 + # work queue) + modelled <- union(env$veg.species.list, env$soil.species.list) + + # Each list keeps its own v2 order, as a position per list + species_lists <- data.frame( + taxon = taxon, + species = modelled, + in_veg_models = modelled %in% env$veg.species.list, + in_soil_models = modelled %in% env$soil.species.list, + veg_order = match(modelled, env$veg.species.list), + soil_order = match(modelled, env$soil.species.list), + stringsAsFactors = FALSE + ) + + message( + " ", + taxon, + ": ", + ncol(climate) - 1, + " climate, ", + ncol(veg) - 1, + " veg, ", + ncol(soil) - 1, + " soil covariates; ", + nrow(species_lists), + " modelled species" + ) + + return(list( + climate = climate, + veg = veg, + soil = soil, + veg_pm = env$veg.pm, + soil_pm = env$soil.pm, + species_lists = species_lists + )) +} + +## 2.8 read_camera_climate() ---- + +#' Read the Mammal Camera Climate +#' +#' 30-year normals, so identical across years: as v2, the year +#' and the CMU and NWSAR project prefixes are stripped, leaving +#' one row per location. +#' +#' @param path Character. Path to abmi-camera-climate_*.Rdata. +#' @param columns Character vector of climate columns to keep. +#' @return A data frame of `location` plus those columns, one row +#' per location, or NULL when the file is absent. +#' +#' @example # Example usage of the function +#' # read_camera_climate(mammal_camera_climate_file, +#' # mammal_camera_climate_cols) +read_camera_climate <- function(path, columns) { + if (!file.exists(path)) { + return(NULL) + } + + env <- load_rdata(path) + climate <- env$camera.climate + + if (is.null(climate)) { + stop( + basename(path), " holds no `camera.climate` object.", + call. = FALSE + ) + } + + absent <- setdiff(columns, names(climate)) + + if (length(absent) > 0) { + stop( + basename(path), " is missing ", length(absent), + " expected column(s): ", + paste(utils::head(absent, 10), collapse = ", "), + call. = FALSE + ) + } + + location <- sub("_[0-9]{4}$", "", rownames(climate)) + location <- sub("^CMU-|^NWSAR-", "", location) + + out <- data.frame( + location = location, + climate[, columns, drop = FALSE], + stringsAsFactors = FALSE + ) + + out[!duplicated(out$location), ] +} + +## 2.9 read_mammal_region() ---- #' Read One Mammal Snapshot File #' -#' Reads the camera tibble `d` and harmonizes its species-season -#' column names. NAs in the species cells are preserved. +#' Values are densities; NA means fewer than 10 camera-days that +#' season (v2's 02_process-data-files.R). #' #' @param path Character. Path to a mammal .RData file. #' @param region Character. "north" or "south". @@ -628,144 +1021,496 @@ read_mammal_region <- function(path, region, native_sp) { stringsAsFactors = FALSE ) - message( - " mammal ", - region, - ": ", - nrow(species), - " units x ", - length(species_cols), - " species-season columns" - ) + # Step 5: Split the covariates off (section 1.5). Reuse the + # unit ids: make_unique_ids() numbered duplicate deployments. + take_block <- function(wanted) { + present <- intersect(wanted, names(d)) - return(list(species = species, sites = sites)) -} + data.frame( + survey_unit_id = unit_id, + d[, present, drop = FALSE], + check.names = FALSE, + stringsAsFactors = FALSE + ) + } -# 3. Read the sources ---- + climate <- take_block(mammal_climate_cols) -## 3.1 Read the plant-group files ---- -message("Reading plant-group files ...") + # Step 5b: Replace the climate block wholesale with the camera + # climate (section 1.6). Unmatched deployments keep NA, as v2 + # excludes them. + camera_climate <- read_camera_climate( + mammal_camera_climate_file, mammal_camera_climate_cols + ) -plant_parts <- lapply( - names(plant_files), - function(taxon) { - read_plant_taxon( - file.path(snapshot_dir, plant_files[[taxon]]), - taxon + if (is.null(camera_climate)) { + warning( + "Camera climate not found at ", mammal_camera_climate_file, + "; mammal ", region, " keeps the SpTable climate block, ", + "which has no CMD or TD. Set SDM_MAMMAL_CAMERA_CLIMATE.", + call. = FALSE + ) + } else { + matched <- match( + as.character(d$location), camera_climate$location ) - } -) -names(plant_parts) <- names(plant_files) -## 3.2 Read the mammal files ---- -# The WildTrax strings are loaded once and passed to both -# regions, so each resolves its names against the same authority. -message("Reading mammal files ...") + replaced <- intersect( + mammal_camera_climate_cols, names(climate) + ) + added <- setdiff(mammal_camera_climate_cols, names(climate)) -native_sp <- load_rdata(wt_species_file)$native_sp + for (column in mammal_camera_climate_cols) { + climate[[column]] <- camera_climate[[column]][matched] + } -if (!is.character(native_sp) || length(native_sp) == 0) { - stop( - "Expected a non-empty character vector `native_sp` in ", - wt_species_file, - call. = FALSE + message( + " mammal ", region, ": camera climate matched ", + sum(!is.na(matched)), " of ", nrow(d), " deployments (", + round(100 * mean(!is.na(matched)), 1), "%); ", + length(replaced), " column(s) replaced, ", + length(added), " added" + ) + } + + habitat_cols <- setdiff( + names(d), + c(mammal_site_cols, mammal_climate_cols, species_cols) ) -} + habitat <- take_block(habitat_cols) -mammal_parts <- lapply( - names(mammal_files), - function(region) { - read_mammal_region( - file.path(snapshot_dir, mammal_files[[region]]), + # The four blocks must partition `d` exactly + accounted <- length(species_cols) + length(habitat_cols) + + length(intersect(mammal_site_cols, names(d))) + + length(intersect(mammal_climate_cols, names(d))) + + if (accounted != ncol(d)) { + stop( + "mammal ", region, - native_sp + ": the design, climate, species and habitat blocks cover ", + accounted, + " of ", + ncol(d), + " columns.", + call. = FALSE ) } -) -names(mammal_parts) <- names(mammal_files) - -# 4. Harmonize the mammal regions into one taxon table ---- -# North and South are one taxon split across two models, so they -# are stacked. -## 4.1 Confirm the North names reconcile with the South ---- -# A North name that no longer matches means the crosswalk has -# drifted and would split one species across two columns. -north_species <- setdiff( - names(mammal_parts$north$species), - "survey_unit_id" -) -south_species <- setdiff( - names(mammal_parts$south$species), - "survey_unit_id" -) + # Step 6: The work queue: per season, sp_table_* (20+ + # detections, full habitat model) and sp_table_*_ua (3+, + # use-availability) + season_lists <- list( + summer = list( + modelled = env$sp_table_summer, + ua = env$sp_table_summer_ua + ), + winter = list( + modelled = env$sp_table_winter, + ua = env$sp_table_winter_ua + ) + ) -unmatched <- setdiff(north_species, south_species) + species_lists <- do.call(rbind, lapply( + names(season_lists), + function(season) { + lists <- season_lists[[season]] + all_species <- union(lists$modelled, lists$ua) + + data.frame( + region = region, + season = season, + species_season = all_species, + species = normalize_mammal_column( + all_species, native_sp, paste0("mammal ", region) + ), + in_models = all_species %in% lists$modelled, + in_ua_models = all_species %in% lists$ua, + model_order = match(all_species, lists$modelled), + ua_order = match(all_species, lists$ua), + stringsAsFactors = FALSE + ) + } + )) -if (length(unmatched) > 0) { - stop( - "Mammal North columns did not reconcile with South after ", - "normalizing:\n ", - paste(unmatched, collapse = "\n "), - "\nUpdate normalize_mammal_column() before rerunning.", - call. = FALSE + message( + " mammal ", + region, + ": ", + nrow(species), + " units x ", + length(species_cols), + " species-season columns; ", + ncol(climate) - 1, + " climate, ", + ncol(habitat) - 1, + " habitat covariates" ) + + return(list( + species = species, + sites = sites, + climate = climate, + habitat = habitat, + pred_matrix = as.data.frame(env$pred_matrix), + species_lists = species_lists + )) } -## 4.2 Align both regions to the union and stack ---- -mammal_species_cols <- union(south_species, north_species) +## 2.10 read_bird_data() ---- -#' Add a Region's Missing Species Columns as NA +#' Read the Bird Data Package #' -#' @param df Data frame. One region's species table. -#' @param wanted Character. The full set of species columns. -#' @return The data frame with `wanted` present and in order. +#' Birds add a response-shaped QPAD offset table, eligibility as +#' two flags (north and south; a survey may feed both or +#' neither), and integer point counts. +#' +#' @param path Character. Path to Stratified.Rdata. +#' @return A list with `species`, `offsets`, `sites`, `climate`, +#' `veg`, `soil`, `design`, `species_lists`, `bootstrap`, +#' `factor_levels`, and `covs_cols` for the block check. #' #' @example # Example usage of the function -#' # align_columns(north_tbl, mammal_species_cols) -align_columns <- function(df, wanted) { - # Step 1: Add the columns this region lacks - for (col in setdiff(wanted, names(df))) { - df[[col]] <- NA_real_ +#' # out <- read_bird_data(bird_data_file) +#' # dim(out$species) +read_bird_data <- function(path) { + env <- load_rdata(path) + + expected <- c("covs", "bird", "off", "boot", "birdlist") + absent <- setdiff(expected, ls(env)) + + if (length(absent) > 0) { + stop( + "Object(s) missing from ", + basename(path), + ": ", + paste(absent, collapse = ", "), + call. = FALSE + ) } - # Step 2: Put the key first and the species in a fixed order - return(df[, c("survey_unit_id", wanted), drop = FALSE]) -} + covs <- as.data.frame(env$covs, stringsAsFactors = FALSE) + counts <- as.data.frame(env$bird, stringsAsFactors = FALSE) + offsets <- as.data.frame(env$off, stringsAsFactors = FALSE) -mammal_species <- rbind( - align_columns(mammal_parts$north$species, mammal_species_cols), - align_columns(mammal_parts$south$species, mammal_species_cols) -) + # Step 1: The frames must be row-aligned (tables below are + # built by position). Compare surveyid on a common type: `covs` + # holds it as double, the others as integer. + key <- as.integer(covs$surveyid) -message( - " mammal combined: ", - nrow(mammal_species), - " units x ", - length(mammal_species_cols), - " species-season columns" + if ( + !identical(key, counts$surveyid) || + !identical(key, offsets$surveyid) + ) { + stop( + "bird: covs, bird and off are no longer row-aligned on ", + "surveyid; this reader assumes they are.", + call. = FALSE + ) + } + + if (anyDuplicated(key) > 0) { + stop("bird: surveyid is not unique in covs.", call. = FALSE) + } + + unit_id <- paste0("bird|", key) + + # Step 2: Counts, and offsets for species with counts (`off` + # has 219 species, `bird` 127) + species_cols <- setdiff(names(counts), "surveyid") + + absent_offsets <- setdiff(species_cols, names(offsets)) + + if (length(absent_offsets) > 0) { + stop( + "bird: ", + length(absent_offsets), + " species have counts but no QPAD offset: ", + paste(utils::head(absent_offsets, 10), collapse = ", "), + call. = FALSE + ) + } + + species <- data.frame( + survey_unit_id = unit_id, + counts[, species_cols, drop = FALSE], + check.names = FALSE, + stringsAsFactors = FALSE + ) + + offset_table <- data.frame( + survey_unit_id = unit_id, + offsets[, species_cols, drop = FALSE], + check.names = FALSE, + stringsAsFactors = FALSE + ) + + # Step 3: Blocks by name (intersection): shared terms sit in + # both habitat blocks + take_block <- function(wanted) { + present <- setdiff( + intersect(wanted, names(covs)), + bird_cols_in_sites + ) + + data.frame( + survey_unit_id = unit_id, + covs[, present, drop = FALSE], + check.names = FALSE, + stringsAsFactors = FALSE + ) + } + + climate <- take_block(bird_climate_cols) + veg <- take_block(bird_veg_cols) + soil <- take_block(bird_soil_cols) + design <- take_block(bird_design_cols) + + # Format local time: fwrite would write UTC, shifting surveys + # by six hours + design$date_time <- format(design$date_time) + + # Step 4: Site rows. Lat, long and natural region stay NA (not + # reprojected); `year` is calendar year (the recoded model year + # is in the design table). + calendar_year <- as.integer(format(covs$date_time, "%Y")) + + if (!all(covs$year == calendar_year - 1992)) { + stop( + "bird: the recoded `year` column is no longer calendar ", + "year minus 1992, so the calendar year cannot be trusted.", + call. = FALSE + ) + } + + sites <- data.frame( + survey_unit_id = unit_id, + survey_design = "bird_point_count", + region = NA_character_, + site = as.character(covs$locationid), + site_year = as.character(covs$gisid), + year = calendar_year, + quadrant = NA_character_, + on_off_grid = NA_character_, + location = as.character(covs$gisid), + project = as.character(covs$organization), + nearest_site = NA_character_, + lured = NA, + summer_days = NA_real_, + winter_days = NA_real_, + lat = NA_real_, + long = NA_real_, + elevation = NA_real_, + easting = as.numeric(covs$Easting), + northing = as.numeric(covs$Northing), + nr = NA_character_, + nsr = NA_character_, + luf = NA_character_, + stringsAsFactors = FALSE + ) + + # Step 5: The work queue (birdlist, per species and region) + species_lists <- data.frame( + as.data.frame(env$birdlist, stringsAsFactors = FALSE), + stringsAsFactors = FALSE + ) + + # Step 6: Prefix the bootstrap columns "1" to "100", which a + # CSV reader takes for a data row rather than a header + bootstrap <- as.data.frame(env$boot) + names(bootstrap) <- sprintf( + "boot_%03d", seq_len(ncol(bootstrap)) + ) + + # Step 7: Factor levels in source order, since a CSV re-read + # would give alphabetical levels and move the reference + factor_cols <- names(covs)[vapply(covs, is.factor, logical(1))] + + factor_levels <- do.call(rbind, lapply( + factor_cols, + function(col) { + data.frame( + column = col, + level_order = seq_along(levels(covs[[col]])), + level = levels(covs[[col]]), + stringsAsFactors = FALSE + ) + } + )) + + message( + " bird: ", + nrow(species), + " surveys x ", + length(species_cols), + " species; ", + ncol(climate) - 1, + " climate, ", + ncol(veg) - 1, + " veg, ", + ncol(soil) - 1, + " soil covariates; ", + nrow(species_lists), + " species-region models" + ) + + return(list( + species = species, + offsets = offset_table, + sites = sites, + climate = climate, + veg = veg, + soil = soil, + design = design, + species_lists = species_lists, + bootstrap = bootstrap, + factor_levels = factor_levels, + covs_cols = names(covs) + )) +} + +# 3. Read the sources ---- + +## 3.1 Read the plant-group files ---- +message("Reading plant-group files ...") + +plant_parts <- lapply( + names(plant_files), + function(taxon) { + read_plant_taxon( + file.path(snapshot_dir, plant_files[[taxon]]), + taxon + ) + } +) +names(plant_parts) <- names(plant_files) + +## 3.2 Read the plant-group covariates and lookups ---- +# A second pass over the same four files (see the header TODO) +message("Reading plant-group covariates ...") + +covariate_parts <- lapply( + names(plant_files), + function(taxon) { + read_plant_covariates( + file.path(snapshot_dir, plant_files[[taxon]]), + taxon + ) + } +) +names(covariate_parts) <- names(plant_files) + +## 3.3 Read the mammal files ---- +message("Reading mammal files ...") + +native_sp <- load_rdata(wt_species_file)$native_sp + +if (!is.character(native_sp) || length(native_sp) == 0) { + stop( + "Expected a non-empty character vector `native_sp` in ", + wt_species_file, + call. = FALSE + ) +} + +mammal_parts <- lapply( + names(mammal_files), + function(region) { + read_mammal_region( + file.path(snapshot_dir, mammal_files[[region]]), + region, + native_sp + ) + } +) +names(mammal_parts) <- names(mammal_files) + +## 3.4 Read the bird data package ---- +message("Reading bird data ...") + +bird_parts <- read_bird_data(bird_data_file) + +# 4. Harmonize the mammal regions into one taxon table ---- + +## 4.1 Confirm the North names reconcile with the South ---- +# A mismatch would split one species across two columns +north_species <- setdiff( + names(mammal_parts$north$species), + "survey_unit_id" +) +south_species <- setdiff( + names(mammal_parts$south$species), + "survey_unit_id" +) + +unmatched <- setdiff(north_species, south_species) + +if (length(unmatched) > 0) { + stop( + "Mammal North columns did not reconcile with South after ", + "normalizing:\n ", + paste(unmatched, collapse = "\n "), + "\nUpdate normalize_mammal_column() before rerunning.", + call. = FALSE + ) +} + +## 4.2 Align both regions to the union and stack ---- +mammal_species_cols <- union(south_species, north_species) + +#' Add a Region's Missing Species Columns as NA +#' +#' @param df Data frame. One region's species table. +#' @param wanted Character. The full set of species columns. +#' @return The data frame with `wanted` present and in order. +#' +#' @example # Example usage of the function +#' # align_columns(north_tbl, mammal_species_cols) +align_columns <- function(df, wanted) { + # Step 1: Add the columns this region lacks + for (col in setdiff(wanted, names(df))) { + df[[col]] <- NA_real_ + } + + # Step 2: Put the key first and the species in a fixed order + return(df[, c("survey_unit_id", wanted), drop = FALSE]) +} + +mammal_species <- rbind( + align_columns(mammal_parts$north$species, mammal_species_cols), + align_columns(mammal_parts$south$species, mammal_species_cols) +) + +message( + " mammal combined: ", + nrow(mammal_species), + " units x ", + length(mammal_species_cols), + " species-season columns" ) # 5. Build the master site table ---- -# One row per survey unit across all six sources, plus a flag per -# taxon recording which taxon files cover that unit. +# One row per survey unit, with an in_ flag per taxon ## 5.1 Stack every source's site rows ---- all_sites <- do.call( rbind, c( lapply(plant_parts, function(x) x$sites), - lapply(mammal_parts, function(x) x$sites) + lapply(mammal_parts, function(x) x$sites), + list(bird = bird_parts$sites) ) ) rownames(all_sites) <- NULL ## 5.2 Record which taxon files cover each unit ---- -# The four plant taxa share the SiteYearQu key but sample -# different unit sets. The flags make that coverage explicit. +# The plant taxa share keys but sample different units taxon_units <- c( lapply(plant_parts, function(x) x$species$survey_unit_id), - list(mammal = mammal_species$survey_unit_id) + list( + mammal = mammal_species$survey_unit_id, + bird = bird_parts$species$survey_unit_id + ) ) for (taxon in names(taxon_units)) { @@ -774,8 +1519,6 @@ for (taxon in names(taxon_units)) { } ## 5.3 Collapse to one row per survey unit ---- -# A plant unit contributes an identical site row from each taxon -# file that sampled it. flag_cols <- grep("^in_", names(all_sites), value = TRUE) attribute_cols <- setdiff( names(all_sites), @@ -801,13 +1544,154 @@ if (length(conflicting) > 0) { sites <- all_sites[!duplicated(all_sites$survey_unit_id), ] rownames(sites) <- NULL +## 5.4 Build the master covariate table ---- +# Keyed on survey_unit_id and taxon because the plant files +# disagree: on the 7001 quadrats vascular plant and mite share, +# 154 of 162 veg and 58 of 59 soil columns differ (climate +# agrees; bryophyte and lichen match vascular plant). Each file +# is a separate extraction (01a_data-standardization.R); choosing +# between them is not this script's call. Columns are the union +# across taxa (~16% populated; birds are 86% of rows). + +#' Join One Taxon's Covariate Blocks Side by Side +#' +#' Combined by position (one source frame). Names in more than +#' one block are block-suffixed: of 42 plant names in both veg +#' and soil, 14 differ (footprint computed under each framework), +#' so a single `Crop` would feed the south models north numbers. +#' +#' @param blocks Named list of data frames, each keyed on +#' survey_unit_id. The names become the block suffixes. +#' @param taxon Character. Value for the taxon column. +#' @return A list with `table` (survey_unit_id, taxon, then the +#' blocks' columns) and `map` (taxon, block, source_column, +#' master_column) recording where each column came from. +#' +#' @example # Example usage of the function +#' # merge_blocks(list(climate = a, veg = b), "bryophyte") +merge_blocks <- function(blocks, taxon) { + # Step 1: Find the names more than one block carries + every_name <- unlist(lapply(blocks, function(block) { + setdiff(names(block), "survey_unit_id") + })) + collide <- unique(every_name[duplicated(every_name)]) + + key <- blocks[[1]]$survey_unit_id + out <- data.frame( + survey_unit_id = key, + stringsAsFactors = FALSE + ) + map <- list() + + for (block_name in names(blocks)) { + block <- blocks[[block_name]] + + # Step 2: Refuse to combine blocks that have drifted apart, + # since they are joined by position and not by key + if (!identical(key, block$survey_unit_id)) { + stop( + taxon, + ": covariate blocks are not in one row order.", + call. = FALSE + ) + } + + # Step 3: Suffix the colliding names, keep the rest as the + # v2 scripts spell them + cols <- setdiff(names(block), "survey_unit_id") + renamed <- ifelse( + cols %in% collide, + paste0(cols, "_", block_name), + cols + ) + + piece <- block[, cols, drop = FALSE] + names(piece) <- renamed + out <- cbind(out, piece) + + map[[length(map) + 1]] <- data.frame( + taxon = taxon, + block = block_name, + source_column = cols, + master_column = renamed, + stringsAsFactors = FALSE + ) + } + + out$taxon <- taxon + + return(list(table = out, map = do.call(rbind, map))) +} + +# Mammals are split by region (separate models on overlapping +# deployments: 512 location_project values in both); birds add +# a design block +covariate_blocks <- c( + lapply(covariate_parts, function(x) { + list(climate = x$climate, veg = x$veg, soil = x$soil) + }), + list( + mammal_north = list( + climate = mammal_parts$north$climate, + veg = mammal_parts$north$habitat + ), + mammal_south = list( + climate = mammal_parts$south$climate, + soil = mammal_parts$south$habitat + ), + bird = list( + climate = bird_parts$climate, + veg = bird_parts$veg, + soil = bird_parts$soil, + design = bird_parts$design + ) + ) +) + +merged_covariates <- lapply( + names(covariate_blocks), + function(taxon) { + merge_blocks(covariate_blocks[[taxon]], taxon) + } +) + +covariates <- as.data.frame(rbindlist( + lapply(merged_covariates, function(x) x$table), + fill = TRUE, + use.names = TRUE +)) + +covariate_columns <- do.call( + rbind, + lapply(merged_covariates, function(x) x$map) +) +rownames(covariate_columns) <- NULL + +covariates <- covariates[ + , c( + "survey_unit_id", + "taxon", + setdiff(names(covariates), c("survey_unit_id", "taxon")) + ) +] + +message( + " covariates: ", + nrow(covariates), + " unit-taxon rows x ", + ncol(covariates) - 2, + " covariates" +) + # 6. Validate the assembled tables ---- -# Cheap checks that would catch a layout change in a future -# snapshot before the CSVs are trusted downstream. +# Catch layout changes in a future snapshot species_tables <- c( lapply(plant_parts, function(x) x$species), - list(mammal = mammal_species) + list( + mammal = mammal_species, + bird = bird_parts$species + ) ) ## 6.1 Every taxon key must resolve in the site table ---- @@ -844,9 +1728,241 @@ for (taxon in names(species_tables)) { } } +## 6.3 Covariates must cover the response, unit for unit ---- +# Otherwise units drop silently at model time. Mammal regions +# are pooled first (two covariate keys, one response table). +covariate_taxa <- list( + vascular_plant = "vascular_plant", + bryophyte = "bryophyte", + lichen = "lichen", + mite = "mite", + mammal = c("mammal_north", "mammal_south"), + bird = "bird" +) + +for (taxon in names(covariate_taxa)) { + response_ids <- species_tables[[taxon]]$survey_unit_id + block_ids <- covariates$survey_unit_id[ + covariates$taxon %in% covariate_taxa[[taxon]] + ] + + if (!setequal(response_ids, block_ids)) { + stop( + taxon, + ": the covariates and the response cover different survey ", + "units (", + length(setdiff(response_ids, block_ids)), + " missing, ", + length(setdiff(block_ids, response_ids)), + " extra).", + call. = FALSE + ) + } +} + +## 6.3b Every covariate row must resolve in the site table ---- +orphan_covariates <- setdiff( + covariates$survey_unit_id, + sites$survey_unit_id +) + +if (length(orphan_covariates) > 0) { + stop( + length(orphan_covariates), + " covariate row(s) name a survey unit that sites.csv does ", + "not carry.", + call. = FALSE + ) +} + +## 6.4 Modelled species must exist as response columns ---- +# Otherwise it fails per bootstrap, inside a tryCatch +for (taxon in names(covariate_parts)) { + declared <- covariate_parts[[taxon]]$species_lists$species + available <- setdiff( + names(species_tables[[taxon]]), + "survey_unit_id" + ) + unknown <- setdiff(declared, available) + + if (length(unknown) > 0) { + stop( + taxon, + ": ", + length(unknown), + " modelled species are not response columns:\n ", + paste(utils::head(unknown, 10), collapse = "\n "), + call. = FALSE + ) + } +} + +## 6.5 The prediction matrices must agree across taxa ---- +# Written once, so all four files must carry the same grid +for (matrix_name in c("veg_pm", "soil_pm")) { + reference <- covariate_parts[[1]][[matrix_name]] + + for (taxon in names(covariate_parts)) { + written <- covariate_parts[[taxon]][[matrix_name]] + + if (!identical(written, reference)) { + stop( + "The ", + matrix_name, + " prediction matrix in ", + taxon, + " differs from ", + names(covariate_parts)[1], + "; it can no longer be written once for all taxa.", + call. = FALSE + ) + } + } +} + +## 6.6 Mammal habitat must be cover proportions ---- +# Habitat is the remainder, so a stray design field would land +# here; check it is all numeric +for (region in names(mammal_parts)) { + part <- mammal_parts[[region]] + + habitat_values <- part$habitat[ + , setdiff(names(part$habitat), "survey_unit_id"), + drop = FALSE + ] + + non_numeric <- names(habitat_values)[ + !vapply(habitat_values, is.numeric, logical(1)) + ] + + if (length(non_numeric) > 0) { + stop( + "mammal ", + region, + ": non-numeric column(s) fell into the habitat block: ", + paste(non_numeric, collapse = ", "), + "\nName them in mammal_site_cols or mammal_climate_cols.", + call. = FALSE + ) + } +} + +## 6.7 Mammal species lists must be response columns ---- +for (region in names(mammal_parts)) { + declared <- mammal_parts[[region]]$species_lists$species + unknown <- setdiff(declared, names(mammal_species)) + + if (length(unknown) > 0) { + stop( + "mammal ", + region, + ": ", + length(unknown), + " modelled species are not response columns:\n ", + paste(utils::head(unknown, 10), collapse = "\n "), + call. = FALSE + ) + } +} + +## 6.8 Bird blocks must account for every covariate column ---- +# Blocks are taken by name, so a new source column would drop +# silently. Easting and Northing are in sites.csv. +bird_named <- unique(c( + bird_climate_cols, + bird_veg_cols, + bird_soil_cols, + bird_design_cols, + bird_cols_in_sites +)) + +bird_unnamed <- setdiff(bird_parts$covs_cols, bird_named) + +if (length(bird_unnamed) > 0) { + stop( + "bird: ", + length(bird_unnamed), + " covariate column(s) belong to no block: ", + paste(bird_unnamed, collapse = ", "), + "\nAdd them to one of the bird_*_cols vectors.", + call. = FALSE + ) +} + +## 6.9 Bird counts and offsets must be model ready ---- +bird_counts <- as.matrix( + bird_parts$species[, -1, drop = FALSE] +) + +if ( + anyNA(bird_counts) || + any(bird_counts < 0) || + !all(bird_counts %% 1 == 0) +) { + stop( + "bird: the count block is not non-negative whole numbers.", + call. = FALSE + ) +} + +bird_offsets <- as.matrix( + bird_parts$offsets[, -1, drop = FALSE] +) + +if (anyNA(bird_offsets)) { + stop( + "bird: ", + sum(is.na(bird_offsets)), + " QPAD offset(s) are NA; every count needs one.", + call. = FALSE + ) +} + +if ( + !identical(names(bird_parts$species), names(bird_parts$offsets)) +) { + stop( + "bird: the count and offset tables do not carry the same ", + "species columns in the same order.", + call. = FALSE + ) +} + +## 6.10 Bird species lists must be response columns ---- +bird_declared <- unique(bird_parts$species_lists$species) +bird_unknown <- setdiff( + bird_declared, + names(bird_parts$species) +) + +if (length(bird_unknown) > 0) { + stop( + "bird: ", + length(bird_unknown), + " modelled species are not response columns:\n ", + paste(utils::head(bird_unknown, 10), collapse = "\n "), + call. = FALSE + ) +} + +## 6.11 Bootstrap draws must resolve to surveys ---- +bird_boot_ids <- unique(unlist(bird_parts$bootstrap)) +bird_orphan_draws <- setdiff( + bird_boot_ids, + bird_parts$design$surveyid +) + +if (length(bird_orphan_draws) > 0) { + stop( + "bird: ", + length(bird_orphan_draws), + " bootstrap draw(s) name a surveyid that is not in the ", + "design table.", + call. = FALSE + ) +} + # 7. Write the CSVs ---- -# One file per taxon plus the site table, all sharing the -# survey_unit_id key. ## 7.1 Write the taxon tables ---- for (taxon in names(species_tables)) { @@ -875,6 +1991,295 @@ message( ncol(sites), " cols" ) + +## 7.3 Write the master covariate table ---- +# Also removes the old per-taxon covariate folder, so a stale +# copy cannot be read +old_covariate_dir <- file.path(output_dir, "covariates") + +if (dir.exists(old_covariate_dir)) { + unlink(old_covariate_dir, recursive = TRUE) + message("Removed the superseded covariates/ folder") +} + +covariates_path <- file.path(output_dir, "covariates.csv") +fwrite(covariates, covariates_path, na = "") + +message( + "Wrote covariates.csv: ", + nrow(covariates), + " rows x ", + ncol(covariates), + " cols (", + round(file.size(covariates_path) / 1024^2), + " MB)" +) + +dir.create(lookup_dir, recursive = TRUE, showWarnings = FALSE) + +columns_path <- file.path(lookup_dir, "covariate_columns.csv") +fwrite(covariate_columns, columns_path, na = "") + +renamed_count <- sum( + covariate_columns$source_column != covariate_columns$master_column +) + +message( + "Wrote lookup/covariate_columns.csv: ", + nrow(covariate_columns), + " rows x ", + ncol(covariate_columns), + " cols; ", + renamed_count, + " column(s) suffixed by block to avoid a collision" +) + +## 7.4 Write the shared lookups ---- +# Written once (checked identical across taxa in 6.5) +dir.create(lookup_dir, recursive = TRUE, showWarnings = FALSE) + +prediction_matrices <- list( + veg_prediction_matrix = covariate_parts[[1]]$veg_pm, + soil_prediction_matrix = covariate_parts[[1]]$soil_pm +) + +# The v2 CSVs when reachable (section 1.8) +for (matrix_name in names(prediction_matrices)) { + if (is.na(v2_lookup_dir) || !nzchar(v2_lookup_dir)) { + next + } + + source_csv <- file.path( + v2_lookup_dir, v2_lookup_files[[matrix_name]] + ) + + if (file.exists(source_csv)) { + prediction_matrices[[matrix_name]] <- as.data.frame( + fread(source_csv) + ) + message(" using ", source_csv) + } else { + warning( + "SDM_V2_LOOKUP is set but ", + source_csv, + " was not found; falling back to the snapshot copy.", + call. = FALSE + ) + } +} + +for (matrix_name in names(prediction_matrices)) { + path <- file.path(lookup_dir, paste0(matrix_name, ".csv")) + fwrite(prediction_matrices[[matrix_name]], path, na = "") + + message( + "Wrote lookup/", + basename(path), + ": ", + nrow(prediction_matrices[[matrix_name]]), + " rows x ", + ncol(prediction_matrices[[matrix_name]]), + " cols" + ) +} + +# Report whether the four aggregate columns are present, rather +# than fail later at prediction time +veg_aggregates <- c("Peatland", "Mineral", "Upland", "CCR1234") +absent_aggregates <- setdiff( + veg_aggregates, + colnames(prediction_matrices$veg_prediction_matrix) +) + +if (length(absent_aggregates) > 0) { + message( + " note: the vegetation prediction matrix has no column for ", + paste(absent_aggregates, collapse = ", "), + ".\n The vegetation models cannot be fitted until ", + v2_lookup_files[["veg_prediction_matrix"]], + "\n from the v2 project is available. Set SDM_V2_LOOKUP to ", + "the folder holding it\n and re-run this script. The ", + "climate and soil models are unaffected." + ) +} + +modelled_species <- do.call( + rbind, + lapply(covariate_parts, function(x) x$species_lists) +) +rownames(modelled_species) <- NULL + +modelled_path <- file.path(lookup_dir, "modelled_species.csv") +fwrite(modelled_species, modelled_path, na = "") + +message( + "Wrote lookup/modelled_species.csv: ", + nrow(modelled_species), + " rows x ", + ncol(modelled_species), + " cols" +) + +## 7.5 Write the mammal lookups ---- +# From the snapshot (checked identical to the ABMI Mammals CSVs) +for (region in names(mammal_parts)) { + path <- file.path( + lookup_dir, + paste0("mammal_", region, "_prediction_matrix.csv") + ) + fwrite(mammal_parts[[region]]$pred_matrix, path, na = "") + + message( + "Wrote lookup/", + basename(path), + ": ", + nrow(mammal_parts[[region]]$pred_matrix), + " rows x ", + ncol(mammal_parts[[region]]$pred_matrix), + " cols" + ) +} + +# Own table: season by threshold does not fit the plant schema +mammal_modelled <- do.call( + rbind, + lapply(mammal_parts, function(x) x$species_lists) +) +rownames(mammal_modelled) <- NULL + +mammal_modelled_path <- file.path( + lookup_dir, "mammal_modelled_species.csv" +) +fwrite(mammal_modelled, mammal_modelled_path, na = "") + +message( + "Wrote lookup/mammal_modelled_species.csv: ", + nrow(mammal_modelled), + " rows x ", + ncol(mammal_modelled), + " cols" +) + +# Copied in with survey_unit_id added; unmatched deployments +# keep NA, as the v2 join gives +if (file.exists(mammal_climate_pred_file)) { + climate_pred <- as.data.frame( + fread(mammal_climate_pred_file), stringsAsFactors = FALSE + ) + + unit_lookup <- do.call(rbind, lapply( + names(mammal_parts), + function(region) { + data.frame( + survey_unit_id = + mammal_parts[[region]]$climate$survey_unit_id, + location_project = + mammal_parts[[region]]$climate$location_project, + stringsAsFactors = FALSE + ) + } + )) + + climate_pred <- merge( + unit_lookup, climate_pred, + by = "location_project", all.x = TRUE, sort = FALSE + ) + + climate_pred <- climate_pred[ + , c( + "survey_unit_id", "location_project", + setdiff( + names(climate_pred), + c("survey_unit_id", "location_project") + ) + ) + ] + + climate_pred_path <- file.path( + lookup_dir, "mammal_climate_predictions.csv" + ) + fwrite(climate_pred, climate_pred_path, na = "") + + uncovered <- sum(is.na(climate_pred[[3]])) + + message( + "Wrote lookup/mammal_climate_predictions.csv: ", + nrow(climate_pred), + " rows x ", + ncol(climate_pred), + " cols; ", + uncovered, + " deployment(s) have no climate prediction" + ) +} else { + warning( + "Mammal climate predictions not found at ", + mammal_climate_pred_file, + "; the mammal habitat models cannot be fitted without them. ", + "Set SDM_MAMMAL_CLIMATE_PRED.", + call. = FALSE + ) +} + +## 7.6 Write the bird offsets ---- +# One QPAD offset per survey and species; the largest table +offsets_path <- file.path(output_dir, "bird_offsets.csv") +fwrite(bird_parts$offsets, offsets_path, na = "") + +message( + "Wrote bird_offsets.csv: ", + nrow(bird_parts$offsets), + " rows x ", + ncol(bird_parts$offsets), + " cols (", + round(file.size(offsets_path) / 1024^2), + " MB)" +) + +## 7.7 Write the bird lookups ---- +# The species-region work queue, the bootstrap draws, and the +# factor levels in source order. +bird_modelled_path <- file.path( + lookup_dir, "bird_modelled_species.csv" +) +fwrite(bird_parts$species_lists, bird_modelled_path, na = "") + +message( + "Wrote lookup/bird_modelled_species.csv: ", + nrow(bird_parts$species_lists), + " rows x ", + ncol(bird_parts$species_lists), + " cols" +) + +# Raw surveyids (joined via covariates.csv's surveyid), a tenth +# the size of prefixed keys +bird_boot_path <- file.path( + lookup_dir, "bird_bootstrap_ids.csv" +) +fwrite(bird_parts$bootstrap, bird_boot_path, na = "") + +message( + "Wrote lookup/bird_bootstrap_ids.csv: ", + nrow(bird_parts$bootstrap), + " rows x ", + ncol(bird_parts$bootstrap), + " cols" +) + +bird_levels_path <- file.path( + lookup_dir, "bird_factor_levels.csv" +) +fwrite(bird_parts$factor_levels, bird_levels_path, na = "") + +message( + "Wrote lookup/bird_factor_levels.csv: ", + nrow(bird_parts$factor_levels), + " rows x ", + ncol(bird_parts$factor_levels), + " cols" +) + message("Output written to ", output_dir) # End of script ---- diff --git a/1_code/_setup/02_validate_test_dataset.R b/1_code/_setup/02_validate_test_dataset.R new file mode 100644 index 0000000..64078d2 --- /dev/null +++ b/1_code/_setup/02_validate_test_dataset.R @@ -0,0 +1,1356 @@ +# --- +# title: Validate the Harmonized Test Dataset +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. +# in 0_data/test_dataset/, written by +# _setup/01_harmonize_model_ready_v2.R: +# - sites.csv +# - vascular_plant.csv +# - bryophyte.csv +# - lichen.csv +# - mite.csv +# - mammal.csv +# - bird.csv +# - bird_offsets.csv +# - covariates.csv +# - lookup/covariate_columns.csv +# - lookup/veg_prediction_matrix.csv +# - lookup/soil_prediction_matrix.csv +# - lookup/modelled_species.csv +# - lookup/mammal__prediction_matrix.csv +# - lookup/mammal_modelled_species.csv +# - lookup/mammal_climate_predictions.csv +# - lookup/bird_modelled_species.csv +# - lookup/bird_bootstrap_ids.csv +# - lookup/bird_factor_levels.csv +# from 0_data/data_snapshots/model_ready_v2/ on ABMI-DATA2: +# - the four plant-group .Rdata files +# - the two mammal SpTable .RData files +# from the work_abmi shared drive, read-only: +# - 1_projects/active/sdmMethodsDev/remote/birds_data_v2/ +# Stratified.Rdata, the copy 01 harmonizes from +# outputs: +# - none; every result is printed to the console +# notes: +# - Section 2 describes the dataset (sizes, coverage, ranges, +# joins); section 3 traces every written value back to its +# source snapshot. +# - Covariate blocks are rebuilt from the master table via +# lookup/covariate_columns.csv, which also catches dropped or +# renamed columns. +# - Covariates are compared on relative difference: CSV keeps +# ~15 significant digits (UTMY at 6.6e6 drifts ~6e-9). +# - Run after 01, and whenever the snapshot or 01 changes. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) + +## 1.2 Configure paths ---- +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(getwd(), "1_code/_setup/utils/input_paths.R")) + +# data_dir holds the harmonized CSVs; snapshot_dir holds the +# read-only sources they were built from. +data_dir <- file.path( + normalizePath(getwd(), winslash = "/"), + "0_data/test_dataset" +) + +snapshot_dir <- Sys.getenv( + "SDM_SNAPSHOT_V2", + unset = setup_input("model_ready_v2") +) + +taxa <- c( + "vascular_plant", + "bryophyte", + "lichen", + "mite", + "mammal", + "bird" +) + +# The bird data package 01 harmonizes from: the copy v2's birds +# were fitted on, not the BirdModels drive's rebuilt one. +bird_data_file <- Sys.getenv( + "SDM_BIRD_DATA", + unset = setup_input("birds_data_v2", "Stratified.Rdata") +) + +## 1.3 Read the harmonized CSVs ---- +sites <- fread(file.path(data_dir, "sites.csv"), na.strings = "") + +sp <- lapply(taxa, function(x) { + fread(file.path(data_dir, paste0(x, ".csv"))) +}) +names(sp) <- taxa + +# The master covariate table and the map that says which block +# and which v2 name each of its columns came from. +covariates <- fread( + file.path(data_dir, "covariates.csv"), + na.strings = "" +) + +col_map <- fread( + file.path(data_dir, "lookup", "covariate_columns.csv") +) + +# 2. Describe the harmonized dataset ---- +# What the six files hold, and whether they hold together. + +## 2.1 File overview ---- +# Rows, columns and size on disk. +print(data.table( + file = c("sites", taxa), + rows = c(nrow(sites), sapply(sp, nrow)), + cols = c(ncol(sites), sapply(sp, ncol)), + mb = round( + file.info( + file.path(data_dir, paste0(c("sites", taxa), ".csv")) + )$size / + 1024^2, + 1 + ) +)) + +## 2.1b Master covariate table ---- +# One row per survey unit and taxon, not per survey unit. The +# plant files disagree on the same quadrat, so taxon is part of +# the key; see the header of 01_harmonize_model_ready_v2.R. +cat("\ncovariates.csv:", nrow(covariates), "rows x", + ncol(covariates), "cols\n") +print(covariates[, .N, by = taxon]) + +# Columns are the union across taxa, so each taxon fills its own +# blocks and leaves the rest empty. +cat("\nnon-empty covariate columns per taxon:\n") +for (tx in unique(covariates$taxon)) { + sub <- covariates[taxon == tx] + filled <- sum(vapply( + sub, function(x) as.numeric(!all(is.na(x))), numeric(1) + )) + cat(sprintf( + " %-15s %6d rows, %3d of %3d columns used\n", + tx, nrow(sub), filled - 2, ncol(covariates) - 2 + )) +} + +# Which columns were suffixed because two blocks share a name. +cat("\ncolumns suffixed by block:", + sum(col_map$source_column != col_map$master_column), + "of", nrow(col_map), "\n") + +## 2.2 Site table ---- +# Structure of sites.csv +str(sites) + +# One row per design; each leaves the other's fields empty +print(head(sites[survey_design == "plant_quadrant"], 3)) +print(head(sites[survey_design == "mammal_camera"], 3)) +print(head(sites[survey_design == "bird_point_count"], 3)) + +# Survey units by design and region +print(sites[, .N, by = .(survey_design, region)]) + +# Units covered by each taxon file +print(sites[, lapply(.SD, sum), .SDcols = patterns("^in_")]) + +# Units sampled by all four plant taxa +print(sites[ + in_vascular_plant & in_bryophyte & in_lichen & in_mite, + .N +]) + +# Temporal and spatial extent +print(sites[, .( + first_year = min(year, na.rm = TRUE), + last_year = max(year, na.rm = TRUE) +)]) +print(summary(sites[, .(lat, long)])) + +# Survey effort, which the mammal cameras alone carry +print(summary(sites[ + survey_design == "mammal_camera", + .(summer_days, winter_days) +])) + +## 2.3 Join integrity ---- +# Every taxon key should resolve in sites.csv, with no repeats. +for (tx in taxa) { + key <- sp[[tx]]$survey_unit_id + cat(sprintf( + "%-15s rows %6d | all in sites %-5s | dup keys %d\n", + tx, + length(key), + all(key %in% sites$survey_unit_id), + sum(duplicated(key)) + )) +} + +## 2.4 Response values per taxon ---- +# Three response scales, one per design. +# Plants are 0/1 presence-absence, with no NAs. +# Mammals are densities. A mammal NA is not a missing record: +# the v2 script 02_process-data-files.R sets a season's +# densities to NA when that season has fewer than 10 +# camera-days, so NA means too little effort to estimate from. +# Birds are integer point counts, paired with a QPAD log +# offset per survey and species in bird_offsets.csv. +# fill is the share of observed cells with a detection. +for (tx in taxa) { + m <- as.matrix(sp[[tx]][, -1]) + cat(sprintf( + "%-15s spp %5d | range %-12s | NA %6d | fill %.3f\n", + tx, + ncol(m), + paste(round(range(m, na.rm = TRUE), 2), collapse = " - "), + sum(is.na(m)), + mean(m > 0, na.rm = TRUE) + )) +} + +## 2.5 Species prevalence ---- + +#' Rank a Taxon's Species by How Widely They Were Detected +#' +#' @param taxon Character. Name of one taxon CSV in `sp`. +#' @param n Integer. How many species to return. +#' @return A data.table of species and the proportion of +#' surveyed units where each was detected. +#' +#' @example # Example usage of the function +#' # prevalence("mammal", 5) +prevalence <- function(taxon, n = 10) { + # Step 1: Share of observed cells holding a detection + m <- as.matrix(sp[[taxon]][, -1]) + p <- sort(colMeans(m > 0, na.rm = TRUE), decreasing = TRUE) + + # Step 2: Return the most widespread few + data.table( + species = names(p), + prop_units = round(unname(p), 3) + )[seq_len(n)] +} + +# Most widespread vascular plants +print(prevalence("vascular_plant")) + +# Most widespread mammals +print(prevalence("mammal")) + +# Species never detected anywhere, which carry no signal +for (tx in taxa) { + m <- as.matrix(sp[[tx]][, -1]) + cat(sprintf( + "%-15s %4d of %5d species never detected\n", + tx, + sum(colSums(m > 0, na.rm = TRUE) == 0), + ncol(m) + )) +} + +## 2.6 Richness per survey unit ---- +# Species detected per survey unit. +for (tx in taxa) { + r <- rowSums(as.matrix(sp[[tx]][, -1]) > 0, na.rm = TRUE) + cat(sprintf( + "%-15s richness min %3.0f median %6.1f max %4.0f\n", + tx, + min(r), + median(r), + max(r) + )) +} + +## 2.7 Mammal specifics ---- +mam <- sp$mammal +region <- sites[ + match(mam$survey_unit_id, sites$survey_unit_id), + region +] + +# Mammal rows by region +print(table(region)) + +# Season pairing: expect one 2 per species, and nothing else +mam_base <- sub("_(Summer|Winter)$", "", names(mam)[-1]) +print(table(table(mam_base))) + +## 2.8 Peek at a corner of each table ---- +# First rows and columns of each taxon file. +for (tx in taxa) { + cat("\n ", tx, "\n", sep = "") + print(sp[[tx]][1:3, 1:6]) +} + +## 2.9 Example join ---- +# What the split layout is for: response from a taxon CSV, +# context from sites.csv, joined on survey_unit_id. +moose <- merge( + mam[, .(survey_unit_id, Moose_Summer)], + sites[, .(survey_unit_id, region, nr, lat, long, summer_days)], + by = "survey_unit_id" +) + +print(head(moose)) + +# Mean Moose_Summer by natural region, as a sanity check +print(moose[, + .( + mean_moose = round(mean(Moose_Summer, na.rm = TRUE), 3), + units = .N + ), + by = nr +][order(-mean_moose)]) + +# 3. Compare the CSVs against the source files ---- +# Round trip on 01_harmonize_model_ready_v2.R: every written +# value is traced back to the snapshot it came from. + +## 3.1 Name the source files ---- +plant_files <- c( + vascular_plant = "vascular-plant-model-data.Rdata", + bryophyte = "bryophyte-model-data.Rdata", + lichen = "lichen-model-data.Rdata", + mite = "mite-model-data.Rdata" +) + +# The mammal climate offset, produced outside this repository. +mammal_climate_pred_file <- Sys.getenv( + "SDM_MAMMAL_CLIMATE_PRED", + unset = setup_input( + "abmi_mammals", + "Results/Habitat Modeling/2024/Climate/Predictions", + "All Species Climate Predictions.csv" + ) +) + +mammal_files <- c( + north = paste0( + "R Dataset SpTable for ABMI North mammal ", + "coefficients 2024.RData" + ), + south = paste0( + "R Dataset SpTable for ABMI South mammal ", + "coefficients 2024.RData" + ) +) + +## 3.2 Helper functions ---- + +#' Load a Snapshot File into an Isolated Environment +#' +#' @param file Character. File name within snapshot_dir. +#' @return An environment holding the file's objects. +#' +#' @example # Example usage of the function +#' # read_source("mite-model-data.Rdata") +read_source <- function(file) { + # Step 1: Read into a fresh environment, so the six files + # cannot overwrite each other's objects + env <- new.env() + load(file.path(snapshot_dir, file), envir = env) + + return(env) +} + +#' Count Disagreements Between Two Blocks of Values +#' +#' NA patterns must match exactly, but values are compared with +#' a tolerance, because a double does not survive the CSV round +#' trip bit-exactly. max_diff reports the drift +#' +#' @param a,b Data frames or matrices of the same shape. +#' @param tol Numeric. Largest difference treated as equal. +#' @return A list with `n`, the count of disagreeing cells, and +#' `max_diff`, the largest absolute difference seen. +#' +#' @example # Example usage of the function +#' # compare_blocks(csv[, ..spp], clim[, spp]) +compare_blocks <- function(a, b, tol = 1e-9) { + # Step 1: A shape mismatch is not comparable cell by cell + a <- unname(as.matrix(a)) + b <- unname(as.matrix(b)) + + if (!identical(dim(a), dim(b))) { + return(list(n = NA_integer_, max_diff = NA_real_)) + } + + # Step 2: Count NA-pattern and value disagreements together + delta <- abs(a - b) + + list( + n = sum(xor(is.na(a), is.na(b))) + + sum(delta > tol, na.rm = TRUE), + max_diff = max(delta, na.rm = TRUE) + ) +} + +# Results accumulate here so the checks read as one table. +checks <- list() + +#' Record the Outcome of One Check +#' +#' @param source Character. Which file the check ran against. +#' @param check Character. What was tested. +#' @param pass Logical. Whether it held. +#' @param detail Character. Optional supporting figure. +#' @return Invisibly NULL. Appends to `checks`. +#' +#' @example # Example usage of the function +#' # note("mite", "keys match source", TRUE) +note <- function(source, check, pass, detail = "") { + checks[[length(checks) + 1]] <<- data.table( + source = source, + check = check, + pass = pass, + detail = detail + ) + + invisible(NULL) +} + +#' Reduce a Species String to a Column-Safe Token +#' +#' @param x Character. Species strings. +#' @return Character. CamelCase with no punctuation. +#' +#' @example # Example usage of the function +#' # squash("Voles, Mice and Allies") +#' # [1] "VolesMiceAndAllies" +squash <- function(x) { + # Step 1: Delete apostrophes so they are not split points + x <- gsub("'", "", x, fixed = TRUE) + + # Step 2: Split on the remaining punctuation and capitalize + vapply( + strsplit(x, "[^A-Za-z0-9]+"), + function(p) { + p <- p[nzchar(p)] + paste0( + toupper(substring(p, 1, 1)), + substring(p, 2), + collapse = "" + ) + }, + character(1) + ) +} + +#' Rebuild a Mammal Column Name as the Harmonizer Would +#' +#' @param cols Character. Source column names, each ending in +#' "Summer" or "Winter". +#' @return Character. Harmonized names. +#' +#' @example # Example usage of the function +#' # harmonized_name("Black BearSummer") +#' # [1] "BlackBear_Summer" +harmonized_name <- function(cols) { + season <- ifelse(grepl("Summer$", cols), "Summer", "Winter") + + paste0(squash(sub("(Summer|Winter)$", "", cols)), "_", season) +} + +## 3.3 Plant taxa against source ---- +# Columns each CSV left behind are collected into `omitted`, to +# confirm only identity, site and climate fields were cut. +omitted <- list() + +for (tx in names(plant_files)) { + cat(" ", tx, "\n", sep = "") + csv <- fread(file.path(data_dir, paste0(tx, ".csv"))) + env <- read_source(plant_files[[tx]]) + clim <- env$climate.data + spp <- setdiff(names(csv), "survey_unit_id") + + note( + tx, + "keys match source, in order", + identical(csv$survey_unit_id, as.character(clim$SiteYearQu)) + ) + + note( + tx, + "every CSV species exists in source", + all(spp %in% names(clim)), + paste(setdiff(spp, names(clim)), collapse = ", ") + ) + + cmp <- compare_blocks(csv[, ..spp], clim[, spp]) + note( + tx, + "all species values match source", + cmp$n == 0, + sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) + ) + + declared <- unique(c( + env$veg.species.list, + env$soil.species.list + )) + note( + tx, + "modelled species all carried through", + all(declared %in% spp), + paste(length(setdiff(declared, spp)), "missing") + ) + + s <- sites[match(csv$survey_unit_id, survey_unit_id)] + + note( + tx, + "site coordinates match source", + isTRUE(all.equal(s$lat, as.numeric(clim$Lat))) && + isTRUE(all.equal(s$long, as.numeric(clim$Long))) + ) + + note( + tx, + "site design fields match source", + identical(s$year, as.integer(clim$Year)) && + identical(s$quadrant, as.character(clim$QUAD)) && + identical(s$nr, as.character(clim$NR)) + ) + + omitted[[tx]] <- setdiff(names(clim), spp) +} + +## 3.4 Mammal against source ---- +mam_csv <- fread(file.path(data_dir, "mammal.csv")) + +for (rg in names(mammal_files)) { + env <- read_source(mammal_files[[rg]]) + d <- as.data.frame(env$d, check.names = FALSE) + src_cols <- names(d)[ + env$first_sp_col_summer:env$last_sp_col_winter + ] + out_cols <- harmonized_name(src_cols) + lab <- paste("mammal", rg) + cat(" ", lab, "\n", sep = "") + + rows <- which(startsWith( + mam_csv$survey_unit_id, + paste0("mammal_", rg, "|") + )) + + note(lab, "row count matches source", length(rows) == nrow(d)) + + # Suffixes disambiguate the repeated location_project values, + # so strip them before comparing the keys back to source. + keys <- sub("__[0-9]+$", "", mam_csv$survey_unit_id[rows]) + note( + lab, + "keys match source, in order", + identical( + keys, + paste0("mammal_", rg, "|", d$location_project) + ) + ) + + note( + lab, + "harmonized names all present in CSV", + all(out_cols %in% names(mam_csv)), + paste(setdiff(out_cols, names(mam_csv)), collapse = ", ") + ) + + cmp <- compare_blocks(mam_csv[rows, ..out_cols], d[, src_cols]) + note( + lab, + "all species values match source", + cmp$n == 0, + sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) + ) + + # Species the other region carries but this one does not must + # be NA here, never zero. + all_spp <- setdiff(names(mam_csv), "survey_unit_id") + absent <- setdiff(all_spp, out_cols) + note( + lab, + "species absent from this region are NA", + length(absent) == 0 || + all(is.na(as.matrix(mam_csv[rows, ..absent]))), + paste(absent, collapse = ", ") + ) + + s <- sites[match(mam_csv$survey_unit_id[rows], survey_unit_id)] + + note( + lab, + "site fields match source", + isTRUE(all.equal(s$lat, as.numeric(d$Lat))) && + identical(s$summer_days, as.integer(d$SummerDays)) && + identical(s$winter_days, as.integer(d$WinterDays)) && + identical(s$project, as.character(d$project)) + ) +} + +## 3.5 Covariates and lookups against source ---- +# The covariate tables carry what the models regress against, so +# they are traced back the same way the responses were. Values +# are compared on relative difference; see the header. + +#' Count Disagreements on Relative Difference +#' +#' Covariates span 1e-4 (cover) to 1e6 (UTM), so no single +#' absolute tolerance fits; compare_blocks() suits responses. +#' +#' @param a,b Data frames or matrices of the same shape. +#' @param tol Numeric. Largest relative difference treated as +#' equal. The default is three orders of magnitude above the +#' drift a 15-significant-digit CSV actually produces. +#' @return A list with `n`, the count of disagreeing cells, and +#' `max_diff`, the largest relative difference seen. +#' +#' @example # Example usage of the function +#' # compare_blocks_rel(csv[, cols], clim[, cols]) +compare_blocks_rel <- function(a, b, tol = 1e-12) { + # Step 1: A shape mismatch is not comparable cell by cell + a <- unname(as.matrix(a)) + b <- unname(as.matrix(b)) + + if (!identical(dim(a), dim(b))) { + return(list(n = NA_integer_, max_diff = NA_real_)) + } + + # Step 2: Scale each difference by the source magnitude, with + # a floor so an exact zero does not divide by zero + scale <- pmax(abs(b), 1e-300) + delta <- abs(a - b) / scale + + list( + n = sum(xor(is.na(a), is.na(b))) + + sum(delta > tol, na.rm = TRUE), + max_diff = max(delta, na.rm = TRUE) + ) +} + +# The terms 01_harmonize_model_ready_v2.R leaves out of the +# climate table because they are products of stored columns, and +# the expressions the loader rebuilds them with. +derived_terms <- list( + Easting2 = function(d) d$Easting * d$Easting, + Northing2 = function(d) d$Northing * d$Northing, + EastingNorthing = function(d) d$Northing * d$Easting, + MAPPET = function(d) d$MAP * d$PET, + MAT2 = function(d) d$MAT * d$MAT, + CMDMAT = function(d) d$CMD * d$MAT, + MWMT2 = function(d) d$MWMT * d$MWMT +) + +#' Check One Taxon's Covariate Blocks Against Their Source +#' +#' Rebuilds each block from the master table via the column map +#' (master columns may carry a block suffix) and compares it to +#' its source frame. +#' +#' @param taxon_label Character. Value in covariates$taxon. +#' @param source_frames Named list of source data frames, one +#' per block, named as the map names the blocks. +#' @param source_ids Character. The survey_unit_id each source +#' row corresponds to, in source row order. NULL where the +#' source has no key that survives into the dataset, as for +#' mammals, whose repeated deployments are disambiguated with +#' a numbered suffix; the rows are then compared by position +#' and the row count is asserted instead. +#' @param label Character. Name used in the check output. +#' @return Invisibly NULL. Records checks through note(). +#' +#' @example # Example usage of the function +#' # check_covariates("mite", frames, ids, "mite") +check_covariates <- function(taxon_label, source_frames, + source_ids, label) { + sub <- as.data.frame(covariates[taxon == taxon_label]) + + note( + label, + "covariate rows present", + nrow(sub) > 0, + paste(nrow(sub), "rows") + ) + + if (nrow(sub) == 0) { + return(invisible(NULL)) + } + + # Step 1: Align rows with the source, by key or by position + n_source <- nrow(source_frames[[1]]) + + if (is.null(source_ids)) { + note( + label, + "covariate row count matches source", + nrow(sub) == n_source, + paste(nrow(sub), "vs", n_source, "source rows") + ) + + if (nrow(sub) != n_source) { + return(invisible(NULL)) + } + + row_order <- seq_len(nrow(sub)) + } else { + row_order <- match(sub$survey_unit_id, source_ids) + + note( + label, + "covariate keys resolve in source", + !anyNA(row_order), + paste(sum(is.na(row_order)), "unresolved") + ) + + if (anyNA(row_order)) { + return(invisible(NULL)) + } + } + + # Step 2: One pass per block the map records for this taxon + for (blk in names(source_frames)) { + m <- col_map[taxon == taxon_label & block == blk] + source_frame <- source_frames[[blk]] + + if (nrow(m) == 0) { + note(label, paste(blk, "block recorded in the map"), FALSE) + next + } + + absent_master <- setdiff(m$master_column, names(sub)) + absent_source <- setdiff(m$source_column, names(source_frame)) + + note( + label, + paste(blk, "columns present both sides"), + length(absent_master) == 0 && length(absent_source) == 0, + if (length(c(absent_master, absent_source)) > 0) { + paste( + utils::head(c(absent_master, absent_source), 5), + collapse = ", " + ) + } else { + paste(nrow(m), "columns") + } + ) + + if (length(absent_master) > 0 || length(absent_source) > 0) { + next + } + + # Step 3: Split by type. Numbers are compared on relative + # difference, everything else has to round-trip exactly. + is_num <- vapply( + m$source_column, + function(one) is.numeric(source_frame[[one]]), + logical(1) + ) + + if (any(is_num)) { + cmp <- compare_blocks_rel( + sub[, m$master_column[is_num], drop = FALSE], + source_frame[row_order, m$source_column[is_num], + drop = FALSE + ] + ) + + note( + label, + paste(blk, "numeric values match source"), + isTRUE(cmp$n == 0), + sprintf( + "%d cols, max rel diff %.2e", sum(is_num), cmp$max_diff + ) + ) + } + + other <- which(!is_num) + mismatched <- character(0) + + for (i in other) { + got <- as.character(sub[[m$master_column[i]]]) + src <- source_frame[row_order, m$source_column[i]] + + # A timestamp is stored formatted, not as POSIXct, so that + # a CSV round trip cannot shift it by a time zone. + if (inherits(src, "POSIXct")) { + src <- format(src) + } + + if (!identical(got, as.character(src))) { + mismatched <- c(mismatched, m$source_column[i]) + } + } + + if (length(other) > 0) { + note( + label, + paste(blk, "non-numeric values match"), + length(mismatched) == 0, + if (length(mismatched) > 0) { + paste(mismatched, collapse = ", ") + } else { + paste(length(other), "columns") + } + ) + } + } + + invisible(NULL) +} + +for (taxon in names(plant_files)) { + src <- read_source(plant_files[[taxon]]) + clim <- src$climate.data + + check_covariates( + taxon, + list( + climate = clim, + veg = src$veg.data, + soil = src$soil.data + ), + as.character(clim$SiteYearQu), + taxon + ) + + # The seven derived terms are not stored. Confirm each rebuilds + # from the stored columns to the value the snapshot holds. + # + # The filter value is held in its own variable: `taxon` is also + # a column of the master table, and data.table would resolve + # both sides of `taxon == taxon` to the column and keep every + # row. + this_taxon <- taxon + clim_csv <- as.data.frame(covariates[taxon == this_taxon]) + + sites_csv <- as.data.frame(sites) + + rebuild <- merge( + clim_csv, + sites_csv[, c("survey_unit_id", "easting", "northing")], + by = "survey_unit_id", + sort = FALSE + ) + names(rebuild)[names(rebuild) == "easting"] <- "Easting" + names(rebuild)[names(rebuild) == "northing"] <- "Northing" + + row_order <- match( + rebuild$survey_unit_id, as.character(clim$SiteYearQu) + ) + + stored_terms <- intersect(names(derived_terms), names(clim)) + worst <- 0 + + for (term in stored_terms) { + cmp <- compare_blocks_rel( + matrix(derived_terms[[term]](rebuild), ncol = 1), + matrix(clim[row_order, term], ncol = 1) + ) + worst <- max(worst, cmp$max_diff, na.rm = TRUE) + } + + note( + taxon, + "derived terms rebuild from stored", + worst <= 1e-12, + sprintf( + "%d terms, max rel diff %.2e", length(stored_terms), worst + ) + ) + + # The two species lists are the work queue, and each has its + # own ordering that modelled_species.csv has to preserve. + modelled <- as.data.frame(fread( + file.path(data_dir, "lookup", "modelled_species.csv") + )) + modelled <- modelled[modelled$taxon == taxon, ] + + veg_rows <- modelled[modelled$in_veg_models, ] + soil_rows <- modelled[modelled$in_soil_models, ] + + note( + taxon, + "veg species list round-trips", + identical( + veg_rows$species[order(veg_rows$veg_order)], + src$veg.species.list + ), + paste(nrow(veg_rows), "species") + ) + + note( + taxon, + "soil species list round-trips", + identical( + soil_rows$species[order(soil_rows$soil_order)], + src$soil.species.list + ), + paste(nrow(soil_rows), "species") + ) +} + +# Shared by all four taxa, so checked once (against the last +# taxon read above) +veg_pm_csv <- as.data.frame(fread( + file.path(data_dir, "lookup", "veg_prediction_matrix.csv") +)) +soil_pm_csv <- as.data.frame(fread( + file.path(data_dir, "lookup", "soil_prediction_matrix.csv") +)) + +# The four aggregate columns the vegetation models are predicted +# onto. They are absent from the snapshot's veg.pm and present in +# the v2 project's veg-prediction-matrix-CC_2024.csv, so this +# check reports which of the two was written. +veg_aggregates <- c("Peatland", "Mineral", "Upland", "CCR1234") +have_aggregates <- all( + veg_aggregates %in% colnames(veg_pm_csv) +) + +note( + "lookup", + "veg prediction matrix is the v2 CSV", + have_aggregates, + if (have_aggregates) { + "has the aggregate columns" + } else { + paste0( + "snapshot veg.pm fallback; no ", + paste( + setdiff(veg_aggregates, colnames(veg_pm_csv)), + collapse = ", " + ), + " - vegetation models cannot be fitted" + ) + } +) + +note( + "lookup", + "soil prediction matrix matches source", + isTRUE(all.equal( + soil_pm_csv, src$soil.pm, + check.attributes = FALSE + )), + paste(nrow(soil_pm_csv), "rows x", ncol(soil_pm_csv), "cols") +) + +## 3.6 Mammal covariates and lookups against source ---- +# From the same two SpTable files as the mammal response + +mammal_habitat_name <- c(north = "veg", south = "soil") + +for (region in names(mammal_files)) { + env <- read_source(mammal_files[[region]]) + d <- as.data.frame(env$d, stringsAsFactors = FALSE) + label <- paste("mammal", region) + + # Keyed mammal_: north and south are separate models on + # overlapping deployments. The habitat block is veg in the north + # and soil in the south. + habitat <- mammal_habitat_name[[region]] + frames <- list(d, d) + names(frames) <- c("climate", habitat) + + check_covariates( + paste0("mammal_", region), + frames, + NULL, + label + ) + + # The prediction matrix travels with the snapshot rather than + # being copied from the ABMI Mammals drive, because the two + # were checked and are the same. + pm_path <- file.path( + data_dir, "lookup", + paste0("mammal_", region, "_prediction_matrix.csv") + ) + + note( + label, + "prediction matrix matches source", + isTRUE(all.equal( + as.data.frame(fread(pm_path)), + as.data.frame(env$pred_matrix), + check.attributes = FALSE + )), + paste(nrow(env$pred_matrix), "rows") + ) + + # Four ordered lists per region: each season at the modelling + # threshold and at the use-availability threshold. + modelled <- as.data.frame(fread( + file.path(data_dir, "lookup", "mammal_modelled_species.csv") + )) + modelled <- modelled[modelled$region == region, ] + + for (season in c("summer", "winter")) { + rows <- modelled[modelled$season == season, ] + + in_models <- rows$in_models + got_models <- rows$species_season[in_models][ + order(rows$model_order[in_models]) + ] + + in_ua <- rows$in_ua_models + got_ua <- rows$species_season[in_ua][ + order(rows$ua_order[in_ua]) + ] + + note( + label, + paste(season, "species list round-trips"), + identical(got_models, env[[paste0("sp_table_", season)]]), + paste(length(got_models), "species") + ) + + note( + label, + paste(season, "ua species list round-trips"), + identical( + got_ua, env[[paste0("sp_table_", season, "_ua")]] + ), + paste(length(got_ua), "species") + ) + } +} + +## 3.6.1 Mammal climate predictions ---- +# The offset the habitat models take, produced by a separate +# climate pipeline and copied in with survey_unit_id added. +climate_pred_path <- file.path( + data_dir, "lookup", "mammal_climate_predictions.csv" +) + +if (file.exists(climate_pred_path) && + file.exists(mammal_climate_pred_file)) { + written <- as.data.frame( + fread(climate_pred_path, na.strings = "") + ) + source_pred <- as.data.frame(fread(mammal_climate_pred_file)) + + pred_species <- setdiff( + names(written), c("survey_unit_id", "location_project") + ) + + note( + "mammal climate", + "species columns match source", + identical( + pred_species, + setdiff(names(source_pred), "location_project") + ), + paste(length(pred_species), "species") + ) + + row_match <- match( + written$location_project, source_pred$location_project + ) + covered <- !is.na(row_match) + + cmp <- compare_blocks_rel( + written[covered, pred_species], + source_pred[row_match[covered], pred_species] + ) + + note( + "mammal climate", + "predictions match source", + isTRUE(cmp$n == 0), + sprintf( + "%d of %d rows covered, max rel diff %.2e", + sum(covered), nrow(written), cmp$max_diff + ) + ) + + # A deployment the climate pipeline did not reach must carry + # NA, which is what the v2 join would have produced. + note( + "mammal climate", + "uncovered deployments are NA", + all(is.na(written[!covered, pred_species])), + paste(sum(!covered), "uncovered") + ) +} else { + note( + "mammal climate", + "predictions available", + FALSE, + "file not found; set SDM_MAMMAL_CLIMATE_PRED" + ) +} + +## 3.6.2 Bird response, offsets and covariates ---- +# Birds come from one file rather than the snapshot. Its three +# frames are stored row-aligned on surveyid, so the key is +# rebuilt the same way 01_harmonize_model_ready_v2.R does. +if (file.exists(bird_data_file)) { + benv <- new.env() + load(bird_data_file, envir = benv) + + bcovs <- as.data.frame(benv$covs) + bkey <- paste0("bird|", as.integer(bcovs$surveyid)) + + bird_csv <- fread(file.path(data_dir, "bird.csv")) + bird_spp <- setdiff(names(bird_csv), "survey_unit_id") + + note( + "bird", + "keys match source, in order", + identical(bird_csv$survey_unit_id, bkey), + paste(nrow(bird_csv), "surveys") + ) + + cmp <- compare_blocks( + bird_csv[, ..bird_spp], benv$bird[, bird_spp] + ) + note( + "bird", + "counts match source", + isTRUE(cmp$n == 0), + sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) + ) + + # Poisson counts: whole and non-negative + bird_counts <- as.matrix(bird_csv[, ..bird_spp]) + note( + "bird", + "counts are non-negative whole numbers", + !anyNA(bird_counts) && + all(bird_counts >= 0) && + all(bird_counts %% 1 == 0), + paste("max", max(bird_counts)) + ) + + # One offset per survey and species + off_csv <- fread(file.path(data_dir, "bird_offsets.csv")) + + note( + "bird", + "offsets share the response layout", + identical(names(off_csv), names(bird_csv)) && + identical(off_csv$survey_unit_id, bkey), + paste(ncol(off_csv) - 1, "species") + ) + + cmp <- compare_blocks( + off_csv[, ..bird_spp], benv$off[, bird_spp] + ) + note( + "bird", + "offsets match source", + isTRUE(cmp$n == 0), + sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) + ) + + note( + "bird", + "every count has an offset", + !anyNA(as.matrix(off_csv[, ..bird_spp])), + paste(sum(is.na(as.matrix(off_csv[, ..bird_spp]))), "NA") + ) + + check_covariates( + "bird", + list( + climate = bcovs, + veg = bcovs, + soil = bcovs, + design = bcovs + ), + bkey, + "bird" + ) + + ## 3.6.3 Bird lookups ---- + bird_modelled <- fread( + file.path(data_dir, "lookup", "bird_modelled_species.csv") + ) + + note( + "bird", + "modelled species round-trip", + nrow(bird_modelled) == nrow(benv$birdlist) && + setequal(bird_modelled$species, benv$birdlist$species), + paste( + nrow(bird_modelled), "rows,", + length(unique(bird_modelled$species)), "species" + ) + ) + + note( + "bird", + "modelled species are response columns", + all(unique(bird_modelled$species) %in% bird_spp), + paste( + length(setdiff(unique(bird_modelled$species), bird_spp)), + "missing" + ) + ) + + # The source names the bootstrap columns "1" to "100", which a + # CSV header cannot be told apart from a row of data. They are + # renamed on write, so the check is on shape and values. + boot_csv <- fread( + file.path(data_dir, "lookup", "bird_bootstrap_ids.csv") + ) + + note( + "bird", + "bootstrap draws match source", + identical(dim(boot_csv), dim(as.data.frame(benv$boot))) && + all(as.matrix(boot_csv) == as.matrix(benv$boot)), + paste(nrow(boot_csv), "x", ncol(boot_csv)) + ) + + bird_design_ids <- covariates[taxon == "bird"]$surveyid + + note( + "bird", + "bootstrap draws resolve to a survey", + all(unique(unlist(boot_csv)) %in% bird_design_ids), + paste( + length(setdiff(unique(unlist(boot_csv)), bird_design_ids)), + "orphan draws" + ) + ) + + # Read back from CSV, factors take alphabetical levels, moving + # the reference level + levels_csv <- fread( + file.path(data_dir, "lookup", "bird_factor_levels.csv") + ) + + factor_cols <- names(bcovs)[ + vapply(bcovs, is.factor, logical(1)) + ] + + levels_ok <- all(vapply( + factor_cols, + function(one) { + got <- levels_csv[column == one][order(level_order)]$level + identical(got, levels(bcovs[[one]])) + }, + logical(1) + )) + + note( + "bird", + "factor levels kept in source order", + levels_ok, + paste(factor_cols, collapse = ", ") + ) +} else { + note( + "bird", + "data package reachable", + FALSE, + "file not found; set SDM_BIRD_DATA" + ) +} + +## 3.6.4 Harmonized lookups ---- +# _setup/09's outputs against the files checked above, so a +# lookup left stale by a rebuild of 01 or 06 fails +lookup_dir <- file.path(data_dir, "lookup") +harmonized <- c( + "species_queue.csv", "factor_levels.csv", "dataset_manifest.csv", + "bird_north_prediction_matrix.csv", + "bird_south_prediction_matrix.csv" +) +present <- file.exists(file.path(lookup_dir, harmonized)) + +note( + "lookups", "harmonized lookups written", all(present), + if (all(present)) "" else paste0( + "missing ", paste(harmonized[!present], collapse = ", "), + "; run 09_harmonize_lookups.R" + ) +) + +if (all(present)) { + queue <- fread(file.path(lookup_dir, "species_queue.csv"), + na.strings = "") + manifest <- fread(file.path(lookup_dir, "dataset_manifest.csv"), + na.strings = "") + + # Every queued species is a column of its taxon's response file + queued_ok <- vapply(unique(queue$taxon), function(one) { + file <- manifest$response_file[manifest$taxon == one][1] + columns <- names(fread(file.path(data_dir, file), nrows = 0)) + all(queue$species[queue$taxon == one] %in% columns) + }, logical(1)) + + note( + "lookups", "queued species are response columns", + all(queued_ok), + paste(names(queued_ok)[!queued_ok], collapse = ", ") + ) + + # The queue holds what the three source lookups hold + plant_rows <- fread(file.path(lookup_dir, "modelled_species.csv")) + bird_rows <- fread( + file.path(lookup_dir, "bird_modelled_species.csv") + ) + mammal_rows <- fread( + file.path(lookup_dir, "mammal_modelled_species.csv") + ) + expected <- sum(plant_rows$in_veg_models) + + sum(plant_rows$in_soil_models) + nrow(bird_rows) + + sum(mammal_rows$in_models) + sum(mammal_rows$in_ua_models) + + note( + "lookups", "queue rows match the source lookups", + nrow(queue) == expected, + paste0(nrow(queue), " queued, ", expected, " in the sources") + ) + + # Every file the manifest names exists + named <- c( + file.path(data_dir, manifest$response_file), + file.path(data_dir, stats::na.omit(manifest$offset_file)), + file.path(lookup_dir, + paste0(manifest$grid, "_prediction_matrix.csv")) + ) + + note( + "lookups", "manifest files exist", all(file.exists(named)), + paste(basename(named[!file.exists(named)]), collapse = ", ") + ) +} + +## 3.7 Verdict ---- +# Every check, then the tally. A FAIL means the CSVs no longer +# match the snapshot they claim to come from. +results <- rbindlist(checks) + +for (i in seq_len(nrow(results))) { + cat(sprintf( + "%-4s %-15s %-38s %s\n", + if (isTRUE(results$pass[i])) "ok" else "FAIL", + results$source[i], + results$check[i], + results$detail[i] + )) +} + +cat(sprintf( + "\n%d of %d checks passed\n", + sum(results$pass, na.rm = TRUE), + nrow(results) +)) + +# Columns the plant detection CSVs left behind. +# Confirm by eye that these are identity, site and climate fields +# only, and that no species is among them. +print(omitted) + +# End of script ---- diff --git a/1_code/_setup/03_rerun_bryophyte_v2_reference.R b/1_code/_setup/03_rerun_bryophyte_v2_reference.R new file mode 100644 index 0000000..580aa08 --- /dev/null +++ b/1_code/_setup/03_rerun_bryophyte_v2_reference.R @@ -0,0 +1,357 @@ +# --- +# title: Re-run the v2 Bryophyte Models to Restore the Reference +# author: Brendan Casey +# created: 2026-09-10 +# inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. +# in the v2 project (SDM_V2_PROJECT): +# - 0_data/species/processed/bryophyte-model-data.Rdata +# - 0_data/bootstrap/bryophyte-bootstrap-ids.Rdata +# - 0_data/lookup/prediction-matrix/*.csv +# in this repository: +# - 0_data/v2_scripts/plants/hierarchical-model_functions.R +# outputs: +# in 2_pipeline/v2_reference/: +# - bryophyte-species-models.Rdata +# notes: +# - The published bryophyte reference is unusable: every entry +# is a `could not find function "model.avg"` error (MuMIn was +# missing on the cluster workers). +# - Regenerates the climate stage with the frozen v2 functions, +# unmodified, writing to 2_pipeline/ only. +# - 134 species x 100 draws x 58 models is large; +# `species_n` and `boot_n` build a partial reference, which +# the per-species gate can still use. +# - Section 3.3 checks MuMIn loads on a worker before fitting. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(foreach) # sequential %dopar%, as in v2 (version: 1.5.2) +library(parallel) # bootstrap-level parallelism (version: 4.5.0) + +## 1.2 Configure ---- +project_root <- normalizePath(getwd(), winslash = "/") + +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(project_root, "1_code/_setup/utils/input_paths.R")) + +v2_project <- Sys.getenv( + "SDM_V2_PROJECT", + unset = setup_input("vegetation_models") +) + +out_dir <- file.path(project_root, "2_pipeline/v2_reference") + +# NULL runs everything. Set them to build a partial reference. +species_n <- NULL +boot_n <- NULL + +n_clusters <- 14 + +## 1.3 Load the frozen v2 functions ---- +# From the byte-identical snapshot in 0_data/v2_scripts/ +source(file.path( + project_root, + "0_data/v2_scripts/plants/hierarchical-model_functions.R" +)) + +## 1.4 Set the seed ---- +# Seeded, unlike v2, so this reference reproduces itself +boot_seed <- 20260910L + +## 1.5 Load the v2 data ---- +model_data_path <- file.path( + v2_project, "0_data/species/processed", + "bryophyte-model-data.Rdata" +) + +bootstrap_path <- file.path( + v2_project, "0_data/bootstrap", "bryophyte-bootstrap-ids.Rdata" +) + +for (path in c(model_data_path, bootstrap_path)) { + if (!file.exists(path)) { + stop( + "v2 input not found:\n ", path, + "\nSet SDM_V2_PROJECT to the VegetationModels project.", + call. = FALSE + ) + } +} + +load(model_data_path) +load(bootstrap_path) + +species.list <- unique(c(veg.species.list, soil.species.list)) + +if (!is.null(species_n)) { + species.list <- utils::head(species.list, species_n) + veg.species.list <- intersect(veg.species.list, species.list) + soil.species.list <- intersect(soil.species.list, species.list) +} + +boot.iter <- if (is.null(boot_n)) 1:100 else seq_len(boot_n) + +dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + +cat( + "Re-running v2 bryophyte models: ", length(species.list), + " species x ", length(boot.iter), " bootstraps\n", + sep = "" +) + +# 2. Bootstrap ids ---- +# Checked, not trusted: the bryophyte file holds 3 draws, not 100 + +## 2.1 Check what the stored ids carry ---- +stored_draws <- min(vapply(bootstrap.ids, ncol, integer(1))) + +cat("Stored bootstrap draws: ", stored_draws, "\n", sep = "") + +## 2.2 Regenerate when they fall short ---- +# A fresh, seeded draw (an unseeded partial set cannot be +# extended); the seed is saved beside the ids +if (stored_draws < max(boot.iter)) { + cat( + "Regenerating: ", max(boot.iter), " draws needed, ", + stored_draws, " stored.\n", + sep = "" + ) + + source(file.path( + project_root, + "0_data/v2_scripts/plants/bootstrapping_functions.R" + )) + + # The spatial blocks v2 resamples within, on its own grid. + site.block <- data.frame( + LongBlock = cut( + climate.data$Long, c(-121, -116, -112, -109) + ), + LatBlock = cut(climate.data$Lat, c(48, 51, 54, 57, 61)) + ) + + site.block$Block <- interaction( + droplevels(site.block$LongBlock), + droplevels(site.block$LatBlock), + sep = "::", drop = TRUE + ) + + reclass.site <- data.frame( + Orig = unique(site.block$Block), + Update = letters[seq_along(unique(site.block$Block))] + ) + + climate.data$Block <- reclass.site$Update[ + match(site.block$Block, reclass.site$Orig) + ] + + rm(site.block, reclass.site) + + set.seed(boot_seed) + + boot_cluster <- makeCluster(n_clusters) + clusterSetRNGStream(boot_cluster, boot_seed) + + clusterExport(boot_cluster, c( + "climate.data", "boot.iter", "bootstrap_data" + )) + + boot_start <- Sys.time() + + bootstrap.list <- lapply(species.list, function(one) { + # Exported by name: a worker cannot see the loop variable + # of a closure whose environment is the global one. + focal <- one + clusterExport(boot_cluster, "focal", envir = environment()) + + parSapply( + boot_cluster, as.list(boot.iter), + FUN = function(boot) { + tryCatch( + bootstrap_data( + data = climate.data, species = focal, + threshold = 20, boot = boot + ), + error = function(e) e + ) + } + ) + }) + + names(bootstrap.list) <- species.list + stopCluster(boot_cluster) + + bootstrap.ids <- lapply(bootstrap.list, simplify2array) + + cat( + "Regenerated ", length(bootstrap.ids), " species in ", + format(round(Sys.time() - boot_start, 1)), "\n", + sep = "" + ) + + save( + bootstrap.ids, boot_seed, + file = file.path(out_dir, "bryophyte-bootstrap-ids.Rdata") + ) +} + +# 3. Climate models ---- +# v2's 58 candidates: 14 base, 14 bioclim, 30 spatial + +## 3.1 Define the model sets ---- +climate.models <- list( + as.formula(paste("pcount ~ 1")), + as.formula(paste("pcount ~ PET")), + as.formula(paste("pcount ~ CMD")), + as.formula(paste("pcount ~ MAT")), + as.formula(paste("pcount ~ FFP")), + as.formula(paste("pcount ~ MAP + FFP")), + as.formula(paste("pcount ~ MAP + FFP + CMD")), + as.formula(paste("pcount ~ MAP + PET + CMD + MAPPET")), + as.formula(paste("pcount ~ MAT + MAP + CMD + CMDMAT")), + as.formula(paste("pcount ~ MAT + MAP")), + as.formula(paste("pcount ~ MWMT + TD")), + as.formula(paste("pcount ~ CMD + PET")), + as.formula(paste("pcount ~ MAT + MAT2 + MWMT + MWMT2")), + as.formula(paste("pcount ~ TD + FFP + MAT")) +) + +bioclim.models <- list(as.formula(paste(".~.+ bio9 + bio15"))) + +space.models <- list( + as.formula(paste(".~.+ Easting + Northing")), + as.formula(paste(".~.+ Easting + Northing + EastingNorthing")), + as.formula(paste( + ".~.+ Easting + Northing + Easting2 + Northing2 +", + "EastingNorthing" + )) +) + +## 3.2 Start the cluster ---- +core.input <- makeCluster(n_clusters) + +clusterExport(core.input, c( + "climate.data", "species.list", "bootstrap.ids", + "climate.models", "bioclim.models", "space.models", "boot.iter", + "climate_models" +)) + +invisible(clusterEvalQ(core.input, { + library(AICcmodavg) + library(arm) + library(binom) + library(mapproj) + library(mgcv) + library(MuMIn) + library(pROC) + library(RcmdrMisc) +})) + +## 3.3 Confirm MuMIn is loadable on a worker ---- +# The failure behind the unusable published reference +worker_has_mumin <- unlist(clusterEvalQ( + core.input, exists("model.avg") +)) + +if (!all(worker_has_mumin)) { + stopCluster(core.input) + stop( + "model.avg() is not available on ", sum(!worker_has_mumin), + " of ", length(worker_has_mumin), " cluster workers.\n", + "That is the failure that made the published reference ", + "unusable. Install MuMIn where the workers can see it.", + call. = FALSE + ) +} + +cat("MuMIn confirmed on all ", length(worker_has_mumin), + " workers\n", sep = "") + +## 3.4 Fit ---- +climate_start <- Sys.time() + +climate.coef <- foreach(species = species.list) %dopar% + t(parSapply( + core.input, + as.list(boot.iter), + FUN = function(boot) { + tryCatch( + climate_models( + species = species, data = climate.data, + boot.data = bootstrap.ids, + climate.models = climate.models, + bioclim.models = bioclim.models, + space.models = space.models, boot = boot + ), + error = function(e) e + ) + } + )) + +names(climate.coef) <- species.list +stopCluster(core.input) + +# Counted per draw: one bad draw in 100 leaves a usable species +usable_species <- sum( + vapply(climate.coef, is.numeric, logical(1)) +) + +failed_draws <- sum(vapply( + climate.coef, + function(x) { + if (is.numeric(x)) { + return(0L) + } + + sum(vapply( + seq_along(x), function(i) inherits(x[[i]], "condition"), + logical(1) + )) + }, + integer(1) +)) + +cat( + "Climate: ", usable_species, " of ", length(climate.coef), + " species fully usable; ", failed_draws, " failed draw(s),", + " in ", format(round(Sys.time() - climate_start, 1)), "\n", + sep = "" +) + +if (usable_species == 0 && failed_draws > 0) { + first <- climate.coef[[1]] + first_message <- "unknown" + + for (i in seq_along(first)) { + if (inherits(first[[i]], "condition")) { + first_message <- conditionMessage(first[[i]]) + break + } + } + + stop( + "No species produced a usable set. First error: ", + first_message, + call. = FALSE + ) +} + +# 4. Save ---- +# Climate only; the habitat sets depend on it and are a separate +# run +save( + climate.coef, + file = file.path(out_dir, "bryophyte-species-models.Rdata") +) + +cat( + "Wrote ", file.path(out_dir, "bryophyte-species-models.Rdata"), + "\n", + sep = "" +) + +# End of script ---- diff --git a/1_code/_setup/06_harmonize_bird_translation_lookup.R b/1_code/_setup/06_harmonize_bird_translation_lookup.R new file mode 100644 index 0000000..16268d7 --- /dev/null +++ b/1_code/_setup/06_harmonize_bird_translation_lookup.R @@ -0,0 +1,90 @@ +# --- +# title: Harmonize the v2 Bird Coefficient Translation Lookup +# author: Brendan Casey +# created: 2026-09-29 +# inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. +# in the BirdModels project (SDM_V2_BIRD_ROOT): +# - Data/lookups/Xn-veg-v2024.Rdata +# outputs: +# in 0_data/test_dataset/lookup/: +# - bird_veg_age_matrix.csv +# notes: +# - v2's 08.PackageCoefficients.R translates raw bird landcover +# coefficients onto the standardized habitat types by the +# `age` matrix (one row per type, one column per raw term: +# a pure stand's design values, age terms integrated over each +# class). modules/birds/standardize.R needs it. +# - Separate from 01 (hours to re-run), but re-run it whenever +# 01 rebuilds lookup/. +# - Written as read: raw glm column names, interactions sorted +# (isCon:wtAge), as v2 matches them. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # CSV writing (version: 1.16.4) + +## 1.2 Resolve paths ---- +project_root <- normalizePath(getwd(), winslash = "/") + +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(project_root, "1_code/_setup/utils/input_paths.R")) + +v2_bird_root <- Sys.getenv( + "SDM_V2_BIRD_ROOT", + unset = setup_input("bird_models") +) + +source_path <- file.path( + v2_bird_root, "Data", "lookups", "Xn-veg-v2024.Rdata" +) + +out_path <- file.path( + project_root, "0_data", "test_dataset", "lookup", + "bird_veg_age_matrix.csv" +) + +if (!file.exists(source_path)) { + stop( + "Bird age lookup not found:\n ", source_path, + "\nSet SDM_V2_BIRD_ROOT to the BirdModels project.", + call. = FALSE + ) +} + +# 2. Read and check ---- +source_env <- new.env() +load(source_path, envir = source_env) + +if (!exists("age", envir = source_env, inherits = FALSE)) { + stop("Xn-veg-v2024.Rdata holds no `age` object.", call. = FALSE) +} + +age <- source_env$age + +if (!is.matrix(age) || is.null(rownames(age)) || + is.null(colnames(age))) { + stop("`age` must be a matrix with row and column names.", + call. = FALSE) +} + +if (anyNA(age)) { + stop("`age` holds missing values.", call. = FALSE) +} + +# 3. Write ---- +# One row per standardized habitat type, in v2's order. +out <- data.table(type = rownames(age), as.data.table(age)) + +fwrite(out, out_path) + +cat( + "Wrote ", out_path, ": ", nrow(age), " habitat types by ", + ncol(age), " raw terms\n", + sep = "" +) + +# End of script ---- diff --git a/1_code/_setup/07_harmonize_v2_plant_bootstrap_ids.R b/1_code/_setup/07_harmonize_v2_plant_bootstrap_ids.R new file mode 100644 index 0000000..66f1fea --- /dev/null +++ b/1_code/_setup/07_harmonize_v2_plant_bootstrap_ids.R @@ -0,0 +1,163 @@ +# --- +# title: Harmonize v2's Stored Plant-Group Bootstrap Draws +# author: Brendan Casey +# created: 2026-09-29 +# inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. +# in the v2 plant project (SDM_V2_PROJECT): +# - 0_data/bootstrap/lichen-bootstrap-ids.Rdata +# - 0_data/bootstrap/mite-bootstrap-ids.Rdata +# - 0_data/bootstrap/vascular-plant-bootstrap-ids.Rdata +# in this repository: +# - 2_pipeline/v2_reference/bryophyte-bootstrap-ids.Rdata, +# from 03_rerun_bryophyte_v2_reference.R +# outputs: +# in 0_data/test_dataset/lookup/v2_bootstrap_ids//: +# - .rds, one per species +# notes: +# - v2's stored plant draws, replayed with +# `bootstrap = "v2_ids"` so parity can be numerical. +# - Each file: one species' matrix, units (SiteYearQu = +# survey_unit_id) by 100 draws; draw 1 is the full data. +# - Per species because the full sets are large (1.3 GB +# compressed for vascular plants). SDM_V2_BOOT_TAXA and +# SDM_V2_BOOT_SPECIES (comma-separated) select a subset. +# - Bryophytes use 03's regenerated draws (the published file +# holds 3), which are not those behind COEFS.RData, so +# bryophyte parity against v2_results.csv stays +# distributional. +# - Ids not in sites.csv are counted and reported, not dropped. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # reading sites.csv (version: 1.16.4) + +## 1.2 Resolve paths ---- +project_root <- normalizePath(getwd(), winslash = "/") + +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(project_root, "1_code/_setup/utils/input_paths.R")) + +v2_project <- Sys.getenv( + "SDM_V2_PROJECT", + unset = setup_input("vegetation_models") +) + +sources <- c( + bryophyte = file.path( + project_root, "2_pipeline", "v2_reference", + "bryophyte-bootstrap-ids.Rdata" + ), + lichen = file.path( + v2_project, "0_data", "bootstrap", "lichen-bootstrap-ids.Rdata" + ), + mite = file.path( + v2_project, "0_data", "bootstrap", "mite-bootstrap-ids.Rdata" + ), + vascular_plant = file.path( + v2_project, "0_data", "bootstrap", + "vascular-plant-bootstrap-ids.Rdata" + ) +) + +out_root <- file.path( + project_root, "0_data", "test_dataset", "lookup", + "v2_bootstrap_ids" +) + +## 1.3 Choose what to harmonize ---- +`%||%` <- function(a, b) if (is.null(a)) b else a + +split_env <- function(name) { + value <- Sys.getenv(name, unset = "") + if (!nzchar(value)) NULL else trimws(strsplit(value, ",")[[1]]) +} + +taxa <- split_env("SDM_V2_BOOT_TAXA") %||% names(sources) +species_filter <- split_env("SDM_V2_BOOT_SPECIES") + +unknown_taxa <- setdiff(taxa, names(sources)) + +if (length(unknown_taxa) > 0) { + stop("Unknown taxa: ", paste(unknown_taxa, collapse = ", "), + call. = FALSE) +} + +sites <- fread( + file.path(project_root, "0_data", "test_dataset", "sites.csv"), + select = "survey_unit_id" +)$survey_unit_id + +# 2. Harmonize ---- +for (taxon in taxa) { + path <- sources[[taxon]] + + if (!file.exists(path)) { + stop("Bootstrap ids not found for ", taxon, ":\n ", path, + call. = FALSE) + } + + cat("Reading ", taxon, " ...\n", sep = "") + source_env <- new.env() + load(path, envir = source_env) + ids <- source_env$bootstrap.ids + + if (!is.list(ids) || is.null(names(ids))) { + stop(taxon, ": `bootstrap.ids` is not a named list.", + call. = FALSE) + } + + keep <- if (is.null(species_filter)) { + names(ids) + } else { + intersect(names(ids), species_filter) + } + + out_dir <- file.path(out_root, taxon) + dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + + written <- 0L + skipped <- character(0) + unmatched <- 0L + + for (species in keep) { + draws <- ids[[species]] + + # Draws that errored in v2 are stored as error objects + if (!is.matrix(draws) || !is.character(draws)) { + skipped <- c(skipped, species) + next + } + + unmatched <- unmatched + sum(!draws[, 1] %in% sites) + saveRDS( + unname(draws), + file.path(out_dir, paste0(species, ".rds")) + ) + written <- written + 1L + } + + cat( + " ", taxon, ": wrote ", written, " species", + if (length(skipped) > 0) { + paste0("; skipped ", length(skipped), " with no usable draws") + } else { + "" + }, + if (unmatched > 0) { + paste0("; WARNING ", unmatched, " draw-1 ids not in sites.csv") + } else { + "" + }, + "\n", + sep = "" + ) + + rm(source_env, ids) + gc() +} + +# End of script ---- diff --git a/1_code/_setup/08_harmonize_abmiexplorer_results.R b/1_code/_setup/08_harmonize_abmiexplorer_results.R new file mode 100644 index 0000000..8ee573e --- /dev/null +++ b/1_code/_setup/08_harmonize_abmiexplorer_results.R @@ -0,0 +1,555 @@ +# --- +# title: Harmonize the ABMIexploreR Coefficients into a Parity +# Reference +# author: Brendan Casey +# created: 2026-10-02 +# inputs: +# Read via setup_input() (utils/input_paths.R); the original +# locations are listed, and SDM_* variables can point back. +# - data/species-coefs.RData from the ABbiodiversity/ABMIexploreR +# GitHub repository, at the commit pinned in section 1.2 +# - Data/lookups/birdlist.csv on the BirdModels drive, for the +# bird four-letter codes the harness keys on +# - 0_data/test_dataset/mammal.csv, header only, for the mammal +# keys the harness uses +# outputs: +# - 0_data/external/abmiexplorer//species-coefs.RData, the +# downloaded source, never overwritten +# - 0_data/v2_results/abmiexplorer/v2_results.csv +# - 0_data/v2_results/abmiexplorer/v2_results_coverage.csv +# notes: +# - Builds the v2 parity reference exp_000 scores against. +# Only birds need a network drive, for names. "05" below is +# the retired by-hand build from the v2 network outputs, which +# this was verified against. +# - ABMIexploreR holds species x term x draw arrays per taxon +# for Vegetation (north), Soil (south) and Climate, on the +# link scale. +# - Pinned to a commit: the data file changes between commits +# (on 2026-07-27 the mammal models were replaced by the 2024 +# models the harness reproduces). Only the data file is +# downloaded, not the package and its dependencies. +# +# - Checked against 05's reference on 2026-10-02, at the pinned +# commit: +# - Plants and birds are the same models. Every shared +# species and term matches to ~1e-15, except species where +# some v2 draws failed. 05 drops the failed draws (v2_n +# below 100); the package holds 100 finite draws for every +# cell, so its median moves slightly for those species. +# - The package is the published subset: about 10% fewer +# plant species than COEFS.RData, and 124 of 133 birds. +# Bryum.All, AMRO and YEWA, in the parity_check set, are +# not in it. +# - Mammals are the same models as 05's 2024 coefficient +# tables, presence, abundance and total, north and south, +# to ~1e-16 once back-transformed. The package stores them +# on the link scale (logit for presence, log for the other +# two) where the tables are on the response scale, which +# the harness writes, so they are back-transformed here. +# Its 100 draws are one fit repeated, as v2 fits mammal +# habitat once, so they are written as v2_n 1 and the +# comparison reads iteration 1, as it does against 05. +# South WetlandMargin is not in the package. +# - Amphibians are in the package and have no module yet. +# Their rows are written; nothing joins them. +# +# - The package relabels some terms, and puts mammals on the +# cross-taxa template. Verified-identical terms get an alias +# row under the harness's name (term_aliases()). Bird TreedFen +# is one coefficient in the package and nine age classes in +# v2 (r ~ 0.99), so it is not aliased. +# +# - The package pads every species to a full term template +# with exact zeros. A cell whose every draw is exactly zero +# is padding, not a fitted coefficient, and is dropped. +# +# - Read only, apart from the one download. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # summarizing and writing (version: 1.18.0) + +## 1.2 Pin the source ---- +# Change the commit deliberately, then re-run. The download +# lands in its own folder, so an old reference stays readable. +explorer_repo <- "ABbiodiversity/ABMIexploreR" + +explorer_sha <- Sys.getenv( + "SDM_ABMIEXPLORER_SHA", + unset = "848eeed5f7a3347606a02c19211fe35be41240d1" +) + +explorer_file <- "data/species-coefs.RData" + +## 1.3 Resolve the other locations ---- +project_root <- normalizePath(getwd(), winslash = "/") + +# The _setup inputs mirrored on ABMI-DATA2 (setup_input()) +source(file.path(project_root, "1_code/_setup/utils/input_paths.R")) + +# The same lookup v2's 08.PackageCoefficients.R uses to turn +# bird codes into the names the package carries. +bird_lookup_path <- Sys.getenv( + "SDM_V2_BIRD_LOOKUP", + unset = setup_input( + "bird_models", "Data/lookups/birdlist.csv" + ) +) + +mammal_data_path <- file.path( + project_root, "0_data/test_dataset/mammal.csv" +) + +source_dir <- file.path( + project_root, "0_data/external/abmiexplorer", explorer_sha +) +results_dir <- file.path( + project_root, "0_data/v2_results/abmiexplorer" +) + +for (one in c(source_dir, results_dir)) { + dir.create(one, recursive = TRUE, showWarnings = FALSE) +} + +## 1.4 Name the output columns ---- +# Identical to 05, so the comparison reads either file. +result_columns <- c( + "taxon", "region", "stage", "part", "season", + "species", "species_v2", "term", + "v2_median", "v2_p10", "v2_p90", "v2_se", "v2_n", "source" +) + +source_label <- paste0( + "ABMIexploreR@", substr(explorer_sha, 1, 7) +) + +## 1.5 Fetch the pinned data file ---- +coefs_path <- file.path(source_dir, basename(explorer_file)) + +if (!file.exists(coefs_path)) { + url <- paste0( + "https://raw.githubusercontent.com/", explorer_repo, "/", + explorer_sha, "/", explorer_file + ) + + cat("Downloading", url, "\n") + + # Via a temporary name, so an interrupted download leaves no + # truncated file + partial <- paste0(coefs_path, ".part") + old_timeout <- options(timeout = max(600, getOption("timeout"))) + status <- utils::download.file(url, partial, mode = "wb") + options(old_timeout) + + if (status != 0) { + stop("Download failed: ", url, call. = FALSE) + } + + invisible(file.rename(partial, coefs_path)) +} + +coefs_env <- new.env() +load(coefs_path, envir = coefs_env) +species_coefs <- coefs_env$species.coefs + +if (!is.list(species_coefs) || length(species_coefs) == 0) { + stop( + coefs_path, " holds no `species.coefs` list.", call. = FALSE + ) +} + +# 2. Map the package onto the harness ---- + +## 2.1 Taxa, models and parts ---- +taxon_slugs <- c( + Amphibians = "amphibian", + Birds = "bird", + Bryophytes = "bryophyte", + Lichens = "lichen", + Mammals = "mammal", + Mites = "mite", + VascularPlants = "vascular_plant" +) + +# Vegetation is fitted in the north, soil in the south, and +# climate once on everything, as in 05. +model_parts <- list( + Vegetation = list(region = "north", stage = "habitat"), + Soil = list(region = "south", stage = "habitat"), + Climate = list(region = "all", stage = "climate") +) + +# The part each taxon's rows are joined on. Mammal habitat is a +# hurdle stored as three arrays; mammal climate is fitted on +# presence. +mammal_parts <- c( + PA = "presence", AGP = "abundance", TA = "total" +) + +# The package stores mammal habitat on the link scale; v2's +# tables, and the harness, are on the response scale. Verified +# exact against 05 on 2026-10-02. Mammal climate is on the link +# scale in both, so it is left alone. +mammal_inverse_links <- list( + presence = stats::plogis, abundance = exp, total = exp +) + +part_of <- function(slug, stage, hurdle = NA) { + if (slug == "bird") { + return("count") + } + + if (slug == "mammal") { + return(if (stage == "climate") "presence" else hurdle) + } + + "detection" +} + +## 2.2 term_aliases() ---- + +#' Package Terms Under the Names the Harness Writes +#' +#' Each pair was checked on 2026-10-02 against 05's reference: +#' the package term's medians equal the v2 term's for every +#' shared species in the north. The package collapsed the fen +#' age classes and renamed the human-footprint classes; birds +#' also call v2's BlackSpruce classes TreedBog. Mammals are on +#' the cross-taxa template, so their native stand names are +#' restored, and each unaged stand type takes the value of its +#' age classes, which v2 holds equal for mammals. +#' +#' @param slug Character. A taxon slug. +#' @return A data frame of `from` and `to` term names. +#' +#' @example # Example usage of the function +#' # term_aliases("lichen") +term_aliases <- function(slug) { + footprint <- data.frame( + from = c("RuralResidential", "UrbanIndustrial", + "IndustrialRural"), + to = c("Rural", "Urban", "Industrial") + ) + + ages <- c("R", 1:8) + + if (slug %in% c("bryophyte", "lichen", "mite", + "vascular_plant")) { + # Plant fen ages carry one shared value in v2, so the single + # package term stands for each of them exactly. + return(rbind( + footprint, + data.frame(from = "TreedFen", to = paste0("TreedFen", ages)) + )) + } + + if (slug == "bird") { + return(rbind( + footprint, + data.frame( + from = paste0("TreedBog", ages), + to = paste0("BlackSpruce", ages) + ) + )) + } + + if (slug == "mammal") { + stands <- c( + WhiteSpruce = "Spruce", Deciduous = "Decid", + Pine = "Pine", Mixedwood = "Mixedwood", TreedBog = "TreedBog" + ) + cutblocks <- c( + CCWhiteSpruce = "CCSpruce", CCDeciduous = "CCDecid" + ) + renamed <- stands[names(stands) != stands] + + return(rbind( + footprint, + data.frame(from = "Wellsites", to = "Well"), + data.frame( + from = paste0(rep(names(renamed), each = 9), ages), + to = paste0(rep(renamed, each = 9), ages) + ), + data.frame( + from = paste0(rep(names(cutblocks), each = 5), c("R", 1:4)), + to = paste0(rep(cutblocks, each = 5), c("R", 1:4)) + ), + data.frame(from = paste0(names(stands), "R"), to = stands) + )) + } + + data.frame(from = character(0), to = character(0)) +} + +## 2.3 Species keys ---- +# Plants and amphibians key on the package's own SpeciesID. +# Birds key on the four-letter code, mammals on the column +# stems in the harness's mammal data. + +### 2.3.1 Bird codes ---- +bird_codes <- if (file.exists(bird_lookup_path)) { + lookup <- fread(bird_lookup_path, select = c("code", "sppid")) + stats::setNames(lookup$code, lookup$sppid) +} else { + warning( + "Bird lookup not found at ", bird_lookup_path, + "; birds are keyed on the package name and will not join. ", + "Set SDM_V2_BIRD_LOOKUP.", + call. = FALSE + ) + character(0) +} + +### 2.3.2 Mammal keys ---- +mammal_keys <- if (file.exists(mammal_data_path)) { + stems <- names(fread(mammal_data_path, nrows = 0)) + unique(sub("_(Summer|Winter)$", "", stems[-1])) +} else { + character(0) +} + +#' Translate Package Species Names to Harness Keys +#' +#' @param names Character vector of package SpeciesIDs. +#' @param slug Character. The taxon slug. +#' @return Character vector of keys, the package name where no +#' key is known. +#' +#' @example # Example usage of the function +#' # species_key(c("Grizzlybear", "Elk"), "mammal") +species_key <- function(names, slug) { + if (slug == "bird") { + keys <- unname(bird_codes[names]) + return(ifelse(is.na(keys), names, keys)) + } + + if (slug == "mammal" && length(mammal_keys) > 0) { + # The package and the harness differ only in case, except + # elk, which v2's survey data calls "Elk (wapiti)". + names <- ifelse(names == "Elk", "ElkWapiti", names) + keys <- mammal_keys[match(tolower(names), tolower(mammal_keys))] + return(ifelse(is.na(keys), names, keys)) + } + + names +} + +# 3. Flatten ---- + +## 3.1 flatten_array() ---- + +#' Summarize One Species x Term x Draw Array +#' +#' @param values Numeric 3-D array, draws in the third dimension. +#' @param slug Character. Taxon slug. +#' @param model Character. "Vegetation", "Soil" or "Climate". +#' @param hurdle Character. The mammal hurdle part, or NA. +#' @return A data frame in the output schema, or NULL. +#' +#' @example # Example usage of the function +#' # flatten_array(species_coefs$Lichens$Climate, "lichen", +#' # "Climate") +flatten_array <- function(values, slug, model, hurdle = NA) { + if (is.null(values) || length(dim(values)) != 3) { + return(NULL) + } + + species <- dimnames(values)[[1]] + terms <- dimnames(values)[[2]] + + # One row per species and term, draws across. Column-major + # order means species vary fastest, which the rep() calls + # below follow. + draws <- matrix(values, ncol = dim(values)[3]) + + finite <- is.finite(draws) + draws[!finite] <- NA_real_ + counts <- rowSums(finite) + + # Template padding: every draw exactly zero. Checked before any + # back-transform, which would turn the zeros into 0.5 or 1. Not + # applied to the mammal hurdle, which carries no padding and + # where v2 fixes the abundance Climate term at a real 0. + padding <- counts > 0 & is.na(hurdle) & + rowSums(draws != 0, na.rm = TRUE) == 0 + + # The package repeats v2's single mammal fit in every draw: + # written as v2_n 1, scored on iteration 1 + single_fit <- slug == "mammal" && + all(apply(draws, 1, function(x) { + length(unique(x[!is.na(x)])) <= 1 + })) + + if (slug == "mammal" && !is.na(hurdle)) { + draws <- mammal_inverse_links[[hurdle]](draws) + } + + keep <- counts > 0 & !padding + + quantiles <- apply( + draws[keep, , drop = FALSE], 1, stats::quantile, + probs = c(0.1, 0.5, 0.9), na.rm = TRUE, names = FALSE + ) + + stage <- model_parts[[model]]$stage + species_v2 <- rep(species, times = length(terms))[keep] + + data.frame( + taxon = slug, + region = model_parts[[model]]$region, + stage = stage, + part = part_of(slug, stage, hurdle), + season = if (slug == "mammal") "all" else NA_character_, + species = species_key(species_v2, slug), + species_v2 = species_v2, + term = rep(terms, each = length(species))[keep], + v2_median = quantiles[2, ], + v2_p10 = if (single_fit) NA_real_ else quantiles[1, ], + v2_p90 = if (single_fit) NA_real_ else quantiles[3, ], + v2_se = NA_real_, + v2_n = if (single_fit) 1L else counts[keep], + source = source_label, + stringsAsFactors = FALSE + ) +} + +## 3.2 add_aliases() ---- + +#' Copy Relabelled Terms Under the Harness's Names +#' +#' @param rows A data frame in the output schema, one taxon. +#' @param slug Character. The taxon slug. +#' @return `rows` with the alias rows appended. +#' +#' @example # Example usage of the function +#' # add_aliases(rows, "bird") +add_aliases <- function(rows, slug) { + aliases <- term_aliases(slug) + + if (is.null(rows) || nrow(aliases) == 0) { + return(rows) + } + + copies <- merge( + rows, aliases, by.x = "term", by.y = "from" + ) + + # A term the package already carries under the harness's name + # is never shadowed by an alias. + present <- paste(rows$region, rows$species, rows$term) + copies$term <- copies$to + copies <- copies[ + !paste(copies$region, copies$species, copies$term) %in% present, + result_columns + ] + + rbind(rows, copies) +} + +# 4. Assemble ---- +blocks <- list() +coverage <- list() + +for (taxon in names(species_coefs)) { + slug <- taxon_slugs[[taxon]] + + if (is.null(slug)) { + cat("Skipping unrecognized taxon", taxon, "\n") + next + } + + for (model in names(model_parts)) { + values <- species_coefs[[taxon]][[model]] + label <- paste(slug, model_parts[[model]]$region, + model_parts[[model]]$stage) + note <- NA_character_ + + # Mammal habitat is a list of hurdle arrays, named PA, AGP + # and TA; everything else is one unnamed array. + arrays <- if (is.list(values) && !is.array(values)) { + values[intersect(names(mammal_parts), names(values))] + } else { + list(values) + } + + rows <- do.call(rbind, lapply(seq_along(arrays), function(i) { + hurdle <- if (is.null(names(arrays))) { + NA + } else { + mammal_parts[[names(arrays)[i]]] + } + flatten_array(arrays[[i]], slug, model, hurdle) + })) + + rows <- add_aliases(rows, slug) + blocks[[label]] <- rows + + # Birds without a code cannot join; report the count + unkeyed <- if (slug == "bird" && !is.null(rows)) { + sum(!unique(rows$species_v2) %in% names(bird_codes)) + } else { + 0L + } + + coverage[[label]] <- data.frame( + source_label = label, + reachable = !is.null(rows) && nrow(rows) > 0, + rows = if (is.null(rows)) 0L else nrow(rows), + species = if (is.null(rows)) { + 0L + } else { + length(unique(rows$species)) + }, + looked_in = paste0(explorer_repo, "@", explorer_sha), + note = if (is.na(note) && unkeyed > 0) { + paste(unkeyed, "species have no bird code") + } else { + note + }, + stringsAsFactors = FALSE + ) + } +} + +# 5. Write ---- +kept <- blocks[!vapply(blocks, is.null, logical(1))] +results <- do.call(rbind, kept) + +if (is.null(results) || nrow(results) == 0) { + stop("No coefficients were read from ", coefs_path, + call. = FALSE) +} + +rownames(results) <- NULL +results <- results[, result_columns] + +# Ordered so the file is stable between builds and diffable. +results <- results[ + order( + results$taxon, results$region, results$stage, results$part, + results$species, results$term + ), , + drop = FALSE +] + +coverage <- do.call(rbind, coverage) +rownames(coverage) <- NULL + +results_path <- file.path(results_dir, "v2_results.csv") +coverage_path <- file.path(results_dir, "v2_results_coverage.csv") + +fwrite(results, results_path, na = "") +fwrite(coverage, coverage_path, na = "") + +cat("\nWrote", results_path, "\n") +cat(nrow(results), "rows,", length(unique(results$species)), + "species,", length(unique(results$taxon)), "taxa, from", + source_label, "\n\n") + +print(coverage[, c("source_label", "reachable", "rows", "species", + "note")]) + +# End of script ---- diff --git a/1_code/_setup/09_harmonize_lookups.R b/1_code/_setup/09_harmonize_lookups.R new file mode 100644 index 0000000..05baa77 --- /dev/null +++ b/1_code/_setup/09_harmonize_lookups.R @@ -0,0 +1,368 @@ +# --- +# title: Harmonize the Test Dataset Lookups Across Taxa +# author: Brendan Casey +# created: 2026-10-03 +# inputs: +# in 0_data/test_dataset/lookup/ (all written by 01 and 06): +# - modelled_species.csv, mammal_modelled_species.csv, +# bird_modelled_species.csv +# - bird_factor_levels.csv +# - bird_veg_age_matrix.csv +# - veg_, soil_, mammal_north_ and mammal_south_ +# prediction_matrix.csv +# outputs: +# in 0_data/test_dataset/lookup/: +# - species_queue.csv +# - factor_levels.csv +# - dataset_manifest.csv +# - bird_north_prediction_matrix.csv +# - bird_south_prediction_matrix.csv +# notes: +# - Writes one cross-taxon form of each lookup, so no method or +# new taxon needs taxon-specific file logic. Reads only +# 0_data/test_dataset/; run after 01 and 06. +# - species_queue.csv: `order` is the source list's order; +# `tier` separates mammals' full habitat models (20+ +# detections) from use-availability models (3+). +# - dataset_manifest.csv: the only place the harness learns file +# locations, covariate keys, grids and stored-draw layouts. +# - Bird grids: v2 translates bird coefficients with a model +# matrix, not a grid. The north grid rebuilds that matrix in +# covariate space and is checked to reproduce it exactly; the +# south grid is one row per soil class. Terms the matrix lacks +# are zero or the factor reference level, as v2 assumes. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # CSV reading and writing (version: 1.16.4) + +## 1.2 Resolve paths ---- +project_root <- normalizePath(getwd(), winslash = "/") +lookup_dir <- file.path( + project_root, "0_data", "test_dataset", "lookup" +) + +if (!dir.exists(lookup_dir)) { + stop( + "Run this from the repository root; no ", lookup_dir, + call. = FALSE + ) +} + +read_lookup <- function(name) { + path <- file.path(lookup_dir, name) + + if (!file.exists(path)) { + stop( + "Missing ", path, ". Run 01_harmonize_model_ready_v2.R ", + "(and 06 for the bird matrix) first.", + call. = FALSE + ) + } + + as.data.frame(fread(path)) +} + +write_lookup <- function(frame, name) { + fwrite(frame, file.path(lookup_dir, name), na = "") + cat("Wrote ", name, " (", nrow(frame), " rows)\n", sep = "") +} + +# 2. Species queue ---- +# Three source schemas become one + +## 2.1 queue_rows() ---- + +#' Rows of the Unified Species Queue +#' +#' @param species Character vector. +#' @param taxon,region,order,tier,season Values recycled to the +#' number of species. +#' @param source_name Character vector. The name the source +#' pipeline uses, where it differs from the dataset's column +#' name: mammals are "Black BearSummer" in v2's files and +#' "BlackBear_Summer" here. +#' @return A data frame in the queue schema. +#' +#' @example # Example usage of the function +#' # queue_rows(c("ALFL", "AMRO"), "bird", "north", 1:2) +queue_rows <- function( + species, taxon, region, order, tier = "modelled", + season = NA_character_, source_name = species +) { + if (length(species) == 0) { + return(NULL) + } + + data.frame( + taxon = as.character(taxon), + region = as.character(region), + season = as.character(season), + tier = as.character(tier), + species = as.character(species), + order = as.integer(order), + source_name = as.character(source_name), + stringsAsFactors = FALSE + ) +} + +## 2.2 Plant groups ---- +# One row per species, with membership of the north (veg) and +# south (soil) model sets as flags; each flag becomes a region. +plants <- read_lookup("modelled_species.csv") +north_plants <- plants[plants$in_veg_models, ] +south_plants <- plants[plants$in_soil_models, ] + +## 2.3 Mammals ---- +# Region and season are already columns; the two occurrence +# thresholds become tiers. +mammals <- read_lookup("mammal_modelled_species.csv") +full_mammals <- mammals[mammals$in_models, ] +ua_mammals <- mammals[mammals$in_ua_models, ] + +## 2.4 Birds ---- +# One row per species and region; the source order is the order +# within each region. +birds <- read_lookup("bird_modelled_species.csv") + +species_queue <- rbind( + queue_rows( + north_plants$species, north_plants$taxon, "north", + north_plants$veg_order + ), + queue_rows( + south_plants$species, south_plants$taxon, "south", + south_plants$soil_order + ), + queue_rows( + full_mammals$species, "mammal", full_mammals$region, + full_mammals$model_order, tier = "modelled", + season = full_mammals$season, + source_name = full_mammals$species_season + ), + queue_rows( + ua_mammals$species, "mammal", ua_mammals$region, + ua_mammals$ua_order, tier = "ua", season = ua_mammals$season, + source_name = ua_mammals$species_season + ), + queue_rows( + birds$species, "bird", birds$region, + stats::ave(seq_len(nrow(birds)), birds$region, FUN = seq_along) + ) +) + +## 2.5 Check and write ---- +duplicated_rows <- duplicated( + species_queue[, c("taxon", "region", "season", "tier", "species")] +) + +if (any(duplicated_rows)) { + stop( + sum(duplicated_rows), " species appear twice in one queue.", + call. = FALSE + ) +} + +write_lookup(species_queue, "species_queue.csv") + +# 3. Factor levels ---- +factor_files <- list.files( + lookup_dir, pattern = "_factor_levels\\.csv$" +) + +factor_levels <- do.call(rbind, lapply(factor_files, function(file) { + levels_table <- read_lookup(file) + data.frame( + taxon = sub("_factor_levels\\.csv$", "", file), + levels_table[, c("column", "level_order", "level")], + stringsAsFactors = FALSE + ) +})) + +write_lookup(factor_levels, "factor_levels.csv") + +reference_level <- function(taxon, column) { + rows <- factor_levels[ + factor_levels$taxon == taxon & factor_levels$column == column, + ] + rows$level[which.min(rows$level_order)] +} + +levels_of <- function(taxon, column) { + rows <- factor_levels[ + factor_levels$taxon == taxon & factor_levels$column == column, + ] + rows$level[order(rows$level_order)] +} + +# 4. Bird prediction grids ---- + +## 4.1 North, rebuilt from v2's translation matrix ---- +age_table <- read_lookup("bird_veg_age_matrix.csv") +age <- as.matrix(age_table[, -1]) +rownames(age) <- age_table$type + +vegc_levels <- levels_of("bird", "vegc") +dummies <- grep("^vegc", colnames(age), value = TRUE) + +# Each row's class is the dummy set to 1, or the reference level +# where none is +vegc <- vapply(seq_len(nrow(age)), function(i) { + hit <- dummies[age[i, dummies] == 1] + + if (length(hit) > 1) { + stop("Matrix row ", rownames(age)[i], " sets two classes.", + call. = FALSE) + } + + if (length(hit) == 0) vegc_levels[1] else sub("^vegc", "", hit) +}, character(1)) + +# Type flags enter only via age interactions, so are recovered as +# interaction / age where age is non-zero; else left at zero (no +# effect on predictions) +flags <- c("isCon", "isUpCon", "isBogFen", "isMix", "isPine", + "isWSpruce") +age_terms <- c("wtAge", "wtAge2", "wtAge05") + +flag_values <- sapply(flags, function(flag) { + vapply(seq_len(nrow(age)), function(i) { + for (term in age_terms) { + if (age[i, term] != 0) { + return(age[i, paste0(flag, ":", term)] / age[i, term]) + } + } + 0 + }, numeric(1)) +}) + +bird_north <- data.frame( + VegType = rownames(age), + vegc = vegc, + age[, c("wtAge", "wtAge2", "wtAge05", "fcc2"), drop = FALSE], + flag_values, + # Absent from a pure stand of a habitat type + road = 0, mWell = 0, mSoft = 0, mEnSft = 0, mTrSft = 0, + mSeism = 0, pWater_KM = 0, pWater2_KM = 0, + method = reference_level("bird", "method"), + stringsAsFactors = FALSE, + check.names = FALSE, + row.names = NULL +) + +### 4.1.1 Check the rebuild ---- +# Must reproduce v2's matrix column for column +rebuilt <- stats::model.matrix( + ~ vegc + wtAge + wtAge2 + wtAge05 + fcc2 + + (wtAge + wtAge2 + wtAge05):(isCon + isUpCon + isBogFen + + isMix + isPine + isWSpruce), + transform( + bird_north, vegc = factor(vegc, levels = vegc_levels) + ) +) +colnames(rebuilt) <- vapply( + strsplit(sub("^\\(Intercept\\)$", "Intercept", colnames(rebuilt)), + ":", fixed = TRUE), + function(pieces) paste(sort(pieces), collapse = ":"), + character(1) +) + +difference <- max(abs( + rebuilt[, colnames(age), drop = FALSE] - age +)) + +if (difference > 1e-12) { + stop( + "The rebuilt bird north grid does not reproduce ", + "bird_veg_age_matrix.csv (largest difference ", difference, + "). Not written.", + call. = FALSE + ) +} + +cat("Bird north grid reproduces v2's matrix (max diff ", + format(difference), ")\n", sep = "") + +write_lookup(bird_north, "bird_north_prediction_matrix.csv") + +## 4.2 South, one row per soil class ---- +soil_levels <- levels_of("bird", "soilc") + +bird_south <- data.frame( + VegType = soil_levels, + soilc = soil_levels, + paspen = 0, + road = 0, mWell = 0, mSoft = 0, pWater_KM = 0, pWater2_KM = 0, + method = reference_level("bird", "method"), + stringsAsFactors = FALSE +) + +write_lookup(bird_south, "bird_south_prediction_matrix.csv") + +# 5. Dataset manifest ---- +# A new taxon is added here and needs no harness change +plant_taxa <- c("vascular_plant", "bryophyte", "lichen", "mite") + +manifest <- rbind( + do.call(rbind, lapply(plant_taxa, function(taxon) { + data.frame( + taxon = taxon, + region = c("north", "south"), + response_file = paste0(taxon, ".csv"), + offset_file = NA_character_, + covariate_key = taxon, + grid = c("veg", "soil"), + bootstrap_ids = file.path("lookup", "v2_bootstrap_ids", taxon), + bootstrap_layout = "per_species_rds", + stringsAsFactors = FALSE + ) + })), + data.frame( + taxon = "mammal", + region = c("north", "south"), + response_file = "mammal.csv", + offset_file = NA_character_, + covariate_key = c("mammal_north", "mammal_south"), + grid = c("mammal_north", "mammal_south"), + bootstrap_ids = NA_character_, + bootstrap_layout = NA_character_, + stringsAsFactors = FALSE + ), + data.frame( + taxon = "bird", + region = c("north", "south"), + response_file = "bird.csv", + offset_file = "bird_offsets.csv", + covariate_key = "bird", + grid = c("bird_north", "bird_south"), + bootstrap_ids = file.path("lookup", "bird_bootstrap_ids.csv"), + bootstrap_layout = "per_taxon_csv", + stringsAsFactors = FALSE + ) +) + +## 5.1 Check every named file exists ---- +dataset_dir <- dirname(lookup_dir) +named <- c( + file.path(dataset_dir, manifest$response_file), + file.path(dataset_dir, stats::na.omit(manifest$offset_file)), + file.path(lookup_dir, + paste0(manifest$grid, "_prediction_matrix.csv")) +) +absent <- unique(named[!file.exists(named)]) + +if (length(absent) > 0) { + stop( + "The manifest names files that do not exist:\n ", + paste(absent, collapse = "\n "), + call. = FALSE + ) +} + +write_lookup(manifest, "dataset_manifest.csv") + +cat("\nLookups harmonized.\n") + +# End of script ---- diff --git a/1_code/_setup/10_publish_datasets.R b/1_code/_setup/10_publish_datasets.R new file mode 100644 index 0000000..30396f0 --- /dev/null +++ b/1_code/_setup/10_publish_datasets.R @@ -0,0 +1,206 @@ +# --- +# title: Publish the Test Dataset and v2 Results to ABMI-DATA2 +# author: Brendan Casey +# created: 2026-10-05 +# inputs: +# - 0_data/test_dataset/, from _setup/01-09, checked by 02 +# - 0_data/v2_results/abmiexplorer/, from _setup/08 +# outputs: +# in //ABMI-DATA2/science/sdmMethodsDev/0_data/ (SDM_SHARE_ROOT +# overrides it), for each dataset: +# - //, a copy of the local folder +# - //checksums.csv: path, bytes, md5 +# - //publish_record.md: when, by whom, from +# which commit +# notes: +# - Runs read these copies (harness/data_source.R). A version +# is never overwritten: publish a new one and move the pin. +# - Files are copied to .partial/, re-hashed, then +# renamed, so readers never see a half copy. +# - SDM_DATASET_VERSION sets the version (default: today's +# date, YYYY-MM-DD). SDM_PUBLISH picks the datasets, +# comma-separated (default: test_dataset,v2_results). +# - Run 02_validate_test_dataset.R first (not run here: it +# re-reads every source). +# - Run from the repository root. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # checksums writing (version: 1.16.4) + +## 1.2 Resolve paths and settings ---- +project_root <- normalizePath(getwd(), winslash = "/") +resolver <- file.path(project_root, "1_code/harness/data_source.R") + +if (!file.exists(resolver)) { + stop("Run this from the repository root.", call. = FALSE) +} + +# For the share root and each dataset's marker file +source(resolver) + +share_root <- Sys.getenv( + "SDM_SHARE_ROOT", + unset = sdm_published$root +) + +version <- Sys.getenv( + "SDM_DATASET_VERSION", + unset = format(Sys.Date()) +) + +datasets <- trimws(strsplit( + Sys.getenv("SDM_PUBLISH", unset = "test_dataset,v2_results"), + "," +)[[1]]) + +if (!grepl("^[0-9]{4}-[0-9]{2}-[0-9]{2}$", version)) { + stop( + "SDM_DATASET_VERSION must be a date, YYYY-MM-DD.", + call. = FALSE + ) +} + +unknown <- setdiff(datasets, names(sdm_published$versions)) + +if (length(unknown) > 0) { + stop("Unknown dataset(s): ", paste(unknown, collapse = ", "), + call. = FALSE) +} + +## 1.3 The commit the data was built with ---- +git_commit <- tryCatch( + system2("git", c("rev-parse", "HEAD"), stdout = TRUE), + error = function(e) "unknown" +) + +git_dirty <- tryCatch( + length(system2("git", c("status", "--porcelain"), + stdout = TRUE)) > 0, + error = function(e) NA +) + +# 2. publish_dataset() ---- + +#' Copy One Local Dataset to the Share as a New Version +#' +#' @param name Character. A dataset under 0_data/, such as +#' "test_dataset". +#' @param version Character. The version folder to create. +#' @return Character. The published folder, invisibly. +#' +#' @example # Example usage of the function +#' # publish_dataset("v2_results", "2026-10-05") +publish_dataset <- function(name, version) { + # Step 1: The local copy, complete enough to be the dataset + local_dir <- file.path(project_root, "0_data", name) + marker <- sdm_published$marker[[name]] + + if (!file.exists(file.path(local_dir, marker))) { + stop("No ", marker, " in ", local_dir, call. = FALSE) + } + + # Step 2: A new version, never an existing or half-made one + target <- file.path(share_root, name, version) + partial <- paste0(target, ".partial") + + if (dir.exists(target)) { + stop( + "Already published, and never overwritten:\n ", target, + "\nSet SDM_DATASET_VERSION to publish a new version.", + call. = FALSE + ) + } + + if (dir.exists(partial)) { + stop( + "A previous publish did not finish:\n ", partial, + "\nDelete it, then run this again.", + call. = FALSE + ) + } + + # Step 3: The files and their md5s + rel <- list.files(local_dir, recursive = TRUE, all.files = TRUE) + rel <- rel[basename(rel) != ".gitkeep"] + sums <- data.table( + path = rel, + bytes = file.size(file.path(local_dir, rel)), + md5 = unname(tools::md5sum(file.path(local_dir, rel))) + ) + + cat( + name, ": ", nrow(sums), " files, ", + round(sum(sums$bytes) / 1e9, 2), " GB -> ", target, "\n", + sep = "" + ) + + # Step 4: Copy into the partial folder + for (i in seq_len(nrow(sums))) { + to <- file.path(partial, sums$path[i]) + dir.create(dirname(to), recursive = TRUE, showWarnings = FALSE) + + if (!file.copy(file.path(local_dir, sums$path[i]), to, + copy.date = TRUE)) { + stop("Copy failed: ", sums$path[i], call. = FALSE) + } + + cat(sprintf(" [%d/%d] %s\n", i, nrow(sums), sums$path[i])) + } + + # Step 5: Re-hash the share copy before it is made visible + copied <- unname(tools::md5sum(file.path(partial, sums$path))) + bad <- is.na(copied) | copied != sums$md5 + + if (any(bad)) { + stop( + "md5 mismatch on the share; ", partial, " left for ", + "inspection:\n ", paste(sums$path[bad], collapse = "\n "), + call. = FALSE + ) + } + + # Step 6: Checksums and the record, then make it visible + fwrite(sums, file.path(partial, "checksums.csv")) + + writeLines(c( + paste0("# ", name, " ", version), + "", + paste0("- Published: ", format(Sys.time(), "%Y-%m-%d %H:%M")), + paste0("- By: ", Sys.info()[["user"]]), + paste0("- From: ", local_dir), + paste0( + "- Commit: ", git_commit, + if (isTRUE(git_dirty)) " (with uncommitted changes)" else "" + ), + paste0("- Files: ", nrow(sums), ", ", + round(sum(sums$bytes) / 1e6, 1), " MB"), + paste0("- R: ", R.version.string), + "", + "Built by 1_code/_setup/ in the sdmMethodsDev repository and", + "published by 1_code/_setup/10_publish_datasets.R. Never", + "edited after publishing; checksums.csv lists every file." + ), file.path(partial, "publish_record.md")) + + if (!file.rename(partial, target)) { + stop("Could not rename ", partial, " to ", target, call. = FALSE) + } + + invisible(target) +} + +# 3. Publish ---- +published <- vapply( + datasets, publish_dataset, character(1), version = version +) + +cat( + "\nPublished:\n ", paste(published, collapse = "\n "), + "\n\nTo use them, set sdm_published$versions in ", + "1_code/harness/data_source.R to \"", version, "\".\n", + sep = "" +) + +# End of script ---- diff --git a/1_code/_setup/README.md b/1_code/_setup/README.md new file mode 100644 index 0000000..85bcd14 --- /dev/null +++ b/1_code/_setup/README.md @@ -0,0 +1,89 @@ +# _setup + +Builds the frozen test dataset and the v2 reference in `0_data/`, then +publishes them to ABMI-DATA2. Run by hand, by maintainers, once per +source snapshot. No experiment runs these scripts: experiments read the +published copies (see `harness/data_source.R`). + +The scripts read their external inputs from a mirror on +`//ABMI-DATA2/science/sdmMethodsDev/0_data/setup_inputs/`, through +`utils/input_paths.R`, so anyone with access to that share can +rebuild. + +## Run + +From the repository root: + +```r +source("1_code/_setup/run.R") +``` + +`run.R` runs the steps in dependency order, with on/off switches in +section 1.2, and logs timings to `2_pipeline/_setup/run_log.csv`. `00`, +`03` and `10` are off by default. Run order: `01`, `06`, `09`, `02`, +`03`, `07`, `08`, then `10`. There is no `04` or `05`; they were +retired once `08` replaced them. + +## Scripts + +| Script | Reads | Writes | +| --- | --- | --- | +| `00_mirror_setup_inputs.R` | Every external input, at its original location | `setup_inputs/` on ABMI-DATA2, with `inputs_manifest.csv`. Run once; never overwrites | +| `01_harmonize_model_ready_v2.R` | The `model_ready_v2` snapshot, mammal camera climate, WildTrax species lookup, v2 prediction matrices, bird `Stratified.Rdata` | `0_data/test_dataset/`: responses, `sites.csv`, `covariates.csv`, `bird_offsets.csv`, and most of `lookup/` | +| `02_validate_test_dataset.R` | The test dataset and the same sources | Nothing; prints a pass / fail tally. Run after `01`, `06` and `09` | +| `03_rerun_bryophyte_v2_reference.R` | v2 plant project bryophyte data, frozen v2 functions in `0_data/v2_scripts/plants/` | `2_pipeline/v2_reference/`: `bryophyte-species-models.Rdata`, `bryophyte-bootstrap-ids.Rdata`. Takes hours | +| `06_harmonize_bird_translation_lookup.R` | v2's bird `Xn-veg-v2024.Rdata` | `lookup/bird_veg_age_matrix.csv`. Re-run whenever `01` rebuilds `lookup/` | +| `07_harmonize_v2_plant_bootstrap_ids.R` | v2's stored plant draws; `03`'s bryophyte draws | `lookup/v2_bootstrap_ids//.rds`, for `plant_bootstrap = "v2_ids"` | +| `08_harmonize_abmiexplorer_results.R` | ABMIexploreR's `species-coefs.RData` at a pinned commit; bird `birdlist.csv` | `0_data/external/abmiexplorer//`; `0_data/v2_results/abmiexplorer/v2_results.csv` and `v2_results_coverage.csv` | +| `09_harmonize_lookups.R` | `0_data/test_dataset/lookup/` only; offline, seconds | `species_queue.csv`, `factor_levels.csv`, `dataset_manifest.csv`, bird prediction grids | +| `10_publish_datasets.R` | `0_data/test_dataset/`, `0_data/v2_results/` | A new `/` of each on ABMI-DATA2, with `checksums.csv` and `publish_record.md` | +| `run.R` | The scripts above | Runs them in order | +| `utils/input_paths.R` | | `setup_input()`: paths inside the input mirror | + +After `10`, move the pin in `1_code/harness/data_source.R`. A +published version is never overwritten. + +## The test dataset + +`0_data/test_dataset/` holds the data the v2 models were fitted on. It +does not change between experiments. + +| File | Holds | +| --- | --- | +| `sites.csv` | One row per survey unit: identity, design, location, and an `in_` flag per taxon | +| `.csv` | `survey_unit_id` plus one column per species: detections (plants), densities (mammals), counts (birds) | +| `bird_offsets.csv` | QPAD log offsets per survey unit and bird species | +| `covariates.csv` | Every covariate for every taxon, keyed on `survey_unit_id` and a taxon covariate key | +| `lookup/dataset_manifest.csv` | Per taxon and region: files, covariate key, grid and stored draws. The harness reads file locations only from here | +| `lookup/species_queue.csv` | Every taxon's species queue in one schema | +| `lookup/covariate_columns.csv` | Each covariate's block and v2 spelling, per taxon | +| `lookup/factor_levels.csv` | Source order of categorical levels, so contrasts match v2 | +| `lookup/*_prediction_matrix.csv` | Habitat grids: one row per habitat type, a pure stand | +| `lookup/bird_bootstrap_ids.csv`, `lookup/v2_bootstrap_ids/` | v2's stored draws: birds, and plants per species | +| `lookup/mammal_climate_predictions.csv` | v2's precomputed mammal climate prediction | +| `lookup/bird_veg_age_matrix.csv` | v2's bird landcover translation matrix | + +Columns in more than one block are suffixed (`HardLin_veg`, +`HardLin_soil`). Ten derived columns (`TD`, `MAT2`, `Easting2` and +others) are computed on load, not stored. Taxon-specific details are in +[`docs/taxon_quirks.md`](../../docs/taxon_quirks.md). + +## Environment variables + +Each overrides a default path. + +| Variable | Read by | Points at | +| --- | --- | --- | +| `SDM_SETUP_INPUT_ROOT` | `00`–`08` | The input mirror | +| `SDM_SNAPSHOT_V2` | `01`, `02` | The `model_ready_v2` snapshot folder | +| `SDM_MAMMAL_CAMERA_CLIMATE` | `01` | `abmi-camera-climate_2023.Rdata` | +| `SDM_MAMMAL_CLIMATE_PRED` | `01`, `02` | `All Species Climate Predictions.csv` | +| `SDM_V2_LOOKUP` | `01` | The v2 folder holding the plant prediction matrices | +| `SDM_WT_SPECIES` | `01` | `WildTrax Species Strings.RData` | +| `SDM_BIRD_DATA` | `01`, `02` | The bird `Stratified.Rdata` v2 was fitted on | +| `SDM_V2_PROJECT` | `03`, `07` | The v2 plant project (`VegetationModels`) | +| `SDM_V2_BIRD_ROOT` | `06` | The v2 bird project (`BirdModels`) | +| `SDM_V2_BOOT_TAXA`, `SDM_V2_BOOT_SPECIES` | `07` | Comma-separated subsets to copy | +| `SDM_ABMIEXPLORER_SHA` | `08` | The ABMIexploreR commit to download | +| `SDM_V2_BIRD_LOOKUP` | `08` | The v2 bird `birdlist.csv` | +| `SDM_SHARE_ROOT`, `SDM_DATASET_VERSION`, `SDM_PUBLISH` | `10` | Publish root, version folder (default today, `YYYY-MM-DD`), datasets | diff --git a/1_code/_setup/_scratch.R b/1_code/_setup/_scratch.R deleted file mode 100644 index 5afe17c..0000000 --- a/1_code/_setup/_scratch.R +++ /dev/null @@ -1,507 +0,0 @@ -# --- -# title: Scratch Work -# author: Brendan Casey -# created: 2026-09-06 -# inputs: -# - ad hoc, temporary inputs as needed -# outputs: -# - none by default -# notes: -# Temporary workspace for testing, exploration, and one-off -# tasks. Keep work grouped under dated headings and move any -# durable code into the appropriate script or module. -# -# Headings run three deep, so the Outline menu reads as a -# day > task > step outline: -# # YYYY-MM-DD ---- one per day of scratch work -# ## Task ---- one per piece of work that day, named -# for what it does, not for the date -# ### Step ---- stages within a task; the first is -# Setup, loading packages and data -# -# Add new code under the current date heading, creating that -# heading if the day does not have one yet. A day with only -# one task still gets both a date and a task heading, so the -# outline stays the same shape throughout. -# --- - -# 2026-09-06 ---- - -## Inspect the harmonized test dataset ---- -# Read the six CSVs written by -# _setup/01_harmonize_model_ready_v2.R and check they hold -# together: that every taxon key resolves in sites.csv, that the -# response values are on the scale each taxon should be on, and -# that the two-file layout joins the way it is meant to. - -### Setup ---- -library(data.table) - -data_dir <- file.path( - normalizePath(getwd(), winslash = "/"), - "0_data/test_dataset" -) - -taxa <- c( - "vascular_plant", - "bryophyte", - "lichen", - "mite", - "mammal" -) - -sites <- fread(file.path(data_dir, "sites.csv")) - -sp <- lapply(taxa, function(x) { - fread(file.path(data_dir, paste0(x, ".csv"))) -}) -names(sp) <- taxa - -### File overview ---- -# File overview: rows, columns and size on disk -print(data.table( - file = c("sites", taxa), - rows = c(nrow(sites), sapply(sp, nrow)), - cols = c(ncol(sites), sapply(sp, ncol)), - mb = round( - file.info( - file.path(data_dir, paste0(c("sites", taxa), ".csv")) - )$size / - 1024^2, - 1 - ) -)) - -### Site table ---- -# Structure of sites.csv -str(sites) - -# One row per design; each leaves the other's fields empty -print(head(sites[survey_design == "plant_quadrant"], 3)) -print(head(sites[survey_design == "mammal_camera"], 3)) - -# Survey units by design and region -print(sites[, .N, by = .(survey_design, region)]) - -# Units covered by each taxon file -print(sites[, lapply(.SD, sum), .SDcols = patterns("^in_")]) - -# Units sampled by all four plant taxa -print(sites[ - in_vascular_plant & in_bryophyte & in_lichen & in_mite, - .N -]) - -# Temporal and spatial extent -print(sites[, .( - first_year = min(year, na.rm = TRUE), - last_year = max(year, na.rm = TRUE) -)]) -print(summary(sites[, .(lat, long)])) - -# Survey effort, which the mammal cameras alone carry -print(summary(sites[ - survey_design == "mammal_camera", - .(summer_days, winter_days) -])) - -### Join integrity ---- -# Every taxon key should resolve in sites.csv, with no repeats -for (tx in taxa) { - key <- sp[[tx]]$survey_unit_id - cat(sprintf( - "%-15s rows %6d | all in sites %-5s | dup keys %d\n", - tx, - length(key), - all(key %in% sites$survey_unit_id), - sum(duplicated(key)) - )) -} - -### Response values per taxon ---- -# Plants are 0/1 with no NAs; mammals are counts and carry NAs -# NA means not tabulated, which is not the same as zero. -# fill is the share of observed cells with a detection. - -for (tx in taxa) { - m <- as.matrix(sp[[tx]][, -1]) - cat(sprintf( - "%-15s spp %5d | range %-12s | NA %6d | fill %.3f\n", - tx, - ncol(m), - paste(round(range(m, na.rm = TRUE), 2), collapse = " - "), - sum(is.na(m)), - mean(m > 0, na.rm = TRUE) - )) -} - -### Species prevalence ---- -# Proportion of surveyed units where each species was detected. -prevalence <- function(taxon, n = 10) { - m <- as.matrix(sp[[taxon]][, -1]) - p <- sort(colMeans(m > 0, na.rm = TRUE), decreasing = TRUE) - - data.table( - species = names(p), - prop_units = round(unname(p), 3) - )[seq_len(n)] -} - -# Most widespread vascular plants -print(prevalence("vascular_plant")) - -# Most widespread mammals -print(prevalence("mammal")) - -# Species never detected anywhere, which carry no signal -for (tx in taxa) { - m <- as.matrix(sp[[tx]][, -1]) - cat(sprintf( - "%-15s %4d of %5d species never detected\n", - tx, - sum(colSums(m > 0, na.rm = TRUE) == 0), - ncol(m) - )) -} - -### Richness per survey unit ---- -# Species detected per survey unit -for (tx in taxa) { - r <- rowSums(as.matrix(sp[[tx]][, -1]) > 0, na.rm = TRUE) - cat(sprintf( - "%-15s richness min %3.0f median %6.1f max %4.0f\n", - tx, - min(r), - median(r), - max(r) - )) -} - -### Mammal specifics ---- -mam <- sp$mammal -region <- sites[ - match(mam$survey_unit_id, sites$survey_unit_id), - region -] - -# Mammal rows by region -print(table(region)) - -# Season pairing: expect one 2 per species, and nothing else -mam_base <- sub("_(Summer|Winter)$", "", names(mam)[-1]) -print(table(table(mam_base))) - -# Raccoon: South-only, and the one name absent from WildTrax -cat( - "Raccoon_Summer all NA in north:", - all(is.na(mam$Raccoon_Summer[region == "north"])), - "\n" -) -cat( - "Raccoon_Summer observed in south:", - sum(!is.na(mam$Raccoon_Summer[region == "south"])), - "rows\n" -) - -### Peek at a corner of each table ---- -# First rows and columns of each taxon file -for (tx in taxa) { - cat("\n ", tx, "\n", sep = "") - print(sp[[tx]][1:3, 1:6]) -} - -### Example join ---- -# What the split layout is for: response joined to context -moose <- merge( - mam[, .(survey_unit_id, Moose_Summer)], - sites[, .(survey_unit_id, region, nr, lat, long, summer_days)], - by = "survey_unit_id" -) - -print(head(moose)) - -# Mean Moose_Summer by natural region, as a sanity check -print(moose[, - .( - mean_moose = round(mean(Moose_Summer, na.rm = TRUE), 3), - units = .N - ), - by = nr -][order(-mean_moose)]) - -## Compare the CSVs against the source .RData files ---- -# Round trip on 01_harmonize_model_ready_v2.R: every written -# value is traced back to the snapshot it came from. This does -# not call that script's functions, and restates the few rules it -# needs, so a bug in the harmonizer shows up here instead of -# cancelling itself out. - -### Setup ---- -# Round trip: every written value traced back to the snapshot -# The harmonizer's own functions are not used, so a bug there -# shows up here rather than cancelling itself out. - -library(data.table) - -snapshot_dir <- Sys.getenv( - "SDM_SNAPSHOT_V2", - unset = paste0( - "//ABMI-DATA2/science/sc/sdmMethodsDev/0_data/", - "data_snapshots/model_ready_v2" - ) -) - -out_dir <- file.path( - normalizePath(getwd(), winslash = "/"), - "0_data/test_dataset" -) - -plant_files <- c( - vascular_plant = "vascular-plant-model-data.Rdata", - bryophyte = "bryophyte-model-data.Rdata", - lichen = "lichen-model-data.Rdata", - mite = "mite-model-data.Rdata" -) - -mammal_files <- c( - north = paste0( - "R Dataset SpTable for ABMI North mammal ", - "coefficients 2024.RData" - ), - south = paste0( - "R Dataset SpTable for ABMI South mammal ", - "coefficients 2024.RData" - ) -) - -# na.strings = "" matters here: fwrite wrote NA as empty, and -# without this the character columns read back as "" and every -# is.na() test below would silently return FALSE. -site_csv <- fread( - file.path(out_dir, "sites.csv"), - na.strings = "" -) - -read_source <- function(file) { - env <- new.env() - load(file.path(snapshot_dir, file), envir = env) - env -} - -# Count disagreements between two blocks. NA patterns must match -# exactly, but values are compared with a tolerance: fwrite emits -# 15 significant digits, so a double does not survive the CSV -# round trip bit-exactly. The plant 0/1 blocks come back exact; -# the mammal counts drift by ~1e-13, which max_diff makes -# visible rather than hiding behind a tolerance. -compare_blocks <- function(a, b, tol = 1e-9) { - a <- unname(as.matrix(a)) - b <- unname(as.matrix(b)) - - if (!identical(dim(a), dim(b))) { - return(list(n = NA_integer_, max_diff = NA_real_)) - } - - delta <- abs(a - b) - - list( - n = sum(xor(is.na(a), is.na(b))) + sum(delta > tol, na.rm = TRUE), - max_diff = max(delta, na.rm = TRUE) - ) -} - -# Results accumulate here so the checks read as one table. -checks <- list() - -note <- function(source, check, pass, detail = "") { - checks[[length(checks) + 1]] <<- data.table( - source = source, - check = check, - pass = pass, - detail = detail - ) -} - -### Plant taxa against source ---- -# Checking the four plant-group CSVs against their .Rdata files -# Columns each CSV left behind are collected into `omitted`, -# to confirm only identity, site and climate fields were cut. - -omitted <- list() - -for (tx in names(plant_files)) { - cat(" ", tx, "\n", sep = "") - csv <- fread(file.path(out_dir, paste0(tx, ".csv"))) - env <- read_source(plant_files[[tx]]) - clim <- env$climate.data - spp <- setdiff(names(csv), "survey_unit_id") - - note( - tx, - "keys match source, in order", - identical(csv$survey_unit_id, as.character(clim$SiteYearQu)) - ) - - note( - tx, - "every CSV species exists in source", - all(spp %in% names(clim)), - paste(setdiff(spp, names(clim)), collapse = ", ") - ) - - cmp <- compare_blocks(csv[, ..spp], clim[, spp]) - note( - tx, - "all species values match source", - cmp$n == 0, - sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) - ) - - declared <- unique(c(env$veg.species.list, env$soil.species.list)) - note( - tx, - "modelled species all carried through", - all(declared %in% spp), - paste(length(setdiff(declared, spp)), "missing") - ) - - s <- site_csv[match(csv$survey_unit_id, survey_unit_id)] - - note( - tx, - "site coordinates match source", - isTRUE(all.equal(s$lat, as.numeric(clim$Lat))) && - isTRUE(all.equal(s$long, as.numeric(clim$Long))) - ) - - note( - tx, - "site design fields match source", - identical(s$year, as.integer(clim$Year)) && - identical(s$quadrant, as.character(clim$QUAD)) && - identical(s$nr, as.character(clim$NR)) - ) - - omitted[[tx]] <- setdiff(names(clim), spp) -} - -### Mammal against source ---- -# Checking mammal.csv against the North and South .RData files -# Column names are rebuilt here as punctuation-stripped -# CamelCase. That they match confirms the WildTrax lookup only -# ever canonicalized punctuation, never renamed a species. - -squash <- function(x) { - x <- gsub("'", "", x, fixed = TRUE) - vapply( - strsplit(x, "[^A-Za-z0-9]+"), - function(p) { - p <- p[nzchar(p)] - paste0( - toupper(substring(p, 1, 1)), - substring(p, 2), - collapse = "" - ) - }, - character(1) - ) -} - -harmonized_name <- function(cols) { - season <- ifelse(grepl("Summer$", cols), "Summer", "Winter") - paste0(squash(sub("(Summer|Winter)$", "", cols)), "_", season) -} - -mam_csv <- fread(file.path(out_dir, "mammal.csv")) - -for (rg in names(mammal_files)) { - env <- read_source(mammal_files[[rg]]) - d <- as.data.frame(env$d, check.names = FALSE) - src_cols <- names(d)[ - env$first_sp_col_summer:env$last_sp_col_winter - ] - out_cols <- harmonized_name(src_cols) - lab <- paste("mammal", rg) - cat(" ", lab, "\n", sep = "") - - rows <- which(startsWith( - mam_csv$survey_unit_id, - paste0("mammal_", rg, "|") - )) - - note(lab, "row count matches source", length(rows) == nrow(d)) - - # Suffixes disambiguate the repeated location_project values, - # so strip them before comparing the keys back to source. - keys <- sub("__[0-9]+$", "", mam_csv$survey_unit_id[rows]) - note( - lab, - "keys match source, in order", - identical(keys, paste0("mammal_", rg, "|", d$location_project)) - ) - - note( - lab, - "harmonized names all present in CSV", - all(out_cols %in% names(mam_csv)), - paste(setdiff(out_cols, names(mam_csv)), collapse = ", ") - ) - - cmp <- compare_blocks(mam_csv[rows, ..out_cols], d[, src_cols]) - note( - lab, - "all species values match source", - cmp$n == 0, - sprintf("%d cells, max diff %.1g", cmp$n, cmp$max_diff) - ) - - # Species the other region carries but this one does not must - # be NA here, never zero. - all_spp <- setdiff(names(mam_csv), "survey_unit_id") - absent <- setdiff(all_spp, out_cols) - note( - lab, - "species absent from this region are NA", - length(absent) == 0 || - all(is.na(as.matrix(mam_csv[rows, ..absent]))), - paste(absent, collapse = ", ") - ) - - s <- site_csv[match(mam_csv$survey_unit_id[rows], survey_unit_id)] - - note( - lab, - "site fields match source", - isTRUE(all.equal(s$lat, as.numeric(d$Lat))) && - identical(s$summer_days, as.integer(d$SummerDays)) && - identical(s$winter_days, as.integer(d$WinterDays)) && - identical(s$project, as.character(d$project)) - ) -} - -### Verdict ---- -# Every check, most specific first -results <- rbindlist(checks) - -for (i in seq_len(nrow(results))) { - cat(sprintf( - "%-4s %-15s %-38s %s\n", - if (isTRUE(results$pass[i])) "ok" else "FAIL", - results$source[i], - results$check[i], - results$detail[i] - )) -} - -cat(sprintf( - "\n%d of %d checks passed\n", - sum(results$pass, na.rm = TRUE), - nrow(results) -)) - -# Columns the plant CSVs left behind -# Confirm by eye that these are identity, site and climate -# fields only, and that no species is among them. -print(omitted) - -# End of script ---- diff --git a/1_code/_setup/run.R b/1_code/_setup/run.R new file mode 100644 index 0000000..519de94 --- /dev/null +++ b/1_code/_setup/run.R @@ -0,0 +1,165 @@ +# --- +# title: Rebuild the Test Dataset and v2 Reference +# author: Brendan Casey +# created: 2026-10-05 +# inputs: +# - the _setup/ scripts in this folder, and whatever each reads +# (see their headers); most read the input mirror on +# ABMI-DATA2 through utils/input_paths.R +# outputs: +# - 0_data/test_dataset/, from 01, 06 and 09 +# - 0_data/test_dataset/lookup/v2_bootstrap_ids/, from 07 +# - 0_data/v2_results/abmiexplorer/, from 08 +# - 2_pipeline/v2_reference/, from 03 +# - a new published version on ABMI-DATA2, from 10, only if +# switched on +# - 2_pipeline/_setup/run_log.csv: per step, start, end, +# minutes and whether it finished +# notes: +# - Runs the _setup/ scripts in their dependency order, for a +# manual rebuild. Switch steps on or off in section 1.2; the +# defaults rebuild everything local and publish nothing. +# - Off by default: +# - 00 mirrors the inputs onto ABMI-DATA2. Run once, by +# someone who can reach the original drives. +# - 03 re-runs the v2 bryophyte models: hours, and its +# output only changes if its sources do. +# - 10 publishes a new version. Run it deliberately, after +# checking 02's tally, then move the pin in +# 1_code/harness/data_source.R. +# - Each script runs in its own environment; an error stops +# the rebuild and is logged. +# - 02 prints a pass / fail tally rather than stopping; read it +# before using or publishing. +# - Section 3 prints how to point experiments at this rebuild. +# - Run from the repository root. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; each script loads its own. + +## 1.2 Choose the steps ---- +# In run order: 09 reads 01's and 06's lookups, 02 checks the +# finished dataset, 07 reads 03's bryophyte draws. +steps <- c( + "00_mirror_setup_inputs.R" = FALSE, + "01_harmonize_model_ready_v2.R" = TRUE, + "06_harmonize_bird_translation_lookup.R" = TRUE, + "09_harmonize_lookups.R" = TRUE, + "02_validate_test_dataset.R" = TRUE, + "03_rerun_bryophyte_v2_reference.R" = FALSE, + "07_harmonize_v2_plant_bootstrap_ids.R" = TRUE, + "08_harmonize_abmiexplorer_results.R" = TRUE, + "10_publish_datasets.R" = FALSE +) + +## 1.3 Check the paths ---- +setup_dir <- "1_code/_setup" + +if (!dir.exists(setup_dir)) { + stop( + "Run from the repository root; ", + setup_dir, + " not found.", + call. = FALSE + ) +} + +found <- file.exists(file.path(setup_dir, names(steps))) +missing <- names(steps)[!found] + +if (length(missing) > 0) { + stop( + "Not found in ", + setup_dir, + ":\n ", + paste(missing, collapse = "\n "), + call. = FALSE + ) +} + +log_dir <- "2_pipeline/_setup" +dir.create(log_dir, recursive = TRUE, showWarnings = FALSE) +log_path <- file.path(log_dir, "run_log.csv") + +# 2. Run the steps ---- + +## 2.1 run_step() ---- + +#' Source One _setup Script in an Environment of Its Own +#' +#' @param script Character. File name inside `setup_dir`. +#' @param setup_dir Character. The _setup folder. +#' @param log_path Character. The run log to append to. +#' @return TRUE, invisibly; stops if the script errors. +#' +#' @example # Example usage of the function +#' # run_step("09_harmonize_lookups.R", setup_dir, log_path) +run_step <- function(script, setup_dir, log_path) { + # Step 1: Announce and time the step + message("\n== ", script, " (", format(Sys.time(), "%H:%M"), ")") + started <- Sys.time() + + # Step 2: Source it in isolation, keeping any error + error <- tryCatch( + { + source( + file.path(setup_dir, script), + local = new.env(parent = globalenv()) + ) + NULL + }, + error = function(e) e + ) + + # Step 3: Log the outcome before stopping on an error + ended <- Sys.time() + row <- data.frame( + script = script, + started = format(started, "%Y-%m-%d %H:%M:%S"), + ended = format(ended, "%Y-%m-%d %H:%M:%S"), + minutes = round( + as.numeric(difftime(ended, started, units = "mins")), + 1 + ), + status = if (is.null(error)) "done" else "failed" + ) + + write.table( + row, + log_path, + sep = ",", + row.names = FALSE, + col.names = !file.exists(log_path), + append = file.exists(log_path) + ) + + if (!is.null(error)) { + stop(script, " failed: ", conditionMessage(error), call. = FALSE) + } + + message(" done in ", row$minutes, " min") + invisible(TRUE) +} + +## 2.2 Run the chosen steps in order ---- +to_run <- names(steps)[steps] +message("Rebuilding: ", paste(to_run, collapse = ", ")) + +for (script in to_run) { + run_step(script, setup_dir, log_path) +} + +# 3. Point experiments at the rebuild ---- +# The published copies are what experiments read by default. +message( + "\nRebuild finished. To run an experiment against it:\n", + " Sys.setenv(SDM_TEST_DATASET = \"0_data/test_dataset\")\n", + " Sys.setenv(SDM_V2_RESULTS = \"0_data/v2_results\")\n", + "Run log: ", + log_path +) + +# End of script ---- diff --git a/1_code/_setup/utils/input_paths.R b/1_code/_setup/utils/input_paths.R new file mode 100644 index 0000000..8d42d0e --- /dev/null +++ b/1_code/_setup/utils/input_paths.R @@ -0,0 +1,39 @@ +# --- +# title: Locate the _setup Inputs on ABMI-DATA2 +# author: Brendan Casey +# created: 2026-10-05 +# inputs: none +# outputs: none; defines setup_input_root and setup_input() +# notes: +# - Every external file _setup/ reads is mirrored, unchanged, +# under //ABMI-DATA2/science/sdmMethodsDev/0_data/ +# setup_inputs/ by 00_mirror_setup_inputs.R, so _setup/ can be +# run by anyone with access to that share. The originals stay +# where they were; 00_mirror_setup_inputs.R lists them and +# setup_inputs/inputs_manifest.csv records each copy. +# - The scripts' own SDM_* environment variables still override +# each path, so a source can be read from its original +# location. SDM_SETUP_INPUT_ROOT moves the whole mirror. +# --- + +# 1. The mirror root ---- +setup_input_root <- Sys.getenv( + "SDM_SETUP_INPUT_ROOT", + unset = "//ABMI-DATA2/science/sdmMethodsDev/0_data/setup_inputs" +) + +# 2. setup_input() ---- + +#' Build a Path Inside the _setup Input Mirror +#' +#' @param ... Character. Path components below the mirror root, +#' starting with the source folder (for example "bird_models"). +#' @return Character. The full path. +#' +#' @example # Example usage of the function +#' # setup_input("bird_models", "Data", "lookups", "birdlist.csv") +setup_input <- function(...) { + file.path(setup_input_root, ...) +} + +# End of script ---- diff --git a/1_code/experiments/.gitkeep b/1_code/experiments/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/experiments/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/experiments/README.md b/1_code/experiments/README.md new file mode 100644 index 0000000..03dae98 --- /dev/null +++ b/1_code/experiments/README.md @@ -0,0 +1,46 @@ +# experiments + +One folder per methods question, keyed `exp_NNN_short_description`. +Each folder has a `run.R` entry point that calls `experiment_config()` +and `run_experiment()` (see the [harness README](../harness/README.md)), +and a `README.md` stating the question. The same id names the +experiment's folders in `2_pipeline/` and `3_output/`. + +| Folder | Holds | Status | +| --- | --- | --- | +| `_shared/` | `focal_species.R`: `focal_species_sets()`, the named species sets (`full`, `parity_check`, `plants_only`, `one_each`) | | +| `_template/` | The `run.R` and `README.md` that `new_experiment()` fills in | | +| [`exp_000_parity_v2/`](exp_000_parity_v2/README.md) | The v2 parity check and the baseline for every other experiment | Not yet a gate | +| [`exp_001_xgboost/`](exp_001_xgboost/README.md) | Habitat stage fitted with xgboost, every taxon | Test; 5-draw check only | +| [`exp_002_soilgrids/`](exp_002_soilgrids/README.md) | SoilGrids 0–5 cm terms in the climate stage, plants and birds | Test; 5-draw check only | + +exp_000 is the required gate before iterative R&D: every other +experiment is compared against its tables. + +## Adding an experiment + +1. Scaffold it from the repository root: + + ```r + source("1_code/harness/new_experiment.R") + new_experiment("covariate scale") # dry_run = TRUE to preview + ``` + + This takes the next free number across `1_code/experiments/`, + `2_pipeline/` and `3_output/`, copies `_template/` with the id, + title, author and date filled in, and creates + `2_pipeline//logs/` and `3_output//` with `figures/`, + `tables/` and a stub `report.md`. Leave `id` in `run.R` as it is. +2. State the question and design in its `README.md`. +3. Change one thing relative to exp_000: `stage_models`, + `covariate_files` or `specs`. Keep exp_000's species, draws and seed + unless they are the question. +4. Never add columns to `0_data/` or change `_setup/` for an + experiment. Covariates the dataset lacks are written by a script in + the experiment's folder to `2_pipeline//inputs/` and named in + `covariate_files`; `exp_002_soilgrids` is the example. +5. Run it at 5 draws to check it works, then at 100. Compare it with + an exp_000 run at the same number of draws. + +Each lever is walked through in +[`docs/getting_started.md`](../../docs/getting_started.md#test-a-change). diff --git a/1_code/experiments/_shared/focal_species.R b/1_code/experiments/_shared/focal_species.R new file mode 100644 index 0000000..9f999d5 --- /dev/null +++ b/1_code/experiments/_shared/focal_species.R @@ -0,0 +1,154 @@ +# --- +# title: Focal Species Sets, Shared by Every Experiment +# author: Brendan Casey +# created: 2026-09-11 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - Named species sets shared by experiments, so a later +# experiment can run exactly exp_000's species. Sets follow +# taxon_values() (names are data slugs, e.g. "mite"); NULL +# means every species. +# - A taxon a set does not name is unrestricted, not excluded; +# narrow `taxa` alongside a partial set. +# - Available species: list_species(data_dir, "mite", "north"). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. focal_species_sets() ---- + +#' Every Named Focal-Species Set +#' +#' @return A named list of species vectors, each in the harness's +#' named-vector convention. +#' +#' @example # Example usage of the function +#' # names(focal_species_sets()) +#' # focal_species_sets()$parity_check +focal_species_sets <- function() { + list( + + ## 2.1 full ---- + # The full parity run + full = NULL, + + ## 2.2 parity_check ---- + # Two per taxon, chosen so the parity test discriminates: rare + # species have bands wide enough to pass anything. Criteria: + # well above 20 detections in both regions; prevalence ~5-45%; + # all 100 v2 draws usable; and one of each pair balanced + # between north and south. + # + # Detections north / south, and prevalence north / south: + # Ceratodon.purpureus 2140 / 554 44.1 / 24.0 + # Bryum.All 1941 / 856 40.0 / 37.1 + # Physcia.adscendens 2232 / 506 38.4 / 21.6 + # Cladonia.chlorophaea 2236 / 218 38.5 / 9.3 + # Ceratozetes.gracilis 1190 / 133 20.8 / 5.6 + # Trhypochthonius.tectorum 546 / 197 9.6 / 8.3 + # Galium.boreale 2875 / 588 41.8 / 22.2 + # Vicia.americana 2596 / 700 37.8 / 26.4 + # Moose_Summer 1585 / 225 31.2 / 17.8 + # Coyote_Summer 1362 / 893 26.8 / 70.8 + # AMRO 41853 /23613 24.4 / 25.9 + # YEWA 22337 /15887 13.0 / 17.5 + parity_check = c( + # Bryum.All is a genus-level aggregate rather than a + # single species, and is here because it is the only + # bryophyte with a strong south signal as well as a + # strong north one. Swap in Pylaisia.polyantha for two + # true species, at the cost of the southern test. + bryophyte = "Ceratodon.purpureus", + bryophyte = "Bryum.All", + + # The two best-detected lichens, so the tightest bands of + # any plant-group taxon. + lichen = "Physcia.adscendens", + lichen = "Cladonia.chlorophaea", + + # Ceratozetes is the strongest mite in the north; + # Trhypochthonius is the most even across the regions. + mite = "Ceratozetes.gracilis", + mite = "Trhypochthonius.tectorum", + + # Both common in both regions, which makes them the most + # discriminating pair in the set. + vascular_plant = "Galium.boreale", + vascular_plant = "Vicia.americana", + + # Both have a published climate reference. Coyote carries + # the south, where moose is thinner. Both seasons, because + # v2's mammal references average summer and winter; each + # season's spec takes its own and skips the other. + mammal = "Moose_Summer", + mammal = "Moose_Winter", + mammal = "Coyote_Summer", + mammal = "Coyote_Winter", + + # Gated on climate, and on landcover once translated to + # v2's standardized terms. + bird = "AMRO", + bird = "YEWA" + ), + + ## 2.3 plants_only ---- + # Pair with a narrowed `taxa`, or mammals and birds run every + # species (experiment_config() warns) + plants_only = c( + bryophyte = "Ceratodon.purpureus", + bryophyte = "Bryum.All", + lichen = "Physcia.adscendens", + lichen = "Cladonia.chlorophaea", + mite = "Ceratozetes.gracilis", + mite = "Trhypochthonius.tectorum", + vascular_plant = "Galium.boreale", + vascular_plant = "Vicia.americana" + ), + + ## 2.4 one_each ---- + # Shortest run touching every module, for plumbing checks + one_each = c( + bryophyte = "Ceratodon.purpureus", + lichen = "Physcia.adscendens", + mite = "Ceratozetes.gracilis", + vascular_plant = "Galium.boreale", + mammal = "Moose_Summer", + mammal = "Moose_Winter", + bird = "AMRO" + ) + ) +} + +# 3. get_focal_species() ---- + +#' Look Up One Focal-Species Set by Name +#' +#' An unrecognized value (e.g. an inline species vector) is +#' returned unchanged. +#' +#' @param name Character. A name from focal_species_sets(), or +#' a species vector to pass through, or NULL for all species. +#' @param sets Named list. The registry to look in. +#' @return A named character vector, or NULL. +#' +#' @example # Example usage of the function +#' # get_focal_species("one_each") +#' # get_focal_species(c(mite = "Oppiella.nova")) +get_focal_species <- function(name, + sets = focal_species_sets()) { + if (is.null(name) || length(name) == 0) { + return(NULL) + } + + if (length(name) > 1 || !name %in% names(sets)) { + return(name) + } + + sets[[name]] +} + +# End of script ---- diff --git a/1_code/experiments/_template/README.md b/1_code/experiments/_template/README.md new file mode 100644 index 0000000..5ab9715 --- /dev/null +++ b/1_code/experiments/_template/README.md @@ -0,0 +1,40 @@ +# exp_NNN_short_description + +![Status](https://img.shields.io/badge/Status-Planned-lightgrey) +![Languages](https://img.shields.io/badge/Languages-R-blue) + +## Question + +One sentence: what does this experiment ask? + +## Design + +- **What changes relative to exp_000:** the one thing this + experiment varies (a covariate, a model set, an engine, a + selection rule). +- **What stays the same:** taxa, species, draws and seed, unless + they are the question. +- **How it is set:** `stage_models` or `specs` in `run.R`. + +## How to read the result + +Every experiment is compared with the v2 baseline (exp_000): +`run_experiment()` prints the headline per taxon, region and +metric (median difference, and the share of species that did +better), and writes one comparison table to `3_output//tables/`: + +| File | One row per | Read it for | +| --- | --- | --- | +| `comparison_metrics.csv` | species and metric | Which species moved, with both runs' 10-90% bands | + +The metrics are out-of-bag: each draw scored on the survey units it +left out. "Better" is higher AUC, deviance explained and Spearman, +lower RMSE, and a calibration slope closer to 1. + +## Result + +_To be written after a full run._ + +## Assumptions and caveats + +- diff --git a/1_code/experiments/_template/run.R b/1_code/experiments/_template/run.R new file mode 100644 index 0000000..93b2129 --- /dev/null +++ b/1_code/experiments/_template/run.R @@ -0,0 +1,83 @@ +# --- +# title: Run Experiment NNN - [Short Description] +# author: [Your Name] +# created: [YYYY-MM-DD] +# inputs: +# - the published test dataset (harness/data_source.R) +# - 3_output/exp_000_parity_v2/tables/, the v2 baseline +# outputs: +# in 2_pipeline/exp_NNN_short_description/: +# - // result stores, and run_log.csv +# in 3_output/exp_NNN_short_description/: +# - tables/ (summaries, and comparison_metrics.csv against the +# baseline), run_record.md +# notes: +# - Start an experiment with new_experiment("description") +# (harness/new_experiment.R), which numbers it, fills this +# header and creates its 2_pipeline/ and 3_output/ folders. +# Copying by hand instead, set `id` below to the folder's name. +# - State the question in the README. +# - Change one thing relative to exp_000, so a difference in the +# comparison is a difference in that thing. Use the same +# species, draws and seed as exp_000 unless they are the +# question. +# - The usual levers, from least to most invasive: +# - `stage_models`: different candidate formulas for a stage +# (new covariates, a different model set). +# - `covariate_files`: covariates the dataset does not hold, +# from a CSV this experiment's own script writes to +# 2_pipeline//inputs/. Never add them to 0_data/ or +# _setup/, which stay the v2 data. +# - `specs`: a spec with a stage changed - a different engine +# or selection rule. For a new habitat method in every +# taxon, mammals included, one call: +# specs <- lapply(standard_specs(), replace_stage_method, +# engine = "xgboost") +# See exp_001_xgboost and docs/getting_started.md. +# - A new method in 1_code/methods/, then named in a spec; +# see 1_code/methods/README.md. +# --- + +# 1. Setup ---- + +## 1.1 Load the framework ---- +source("1_code/harness/harness.R") +load_framework() + +## 1.2 Configure the run ---- +config <- experiment_config( + id = "exp_NNN_short_description", + + # The runs to fit, from names(standard_specs()) + taxa = c( + "bryophyte", "lichen", "mite", "vascular_plant", + "mammal_summer", "mammal_winter", "bird" + ), + + # The same species exp_000 ran, so the comparison is like for + # like + species = "parity_check", + n_bootstraps = 100, + seed = 20260909, + + # The change this experiment tests. For example, every climate + # candidate with elevation added: + # stage_models = list( + # climate = extend_models("climate_plant_v2_full", "elevation") + # ), + stage_models = NULL, + + workers = 12 +) + +# 2. Run ---- +# Fit, summarize, and compare with the v2 baseline (exp_000); +# every experiment is compared with it. The comparison is +# written to tables/comparison_metrics.csv. Add `steps` for anything +# this experiment needs beyond that. +results <- run_experiment( + config, + translate = list(bird = bird_habitat_translation) +) + +# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/.gitkeep b/1_code/experiments/exp_000_parity_v2/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/experiments/exp_000_parity_v2/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/experiments/exp_000_parity_v2/01_collect_results.R b/1_code/experiments/exp_000_parity_v2/01_collect_results.R deleted file mode 100644 index 3418500..0000000 --- a/1_code/experiments/exp_000_parity_v2/01_collect_results.R +++ /dev/null @@ -1,62 +0,0 @@ -# --- -# title: Collect v2 Model Output (Experiment 000) -# author: Brendan Casey -# created: 2026-09-05 -# inputs: -# in 2_pipeline/exp_000_parity_v2//3_output/: -# - models/-species-models.Rdata -# - validation/-models-validation.Rdata -# outputs: -# in 3_output/exp_000_parity_v2/tables/: -# - species_.csv -# - validation_summary.csv -# notes: -# - Placeholder. Reads the raw output each taxon module left in -# 2_pipeline/ and writes flat summaries to 3_output/. -# - Raw model objects stay in 2_pipeline/ on purpose. They are -# 100 bootstraps by every species by three model families, -# which is too large to commit; only the derived summaries -# belong in 3_output/. -# - Expects exp_id, project_root, and out_dir from run.R. -# --- - -# 1. Setup ---- - -## 1.1 Resolve paths ---- -# Sourced by run.R, so the experiment configuration is already -# in the environment. -pipeline_dir <- file.path(project_root, "2_pipeline", exp_id) - -tables_dir <- file.path(out_dir, "tables") -dir.create(tables_dir, recursive = TRUE, showWarnings = FALSE) - -## 1.2 Identify the taxa that produced output ---- -# A taxon appears here only when its module ran in this pass. -staged_taxa <- list.dirs( - pipeline_dir, full.names = FALSE, recursive = FALSE -) -staged_taxa <- setdiff(staged_taxa, "logs") - -# 2. Collect model coefficients ---- -# TODO: load each -species-models.Rdata, reduce the -# bootstrap coefficient arrays to per-species summaries, and -# write one table per taxon. - -# 3. Collect validation metrics ---- -# TODO: load each -models-validation.Rdata and write the -# per-species AUC and fit measures to validation_summary.csv. - -# 4. Report what was found ---- -cat( - "01_collect_results.R is a placeholder. Taxa staged in ", - pipeline_dir, ": ", - if (length(staged_taxa) > 0) { - paste(staged_taxa, collapse = ", ") - } else { - "none" - }, - "\n", - sep = "" -) - -# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/01_compare_to_v2.R b/1_code/experiments/exp_000_parity_v2/01_compare_to_v2.R new file mode 100644 index 0000000..6195a41 --- /dev/null +++ b/1_code/experiments/exp_000_parity_v2/01_compare_to_v2.R @@ -0,0 +1,510 @@ +# --- +# title: Compare Against the v2.0 Reference (Experiment 000) +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# - `config`, from run.R: out_dir, data_dir, v2_reference_dir, +# n_bootstraps, v2_bootstraps, focal_species +# - `results$coefficient_summary`, from collect_results() +# - in config$v2_reference_dir: +# - v2_results.csv, built by _setup/08 from the pinned +# ABMIexploreR coefficients +# outputs: +# - in out_dir/tables/: parity_terms.csv, parity_summary.csv +# - `results$parity`, `results$parity_summary` and +# `results$parity_notes`, for the later steps +# notes: +# - The gate: this run's coefficients against v2's, per stage, +# species and term. Reads only v2_results.csv. +# - What is joined to what: +# - v2 climate reference rows carry region "all"; a run's +# north and south climate results are both scored against +# them. +# - Habitat is joined on region. Plant terms are relabelled +# as v2's 04a standardization does; bird terms are the +# translated ones collect_results() adds (stage "habitat", +# via run.R's `translate`), and the raw "landcover" stage +# is not scored. +# - Mammals are joined on the hurdle part, and their two +# season runs are averaged first, because v2's `.all` +# references average summer and winter. +# - Where v2 bootstraps, the v2 median is scored against this +# run's 10-90% band. Where v2 fits once (mammals, v2_n = 1), +# iteration 1 is compared and the absolute difference read. +# - Terms from v2_unreachable_terms() are left out of the +# reachable scores. What cannot be compared goes to +# `results$parity_notes`. +# - Run as a script_step(). +# --- + +# 1. Setup ---- + +## 1.1 Resolve paths ---- +tables_dir <- file.path(config$out_dir, "tables") +dir.create(tables_dir, recursive = TRUE, showWarnings = FALSE) + +reference_path <- file.path(config$v2_reference_dir, "v2_results.csv") +reference_builder <- config$v2_reference_builder + +## 1.2 Read this run and the reference ---- +run_coefficients <- results$coefficient_summary + +if (is.null(run_coefficients)) { + message("No coefficients were collected; nothing to compare.") +} + +reference <- if (file.exists(reference_path)) { + as.data.frame(data.table::fread(reference_path)) +} else { + message( + "No v2 reference at ", reference_path, + "; run ", reference_builder, "." + ) + NULL +} + +notes <- list() + +# 2. What cannot match ---- + +## 2.1 v2_unreachable_terms() ---- + +#' Terms v2 Sets by Machinery the Harness Lacks, or Fixes +#' +#' Built from the v2 code, not from a name pattern. A term here +#' can join and still not be expected to agree, so it is scored +#' but left out of the reachable totals. +#' +#' - Plant age splines, cutblock convergence and the soft-linear +#' pooling that borrows from them are reproduced by the plant +#' module (plant_age_splines(), plant_cutblock_convergence()), +#' and are reachable. +#' - Plant placeholders: 04a sets Water, Bare, SnowIce, Mine, +#' MineV, HWater and, in the south, SoilUnknown to -10,000. +#' - Mammal age splines and cutblock convergence are reproduced +#' by modules/mammals/hurdle.R, and are reachable. +#' - Mammal placeholders: section 7.1 adds Bare and Water at 0. +#' - Bird placeholders: 08.PackageCoefficients.R fixes HardLin, +#' Water, Bare, SnowIce and Mine. +#' +#' @return A data frame of group, region, part, term and reason. +#' `region` and `part` NA mean any. +#' +#' @example # Example usage of the function +#' # head(v2_unreachable_terms()) +v2_unreachable_terms <- function() { + rows <- function(group, terms, reason, region = NA, part = NA) { + data.frame( + group = group, region = region, part = part, term = terms, + reason = reason, stringsAsFactors = FALSE + ) + } + + rbind( + rows( + "plant", + c("Water", "Bare", "SnowIce", "Mine", "MineV", "HWater", + "SoilUnknown"), + "v2 placeholder" + ), + rows("mammal", c("Bare", "Water"), "v2 placeholder"), + rows( + "bird", c("HardLin", "Water", "Bare", "SnowIce", "Mine"), + "v2 placeholder" + ) + ) +} + +# 3. Shape the run like the reference ---- + +## 3.1 The run's key columns ---- +run_rows <- NULL + +if (!is.null(run_coefficients)) { + run_rows <- run_coefficients + + # The raw bird landcover coefficients have no v2 counterpart; + # their translation (stage "habitat") does. + run_rows <- run_rows[ + !(run_rows$taxon == "bird" & run_rows$stage == "landcover"), + ] + + # glm names terms as the formula writes them (e.g. the bird + # spatial terms); v2's tables use plain names + v2_names <- c( + "(Intercept)" = "Intercept", + "I(Easting^2)" = "Easting2", + "I(Northing^2)" = "Northing2", + "Easting:Northing" = "EastingNorthing" + ) + renamed <- run_rows$term %in% names(v2_names) + run_rows$term[renamed] <- v2_names[run_rows$term[renamed]] + + # The hurdle's habitat_ stages map to v2's habitat stage + hurdle <- grepl( + "^habitat_(presence|abundance|total)$", run_rows$stage + ) + run_rows$part[hurdle] <- sub( + "^habitat_", "", run_rows$stage[hurdle] + ) + run_rows$stage[hurdle] <- "habitat" + + # v2 fits climate once across the province. + run_rows$ref_region <- ifelse( + run_rows$stage == "climate", "all", run_rows$region + ) + + run_rows$group <- ifelse( + run_rows$taxon %in% c("bryophyte", "lichen", "mite", + "vascular_plant"), + "plant", run_rows$taxon + ) + + # The part each reference row belongs to. Mammal climate is + # fitted on presence whichever half runs. + run_rows$ref_part <- ifelse( + run_rows$group == "plant", "detection", + ifelse( + run_rows$group == "bird", "count", + ifelse(run_rows$stage == "climate", "presence", + run_rows$part) + ) + ) + + ## 3.2 Relabel plant habitat terms as v2 publishes them ---- + is_plant_habitat <- run_rows$group == "plant" & + run_rows$stage == "habitat" + + if (any(is_plant_habitat)) { + labels <- plant_v2_term_labels(run_rows$term[is_plant_habitat]) + relabelled <- merge( + run_rows[is_plant_habitat, ], labels, + by = "term", all.x = TRUE + ) + relabelled$term <- relabelled$v2_term + relabelled$v2_term <- NULL + + run_rows <- rbind( + run_rows[!is_plant_habitat, ], + relabelled[, names(run_rows)] + ) + } + + ## 3.3 Average the mammal seasons ---- + # v2's `.all` references average summer and winter + is_mammal <- run_rows$group == "mammal" + + if (any(is_mammal)) { + mammals <- run_rows[is_mammal, ] + + # Older stores lack season and part in meta.json: take the + # season from the species name; those runs fitted presence + no_season <- is.na(mammals$season) | mammals$season == "" + mammals$season[no_season] <- tolower( + sub("^.*_(Summer|Winter)$", "\\1", mammals$species[no_season]) + ) + + no_part <- is.na(mammals$ref_part) | mammals$ref_part == "" + if (any(no_part)) { + mammals$ref_part[no_part] <- "presence" + notes[["mammal part"]] <- paste0( + "mammal: ", sum(no_part), " rows came from stores that do ", + "not record the hurdle part; read as presence, the ", + "spec's default." + ) + } + + mammals$species <- sub("_(Summer|Winter)$", "", mammals$species) + + keys <- c("taxon", "group", "region", "ref_region", "stage", + "ref_part", "species", "term") + values <- c("n", "median", "p10", "p90", "boot1", "mean", "sd") + + averaged <- stats::aggregate( + mammals[, values], + by = mammals[, keys], + FUN = function(x) mean(x, na.rm = TRUE) + ) + averaged$seasons <- stats::aggregate( + mammals$season, by = mammals[, keys], + FUN = function(x) paste(sort(unique(x)), collapse = "+") + )$x + + run_rows$seasons <- NA_character_ + averaged$run <- "mammal" + averaged$season <- "all" + averaged$part <- averaged$ref_part + + run_rows <- rbind( + run_rows[!is_mammal, ], + averaged[, names(run_rows)] + ) + } else { + run_rows$seasons <- NA_character_ + } +} + +# 4. Compare ---- + +parity <- NULL + +if (!is.null(run_rows) && !is.null(reference) && + nrow(run_rows) > 0) { + reference_keys <- reference[, c( + "taxon", "region", "stage", "part", "species", "term", + "v2_median", "v2_p10", "v2_p90", "v2_n", "source" + )] + names(reference_keys)[names(reference_keys) == "region"] <- + "ref_region" + names(reference_keys)[names(reference_keys) == "part"] <- + "ref_part" + + parity <- merge( + run_rows, reference_keys, + by = c("taxon", "ref_region", "stage", "ref_part", "species", + "term"), + all.x = TRUE + ) + + ## 4.1 The run value to compare ---- + # Where v2 fits once, compare iteration 1 + parity$comparison <- ifelse( + !is.na(parity$v2_n) & parity$v2_n == 1, + "iteration 1", "median" + ) + parity$run_value <- ifelse( + parity$comparison == "iteration 1", + parity$boot1, parity$median + ) + + ## 4.2 Flag what cannot match ---- + unreachable <- v2_unreachable_terms() + + parity$unreachable_reason <- vapply( + seq_len(nrow(parity)), + function(i) { + hit <- unreachable[ + unreachable$group == parity$group[i] & + unreachable$term == parity$term[i] & + (is.na(unreachable$region) | + unreachable$region == parity$region[i]) & + (is.na(unreachable$part) | + unreachable$part == parity$ref_part[i]), + ] + + if (nrow(hit) == 0) NA_character_ else hit$reason[1] + }, + character(1) + ) + parity$reachable <- is.na(parity$unreachable_reason) + + ## 4.2a Flag negligible terms ---- + # Kept in the in-band scores (the tolerance handles them), not + # in the band ratio or Spearman, where their noise would decide + term_scales <- term_scale(reference, c("taxon", "stage")) + parity <- merge( + parity, term_scales, + by = c("taxon", "stage", "term"), all.x = TRUE + ) + parity$negligible <- is_negligible( + parity$run_value, parity$v2_median, parity$typical + ) + + ## 4.3 Score ---- + matched <- is.finite(parity$v2_median) + + spread <- (parity$p90 - parity$p10) / 2 + parity$absolute_difference <- ifelse( + matched, abs(parity$run_value - parity$v2_median), NA_real_ + ) + + # In band, or within numerical tolerance (near-zero averaged + # terms run to 1e-20 or 1e-137) + parity$in_band <- matched & ( + (is.finite(parity$p10) & is.finite(parity$p90) & + parity$v2_median >= parity$p10 & + parity$v2_median <= parity$p90) | + parity$absolute_difference <= + parity_targets()$numerical_tolerance + ) + parity$standardized_difference <- ifelse( + matched & is.finite(spread) & spread > 0, + parity$absolute_difference / spread, NA_real_ + ) + + ## 4.4 Say what did not join ---- + combos <- unique(parity[, c("taxon", "region", "stage")]) + + for (i in seq_len(nrow(combos))) { + one <- parity[ + parity$taxon == combos$taxon[i] & + parity$region == combos$region[i] & + parity$stage == combos$stage[i], + ] + label <- paste(combos$taxon[i], combos$region[i], + combos$stage[i]) + + if (!any(is.finite(one$v2_median))) { + notes[[label]] <- paste0( + label, ": no species and term matched v2_results.csv." + ) + } + } +} else if (is.null(reference)) { + notes[["reference"]] <- "v2_results.csv not found." +} + +# 5. Write ---- +if (!is.null(parity) && nrow(parity) > 0) { + parity <- parity[order( + parity$taxon, parity$region, parity$stage, parity$species, + parity$term + ), ] + rownames(parity) <- NULL + + data.table::fwrite( + parity, file.path(tables_dir, "parity_terms.csv"), na = "" + ) + + parity_summary <- do.call(rbind, lapply( + split( + parity, + list(parity$taxon, parity$region, parity$stage), + drop = TRUE + ), + function(block) { + compared <- block[is.finite(block$v2_median), ] + reachable <- compared[compared$reachable, ] + substantive <- reachable[!reachable$negligible, ] + + pct <- function(x) { + if (length(x) == 0) NA_real_ else round(100 * mean(x), 1) + } + + med <- function(x) { + x <- x[is.finite(x)] + if (length(x) == 0) NA_real_ else round(stats::median(x), 3) + } + + data.frame( + taxon = block$taxon[1], + region = block$region[1], + stage = block$stage[1], + comparison = paste(unique(compared$comparison), + collapse = "+"), + species = length(unique(compared$species)), + terms_compared = nrow(compared), + # Draws actually stored, not configured + min_draws = if (nrow(compared) == 0) { + NA_integer_ + } else { + as.integer(min(compared$n)) + }, + in_band_pct = pct(compared$in_band), + reachable_terms = nrow(reachable), + reachable_in_band_pct = pct(reachable$in_band), + median_standardized_difference = med( + reachable$standardized_difference + ), + median_absolute_difference = med( + reachable$absolute_difference + ), + max_absolute_difference = if (nrow(reachable) == 0) { + NA_real_ + } else { + signif(max(reachable$absolute_difference, na.rm = TRUE), 3) + }, + negligible_terms = sum(reachable$negligible), + # Per species, then the median (as the v2 calibration). + # Reported, not gated. + median_spearman = med(vapply( + split(substantive, substantive$species), + function(one) { + if (nrow(one) < 3) { + return(NA_real_) + } + suppressWarnings(stats::cor( + one$run_value, one$v2_median, method = "spearman" + )) + }, + numeric(1) + )), + # Band ratio: median per species, then over species (as + # the calibration). NA for iteration-1 rows. + median_band_ratio = med(vapply( + split(substantive, substantive$species), + function(one) { + ratio <- (one$p90 - one$p10) / (one$v2_p90 - one$v2_p10) + ratio <- ratio[is.finite(ratio) & ratio > 0] + if (length(ratio) == 0) NA_real_ else stats::median(ratio) + }, + numeric(1) + )), + stringsAsFactors = FALSE + ) + } + )) + + # The verdict against the proposed targets. A trial run - fewer + # draws than v2, or a species subset - is not gated. + full_length <- config$n_bootstraps >= config$v2_bootstraps + gated <- full_length && is.null(config$focal_species) + + verdict_of <- function(gate) { + vapply( + seq_len(nrow(parity_summary)), + function(i) { + with(parity_summary[i, ], parity_verdict( + comparison, reachable_in_band_pct, + median_standardized_difference, median_band_ratio, + max_absolute_difference, gate + )) + }, + character(1) + ) + } + + parity_summary$verdict <- verdict_of(gated) + + # Full draws on a species subset: readable, but not the gate + parity_summary$indicative_verdict <- if (!gated && full_length) { + verdict_of(TRUE) + } else { + NA_character_ + } + + # Fewer stored draws than v2: no verdict + short <- grepl("median", parity_summary$comparison) & + !is.na(parity_summary$min_draws) & + parity_summary$min_draws < config$v2_bootstraps + short_note <- paste0( + "not gated (store holds ", parity_summary$min_draws, " draws)" + ) + parity_summary$verdict[short] <- short_note[short] + if (!all(is.na(parity_summary$indicative_verdict))) { + parity_summary$indicative_verdict[short] <- short_note[short] + } + + rownames(parity_summary) <- NULL + data.table::fwrite( + parity_summary, + file.path(tables_dir, "parity_summary.csv"), na = "" + ) + + cat("\nParity against v2, by stage:\n") + print(parity_summary) +} else { + parity_summary <- NULL + cat("\nNo parity comparison produced.\n") +} + +for (note in notes) { + cat(" note: ", note, "\n", sep = "") +} + +# 6. Hand on ---- +results$parity <- parity +results$parity_summary <- parity_summary +results$parity_notes <- notes + +# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/02_compare_to_v2.R b/1_code/experiments/exp_000_parity_v2/02_compare_to_v2.R deleted file mode 100644 index fbb1292..0000000 --- a/1_code/experiments/exp_000_parity_v2/02_compare_to_v2.R +++ /dev/null @@ -1,52 +0,0 @@ -# --- -# title: Compare Against the v2.0 Reference (Experiment 000) -# author: Brendan Casey -# created: 2026-09-05 -# inputs: -# in 3_output/exp_000_parity_v2/tables/: -# - species_.csv -# - validation_summary.csv -# reference: -# - the published v2.0 model output (source to be agreed) -# outputs: -# in 3_output/exp_000_parity_v2/: -# - tables/parity_.csv -# - figures/parity_.png -# notes: -# - Placeholder. This is the parity gate - it compares what -# this repository produced against the species models v2.0 -# results for the same species. -# - Open question: where the v2.0 reference output comes from. -# Either a frozen snapshot under 0_data/ with a pointer in -# manifest.md, or the external v2 project. The comparison -# cannot be written until that is settled. -# - The minimum acceptable parity target is not yet defined and -# will need to be agreed per taxon. -# - Expects exp_id, project_root, and out_dir from run.R. -# --- - -# 1. Setup ---- - -## 1.1 Resolve paths ---- -tables_dir <- file.path(out_dir, "tables") - -figures_dir <- file.path(out_dir, "figures") -dir.create(figures_dir, recursive = TRUE, showWarnings = FALSE) - -# 2. Compare coefficients ---- -# TODO: join this run's per-species coefficients to the v2.0 -# reference and record the differences per model family. - -# 3. Compare validation metrics ---- -# TODO: compare AUC and fit measures per species and bootstrap. - -# 4. Summarize parity ---- -# TODO: write parity_.csv and the matching figure, then -# state the result against the agreed target. -cat( - "02_compare_to_v2.R is a placeholder. The v2.0 reference ", - "source and the parity target are still to be agreed.\n", - sep = "" -) - -# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/02_plot_parity.R b/1_code/experiments/exp_000_parity_v2/02_plot_parity.R new file mode 100644 index 0000000..cec6f34 --- /dev/null +++ b/1_code/experiments/exp_000_parity_v2/02_plot_parity.R @@ -0,0 +1,520 @@ +# --- +# title: Plot Parity Against v2 (Experiment 000) +# author: Brendan Casey +# created: 2026-09-30 +# inputs: +# - `config$out_dir`, from run.R +# - `results$parity`, from 01_compare_to_v2.R; or, run on its +# own, out_dir/tables/parity_terms.csv +# outputs: +# in out_dir/figures/: +# - parity_.png, one per taxon +# - parity_mean.png, every taxon averaged, one facet each +# - parity_bell.png, v2 and the run as bell curves, one facet +# each +# notes: +# - Medians and 10-90% bars, not densities: v2 keeps only those +# three summaries of its draws. +# - Terms span 1e-144 to 1e2, so each is scaled to v2: 0 is v2's +# median, one unit is half v2's band (the gate's standardized +# difference). Where v2 fitted once (mammal hurdle), the unit +# is half the run's band, v2 is a point, and the run's first +# draw (what the gate compares) is shown. +# - Values beyond +/- 4 units are clamped to the edge; +# unreachable or unscalable terms are dropped and counted in +# the caption. +# - Runs as a script_step(), or alone from the repository root +# after 01_compare_to_v2.R. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # reading and reshaping tables (version: 1.18.0) +library(ggplot2) # plotting (version: 4.0.3) + +## 1.2 Resolve paths ---- +out_dir <- if (exists("config")) { + config$out_dir +} else { + file.path(getwd(), "3_output", "exp_000_parity_v2") +} + +terms_path <- file.path(out_dir, "tables", "parity_terms.csv") +figures_dir <- file.path(out_dir, "figures") +dir.create(figures_dir, recursive = TRUE, showWarnings = FALSE) + +## 1.3 Import data ---- +# From the comparison step when it ran; from its table otherwise +parity_terms <- if (exists("results") && !is.null(results$parity)) { + as.data.table(results$parity) +} else if (file.exists(terms_path)) { + fread(terms_path) +} else { + stop( + "No parity terms; run 01_compare_to_v2.R first:\n ", + terms_path, + call. = FALSE + ) +} + +## 1.4 Choose the mean figure's facets ---- +# "taxon" gives one facet per taxon; "group" pools the four plant +# taxa into one facet beside mammals and birds. +mean_facet <- "taxon" + +if (!mean_facet %in% c("taxon", "group")) { + stop("mean_facet must be \"taxon\" or \"group\".", call. = FALSE) +} + +# 2. Put each term on v2's scale ---- +# Input: one row per taxon, region, stage, part, species and term, +# with the run's and v2's median and 10th and 90th percentiles. +# Output: plot_data, one row per term and source, in v2 units. + +## 2.1 Choose the unit per term ---- +# Half v2's band where it has one; otherwise half the run's. +axis_limit <- 4 + +parity_terms[, `:=`( + v2_half = (v2_p90 - v2_p10) / 2, + run_half = (p90 - p10) / 2 +)] +parity_terms[, unit := fifelse( + is.finite(v2_half) & v2_half > 0, v2_half, run_half +)] + +plottable <- parity_terms[ + reachable & is.finite(v2_median) & is.finite(median) & + is.finite(unit) & unit > 0 +] + +## 2.2 Label panels ---- +# A mammal row also names its hurdle part, which v2 reports +# separately. +plottable[, panel := paste(stage, region, sep = " / ")] +plottable[taxon == "mammal", panel := paste(panel, part, sep = " / ")] + +## 2.3 Rescale and stack the two sources ---- +scaled <- function(x, data) (x - data$v2_median) / data$unit + +plot_data <- rbind( + plottable[, .( + taxon, group, panel, species, term, + source = "v2", + centre = 0, + low = scaled(v2_p10, .SD), + high = scaled(v2_p90, .SD) + )], + plottable[, .( + taxon, group, panel, species, term, + source = "exp_000", + centre = scaled(median, .SD), + low = scaled(p10, .SD), + high = scaled(p90, .SD) + )], + # Where v2 fitted once, the gate compares the run's first draw, + # not its median; drawn as a point so the test itself is seen. + plottable[comparison == "iteration 1", .( + taxon, group, panel, species, term, + source = "exp_000 iteration 1", + centre = scaled(boot1, .SD), + low = NA_real_, + high = NA_real_ + )] +) + +plot_data[, source := factor( + source, levels = c("v2", "exp_000", "exp_000 iteration 1") +)] + +# Past the axis limit, drawn at the edge rather than dropped +clamp <- function(x) pmin(pmax(x, -axis_limit), axis_limit) +plot_data[, `:=`( + clipped = abs(centre) > axis_limit, + centre = clamp(centre), + low = clamp(low), + high = clamp(high) +)] + +# 3. Plot ---- + +#' Plot One Taxon's Parity Against v2 +#' +#' Draws each term's median and 10-90% band for v2 and the run, +#' in v2 units, faceted by panel and species. +#' +#' @param data data.table. plot_data rows for one taxon. +#' @param dropped Integer. Terms left out, for the caption. +#' @param taxon Character. The taxon, for the title. +#' @return A ggplot object. +#' +#' @example # Example usage of the function +#' # plot_parity_taxon(plot_data[taxon == "lichen"], 0L, "lichen") +plot_parity_taxon <- function(data, dropped, taxon) { + # Terms top to bottom in the order the table lists them + data <- copy(data) + data[, term := factor(term, levels = rev(unique(term)))] + + dodge <- position_dodge(width = 0.6) + + ggplot(data, aes(y = term, colour = source)) + + geom_vline(xintercept = 0, colour = "grey70") + + geom_vline( + xintercept = c(-1, 1), + colour = "grey85", linetype = "dashed" + ) + + geom_linerange( + aes(xmin = low, xmax = high), + position = dodge, na.rm = TRUE + ) + + geom_point( + aes(x = centre, shape = clipped), + position = dodge, size = 1.4 + ) + + scale_colour_manual( + values = c( + v2 = "#0072B2", exp_000 = "#D55E00", + `exp_000 iteration 1` = "#009E73" + ), + drop = TRUE + ) + + scale_shape_manual( + values = c(`FALSE` = 16, `TRUE` = 4), + guide = "none" + ) + + scale_x_continuous(limits = c(-axis_limit, axis_limit)) + + facet_grid( + panel ~ species, + scales = "free_y", space = "free_y" + ) + + labs( + title = paste0("Parity against v2: ", taxon), + subtitle = paste( + "Median (point) and 10th-90th percentile (bar) of each", + "term, in v2 units:\n0 is v2's median; +/- 1 is half", + "v2's band (the run's band where v2 fitted once).", + "\nAn x marks a median beyond the axis, drawn at its edge." + ), + caption = paste0( + "Terms left out (unreachable, or no band to scale by): ", + dropped + ), + x = "Difference from v2's median, in half-band units", + y = NULL, colour = NULL + ) + + theme_bw(base_size = 9) + + theme( + legend.position = "top", + strip.text.y = element_text(angle = 0), + axis.text.y = element_text(size = 6) + ) +} + +## 3.1 Write one figure per taxon ---- +# Height follows the number of rows, so habitat stages with a +# hundred terms stay legible; capped at ggsave's 50-inch limit. +for (one_taxon in sort(unique(plot_data$taxon))) { + taxon_data <- plot_data[taxon == one_taxon] + dropped <- nrow(parity_terms[taxon == one_taxon]) - + nrow(plottable[taxon == one_taxon]) + + rows <- uniqueN(taxon_data[, .(panel, term)]) + height <- min(49, 2 + rows * 0.14) + width <- 3 + 3 * uniqueN(taxon_data$species) + + figure <- plot_parity_taxon(taxon_data, dropped, one_taxon) + out_file <- file.path( + figures_dir, paste0("parity_", one_taxon, ".png") + ) + + ggsave( + out_file, figure, + width = width, height = height, dpi = 150, limitsize = FALSE + ) + + cat("Parity figure: ", out_file, "\n", sep = "") +} + +# 4. Plot mean parity per taxon ---- +# One figure, one facet per taxon (or group), each row a stage and +# region. Input: plot_data. Output: parity_mean.png. +# +# Averages the clamped scaled values over species and terms. A +# signed mean lets +2 and -2 cancel, so rows are also labelled +# with the mean absolute difference and the in-band share. + +## 4.1 Average per facet, row and source ---- +plot_data[, facet := get(mean_facet)] + +mean_data <- plot_data[, .( + centre = mean(centre), + low = mean(low, na.rm = TRUE), + high = mean(high, na.rm = TRUE), + terms = .N +), by = .(facet, panel, source)] + +# Where every value is NA (the iteration-1 point) mean() is NaN +mean_data[!is.finite(low), low := NA_real_] +mean_data[!is.finite(high), high := NA_real_] + +mean_labels <- plot_data[source == "exp_000", .( + label = sprintf( + "|d| %.2f, in band %.0f%%, %d terms", + mean(abs(centre)), + 100 * mean(low <= 0 & high >= 0), + .N + ) +), by = .(facet, panel)] + +# The measures go in the row's axis label, clear of the bars +mean_data <- merge(mean_data, mean_labels, by = c("facet", "panel")) +mean_data[, row := paste0(panel, "\n", label)] + +## 4.2 Draw ---- + +#' Plot Mean Parity Against v2 by Taxon +#' +#' Draws, per facet and stage, the mean scaled median and mean +#' 10-90% band of v2 and the run; each row's label carries the +#' mean absolute difference and the in-band share. +#' +#' @param data data.table. mean_data: facet, panel, row, source, +#' centre, low, high. +#' @return A ggplot object. +#' +#' @example # Example usage of the function +#' # plot_parity_mean(mean_data) +plot_parity_mean <- function(data) { + # Rows top to bottom: climate before habitat, north before south + data <- copy(data) + data[, row := factor(row, levels = rev(sort(unique(row))))] + + dodge <- position_dodge(width = 0.5) + + ggplot(data, aes(y = row, colour = source)) + + geom_vline(xintercept = 0, colour = "grey70") + + geom_vline( + xintercept = c(-1, 1), + colour = "grey85", linetype = "dashed" + ) + + geom_linerange( + aes(xmin = low, xmax = high), + position = dodge, linewidth = 0.8, na.rm = TRUE + ) + + geom_point(aes(x = centre), position = dodge, size = 2) + + scale_colour_manual( + values = c( + v2 = "#0072B2", exp_000 = "#D55E00", + `exp_000 iteration 1` = "#009E73" + ) + ) + + scale_x_continuous(limits = c(-axis_limit, axis_limit)) + + facet_wrap(~facet, scales = "free_y", ncol = 2) + + labs( + title = "Mean parity against v2", + subtitle = paste( + "Mean over species and terms of each term's median (point)", + "and 10th-90th percentile (bar),\nin v2 units: 0 is v2's", + "median; +/- 1 is half v2's band (the run's band where v2", + "fitted once).\n|d|: mean absolute difference of the run's", + "median from v2's. In band: v2's median inside the run's", + "band." + ), + x = "Difference from v2's median, in half-band units", + y = NULL, colour = NULL + ) + + theme_bw(base_size = 9) + + theme(legend.position = "top") +} + +mean_file <- file.path(figures_dir, "parity_mean.png") +mean_rows <- max(mean_data[, uniqueN(panel), by = facet]$V1) +mean_facets <- uniqueN(mean_data$facet) + +ggsave( + mean_file, plot_parity_mean(mean_data), + width = 10, + height = 2 + ceiling(mean_facets / 2) * (0.6 + 0.55 * mean_rows), + dpi = 150 +) + +cat("Parity figure: ", mean_file, "\n", sep = "") + +# 5. Plot v2 and the run as bell curves ---- +# One figure, one facet per taxon (or group), one curve pair per +# stage and region, stacked. Input: plottable. Output: +# parity_bell.png. +# +# Each term as a normal curve (median centre; the 10-90% band is +# 2 x 1.2816 SD), averaged per row in v2 units. The normal shape +# is a drawing convenience, not a claim. Negligible terms are +# left out; v2 without a band is a line at 0. + +## 5.1 One normal curve per term ---- +# qnorm(0.9): the 90th percentile is this many standard deviations +# above the centre. +z90 <- stats::qnorm(0.9) + +bell_terms <- copy(plottable) +if (!"negligible" %in% names(bell_terms)) { + message( + "parity_terms.csv has no `negligible` column; rerun ", + "01_compare_to_v2.R. Every term is drawn." + ) + bell_terms[, negligible := FALSE] +} +bell_terms <- bell_terms[!(negligible)] + +bell_terms[, `:=`( + facet = get(mean_facet), + run_centre = (median - v2_median) / unit, + run_sd = (p90 - p10) / (2 * z90) / unit, + v2_sd = (v2_p90 - v2_p10) / (2 * z90) / unit +)] + +## 5.2 Average the curves per row ---- +x_grid <- seq(-axis_limit, axis_limit, length.out = 401) + +#' Average of Normal Curves on a Grid +#' +#' @param centre,sd Numeric vectors, one entry per term. +#' @return Numeric, the mean density at each point of x_grid; NA +#' when no term has a usable spread. +mixture_density <- function(centre, sd) { + keep <- is.finite(centre) & is.finite(sd) & sd > 0 + if (!any(keep)) { + return(rep(NA_real_, length(x_grid))) + } + rowMeans(vapply( + which(keep), + function(i) stats::dnorm(x_grid, centre[i], sd[i]), + numeric(length(x_grid)) + )) +} + +bell_curves <- bell_terms[, { + run <- mixture_density(run_centre, run_sd) + v2 <- mixture_density(rep(0, .N), v2_sd) + data.table( + x = rep(x_grid, 2), + density = c(v2, run), + source = rep(c("v2", "exp_000"), each = length(x_grid)) + ) +}, by = .(facet, panel)] + +# v2 with no band: a line at 0 instead of a curve +v2_lines <- bell_curves[ + source == "v2", + .(single = all(is.na(density))), + by = .(facet, panel) +][(single)] +bell_curves <- bell_curves[is.finite(density)] + +## 5.3 Stack the rows ---- +# Climate above habitat, north above south. Each facet's curves +# are scaled so its tallest reaches 0.75 of a row, leaving room +# for the row's label above it. +bell_rows <- unique(bell_terms[, .(facet, panel)]) +setorder(bell_rows, facet, panel) +bell_rows[, offset := rev(seq_len(.N)) - 1, by = facet] + +bell_rows <- merge( + bell_rows, mean_labels, by = c("facet", "panel"), all.x = TRUE +) +bell_rows[, text := fifelse( + is.na(label), panel, paste0(panel, " ", label) +)] + +bell_curves <- merge(bell_curves, bell_rows, by = c("facet", "panel")) +bell_curves[, height := 0.75 * density / max(density), by = facet] +bell_curves[, `:=`(bottom = offset, top = offset + height)] + +v2_lines <- merge(v2_lines, bell_rows, by = c("facet", "panel")) + +bell_curves[, source := factor(source, levels = c("v2", "exp_000"))] + +## 5.4 Draw ---- + +#' Plot v2 and the Run as Bell Curves +#' +#' Draws, per facet, one stacked pair of curves per stage and +#' region: v2 and the run, in v2 units. +#' +#' @param curves data.table. bell_curves: facet, x, bottom, top, +#' source, panel. +#' @param rows data.table. bell_rows: facet, offset, text. +#' @param lines data.table. v2_lines: facet, offset. +#' @return A ggplot object. +#' +#' @example # Example usage of the function +#' # plot_bell(bell_curves, bell_rows, v2_lines) +plot_bell <- function(curves, rows, lines) { + colours <- c(v2 = "#0072B2", exp_000 = "#D55E00") + + ggplot(curves) + + geom_vline(xintercept = 0, colour = "grey75") + + geom_vline( + xintercept = c(-1, 1), + colour = "grey85", linetype = "dashed" + ) + + geom_ribbon( + aes( + x = x, ymin = bottom, ymax = top, + fill = source, colour = source, + group = interaction(panel, source) + ), + alpha = 0.3, linewidth = 0.4 + ) + + geom_segment( + data = lines, + aes(x = 0, xend = 0, y = offset, yend = offset + 0.75), + colour = colours[["v2"]], linewidth = 0.8 + ) + + geom_text( + data = rows, + aes(x = -axis_limit, y = offset + 0.8, label = text), + hjust = 0, vjust = 0, size = 2.4, colour = "grey25" + ) + + scale_fill_manual(values = colours, name = NULL) + + scale_colour_manual(values = colours, name = NULL) + + scale_x_continuous(limits = c(-axis_limit, axis_limit)) + + scale_y_continuous(expand = expansion(add = c(0.05, 0.25))) + + facet_wrap(~facet, scales = "free_y", ncol = 2) + + labs( + title = "v2 and exp_000 as distributions", + subtitle = paste( + "Each curve averages its row's terms, each drawn as a", + "normal curve from its median and 10th-90th percentile", + "band,\nin v2 units: 0 is v2's median; +/- 1 is half v2's", + "band. Negligible terms left out. A blue line: v2 fitted", + "once (no band).\n|d|: mean absolute difference of the", + "medians. In band: v2's median inside the run's band." + ), + x = "Difference from v2's median, in half-band units", + y = NULL + ) + + theme_bw(base_size = 9) + + theme( + legend.position = "top", + axis.text.y = element_blank(), + axis.ticks.y = element_blank(), + panel.grid.major.y = element_blank(), + panel.grid.minor.y = element_blank() + ) +} + +bell_file <- file.path(figures_dir, "parity_bell.png") +bell_depth <- max(bell_rows[, .N, by = facet]$N) +bell_facets <- uniqueN(bell_rows$facet) + +ggsave( + bell_file, plot_bell(bell_curves, bell_rows, v2_lines), + width = 10, + height = 2 + ceiling(bell_facets / 2) * (0.6 + 0.8 * bell_depth), + dpi = 150 +) + +cat("Parity figure: ", bell_file, "\n", sep = "") + +# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/03_build_report.R b/1_code/experiments/exp_000_parity_v2/03_build_report.R index 71e50d0..242ca87 100644 --- a/1_code/experiments/exp_000_parity_v2/03_build_report.R +++ b/1_code/experiments/exp_000_parity_v2/03_build_report.R @@ -1,50 +1,249 @@ # --- # title: Build the Experiment 000 Report # author: Brendan Casey -# created: 2026-09-05 +# created: 2026-09-09 # inputs: -# in 3_output/exp_000_parity_v2/: -# - tables/parity_.csv -# - figures/parity_.png +# - `config`, from run.R: id, specs, taxa, focal_species, +# n_bootstraps, v2_bootstraps, seed, out_dir and the v2 +# reference settings +# - `results`: coverage and metric_summary (collect_results()), +# parity_summary and parity_notes (01_compare_to_v2.R) +# - in config$v2_reference_dir: +# - v2_results_coverage.csv # outputs: -# in 3_output/exp_000_parity_v2/: +# in out_dir/: # - report.md # notes: -# - Placeholder. Assembles the tables and figures into the -# committed report that states whether the parity gate -# passed, per taxon. -# - Writing a stub report.md on every run keeps the experiment -# folder complete, so a partial run is still legible. -# - Expects exp_id, project_root, and out_dir from run.R. +# - Holds no status of its own: coverage comes from the specs' +# `v2_coverage`, references from v2_results_coverage.csv, and +# results from the comparison step. +# - Leads with the kind of run, since a trial writes the same +# files as a full run. Run as a script_step(). # --- # 1. Setup ---- ## 1.1 Resolve paths ---- -report_file <- file.path(out_dir, "report.md") +report_file <- file.path(config$out_dir, "report.md") +v2_coverage_path <- file.path( + config$v2_reference_dir, "v2_results_coverage.csv" +) +v2_reference_builder <- config$v2_reference_builder + +## 1.2 Read the inputs ---- +coverage <- results$coverage +metric_summary <- results$metric_summary +parity_summary <- results$parity_summary +v2_coverage <- if (file.exists(v2_coverage_path)) { + as.data.frame(data.table::fread(v2_coverage_path)) +} else { + NULL +} + +# The comparison step's unreachable references +gate_notes <- unlist(results$parity_notes, use.names = FALSE) + +# 2. Assemble ---- + +## 2.1 Helpers ---- +# Tables are rendered by md_table() (harness/run_record.R), so the +# report and the run record format numbers the same way. +markdown_table <- function(x, empty = "_Nothing recorded._") { + if (is.null(x) || nrow(x) == 0) empty else md_table(x, digits = 3L) +} + +## 2.2 What kind of run this was ---- +is_full_species <- is.null(config$focal_species) +is_full_draws <- config$n_bootstraps >= config$v2_bootstraps + +run_kind <- if (is_full_species && is_full_draws) { + "**Full run.** Every species, every draw." +} else { + paste0( + "**Trial run.** ", + if (!is_full_species) { + paste0(length(config$focal_species), " focal species") + } else { + "every species" + }, + ", ", config$n_bootstraps, " of ", config$v2_bootstraps, + " draws. ", + "Its parity numbers show the pipeline ran; they are not a ", + "parity read." + ) +} + +seed_text <- if (is.null(config$seed)) { + "unseeded, as in v2" +} else { + paste0( + "`seed = ", config$seed, "`, one derived seed per species" + ) +} + +## 2.3 v2 references ---- +reference_lines <- if (is.null(v2_coverage)) { + paste0( + "_`v2_results_coverage.csv` not found; run ", + "`", v2_reference_builder, "`._" + ) +} else { + markdown_table( + v2_coverage[, intersect( + c("source_label", "reachable", "rows", "species", "note"), + names(v2_coverage) + )] + ) +} -dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) +gate_lines <- if (length(gate_notes) == 0) { + paste( + "_Every taxon and region that ran had a reference to", + "compare against._" + ) +} else { + paste0("- ", gate_notes) +} -# 2. Assemble the report ---- -# TODO: read the parity tables and figures and write the results -# section. For now the file records that the run happened and -# which species vector produced it. -report_lines <- c( - paste0("# ", exp_id), +## 2.4 Model fit ---- +fit_lines <- if (is.null(metric_summary)) { + "_No metrics recorded._" +} else { + # Out-of-bag is the honest read; in-sample is what v2 reports + shown <- c( + insample_auc = "insample_auc", + oob_auc = "oob_auc", + v2val_full = "v2val_Full", + oob_v2val_full = "oob_v2val_Full" + ) + auc <- metric_summary[metric_summary$metric %in% shown, ] + + if (nrow(auc) == 0) { + "_No AUC recorded._" + } else { + markdown_table(do.call(rbind, lapply( + split(auc, list(auc$taxon, auc$region), drop = TRUE), + function(block) { + row <- data.frame( + taxon = block$taxon[1], + region = block$region[1], + species = length(unique(block$species)), + stringsAsFactors = FALSE + ) + + for (label in names(shown)) { + values <- block$median[block$metric == shown[[label]]] + column <- paste0("median_", label) + row[[column]] <- if (length(values) == 0) { + NA_real_ + } else { + round(stats::median(values, na.rm = TRUE), 3) + } + } + + row + } + ))) + } +} + +## 2.5 Write the report ---- +lines <- c( + paste0("# ", config$id), "", paste0("Generated ", format(Sys.time(), "%Y-%m-%d %H:%M:%S")), "", - "## Status", + run_kind, + "", + paste0("Draws: ", seed_text, "."), + "", + "## What each spec reproduces of v2", + "", + "Read from each spec's `v2_coverage`, which is where coverage is", + "stated. Change it there, not here.", + "", + markdown_table( + spec_coverage(config$specs), + "_No specs ran._" + ), + "", + "## v2 references", + "", + paste0( + "Scored against `", config$v2_reference, + "`, built by `", v2_reference_builder, "`. What it holds, ", + "from `v2_results_coverage.csv`:" + ), + "", + reference_lines, + "", + "What this run's comparison could not reach:", + "", + gate_lines, + "", + "## What ran", + "", + markdown_table(coverage), + "", + "## Parity against v2, by stage", + "", + "Every stage is compared against `v2_results.csv`. Climate is", + "scored against v2's province-wide fit in both regions. Terms v2", + "fixes at a placeholder are left out of the reachable scores.", + "", + paste0( + "`verdict` reads each row against the parity targets in ", + "`utils/parity_targets.R` (", parity_targets()$status, "): ", + "numerical rows (iteration 1) pass when every reachable term is ", + "within ", parity_targets()$numerical_tolerance, "; ", + "distributional rows when at least ", + parity_targets()$min_in_band_pct, "% of reachable terms are in ", + "band, the median standardized difference is at most ", + parity_targets()$max_standardized_difference, ", and the median ", + "band-width ratio (this run's band over v2's) is between ", + paste(round(parity_targets()$band_ratio_range, 2), + collapse = " and "), + ". `median_spearman` is reported, not gated. ", + "A trial run is not gated." + ), + "", + markdown_table( + parity_summary, + "_No comparison produced. See the references above._" + ), + "", + "Where v2 bootstraps, parity is **distributional**: v2 seeds no", + "random draw, so two v2 runs differ, and each term is scored on", + "whether the v2 median falls inside this run's", + "10th-to-90th percentile band. Where v2 fits once", + "(`comparison` = iteration 1: mammals), the run's full-data fit", + "is compared directly; read `median_absolute_difference`.", + "", + "## Model fit", + "", + paste( + "Median AUC over species, scored on each run's final model:", + "for plants, v2's own prediction from its coefficient tables.", + "`insample` scores the units each draw fitted; `oob` the units", + "it left out, the held-out read. `v2val` is v2's validation,", + "scored from the coefficients as v2 does (plants only), so for", + "plants `v2val_full` equals `insample_auc`. Iteration 1 is the", + "full data and has no out-of-bag units." + ), + "", + fit_lines, + "", + "## What is still needed", "", - "Placeholder report. The parity comparison in", - "`02_compare_to_v2.R` is not yet implemented, so no result is", - "stated here yet.", + "See the experiment's `README.md` for what blocks the gate, and", + "`docs/reviews/2026-09-28_alignment_review.md` for the full", + "remediation plan.", "" ) -# 3. Write the report ---- -writeLines(report_lines, report_file) +writeLines(lines, report_file) cat("Wrote ", report_file, "\n", sep = "") +results$report_file <- report_file # End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/README.md b/1_code/experiments/exp_000_parity_v2/README.md index aa48ade..7d4736c 100644 --- a/1_code/experiments/exp_000_parity_v2/README.md +++ b/1_code/experiments/exp_000_parity_v2/README.md @@ -1,72 +1,157 @@ # exp_000_parity_v2 -![Status](https://img.shields.io/badge/Status-Scaffolded-yellow) +![Status](https://img.shields.io/badge/Status-Not%20yet%20gatable-yellow) ![Languages](https://img.shields.io/badge/Languages-R-blue) -The validation gate. Runs the v2.0 models through this repository's -pipeline and compares the results against the published species models -v2.0 outputs. +The validation gate. Runs each taxon's v2 spec through the harness and +compares the result with the published v2 output. Every other +experiment is compared against this one. ## Question -Does running the unmodified v2 scripts through this repository's -harness and modules reproduce the v2.0 results? - -Everything downstream depends on the answer. Later experiments are -compared against this one, so a difference here is a difference in the -plumbing, not in the method being tested. - -## Design - -| Element | Value | -| --- | --- | -| Taxa | Set per run in `run.R` (`mites <- TRUE`, and so on) | -| Species | Set per taxon in `utils/species_lists.R`; `NULL` runs all | -| Bootstraps | 100, hard-coded in the v2 scripts | -| Reference | The published v2.0 output — source still to be agreed | -| Target | Not yet defined; to be agreed per taxon | - -## Files - -| File | Purpose | -| --- | --- | -| `run.R` | Entry point. Taxon flags, staging, module calls | -| `utils/species_lists.R` | The species vector for each taxon | -| `01_collect_results.R` | Raw v2 output → flat summary tables | -| `02_compare_to_v2.R` | The parity comparison itself | -| `03_build_report.R` | Tables and figures → `report.md` | +Does the framework, configured as v2, reproduce the v2 results? If it +does, a difference in a later experiment is a difference in method, +not in plumbing. ## How to run -1. Set `SDM_V2_ROOT` to the v2 project holding the source data. It is - read only, and only while staging. -2. Edit `utils/species_lists.R` to name the species to model. Start - short — the v2 scripts always run 100 bootstraps, so the species - count is the only way to shorten a run. -3. Set the taxon flags in `run.R` section 1.4. -4. Run `run.R` from the repository root. +From the repository root: ```r source("1_code/experiments/exp_000_parity_v2/run.R") ``` -## Outputs +Every decision is in `run.R`'s `experiment_config()` call (section +1.2); section 1.3 points the run at the v2 reference. As committed, +`run.R` runs the `parity_check` species at 5 draws on 12 workers. For +the gate, set `species = NULL` and `n_bootstraps = 100`. +`run_experiment()` fits, summarizes, then runs this experiment's steps: + +| Step | Script | Writes, in `3_output/exp_000_parity_v2/` | +| --- | --- | --- | +| compare | `01_compare_to_v2.R` | `tables/parity_terms.csv`, `tables/parity_summary.csv` | +| plot | `02_plot_parity.R` | `figures/parity_.png`, `parity_mean.png`, `parity_bell.png` | +| report | `03_build_report.R` | `report.md` | + +`utils/parity_targets.R` holds the targets the compare step reads. +`v2_self_agreement.R` is not part of `run.R`: run it once, after +`_setup/03` and `_setup/08`, to write +`tables/v2_self_agreement.csv` and `v2_self_agreement_summary.csv`. + +## Inputs and outputs + +- **Inputs:** the published test dataset, and + `abmiexplorer/v2_results.csv` from the published v2 results (both + via `harness/data_source.R`). +- **Outputs:** the stores in `2_pipeline/exp_000_parity_v2/`, the + summary tables every experiment writes (see the + [harness README](../../harness/README.md#outputs)), and: + +| Output | Holds | +| --- | --- | +| `tables/parity_terms.csv` | Term by term: `coefficient_summary.csv` joined to the v2 reference. Adds `ref_region`, `ref_part`, the v2 summary (`v2_median`, `v2_p10`, `v2_p90`, `v2_n`), `comparison` (`median`, or `iteration 1` where v2 fits once), `reachable`, `in_band`, `absolute_difference` and `standardized_difference` (gap ÷ half this run's band). Gitignored | +| `tables/parity_summary.csv` | The gate: one row per taxon × region × stage, with in-band rates, gaps, `median_band_ratio`, `median_spearman` (not gated), `min_draws`, `verdict` and `indicative_verdict` | +| `figures/` | Each term's run and v2 median and band relative to v2; the per-taxon mean; v2 and the run as distributions | +| `report.md` | Run kind and seed, what each spec reproduces of v2, parity by stage, model fit | + +## What it covers + +Each spec's `v2_coverage` is the authoritative statement, and +`report.md` prints it. In short: + +| Taxon | Climate | Habitat or landcover | Resampling | +| --- | --- | --- | --- | +| Plant group (×4) | v2's 58-model set, fitted once province-wide; exact to v2's code | IVW on the grid, stand-age splines, cutblock convergence, footprint pooling and pAspen; exact to v2 on the full-data draw | Once per species over the province, or v2's stored draws | +| Mammals | v2's precomputed climate prediction | The hurdle (presence, abundance, total) on the full habitat set, with splines, calibration and convergence; exact to v2's published tables | v2 fits once; iteration 1 is compared | +| Birds | v2's 25 candidates, province-wide, carried as exp(link) without the QPAD offset; exact to v2's code | Weighted staged BIC; exact to v2's code | v2's stored draws | + +If this table and the specs disagree, the specs are right. + +## The v2 reference + +`v2_results.csv` is built by `_setup/08` from ABMIexploreR's published +coefficients (`data/species-coefs.RData`), pinned to commit `848eeed`. +On 2026-10-02 it matched the retired by-hand build from the network +drives to about 1e-15 on every shared species and term. Gaps: + +- `Bryum.All`, and `Trhypochthonius.tectorum` in the north, are not + published. +- Bird `TreedFen` is one coefficient in the package and nine age + classes in v2, so those terms do not join. +- Mammals: the pinned commit holds the 2024 tables the harness + reproduces, on the link scale; `08` back-transforms them. Its draws + are one fit repeated, so they are scored on iteration 1. South + `WetlandMargin`, the placeholder `Bare`, woodland caribou and deer + are not published. + +`08` relabels the package's terms to the harness's names only where +values were checked identical. Plant habitat terms are relabelled as +v2 publishes them; bird landcover is translated onto v2's habitat +template by `modules/birds/standardize.R`; mammal seasons are averaged, +as v2's `.all` tables are. Terms v2 sets by machinery the harness +lacks are listed in `v2_unreachable_terms()` (`01_compare_to_v2.R`) +and left out of the reachable scores. + +## Parity targets (proposed) + +In `utils/parity_targets.R`. **Proposals until agreed.** + +| Comparison | Passes when | +| --- | --- | +| Numerical (iteration 1, where v2 fits once: the mammal hurdle) | Every reachable term within 1e-6 | +| Distributional (plant and bird stages) | At least 90% of reachable terms in band, median standardized difference ≤ 0.25, and median band-width ratio between 0.75 and 1.33 | + +They are set from how closely two v2 runs agree with each other +(`v2_self_agreement.R`: the bryophyte climate stage, ABMIexploreR's +run against `_setup/03`'s rerun). Measured against v2's `COEFS.RData`: -Intermediates, per taxon, in `2_pipeline/exp_000_parity_v2/`: +| Measure | v2 against itself | +| --- | --- | +| Terms with one run's median in the other's 10–90% band | 100% | +| Median standardized difference | 0.019 | +| Band-width ratio, median per species | 1.005 (5th–95th percentile 0.81–1.19) | +| Median per-species Spearman of the medians | 0.998 | -- `/` — the staged run root, plus the raw v2 model and - validation output. Gitignored; too large to commit. -- `logs/` — one timestamped log per pipeline step. +The band ratio and Spearman skip **negligible terms**, those both runs +put below a millionth of the term's typical size (`is_negligible()`). +Spearman is reported but not gated: it failed mite climate with every +term in band, on the ordering of near-zero terms. -Deliverables in `3_output/exp_000_parity_v2/`: +Only a full run (every species, 100 draws) is gated. A 100-draw run on +a species subset gets an `indicative_verdict` instead. Neither is +given to a row whose store holds fewer draws than v2 (`min_draws`). -- `tables/`, `figures/`, `report.md` — committed, so comparisons - across experiments can be made from the repository alone. +Assumptions: the calibration covers plant climate only, and is applied +to plant habitat and birds without a second v2 run to check it. No test +compares whole-model predictions. The negligible-term fraction and the +90th-percentile typical size are judgement calls. ## Status -Scaffolded. The taxon modules and staging run; `01`–`03` are -placeholders pending two decisions: - -- Where the v2.0 reference output comes from. -- What the minimum acceptable parity target is, per taxon. +**Indicative result, 2026-10-03, `parity_check` set, 100 draws:** all +22 rows pass, 100% of reachable terms in band. Mammal habitat matches +v2 to ≤1e-14; plant band-width ratios are 0.88–1.05. Birds passed after +two fixes on 2026-10-02: the dataset is harmonized from the +pre-rebuild `Stratified.Rdata` in `remote/birds_data_v2/`, and the +carried climate prediction no longer includes the QPAD offset. + +The committed `tables/` and `run_record.md` are from a later 5-draw +trial (2026-10-06) and are not gated. + +## Before this gate can be closed + +1. **Agree the parity targets**, or change them in + `utils/parity_targets.R`. +2. **Run the full species queues at 100 draws** and commit the report + and record. That run is days of compute. +3. **Get references that can be matched exactly.** The published + lichen, mite and vascular plant models were fitted on draws v2 did + not keep. Re-running v2 on the stored draws, as `_setup/03` did for + bryophytes, would make those gates numerical. + +## See also + +- [`docs/taxon_quirks.md`](../../../docs/taxon_quirks.md): every + taxon-specific v2 behaviour and the harness's status against each. +- [`docs/reviews/2026-09-28_alignment_review.md`](../../../docs/reviews/2026-09-28_alignment_review.md): + the evidence behind the gaps above. diff --git a/1_code/experiments/exp_000_parity_v2/run.R b/1_code/experiments/exp_000_parity_v2/run.R index 5298d77..8cb8266 100644 --- a/1_code/experiments/exp_000_parity_v2/run.R +++ b/1_code/experiments/exp_000_parity_v2/run.R @@ -1,179 +1,103 @@ # --- # title: Run Experiment 000 - v2.0 Parity Check # author: Brendan Casey -# created: 2026-09-05 +# created: 2026-09-09 # inputs: -# harness, in 1_code/harness/utils/: -# - v2_script_runner.R -# - stage_v2_inputs.R -# experiment: -# - 1_code/experiments/exp_000_parity_v2/utils/species_lists.R -# modules, in 1_code/modules/plants/: -# - run_v2_bryophytes.R -# - run_v2_lichens.R -# - run_v2_mites.R -# - run_v2_vascular_plants.R +# - the published test dataset (harness/data_source.R) +# - the published v2 results, the ABMIexploreR reference +# (section 1.3; see harness/data_source.R) +# - the framework: 1_code/harness/, methods/, modules/ # outputs: # in 2_pipeline/exp_000_parity_v2/: -# - / (staged inputs and raw v2 model output) -# - logs/ +# - // result stores, and run_log.csv # in 3_output/exp_000_parity_v2/: -# - tables/ -# - figures/ -# - report.md +# - tables/, figures/, report.md, run_record.md # notes: -# - Entry point for the experiment. Sets which taxa run and on -# which species, stages the inputs, then sources the taxon -# modules, which in turn source the unmodified v2 scripts. -# - Species vectors live in utils/species_lists.R. A vector of -# NULL models every species in the source data. -# - Each taxon is staged into its own run root under -# 2_pipeline/, so a run writes nothing to 0_data/ and edits -# no v2 code. -# - Set SDM_V2_ROOT to the v2 project holding the source data. -# It is read only, and only at staging. +# - The validation gate and the baseline for every experiment: +# each taxon's v2 spec against the published v2 output. +# - Section 1.2 is the whole configuration. +# - Parity is mostly distributional (v2 seeds nothing); see the +# parity ledger in docs/framework_design.md. # --- # 1. Setup ---- -## 1.1 Set the working directory ---- -# Every path below is relative to this repository's root. In -# RStudio or Positron, uncomment to set it from this script's -# location. -# setwd(dirname(rstudioapi::getActiveDocumentContext()$path)) -# setwd("../../..") +## 1.1 Load the framework ---- +# Run from the repository root +source("1_code/harness/harness.R") +load_framework() -## 1.2 Configure the experiment ---- -# The identifier is used verbatim in 1_code/experiments/, -# 2_pipeline/, and 3_output/, so all three paths derive from one -# variable rather than being typed per stage. -exp_id <- "exp_000_parity_v2" +exp_dir <- "1_code/experiments/exp_000_parity_v2" -project_root <- normalizePath(getwd(), winslash = "/") +source(file.path(exp_dir, "utils", "parity_targets.R")) -exp_code_dir <- file.path( - project_root, "1_code/experiments", exp_id +## 1.2 Configure the run ---- +# See experiment_config() and docs/getting_started.md +config <- experiment_config( + id = "exp_000_parity_v2", + + # Runs, from names(standard_specs()) + taxa = c( + "bryophyte", + "lichen", + "mite", + "vascular_plant", + "mammal_summer", + "mammal_winter", + "bird" + ), + + # A focal_species_sets() name, a vector named by taxon, or NULL + # for every species. Shorten trials by species, not draws, so + # the bands stay honest. + species = "parity_check", + + # 100 is v2's and the only count the gate reads; below ~20 the + # 10-90% bands are unstable. 5 checks the plumbing. + n_bootstraps = 5, + + # Base seed; NULL is unseeded, as v2. Birds replay v2's draws. + seed = 20260909, + + # "spatial_block" draws v2's plant bootstrap afresh; + # "v2_ids" replays v2's stored draws (needs _setup/07). + plant_bootstrap = "spatial_block", + + # NULL fits each spec's v2 candidate sets + stage_models = NULL, + + # Species fitted at once, one R session each + workers = 12, + + # "oob" or "all" write per-unit predictions (GBs for birds) + unit_predictions = "none" ) -log_path <- file.path(project_root, "2_pipeline", exp_id, "logs") - -out_dir <- file.path(project_root, "3_output", exp_id) - -## 1.3 Load harness helpers ---- -# v2_script_runner.R supplies run_step() and the pre-run checks; -# stage_v2_inputs.R builds each taxon's run root. -source(file.path( - project_root, "1_code/harness/utils/v2_script_runner.R" -)) -source(file.path( - project_root, "1_code/harness/utils/stage_v2_inputs.R" -)) - -## 1.4 Set the taxa to run ---- -# Set to TRUE to model that taxon. Toggling a flag re-runs one -# taxon without commenting out code. -bryophytes <- FALSE -lichens <- FALSE -mites <- TRUE -vascular_plants <- FALSE - -## 1.5 Load the species vectors ---- -# Defines bryophyte_species, lichen_species, mite_species, and -# vascular_plant_species. NULL means every species in the data. -source(file.path(exp_code_dir, "utils/species_lists.R")) - -## 1.6 Set the analysis flags ---- -# The steps that turn raw v2 output into committed deliverables. -run_collect <- TRUE -run_compare <- TRUE -run_report <- TRUE - -# 2. Run the taxon modules ---- -# Each block stages that taxon's inputs, then sources its module -# runner. The module reads v2_root and log_path from here, so the -# staged run root is what the v2 scripts see. Nothing outside -# 2_pipeline/ is written. -experiment_start <- Sys.time() - -## 2.1 Bryophytes ---- -if (bryophytes) { - v2_root <- stage_v2_inputs( - exp_id = exp_id, - taxon = "bryophyte", - species = bryophyte_species, - project_root = project_root - ) - source(file.path( - project_root, "1_code/modules/plants/run_v2_bryophytes.R" - )) -} - -## 2.2 Lichens ---- -if (lichens) { - v2_root <- stage_v2_inputs( - exp_id = exp_id, - taxon = "lichen", - species = lichen_species, - project_root = project_root - ) - source(file.path( - project_root, "1_code/modules/plants/run_v2_lichens.R" - )) -} - -## 2.3 Soil mites ---- -if (mites) { - v2_root <- stage_v2_inputs( - exp_id = exp_id, - taxon = "mite", - species = mite_species, - project_root = project_root - ) - source(file.path( - project_root, "1_code/modules/plants/run_v2_mites.R" - )) -} - -## 2.4 Vascular plants ---- -if (vascular_plants) { - v2_root <- stage_v2_inputs( - exp_id = exp_id, - taxon = "vascular-plant", - species = vascular_plant_species, - project_root = project_root +## 1.3 The v2 reference ---- +# ABMIexploreR's published coefficients, pinned to a commit and +# harmonized by _setup/08 +config$v2_reference <- "abmiexplorer" +config$v2_reference_dir <- file.path( + v2_results_dir(), "abmiexplorer" +) +config$v2_reference_builder <- + "1_code/_setup/08_harmonize_abmiexplorer_results.R" + +# 2. Run ---- +# `fit = FALSE` re-summarizes existing stores without fitting +results <- run_experiment( + config, + fit = TRUE, + # Bird landcover onto v2's habitat template + translate = list(bird = bird_habitat_translation), + steps = list( + compare = script_step(file.path(exp_dir, "01_compare_to_v2.R")), + plot = script_step(file.path(exp_dir, "02_plot_parity.R")), + report = script_step(file.path(exp_dir, "03_build_report.R")) ) - source(file.path( - project_root, - "1_code/modules/plants/run_v2_vascular_plants.R" - )) -} - -# 3. Summarize the results ---- -# These read the raw v2 output left in 2_pipeline/ and write the -# committed deliverables to 3_output/. They are placeholders -# until the parity targets are agreed. - -## 3.1 Collect model output ---- -if (run_collect) { - source(file.path(exp_code_dir, "01_collect_results.R")) -} - -## 3.2 Compare against the v2.0 reference ---- -if (run_compare) { - source(file.path(exp_code_dir, "02_compare_to_v2.R")) -} - -## 3.3 Build the report ---- -if (run_report) { - source(file.path(exp_code_dir, "03_build_report.R")) -} - -# 4. Experiment complete ---- -experiment_time <- format(round(Sys.time() - experiment_start, 1)) -cat("\n========================================\n") -cat("EXPERIMENT ", exp_id, " COMPLETE\n", sep = "") -cat("Total run time: ", experiment_time, "\n", sep = "") -cat("========================================\n") -cat("Deliverables are in ", out_dir, "\n", sep = "") +) + +# Commit run_record.md, report.md and the small summary tables +# only after a full run: every species, n_bootstraps = 100. # End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/utils/parity_targets.R b/1_code/experiments/exp_000_parity_v2/utils/parity_targets.R new file mode 100644 index 0000000..ff0758a --- /dev/null +++ b/1_code/experiments/exp_000_parity_v2/utils/parity_targets.R @@ -0,0 +1,190 @@ +# --- +# title: Parity Targets for Experiment 000 +# author: Brendan Casey +# created: 2026-09-29 +# inputs: +# - 3_output/exp_000_parity_v2/tables/v2_self_agreement_summary.csv, +# from v2_self_agreement.R, for the evidence behind the +# distributional targets +# outputs: none; returns objects in memory +# notes: +# - What "pass" means, per comparison type. Proposed from the +# v2 self-agreement calibration; they stand until agreed or +# changed, and the report says they are proposals. +# - Two kinds of comparison: +# - Numerical, where v2 fitted once on the same data the +# harness fits at iteration 1 (the mammal hurdle): every +# reachable term within `numerical_tolerance`. The ports +# reach 2e-14, so 1e-6 leaves room only for platform +# arithmetic, not for a method difference. +# - Distributional, where v2 bootstraps unseeded: the v2 +# median inside this run's 10th-to-90th percentile band +# for at least `min_in_band_pct` of reachable terms, a +# median standardized difference no larger than +# `max_standardized_difference`, and a median band-width +# ratio (this run's band over v2's) inside +# `band_ratio_range`. +# - Why a band-width ratio. The in-band and standardized +# difference tests both measure against this run's own band, +# so a harness that is noisier than v2 passes them more +# easily. The ratio closes that: too wide or too narrow a band +# fails, including one read from a store holding too few +# draws. +# - Spearman of the medians is reported, not gated: averaging +# shrinks unsupported terms to ~1e-30 in both runs, so it +# ranks noise (it failed the mite climate stage with every +# term in band). +# - The calibration (bryophyte climate, two v2 runs of the same +# code): 100% in band, median standardized difference 0.019; +# per-species median band ratio 1.00, 5th to 95th percentile +# 0.78 to 1.21. The targets sit outside those by a margin, +# because one harness run is compared with one v2 run and both +# carry sampling error: +# - in band: 90%, ten points under v2's own 100%; +# - standardized difference: 0.25, over ten times v2's own; +# - band ratio: 0.75 to 1.33, symmetric on a log scale +# (1 / 0.75) and just outside v2's 90% range. +# - The ratio is taken per species as the median over its +# terms, then as the median over species. Single terms are +# useless for it: between two v2 runs, 10% of terms differ in +# width threefold or more. +# - Negligible terms are left out of the ratio (and of the +# reported Spearman): those both runs put below a millionth +# of the term's typical size, from is_negligible(). Model +# averaging leaves them at 1e-20 to 1e-140, where band widths +# are noise; without the rule, twelve such terms took the +# lichen Physcia ratio to 0.31 while its seven real terms sat +# at 0.7 to 1.2. +# - The calibration covers the plant climate stage only. The +# same targets are applied to the plant habitat stage and the +# bird stages on the assumption that v2's self-agreement is +# similar there; no second v2 run exists to check it. +# - A trial run - fewer draws than v2 or a species subset - is +# not gated at all: its bands are too wide or its coverage too +# narrow for a verdict to mean anything. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. parity_targets() ---- + +#' The Proposed Parity Targets +#' +#' @return A named list of thresholds. +#' +#' @example # Example usage of the function +#' # parity_targets()$min_in_band_pct +parity_targets <- function() { + list( + status = "proposed, not yet agreed", + numerical_tolerance = 1e-6, + min_in_band_pct = 90, + max_standardized_difference = 0.25, + band_ratio_range = c(0.75, 1 / 0.75), + negligible_fraction = 1e-6 + ) +} + +# 3. is_negligible() and term_scale() ---- + +#' Flag Terms Model Averaging Has Shrunk to Nothing +#' +#' A term is negligible for a species when both runs put it below +#' `fraction` of that term's typical size: the 90th percentile of +#' its absolute v2 median over every species of the taxon and +#' stage. Typical size is taken per term because terms carry +#' units: an Easting coefficient of 1e-6 is real, a MAP one of +#' 1e-21 is not. +#' +#' @param run_value,v2_value Numeric. The two runs' medians. +#' @param typical Numeric. The term's typical absolute size. +#' @param fraction Numeric. From parity_targets(). +#' @return Logical, TRUE where both runs are negligible. +#' +#' @example # Example usage of the function +#' # is_negligible(1e-22, 1e-21, typical = 1e-3) +is_negligible <- function( + run_value, v2_value, typical, + fraction = parity_targets()$negligible_fraction +) { + limit <- fraction * typical + is.finite(limit) & is.finite(run_value) & is.finite(v2_value) & + abs(run_value) < limit & abs(v2_value) < limit +} + +#' Typical Absolute Size of Each Term +#' +#' @param reference data.frame with group columns, `term` and +#' `v2_median`: every species, not only the run's. +#' @param by Character. The grouping columns besides `term`. +#' @return data.frame of the groups, `term` and `typical`. +#' +#' @example # Example usage of the function +#' # term_scale(reference, c("taxon", "stage")) +term_scale <- function(reference, by) { + values <- reference[is.finite(reference$v2_median), ] + stats::aggregate( + list(typical = abs(values$v2_median)), + values[, c(by, "term")], + function(x) stats::quantile(x, 0.9, names = FALSE) + ) +} + +# 4. parity_verdict() ---- + +#' Read One Parity Summary Row Against the Targets +#' +#' @param comparison Character. "median" or "iteration 1". +#' @param in_band_pct,median_standardized_difference Numbers from +#' the parity summary. +#' @param median_band_ratio,max_absolute_difference Numbers from +#' the parity summary. +#' @param gated Logical. FALSE for a trial run. +#' @param targets From parity_targets(). +#' @return Character: "pass", "fail", "no comparison" or +#' "not gated (trial run)". +#' +#' @example # Example usage of the function +#' # parity_verdict("median", 95, 0.1, 1.02, NA, TRUE) +parity_verdict <- function( + comparison, in_band_pct, median_standardized_difference, + median_band_ratio, max_absolute_difference, gated, + targets = parity_targets() +) { + if (!gated) { + return("not gated (trial run)") + } + + if (identical(comparison, "iteration 1")) { + if (!is.finite(max_absolute_difference)) { + return("no comparison") + } + + return(if ( + max_absolute_difference <= targets$numerical_tolerance + ) { + "pass" + } else { + "fail" + }) + } + + if (!is.finite(in_band_pct)) { + return("no comparison") + } + + passes <- in_band_pct >= targets$min_in_band_pct && + is.finite(median_standardized_difference) && + median_standardized_difference <= + targets$max_standardized_difference && + is.finite(median_band_ratio) && + median_band_ratio >= targets$band_ratio_range[1] && + median_band_ratio <= targets$band_ratio_range[2] + + if (passes) "pass" else "fail" +} + +# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/utils/species_lists.R b/1_code/experiments/exp_000_parity_v2/utils/species_lists.R deleted file mode 100644 index 39e00b2..0000000 --- a/1_code/experiments/exp_000_parity_v2/utils/species_lists.R +++ /dev/null @@ -1,42 +0,0 @@ -# --- -# title: Species Vectors for Experiment 000 -# author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none -# notes: -# - Defines the species each taxon is modelled on. Sourced by -# run.R and passed to stage_v2_inputs(), which narrows the -# staged species queue to these names. -# - NULL models every species in the source data. A short -# vector is the smoke test - the v2 scripts hard-code 100 -# bootstrap iterations, so species count is the only run -# length that can be varied without touching v2 code. -# - Names must match the species columns in the v2 data -# exactly. stage_v2_inputs() stops and lists any name it -# cannot find, so a typo fails before modelling starts. -# - The placeholder vectors below are illustrative. Replace -# them with real species codes before running. -# --- - -# 1. Species vectors ---- - -## 1.1 Bryophytes ---- -# NULL runs every bryophyte in the data. -bryophyte_species <- NULL - -## 1.2 Lichens ---- -lichen_species <- NULL - -## 1.3 Soil mites ---- -# Placeholder - replace with species codes from the v2 mite data. -mite_species <- c( - "species_code_1", - "species_code_2", - "species_code_3" -) - -## 1.4 Vascular plants ---- -vascular_plant_species <- NULL - -# End of script ---- diff --git a/1_code/experiments/exp_000_parity_v2/v2_self_agreement.R b/1_code/experiments/exp_000_parity_v2/v2_self_agreement.R new file mode 100644 index 0000000..7113bae --- /dev/null +++ b/1_code/experiments/exp_000_parity_v2/v2_self_agreement.R @@ -0,0 +1,208 @@ +# --- +# title: How Well Does v2 Agree With Itself? (Experiment 000) +# author: Brendan Casey +# created: 2026-09-29 +# inputs: +# - 2_pipeline/v2_reference/bryophyte-species-models.Rdata, +# from 1_code/_setup/03_rerun_bryophyte_v2_reference.R +# - abmiexplorer/v2_results.csv from the published v2 results +# (see 1_code/harness/data_source.R), the bryophyte climate +# rows, from _setup/08. These are v2's original run: they +# match v2's COEFS.RData to ~1e-15 +# outputs: +# in 3_output/exp_000_parity_v2/tables/: +# - v2_self_agreement.csv, per species and term +# - v2_self_agreement_summary.csv, the rates the gate's +# distributional targets are set from +# notes: +# - The ceiling for any distributional parity target. v2 seeds +# no bootstrap, so two runs of the same v2 code on the same +# data disagree; asking the harness to agree with v2 more +# closely than v2 agrees with itself would fail a perfect +# reimplementation. +# - The two runs are the bryophyte climate stage: v2's original +# run, as ABMIexploreR publishes it, and the rerun _setup/03 +# made with the frozen v2 functions. Same code, same data, +# different unseeded draws; 19 terms by 100 draws for each +# species both hold. Bryum.All is not published, so it +# drops out (133 of the rerun's 134 species). +# - Scored exactly as 01_compare_to_v2.R scores the harness, in +# both directions: is one run's median inside the other's +# 10th-to-90th percentile band, and how far apart are the +# medians relative to half that band. The two directions are +# reported separately and averaged. +# - Also the per-species Spearman of the medians (terms span +# twenty orders of magnitude, so not Pearson). Reported, not +# gated. +# - And the band-width ratio, the rerun's 10-90% band over the +# published run's, as a median per species. Its 5th to 95th +# percentile over species sets the gate's band_ratio_range. +# - Climate only: the regenerated reference has no habitat +# stage. The rate is assumed to carry to the plant habitat +# stage; that is an assumption, stated in the README. +# - Run once, from the repository root, after _setup/03 and 08. +# Not part of run.R's sequence. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # reading and writing tables (version: 1.16.4) + +## 1.2 Resolve paths ---- +project_root <- normalizePath(getwd(), winslash = "/") + +# The gate's negligible-term rule, so both are scored alike +source(file.path( + project_root, + "1_code/experiments/exp_000_parity_v2/utils/parity_targets.R" +)) +rerun_path <- file.path( + project_root, "2_pipeline", "v2_reference", + "bryophyte-species-models.Rdata" +) +source(file.path(project_root, "1_code/harness/data_source.R")) +results_path <- file.path( + v2_results_dir(), "abmiexplorer", "v2_results.csv" +) +tables_dir <- file.path( + project_root, "3_output", "exp_000_parity_v2", "tables" +) +dir.create(tables_dir, recursive = TRUE, showWarnings = FALSE) + +for (path in c(rerun_path, results_path)) { + if (!file.exists(path)) { + stop("Input not found:\n ", path, call. = FALSE) + } +} + +## 1.3 Read the two runs ---- +rerun_env <- new.env() +load(rerun_path, envir = rerun_env) +rerun <- rerun_env$climate.coef + +published <- fread(results_path)[ + taxon == "bryophyte" & stage == "climate" +] + +# 2. Summarize the rerun as the published run is summarized ---- +rerun_summary <- rbindlist(lapply(names(rerun), function(species) { + draws <- rerun[[species]] + + if (!is.matrix(draws)) { + return(NULL) + } + + rbindlist(lapply(colnames(draws), function(term) { + values <- draws[, term] + values <- values[is.finite(values)] + + data.table( + species = species, term = term, + rerun_median = stats::median(values), + rerun_p10 = stats::quantile(values, 0.1, names = FALSE), + rerun_p90 = stats::quantile(values, 0.9, names = FALSE), + rerun_mean = mean(values), + rerun_sd = if (length(values) < 2) { + NA_real_ + } else { + stats::sd(values) + } + ) + })) +})) + +# 3. Score each run against the other ---- +joined <- merge( + rerun_summary, + published[, .(species, term, pub_median = v2_median, + pub_p10 = v2_p10, pub_p90 = v2_p90)], + by = c("species", "term") +) + +# Scored as the gate scores: in band, or within the numerical +# tolerance for terms whose values are effectively zero. +tolerance <- 1e-6 + +joined[, `:=`( + published_in_rerun_band = + (pub_median >= rerun_p10 & pub_median <= rerun_p90) | + abs(pub_median - rerun_median) <= tolerance, + rerun_in_published_band = + (rerun_median >= pub_p10 & rerun_median <= pub_p90) | + abs(pub_median - rerun_median) <= tolerance, + standardized_difference_rerun = + abs(pub_median - rerun_median) / ((rerun_p90 - rerun_p10) / 2), + standardized_difference_published = + abs(pub_median - rerun_median) / ((pub_p90 - pub_p10) / 2) +)] + +finite_median <- function(x) stats::median(x[is.finite(x)]) + +# The rerun's band width over the published run's. Summarized per +# species as the median over its terms, as the gate takes it, and +# without the terms both runs shrink to nothing, by the gate's +# is_negligible() rule. +joined[, band_ratio := (rerun_p90 - rerun_p10) / (pub_p90 - pub_p10)] + +term_scales <- as.data.table(term_scale( + as.data.frame(published), c("taxon", "stage") +)) +joined <- merge( + joined, term_scales[, .(term, typical)], + by = "term", all.x = TRUE +) +joined[, negligible := is_negligible( + rerun_median, pub_median, typical +)] + +by_species <- joined[!(negligible), .( + spearman = suppressWarnings(stats::cor( + rerun_median, pub_median, method = "spearman" + )), + band_ratio = finite_median(band_ratio[band_ratio > 0]) +), by = species] + +summary_table <- data.table( + stage = "climate", + taxon = "bryophyte", + species = uniqueN(joined$species), + terms = nrow(joined), + negligible_terms = sum(joined$negligible), + in_band_pct_published_in_rerun = round( + 100 * mean(joined$published_in_rerun_band), 1 + ), + in_band_pct_rerun_in_published = round( + 100 * mean(joined$rerun_in_published_band), 1 + ), + in_band_pct = round(100 * mean(c( + joined$published_in_rerun_band, joined$rerun_in_published_band + )), 1), + median_standardized_difference = round(finite_median(c( + joined$standardized_difference_rerun, + joined$standardized_difference_published + )), 3), + median_spearman = round(finite_median(by_species$spearman), 3), + p10_spearman = round(stats::quantile( + by_species$spearman, 0.1, na.rm = TRUE, names = FALSE + ), 3), + median_band_ratio = round(finite_median(by_species$band_ratio), 3), + p05_band_ratio = round(stats::quantile( + by_species$band_ratio, 0.05, na.rm = TRUE, names = FALSE + ), 3), + p95_band_ratio = round(stats::quantile( + by_species$band_ratio, 0.95, na.rm = TRUE, names = FALSE + ), 3) +) + +# 4. Write ---- +fwrite(joined, file.path(tables_dir, "v2_self_agreement.csv")) +fwrite( + summary_table, + file.path(tables_dir, "v2_self_agreement_summary.csv") +) + +cat("v2 against itself, bryophyte climate:\n") +print(summary_table) + +# End of script ---- diff --git a/1_code/experiments/exp_001_xgboost/README.md b/1_code/experiments/exp_001_xgboost/README.md new file mode 100644 index 0000000..4f5afe9 --- /dev/null +++ b/1_code/experiments/exp_001_xgboost/README.md @@ -0,0 +1,136 @@ +# exp_001_xgboost + +![Status](https://img.shields.io/badge/Status-Test-lightgrey) +![Languages](https://img.shields.io/badge/Languages-R-blue) + +## Question + +Does a boosted regression tree fit the habitat stage better than v2's linear +models, for every taxon: the plant-group taxa, mammals and birds? + +This is a **test experiment**: its first job is to show that a method with +no coefficients runs through the pipeline for every taxon and is compared +with the v2 baseline. Read its numbers as a result only after a run at 100 +draws with tuned settings. + +## Design + +| | exp_000 (baseline) | exp_001 (this) | +| --- | --- | --- | +| Climate stage | v2: GLM candidates, AICc model averaging (mammals: v2's precomputed prediction) | The same | +| Habitat stage (each spec's `habitat_stage`; birds: landcover) | v2: GLM candidates; IVW averaging (plants), staged BIC (birds), or the hurdle with best-by-AICc halves (mammals); v2's post-processing | `xgboost` with the `single` rule, on every covariate v2's habitat candidates use, `Climate` included | +| Climate → habitat | Carried as `Climate` | The same | +| Species, draws, seed | `parity_check`, 20260909 | The same | + +- **What changes:** the habitat stage's engine, selection rule and + candidate set. `run.R` makes the change with one call for every run: + `lapply(standard_specs(), replace_stage_method, engine = "xgboost", + control = xgb_settings)`. +- **Why one formula:** a tree chooses its own variables, splits and + interactions, so it is given every candidate covariate once (as main + effects) rather than v2's competing formulas. +- **Mammals.** The habitat stage is the generic `hurdle` rule. Its + structure stays: presence on every deployment, on v2's lure-scaled + response (`binary:logistic`, which takes a proportion), then abundance + given presence on the deployments with detections (`reg:gamma`, a + log-link Gamma), unweighted and without `Climate`, as in v2. Boosted + trees fit both halves. The hurdle writes `habitat_presence`, + `habitat_abundance` and `habitat_total` (their product) as grid + predictions, the same tables v2 publishes. +- **What is dropped:** + - v2's post-processing of habitat coefficients: the plant stand-age + splines, cutblock convergence, pAspen and footprint pooling, and v2's + plant validation AUCs; + - the mammal one-hot tables, calibration, stand-age splines, Mule Deer + adjustment and cutblock convergence. + + These all read coefficients a tree does not have. The metrics score the + tree's own prediction: presence, for mammals. + +## How to run + +From the repository root: + +```r +source("1_code/experiments/exp_001_xgboost/run.R") +``` + +It reads the published test dataset and exp_000's +`3_output/exp_000_parity_v2/tables/`, and writes stores to +`2_pipeline/exp_001_xgboost/` and summaries to +`3_output/exp_001_xgboost/`. + +`run.R` uses 5 draws to check the pipeline. For a result, set +`n_bootstraps = 100`, and make sure the exp_000 tables it is compared +against are from a 100-draw run of the same species. + +## How to read the result + +`3_output/exp_001_xgboost/tables/`: + +| File | Read it for | +| --- | --- | +| `comparison_metrics.csv` | Per species, both runs' out-of-bag metrics and 10–90% bands | + +Out-of-bag metrics score each draw on the survey units it left out, which +matters here: a tree fits the units it trained on far more closely than a +GLM does, so in-sample metrics would flatter it. + +## Assumptions and caveats + +- **The xgboost settings are untuned.** At most 1000 rounds, learning + rate 0.05, depth 3, subsample 0.5, minimum child weight 1 (`run.R` + section 1.2). The number of rounds is chosen by early stopping on a + seeded 20% holdout of each draw, then the model is refitted on all of + the draw. A fair comparison tunes + these, ideally per taxon. +- **The grid compares like with like only roughly.** The grid holds each + habitat type as a pure stand at `Climate` 0. A GLM extrapolates to that + linearly; a tree holds the value of its nearest split. Where a type is + rare at the survey units, the two can differ for that reason alone. +- **The baseline includes v2's post-processing** (stand-age splines, + footprint pooling, and for mammals calibration and convergence); this + run does not. A difference in the aged, cutblock or footprint habitat + types partly reflects that. +- **Mammal grid predictions are presence**, as in exp_000. Abundance and + total are compared through the `habitat_abundance` and `habitat_total` + coefficient summaries. Note that exp_000's mammal tables are v2's + calibrated tables, so they are not like for like with this run's + uncalibrated grid predictions. +- **Bird counts keep the QPAD offset**, which the engine passes as the + base margin in fitting and prediction. +- **gbm was replaced.** The first version of this experiment + (`exp_001_gbm`, 2026-10-03) used `gbm`, which cannot fit the mammal + hurdle: its bernoulli rejects a 0–1 proportion and it has no Gamma + family. + +## Result + +_Not yet run at 100 draws._ + +**Pipeline check, 2026-10-05: 5 draws, `parity_check` species.** All 160 +species × region × draw jobs ran, mammals included. Against the exp_000 +tables (whose draw counts match): + +| Taxon | Out-of-bag AUC, north (v2 → xgboost) | South (v2 → xgboost) | +| --- | --- | --- | +| Birds | 0.729 → 0.769 | 0.702 → 0.745 | +| Bryophytes | 0.650 → 0.681 | 0.669 → 0.754 | +| Lichens | 0.803 → 0.827 | 0.792 → 0.860 | +| Mammals, summer | 0.704 → 0.727 | 0.660 → 0.684 | +| Mammals, winter | 0.741 → 0.768 | 0.710 → 0.725 | +| Soil mites | 0.716 → 0.739 | 0.774 → 0.811 | +| Vascular plants | 0.828 → 0.869 | 0.846 → 0.905 | + +xgboost's out-of-bag AUC was higher in every taxon, region and season. +Except for birds, and soil mites in the south, its calibration slopes were +further from 1 than v2's. +Mammal slopes fell from 0.65–0.85 to 0.53–0.72, so the untuned trees are +overconfident there. The median rank correlation of the habitat grid +effects with v2's was 0.28–0.73 by taxon and region, but about 0 for +soil mites in the north. Mammals were 0.69 in the north and 0.68 in the +south. + +**Do not read these as the finding.** Five draws give unstable bands, the +settings are untuned, and two species per taxon is a small sample. They +show the comparison works end to end, for every taxon. diff --git a/1_code/experiments/exp_001_xgboost/run.R b/1_code/experiments/exp_001_xgboost/run.R new file mode 100644 index 0000000..c5c3bdb --- /dev/null +++ b/1_code/experiments/exp_001_xgboost/run.R @@ -0,0 +1,62 @@ +# --- +# title: Run Experiment 001 - Boosted Regression Trees for Habitat +# author: Brendan Casey +# created: 2026-10-03 +# inputs: +# - the published test dataset (harness/data_source.R) +# - 3_output/exp_000_parity_v2/tables/, the v2 baseline +# outputs: +# in 2_pipeline/exp_001_xgboost/: +# - // result stores, and run_log.csv +# in 3_output/exp_001_xgboost/: +# - tables/ (summaries, and comparison_metrics.csv against +# exp_000), run_record.md +# notes: +# - Does xgboost fit the habitat stage better than v2's GLMs? +# See README.md. Only each spec's `habitat_stage` changes +# (via replace_stage_method()); v2's climate stage is kept +# and carried as `Climate`. For mammals, xgboost fits both +# hurdle halves. +# - Settings are untuned (see methods/engines/xgboost.R): this +# tests the pipeline, not the method's best. +# --- + +# 1. Setup ---- + +## 1.1 Load the framework ---- +source("1_code/harness/harness.R") +load_framework() + +## 1.2 The change: fit the habitat stage with xgboost ---- +xgb_settings <- list( + nrounds = 1000, # the most rounds; early stopping picks + eta = 0.05, # learning rate + max_depth = 3, # tree complexity + subsample = 0.5, # share of rows each tree sees + min_child_weight = 1 # smallest leaf, in weighted rows +) + +# One call per run: each spec names its own habitat stage +specs <- lapply( + standard_specs(), replace_stage_method, + engine = "xgboost", control = xgb_settings +) + +## 1.3 Configure the run ---- +# Same species and seed as exp_000 +config <- experiment_config( + id = "exp_001_xgboost", + taxa = names(specs), + species = "parity_check", + # 5 checks the pipeline runs; 100 for a result to read + n_bootstraps = 5, + seed = 20260909, + specs = specs, + workers = 12 +) + +# 2. Run ---- +# Fit, summarize, and compare with exp_000 +results <- run_experiment(config) + +# End of script ---- diff --git a/1_code/experiments/exp_002_soilgrids/01_extract_soilgrids_covariates.R b/1_code/experiments/exp_002_soilgrids/01_extract_soilgrids_covariates.R new file mode 100644 index 0000000..ca9e776 --- /dev/null +++ b/1_code/experiments/exp_002_soilgrids/01_extract_soilgrids_covariates.R @@ -0,0 +1,135 @@ +# --- +# title: Extract SoilGrids Covariates for Experiment 002 +# author: Brendan Casey +# created: 2026-10-04 +# inputs: +# - SoilGrids 2.0, ABMI 1 km variant, from the sciSpatialR +# catalogue (geoscientificInformation/soilgrids_250_v2_ab/ +# abmi1km), on //ABMI-DATA2; SDM_SOILGRIDS overrides the path +# - sites.csv from the published test dataset (see +# 1_code/harness/data_source.R), read only +# outputs: +# in 2_pipeline/exp_002_soilgrids/inputs/: +# - soilgrids_0_5cm.csv: survey_unit_id plus ten +# sg_*_0_5cm columns, one row per survey unit +# - soilgrids_0_5cm_source.csv: where the columns came from +# notes: +# - Written to 2_pipeline/, not the frozen test dataset; run.R +# passes the file as `covariate_files`. +# - All ten SoilGrids properties published at 0-5 cm (organic +# carbon stock is 0-30 cm only, so excluded), in the layer's +# units. Gap-filled cells are interpolations (see the layer's +# readme). +# - Each unit takes its 1 km cell's value, located by easting +# and northing in EPSG:3400 (the layer's grid). Checked +# 2026-10-04: plant units match projected lat/long to 1e-8 m; +# 98% of v2's south-only bird units fall in the Grassland and +# Parkland regions. Mammals have no coordinates, so NA. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # reading and writing tables (version: 1.18.0) +library(sciSpatialR) # catalogue access, extraction (version: 0.1.0) +library(sf) # survey unit points (version: 1.1.2) + +## 1.2 Resolve paths ---- +project_root <- normalizePath(getwd(), winslash = "/") +resolver <- file.path(project_root, "1_code/harness/data_source.R") + +if (!file.exists(resolver)) { + stop("Run this from the repository root.", call. = FALSE) +} + +source(resolver) +sites_path <- file.path(test_dataset_dir(), "sites.csv") +out_dir <- file.path( + project_root, "2_pipeline", "exp_002_soilgrids", "inputs" +) + +layer_id <- "geoscientificInformation/soilgrids_250_v2_ab/abmi1km" +layer_path <- Sys.getenv("SDM_SOILGRIDS", unset = "") + +dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) + +# 2. Read the layer's shallowest depth ---- +soil <- if (nzchar(layer_path)) { + terra::rast(layer_path) +} else { + get_layer(layer_id) +} + +shallow <- grep("_0-5cm_mean$", names(soil), value = TRUE) + +if (length(shallow) != 10) { + stop( + "Expected ten 0-5 cm bands in ", layer_id, "; found ", + length(shallow), ".", + call. = FALSE + ) +} + +soil <- soil[[shallow]] + +# Column names the formulas can use: sg_clay_0_5cm +names(soil) <- paste0( + "sg_", sub("_0-5cm_mean$", "", shallow), "_0_5cm" +) +soil_columns <- names(soil) + +# 3. Extract at every survey unit ---- +sites <- fread( + sites_path, + select = c("survey_unit_id", "easting", "northing"), + colClasses = list(character = "survey_unit_id") +) +located <- sites[!is.na(easting) & !is.na(northing)] + +points <- st_as_sf( + located, coords = c("easting", "northing"), crs = 3400 +) + +values <- as.data.table( + extract_points(soil, points, bind = FALSE) +) +values <- values[, soil_columns, with = FALSE] + +# One row per survey unit, NA where a unit has no location +soil_table <- data.table(survey_unit_id = sites$survey_unit_id) +rows <- match(sites$survey_unit_id, located$survey_unit_id) + +for (column in soil_columns) { + set(soil_table, j = column, value = values[[column]][rows]) +} + +## 3.1 Report ---- +cat( + "Survey units:", nrow(sites), "\n", + " located:", nrow(located), "\n", + " without coordinates (soil left NA):", + nrow(sites) - nrow(located), "\n", + " located but outside the layer:", + sum(!stats::complete.cases(values)), "\n" +) +print(summary(values)) + +# 4. Write ---- +fwrite(soil_table, file.path(out_dir, "soilgrids_0_5cm.csv"), + na = "") + +fwrite(data.table( + columns = paste(soil_columns, collapse = " "), + source = layer_id, + doi = paste0( + "10.17027/isric-soilgrids.", + "713396fa-1687-11ea-a7c0-a0481ca9e724" + ), + depth = "0-5 cm", + extracted = format(Sys.Date()), + method = "value of the 1 km cell each survey unit falls in" +), file.path(out_dir, "soilgrids_0_5cm_source.csv")) + +cat("Wrote", nrow(soil_table), "survey units to", out_dir, "\n") + +# End of script ---- diff --git a/1_code/experiments/exp_002_soilgrids/README.md b/1_code/experiments/exp_002_soilgrids/README.md new file mode 100644 index 0000000..8c4d393 --- /dev/null +++ b/1_code/experiments/exp_002_soilgrids/README.md @@ -0,0 +1,131 @@ +# exp_002_soilgrids + +![Status](https://img.shields.io/badge/Status-Test-lightgrey) +![Languages](https://img.shields.io/badge/Languages-R-blue) + +## Question + +Does adding near-surface soil properties from SoilGrids 2.0 improve the +models, for the plant-group taxa and birds? + +This is a **test experiment**: its first job is to show that a covariate set +from the Science Centre's spatial catalogue +([sciSpatialR](https://github.com/ABbiodiversity/sciSpatialR)) can be tested +against the v2 baseline without changing the frozen dataset. Read its numbers as a +result only after a run at 100 draws. + +## The covariates + +SoilGrids 2.0 (Poggio et al. 2021, SOIL 7: 217–240; +doi:10.17027/isric-soilgrids.713396fa-1687-11ea-a7c0-a0481ca9e724), the ABMI +1 km variant in the catalogue (`geoscientificInformation/soilgrids_250_v2_ab/ +abmi1km`), at its shallowest depth, 0–5 cm. + +| Column | Property | Units | In the models | +| --- | --- | --- | --- | +| `sg_bdod_0_5cm` | Bulk density | kg/dm3 | yes | +| `sg_cec_0_5cm` | Cation exchange capacity | cmol(c)/kg | yes | +| `sg_cfvo_0_5cm` | Coarse fragments | vol % | yes | +| `sg_clay_0_5cm` | Clay | % | yes | +| `sg_sand_0_5cm` | Sand | % | yes | +| `sg_silt_0_5cm` | Silt | % | **no**: sand, silt and clay sum to 100%, so one is fixed by the other two | +| `sg_nitrogen_0_5cm` | Nitrogen | g/kg | yes | +| `sg_phh2o_0_5cm` | pH in water | pH | yes | +| `sg_soc_0_5cm` | Soil organic carbon | g/kg | yes | +| `sg_ocd_0_5cm` | Organic carbon density | kg/m3 | yes | + +They are extracted by `01_extract_soilgrids_covariates.R` in this folder, +which takes the value of the 1 km cell each survey unit falls in and writes +`2_pipeline/exp_002_soilgrids/inputs/soilgrids_0_5cm.csv` (one row per survey +unit) with its source in `soilgrids_0_5cm_source.csv`. `run.R` names that file +in `experiment_config(covariate_files = )`, and the harness joins it on +`survey_unit_id` when it loads the data. `0_data/` and `_setup/` are not +touched. Organic carbon stock is published for 0–30 cm only and is not +included. + +## Design + +| | exp_000 (baseline) | exp_002 (this) | +| --- | --- | --- | +| Climate stage | v2's candidates (plants 58, birds 25), model-averaged | The same candidates, each with the nine soil terms added | +| Climate → habitat | Carried as `Climate` | The same; the carried prediction now includes soil | +| Habitat stage | v2 | v2, unchanged | +| Species, draws, seed | `parity_check`, 20260909 | The same | + +- **Why the climate stage.** It is fitted once, province-wide, so one set of + formulas serves every region, and it is v2's broad-scale environmental + stage. Adding soil to the habitat stage instead would need different + formulas per region and a soil value for every row of the habitat grids. +- **Every candidate gets the terms** (`extend_models()`), so the comparison + between candidates is v2's and the only change is the soil. +- **Mammals are not run.** Their v2 climate is a precomputed prediction rather + than a fitted stage, and their deployments carry no coordinates in the + dataset, so they have no soil values. + +## How to run + +From the repository root: + +```r +source("1_code/experiments/exp_002_soilgrids/run.R") +``` + +`run.R` runs the extraction first if the soil file is missing. That step +reads the layer from the `//ABMI-DATA2` share; set `SDM_SOILGRIDS` to a local +copy of the raster to read it from there instead. Delete the file to extract +again. + +It also reads the published test dataset and exp_000's +`3_output/exp_000_parity_v2/tables/`, and writes stores to +`2_pipeline/exp_002_soilgrids/` and summaries to +`3_output/exp_002_soilgrids/`. + +`run.R` uses 5 draws to check the pipeline. For a result, set +`n_bootstraps = 100` and compare against a 100-draw exp_000. + +## How to read the result + +Every experiment is compared with exp_000; see +`3_output/exp_002_soilgrids/tables/comparison_metrics.csv`. + +## Assumptions and caveats + +- **A 1 km cell is not a plot.** Each survey unit takes the mean of its 1 km + cell, aggregated from SoilGrids' 250 m predictions, which are themselves + model predictions, not measurements. Gap-filled cells are interpolated. +- **Some soil terms are correlated**: bulk density with coarse fragments + (r = −0.83) and pH (0.79), sand with clay (−0.80), nitrogen with organic + carbon (0.75). Model averaging spreads weight across them, so individual + soil coefficients are hard to interpret; the fit metrics and grid + predictions are the reliable read. +- **Raw units, unscaled.** As in v2's climate stage; `bayesglm` scales + predictors internally for its priors. +- **Twelve plant-group survey units have no soil value** (just outside the + 1 km grid), so the climate stage fits on those 12 fewer units than + exp_000. No bird unit is missing. +- **More parameters.** Each candidate gains nine terms; the AICc weights + penalize them, but the averaged model is larger than v2's. + +## Result + +_Not yet run at 100 draws._ + +**Pipeline check, 2026-10-04: 5 draws, `parity_check` species.** All 100 +species × region × draw jobs ran. Against exp_000 at the same species, seed +and draws: + +| Taxon | Out-of-bag AUC, north (v2 → soil) | South (v2 → soil) | +| --- | --- | --- | +| Birds | 0.729 → 0.732 | 0.702 → 0.715 | +| Bryophytes | 0.650 → 0.657 | 0.669 → 0.664 | +| Lichens | 0.803 → 0.803 | 0.792 → 0.811 | +| Soil mites | 0.716 → 0.716 | 0.774 → 0.787 | +| Vascular plants | 0.828 → 0.824 | 0.846 → 0.842 | + +The differences are small and mixed in sign, and calibration slopes moved +slightly away from 1 for most taxa. Habitat effects on the grid barely moved +(rank correlation with exp_000 of 0.86–1.00 by species). + +**Do not read these as the finding.** Five draws give unstable bands and two +species per taxon is a small sample. They show the covariates load and the +comparison works end to end. diff --git a/1_code/experiments/exp_002_soilgrids/run.R b/1_code/experiments/exp_002_soilgrids/run.R new file mode 100644 index 0000000..367d145 --- /dev/null +++ b/1_code/experiments/exp_002_soilgrids/run.R @@ -0,0 +1,92 @@ +# --- +# title: Run Experiment 002 - SoilGrids Terms in the Climate Stage +# author: Brendan Casey +# created: 2026-10-04 +# inputs: +# - the published test dataset, the frozen v2 data, unchanged +# - 2_pipeline/exp_002_soilgrids/inputs/soilgrids_0_5cm.csv, the +# soil covariates, written by 01_extract_soilgrids_covariates.R +# in this folder (run here when the file is missing) +# - 3_output/exp_000_parity_v2/tables/, the v2 baseline +# outputs: +# in 2_pipeline/exp_002_soilgrids/: +# - // result stores, and run_log.csv +# in 3_output/exp_002_soilgrids/: +# - tables/ (summaries, and comparison_metrics.csv against +# exp_000), run_record.md +# notes: +# - Does adding 0-5 cm SoilGrids properties to every climate +# candidate improve the models? See README.md. Soil columns +# come from this experiment's file via `covariate_files`. +# - Mammals are not run: their v2 climate is precomputed, and +# their deployments have no coordinates. +# --- + +# 1. Setup ---- + +## 1.1 Load the framework ---- +source("1_code/harness/harness.R") +load_framework() + +## 1.2 The soil covariates ---- +# Extracted once from the sciSpatialR catalogue; needs the +# network share. Delete the file to extract again. +soil_file <- "2_pipeline/exp_002_soilgrids/inputs/soilgrids_0_5cm.csv" + +if (!file.exists(soil_file)) { + source(file.path( + "1_code", "experiments", "exp_002_soilgrids", + "01_extract_soilgrids_covariates.R" + )) +} + +## 1.3 The change: soil terms in every climate candidate ---- +# The 0-5 cm SoilGrids properties. Silt is left out: sand, silt +# and clay sum to 100%. +soil_terms <- c( + "sg_bdod_0_5cm", # bulk density, kg/dm3 + "sg_cec_0_5cm", # cation exchange capacity, cmol(c)/kg + "sg_cfvo_0_5cm", # coarse fragments, vol % + "sg_clay_0_5cm", # clay, % + "sg_sand_0_5cm", # sand, % + "sg_nitrogen_0_5cm", # nitrogen, g/kg + "sg_phh2o_0_5cm", # pH in water + "sg_soc_0_5cm", # soil organic carbon, g/kg + "sg_ocd_0_5cm" # organic carbon density, kg/m3 +) + +plant_taxa <- c("bryophyte", "lichen", "mite", "vascular_plant") + +# Keys are "taxon.stage" +stage_models <- c( + stats::setNames( + rep(list(extend_models("climate_plant_v2_full", soil_terms)), + length(plant_taxa)), + paste0(plant_taxa, ".climate") + ), + list(bird.climate = extend_models("climate_bird_v2", soil_terms)) +) + +## 1.4 Configure the run ---- +# Same species and seed as exp_000 +config <- experiment_config( + id = "exp_002_soilgrids", + taxa = c(plant_taxa, "bird"), + species = "parity_check", + # 5 checks the pipeline runs; 100 for a result to read + n_bootstraps = 5, + seed = 20260909, + stage_models = stage_models, + # Where the soil columns named in stage_models are read from + covariate_files = soil_file, + workers = 12 +) + +# 2. Run ---- +# Fit, summarize, and compare with exp_000 +results <- run_experiment( + config, + translate = list(bird = bird_habitat_translation) +) + +# End of script ---- diff --git a/1_code/harness/.gitkeep b/1_code/harness/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/harness/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/harness/README.md b/1_code/harness/README.md new file mode 100644 index 0000000..a75af9d --- /dev/null +++ b/1_code/harness/README.md @@ -0,0 +1,123 @@ +# harness + +The shared pipeline. It names no taxon and no method: taxon modules +supply specs, `methods/` supplies what the specs name, and the harness +runs them. A change here affects every experiment, past and future; +review it as such and check it with [`1_code/tests/`](../tests/). + +Load everything with: + +```r +source("1_code/harness/harness.R") +load_framework() # harness/, methods/, modules/, experiments/_shared/ +``` + +`new_experiment.R` is the exception: it is base R and runs without +`load_framework()`. + +## Files + +| File | Holds | +| --- | --- | +| `harness.R` | `load_framework()`: sources the harness, methods, modules and `experiments/_shared/`, in that order | +| `experiment.R` | `experiment_config()`, `run_experiment()`, `script_step()` | +| `new_experiment.R` | `new_experiment()`: scaffold an experiment's three folders | +| `data_source.R` | The pinned published dataset versions; `test_dataset_dir()`, `v2_results_dir()`, `verify_published()` | +| `data_load.R` | `lookup/dataset_manifest.csv`, loaders, `covariate_files` joins, model frames | +| `cache.R` | Session cache for dataset reads | +| `covariate_sets.R` | Named covariate sets, derived columns, term renaming | +| `model_sets.R` | v2 candidate formulas, spliced verbatim; `extend_models()`, `models_from_covariates()` | +| `spec.R` | `validate_spec()`, `apply_stage_models()`, `replace_stage_method()` | +| `registry.R` | `register_engine()` and the other `register_*()`; `list_methods()` | +| `engines.R` | Engine interface and `check_engine()` | +| `selection.R` | Plumbing for selection rules: `fit_candidates()`, `combined_predictor()`, `selection_result()` | +| `resample.R` | Per-species seeds, `with_seed()`, spatial blocks | +| `species.R` | Species lists and focal-species resolution | +| `predict_grid.R` | Projects a final model onto a habitat grid | +| `eval_metrics.R` | Scores a prediction with every registered metric | +| `run_model.R` | `run_specs()`: prepare each spec, fit species in parallel, merge shards | +| `result.R` | The result store: writes and reads its files | +| `summarise.R` | `collect_results()`: stores to summary tables | +| `compare.R` | `compare_experiments()`: one experiment against another | +| `run_record.R` | `run_record()`: writes `run_record.md` | + +## What `run_experiment()` does + +1. **Configure.** `experiment_config()` checks every decision before + anything is fitted. +2. **Fit.** Every spec is validated and each region's data and grid + are loaded once. Each species is one job; with `workers` above 1, + jobs run in parallel R sessions. Each species draws under its own + seed, so results do not depend on the worker count. A failed + species or draw is logged and the run continues. +3. **Store.** Shards are merged into one store per run and region in + `2_pipeline//`, plus `run_log.csv`. +4. **Summarize.** `collect_results()` writes `3_output//tables/`. +5. **Compare.** Every experiment except the baseline writes + `tables/comparison_metrics.csv` against exp_000. +6. **Steps.** The experiment's own `steps`, in order. +7. **Record.** `run_record.md`. + +`run_experiment(config, fit = FALSE)` re-summarizes existing stores. +Nothing outside `2_pipeline//` and `3_output//` is written. + +## `experiment_config()` arguments + +| Argument | Default | Sets | +| --- | --- | --- | +| `id` | | Folder name under `2_pipeline/` and `3_output/` | +| `taxa` | all | Runs, from `names(standard_specs())` | +| `species` | every species | A `focal_species_sets()` name, or a vector named by taxon | +| `n_bootstraps` | `100` | Draws per species; v2 used 100. 5 checks a run works | +| `seed` | `20260909` | Base seed; `NULL` leaves draws unseeded, as v2 did | +| `stage_models` | v2's | Replacement candidate sets, keyed `stage` or `taxon.stage` | +| `covariate_files` | none | CSVs of extra covariates keyed on `survey_unit_id` | +| `specs` | `standard_specs()` | Changed specs, such as a different engine or rule | +| `plant_bootstrap` | `"spatial_block"` | `"v2_ids"` replays v2's stored plant draws | +| `workers` | `1` | Species fitted at once | +| `unit_predictions` | `"none"` | `"oob"` or `"all"` writes per-unit predictions | +| `baseline` | `"exp_000_parity_v2"` | Experiment to compare with; `NULL` skips | +| `v2_bootstraps` | `100` | Draws a run needs to be gated | +| `project_root`, `data_dir`, `pipeline_dir`, `out_dir` | derived | Path overrides | + +## Outputs + +A *draw* is one bootstrap iteration; draw 1 is the full data. Every +summary reduces draws to `median`, `p10` and `p90` (what comparisons +read), plus `mean`, `sd`, `n` and `boot1` (the draw-1 value). + +### Result stores: `2_pipeline////` + +| File | Holds | +| --- | --- | +| `coefficients.csv` | Every stage's coefficients per species, draw and term | +| `metrics.csv` | Metrics per species and draw | +| `grid_predictions.csv` | The final model's prediction for each habitat type | +| `unit_predictions.csv` | Only with `unit_predictions = "oob"` or `"all"`; several GB for birds | +| `meta.json` | Stages, engines, rules, covariates, resampling, seed, overrides | + +`2_pipeline//run_log.csv` records every species, region and draw: +`ok`, or why not. + +### Summary tables: `3_output//tables/` + +| File | One row per | Notes | +| --- | --- | --- | +| `coverage.csv` | run × region | Species, draws and stages written; `species = 0` means nothing ran (see `run_log.csv`) | +| `metric_summary.csv` | taxon × region × species × metric | Prefixes: `insample_`, `oob_` (held-out; NA for draw 1), `v2val_` and `oob_v2val_` (v2's seven plant validation AUCs) | +| `grid_summary.csv` | taxon × region × species × `grid_unit` | Response scale; pure stand at the stage's constants (`Climate` 0) | +| `coefficient_summary.csv` | run × region × stage × species × term | Gitignored. Term meaning varies by taxon and stage | +| `comparison_metrics.csv` | species × metric | Against exp_000; both sides' summaries, the difference, and whether this run did better. Gitignored | + +Metrics: `auc`, `deviance_explained`, `rmse`, `spearman`, +`calibration_slope`, `prevalence`, `n`. They score each run's final +model, so for plants `insample_auc` equals `v2val_Full`. "Better" is +higher AUC, deviance explained and Spearman, lower RMSE, and a +calibration slope closer to 1. + +## Data access + +Runs read the published dataset versions pinned in `data_source.R` +(`sdm_published$versions`), on `//ABMI-DATA2/science/sdmMethodsDev/0_data/`. +Set `SDM_TEST_DATASET` or `SDM_V2_RESULTS` to read another copy. Each +call checks file presence and size; `verify_published()` checks md5. diff --git a/1_code/harness/cache.R b/1_code/harness/cache.R new file mode 100644 index 0000000..55a303a --- /dev/null +++ b/1_code/harness/cache.R @@ -0,0 +1,72 @@ +# --- +# title: Session Cache for Dataset Reads +# author: Brendan Casey +# created: 2026-10-03 +# inputs: none +# outputs: none; holds read results in memory +# notes: +# - Keeps one copy per file per session of lookups that were +# re-read many times per run. Keyed on path, mtime, size and a +# read tag, so an edited file is re-read, not served stale. +# - Only file reads are cached, never fits or results, so the +# cache cannot change what a run computes. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +## 1.2 The cache ---- +if (!exists(".sdm_cache", inherits = FALSE)) { + .sdm_cache <- new.env(parent = emptyenv()) +} + +# 2. cached_read() ---- + +#' Read a File Once per Session +#' +#' @param path Character. The file to read. +#' @param reader A function of the path returning its contents. +#' @param tag Character. Distinguishes two different reads of the +#' same file, such as one column subset and another. +#' @return Whatever `reader` returns. +#' +#' @example # Example usage of the function +#' # map <- cached_read(path, function(p) as.data.frame(fread(p))) +cached_read <- function(path, reader, tag = "") { + info <- file.info(path) + + if (is.na(info$size)) { + return(reader(path)) + } + + key <- paste( + normalizePath(path, winslash = "/", mustWork = FALSE), + format(info$mtime, "%Y%m%d%H%M%OS3"), info$size, tag, + sep = "|" + ) + + if (!exists(key, envir = .sdm_cache, inherits = FALSE)) { + assign(key, reader(path), envir = .sdm_cache) + } + + get(key, envir = .sdm_cache, inherits = FALSE) +} + +# 3. clear_cache() ---- + +#' Empty the Session Cache +#' +#' @return The number of entries removed, invisibly. +#' +#' @example # Example usage of the function +#' # clear_cache() +clear_cache <- function() { + keys <- ls(.sdm_cache, all.names = TRUE) + rm(list = keys, envir = .sdm_cache) + + invisible(length(keys)) +} + +# End of script ---- diff --git a/1_code/harness/compare.R b/1_code/harness/compare.R new file mode 100644 index 0000000..625ef43 --- /dev/null +++ b/1_code/harness/compare.R @@ -0,0 +1,182 @@ +# --- +# title: Compare an Experiment Against a Baseline +# author: Brendan Casey +# created: 2026-10-03 +# inputs: +# in each experiment's out_dir/tables/: +# - metric_summary.csv (collect_results()) +# outputs: +# in the candidate's out_dir/tables/: +# - comparison_metrics.csv: one row per species and metric +# the per-taxon, region and metric summary is returned (and +# printed by run_experiment()) but not written +# notes: +# - Rows match on taxon, region, season, part, species and +# metric, not run name; differences are in medians over draws. +# - Defaults to out-of-bag metrics: in-sample metrics flatter +# flexible methods. +# - Warns when the two sides hold different draw counts. Judge +# noise from `share_better` and the p10-p90 bands. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # keyed joins (version: 1.16.4) + +# 2. better_direction() ---- + +#' Which Way Is Better for a Metric +#' +#' @param metric Character vector of metric names, with or +#' without an `insample_` or `oob_` prefix. +#' @return Character vector: "higher", "lower", "toward_one" or +#' "none" (prevalence, n: not a measure of fit). +#' +#' @example # Example usage of the function +#' # better_direction(c("oob_auc", "oob_rmse")) +better_direction <- function(metric) { + base <- sub("^(insample_|oob_)", "", metric) + + ifelse( + base %in% c("rmse"), "lower", + ifelse( + base %in% c("calibration_slope"), "toward_one", + ifelse(base %in% c("prevalence", "n"), "none", "higher") + ) + ) +} + +# 3. compare_experiments() ---- + +#' Compare an Experiment's Summaries Against a Baseline's +#' +#' @param candidate_dir Character. The experiment's out_dir. +#' @param baseline_dir Character. The baseline's out_dir, e.g. +#' 3_output/exp_000_parity_v2. +#' @param metrics Character vector of metrics to compare, or NULL +#' for the out-of-bag fit metrics. +#' @param write Logical. Write `metrics` to +#' `candidate_dir/tables/comparison_metrics.csv`. +#' @return A list of data frames: `metrics` (per species) and +#' `summary` (per taxon, region and metric). +#' +#' @example # Example usage of the function +#' # compare_experiments("3_output/exp_001_brt", +#' # "3_output/exp_000_parity_v2") +compare_experiments <- function( + candidate_dir, + baseline_dir, + metrics = NULL, + write = TRUE +) { + read_summary <- function(dir, name) { + path <- file.path(dir, "tables", paste0(name, ".csv")) + + if (!file.exists(path)) { + return(NULL) + } + + rows <- fread(path, na.strings = "") + # Season and part are empty for most taxa; a join needs them + # equal, not missing + for (column in c("season", "part")) { + if (column %in% names(rows)) { + rows[[column]] <- ifelse( + is.na(rows[[column]]), "", as.character(rows[[column]]) + ) + } + } + rows + } + + keys <- c("taxon", "region", "season", "part", "species") + values <- c("n", "median", "p10", "p90") + + # Step 1: Model fit, per species and metric + metrics <- metrics %||% c( + "oob_auc", "oob_deviance_explained", "oob_rmse", + "oob_spearman", "oob_calibration_slope" + ) + + candidate <- read_summary(candidate_dir, "metric_summary") + baseline <- read_summary(baseline_dir, "metric_summary") + + if (is.null(candidate) || is.null(baseline)) { + stop( + "Both experiments need tables/metric_summary.csv; run their ", + "collect step first.", + call. = FALSE + ) + } + + # The mean and sd ride along where both experiments have them; + # a baseline summarized before they were added lacks them + values <- c(values, intersect( + c("mean", "sd"), intersect(names(candidate), names(baseline)) + )) + + pick <- function(rows) { + rows[metric %in% metrics, c(keys, "metric", values), with = FALSE] + } + + joined <- merge( + pick(baseline), pick(candidate), + by = c(keys, "metric"), suffixes = c("_baseline", "_candidate") + ) + + joined[, difference := median_candidate - median_baseline] + joined[, direction := better_direction(metric)] + joined[, better := data.table::fcase( + direction == "higher", median_candidate > median_baseline, + direction == "lower", median_candidate < median_baseline, + direction == "toward_one", + abs(median_candidate - 1) < abs(median_baseline - 1), + default = NA + )] + + # Step 2: Per taxon, region and metric + summary <- joined[, list( + species = .N, + draws_baseline = stats::median(n_baseline, na.rm = TRUE), + draws_candidate = stats::median(n_candidate, na.rm = TRUE), + median_baseline = stats::median(median_baseline, na.rm = TRUE), + median_candidate = stats::median(median_candidate, na.rm = TRUE), + median_difference = stats::median(difference, na.rm = TRUE), + share_better = mean(better, na.rm = TRUE) + ), by = c("taxon", "region", "season", "part", "metric")] + + # A band from 5 draws is not comparable with one from 100, so a + # mismatch is said out loud rather than left in a column + mismatched <- summary[draws_baseline != draws_candidate] + + if (nrow(mismatched) > 0) { + warning( + "The two experiments hold different numbers of draws (", + paste(unique(mismatched$draws_baseline), collapse = ", "), + " in the baseline, ", + paste(unique(mismatched$draws_candidate), collapse = ", "), + " here). Compare like with like before reading the result.", + call. = FALSE + ) + } + + out <- list( + metrics = as.data.frame(joined), + summary = as.data.frame(summary) + ) + + if (write) { + tables_dir <- file.path(candidate_dir, "tables") + dir.create(tables_dir, recursive = TRUE, showWarnings = FALSE) + fwrite( + out$metrics, + file.path(tables_dir, "comparison_metrics.csv"), + na = "" + ) + } + + out +} + +# End of script ---- diff --git a/1_code/harness/covar_attach.R b/1_code/harness/covar_attach.R deleted file mode 100644 index 975c60a..0000000 --- a/1_code/harness/covar_attach.R +++ /dev/null @@ -1,46 +0,0 @@ -# --- -# title: Attach Covariates to Records -# author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none -# notes: -# - Placeholder. 0_data/covariates/catalogue_v1.csv holds -# metadata and server paths only; the rasters live on the -# ABMI server. -# - The catalogue is extensible - a new catalogue version can -# add covariates without invalidating the test dataset. -# --- - -# 1. attach_covariates() ---- - -#' Attach Covariates to Records -#' -#' Attaches covariates from the versioned catalogue to records. -#' -#' @param data Data frame of response records with -#' coordinates. -#' @param catalogue Character. Catalogue version, e.g. -#' "catalogue_v1". -#' @param covariates Character vector of covariate names to -#' attach, or NULL for every covariate in the catalogue. -#' @return `data` with one column per attached covariate. -#' -#' @example -#' # Example usage of the function -#' # attach_covariates() -attach_covariates <- function( - data, - catalogue = "catalogue_v1", - covariates = NULL -) { - # Step 1: Read the catalogue and resolve the layer paths - # Step 2: Extract at the record coordinates and bind - - stop( - "attach_covariates() is not implemented yet.", - call. = FALSE - ) -} - -# End of script ---- diff --git a/1_code/harness/covariate_sets.R b/1_code/harness/covariate_sets.R new file mode 100644 index 0000000..a933b2b --- /dev/null +++ b/1_code/harness/covariate_sets.R @@ -0,0 +1,577 @@ +# --- +# title: Name and Resolve Covariate Sets +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# in the test dataset's lookup/ (see data_source.R): +# - covariate_columns.csv +# outputs: none; returns objects in memory +# notes: +# - Resolves named, cross-taxa covariate sets to the master +# columns each taxon has (via covariate_columns.csv), failing +# loudly where a taxon lacks one. Sets may name other sets. +# - Needs covariate_key() from data_load.R. +# - The topography and remote_sensing sets are not in the frozen +# dataset and resolve to nothing; they are listed so the gap +# is visible. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup table reading (version: 1.16.4) + +# 2. Covariate set definitions ---- + +## 2.1 covariate_sets() ---- + +#' Named Covariate Bundles +#' +#' Entries hold master column names, other set names, or +#' `block:`, which means whatever that block holds for the +#' taxon being resolved. +#' +#' @return A named list of character vectors. +#' +#' @example # Example usage of the function +#' # names(covariate_sets()) +#' # covariate_sets()$climate_v2 +covariate_sets <- function() { + list( + # Whole blocks, as parity runs use + climate_all = "block:climate", + veg_all = "block:veg", + soil_all = "block:soil", + design_all = "block:design", + + # The climate terms v2 plant model sets draw on (the block + # also holds derived and design columns). Fails on birds; use + # climate_common across taxa. + climate_v2 = c( + "MAT", "MAP", "MWMT", "MCMT", "TD", "MSP", "AHM", "SHM", + "PET", "CMD", "FFP", "EMT", "EXT", "MTD", "PS" + ), + + # Climate columns every taxon has (birds lack MAT and PET). + # Re-derive with common_covariates() after a dataset change. + climate_common = c("MAP", "FFP", "TD", "CMD", "EMT"), + + # The wider set birds and the plant groups share, for an + # experiment that leaves mammals out. + climate_common_plants_birds = c( + "MAP", "TD", "CMD", "FFP", "EMT" + ), + + topography = c("elevation", "slope", "aspect", "TRI", "TPI"), + + remote_sensing = c( + "canopy_height", "canopy_cover", "ndvi", "lai" + ), + + climate_v2_topography = c("climate_v2", "topography"), + climate_v2_remote = c("climate_v2", "remote_sensing") + ) +} + +# 3. derived_covariates() ---- + +## 3.1 derived_covariates() ---- + +#' Covariates Computed from Other Stored Columns +#' +#' Only exact definitions belong here; each entry's `note` says +#' how it was verified. A quantity that merely correlates with a +#' formula does not (see CMD below). +#' +#' @return A named list, each entry with `inputs`, `fn` and +#' `note`. +#' +#' @example # Example usage of the function +#' # names(derived_covariates()) +#' # derived_covariates()$TD$note +derived_covariates <- function() { + list( + TD = list( + inputs = c("MWMT", "MCMT"), + fn = function(d) d$MWMT - d$MCMT, + note = paste( + "MWMT - MCMT. Verified against vascular_plant to 0.1 C,", + "the storage precision of the climate normals." + ) + ) + + # CMD is deliberately absent: "PET - MAP, >= 0" (the mammal + # script's gloss) is off by up to 195 mm against + # vascular_plant, because CMD is a monthly sum. + , + + # Products are not stored: a stored square would not equal + # the square of the stored column at CSV precision. The plant + # climate set fits all four. + MAPPET = list( + inputs = c("MAP", "PET"), + fn = function(d) d$MAP * d$PET, + note = "MAP * PET. Exact against the v2 source." + ), + MAT2 = list( + inputs = "MAT", + fn = function(d) d$MAT * d$MAT, + note = "MAT squared. Exact against the v2 source." + ), + CMDMAT = list( + inputs = c("CMD", "MAT"), + fn = function(d) d$CMD * d$MAT, + note = "CMD * MAT. Exact against the v2 source." + ), + MWMT2 = list( + inputs = "MWMT", + fn = function(d) d$MWMT * d$MWMT, + note = "MWMT squared. Exact against the v2 source." + ), + + # Spatial trend terms, named as the v2 model sets name them, + # so they come from the covariate table without a join + Easting = list( + inputs = "UTMX", + fn = function(d) d$UTMX, + note = "UTMX. Identical in the v2 source." + ), + Northing = list( + inputs = "UTMY", + fn = function(d) d$UTMY, + note = "UTMY. Identical in the v2 source." + ), + Easting2 = list( + inputs = "UTMX", + fn = function(d) d$UTMX * d$UTMX, + note = "UTMX squared. Exact against the v2 source." + ), + Northing2 = list( + inputs = "UTMY", + fn = function(d) d$UTMY * d$UTMY, + note = "UTMY squared. Exact against the v2 source." + ), + EastingNorthing = list( + inputs = c("UTMX", "UTMY"), + fn = function(d) d$UTMY * d$UTMX, + note = "UTMY * UTMX. Exact against the v2 source." + ) + ) +} + +## 3.2 derivable_covariates() ---- + +#' Which Requested Covariates Can Be Derived Here +#' +#' @param requested Character vector of master column names. +#' @param available Character vector of columns the taxon has. +#' @param derived Named list from derived_covariates(). +#' @return A character vector of the requested columns that are +#' absent but derivable from columns that are present. +#' +#' @example # Example usage of the function +#' # derivable_covariates("TD", c("MWMT", "MCMT")) +derivable_covariates <- function( + requested, + available, + derived = derived_covariates() +) { + missing_columns <- setdiff(requested, available) + candidates <- intersect(missing_columns, names(derived)) + + candidates[vapply( + candidates, + function(one) all(derived[[one]]$inputs %in% available), + logical(1) + )] +} + +## 3.3 apply_derivations() ---- + +#' Compute Derived Covariates onto a Loaded Frame +#' +#' @param frame A data frame carrying the input columns. +#' @param columns Character vector of derived columns to add. +#' @param derived Named list from derived_covariates(). +#' @return The frame with the derived columns added. +#' +#' @example # Example usage of the function +#' # apply_derivations(frame, "TD") +apply_derivations <- function( + frame, + columns, + derived = derived_covariates() +) { + for (one in columns) { + definition <- derived[[one]] + + absent <- setdiff(definition$inputs, names(frame)) + + if (length(absent) > 0) { + stop( + "Cannot derive `", one, "`: missing ", + paste(absent, collapse = ", "), ".", + call. = FALSE + ) + } + + frame[[one]] <- definition$fn(frame) + } + + frame +} + +# 4. covariate_catalogue() ---- + +#' Read the Covariate Column Catalogue +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Keep only this taxon's rows, or NULL +#' for all of them. +#' @return A data frame of taxon, block, source_column and +#' master_column. +#' +#' @example # Example usage of the function +#' # cat <- covariate_catalogue(data_dir, taxon = "bryophyte") +#' # unique(cat$block) +covariate_catalogue <- function(data_dir, taxon = NULL) { + path <- file.path( + data_dir, "lookup", "covariate_columns.csv" + ) + + if (!file.exists(path)) { + stop( + "Covariate catalogue not found:\n ", path, + "\nRun 1_code/_setup/01_harmonize_model_ready_v2.R first.", + call. = FALSE + ) + } + + catalogue <- cached_read(path, function(p) as.data.frame(fread(p))) + + if (!is.null(taxon)) { + # A taxon split by region has keys like `_` + keys <- unique(catalogue$taxon) + matching <- keys[ + keys == taxon | startsWith(keys, paste0(taxon, "_")) + ] + + if (length(matching) == 0) { + stop( + "No covariate catalogue entries for taxon `", taxon, + "`. Taxa present: ", paste(keys, collapse = ", "), + call. = FALSE + ) + } + + catalogue <- catalogue[catalogue$taxon %in% matching, ] + } + + rownames(catalogue) <- NULL + + catalogue +} + +# 5. available_covariates() ---- + +#' List the Covariates One Taxon and Region Have +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character. Region name, or NULL. +#' @param block Character. Restrict to one block, or NULL. +#' @param include_derived Logical. Also count covariates +#' derivable from stored ones (see derived_covariates()). +#' @return A character vector of master column names. +#' +#' @example # Example usage of the function +#' # available_covariates(data_dir, "mammal", "north", "veg") +available_covariates <- function( + data_dir, + taxon, + region = NULL, + block = NULL, + include_derived = TRUE +) { + key <- covariate_key(taxon, region, data_dir) + catalogue <- covariate_catalogue(data_dir) + rows <- catalogue[catalogue$taxon == key, ] + + if (nrow(rows) == 0) { + stop( + "No covariate catalogue entries for key `", key, "`.", + call. = FALSE + ) + } + + if (!is.null(block)) { + rows <- rows[rows$block %in% block, ] + } + + stored <- unique(rows$master_column) + + if (!include_derived) { + return(stored) + } + + # e.g. mammals reach TD without it being stored + derived <- derived_covariates() + reachable <- names(derived)[vapply( + names(derived), + function(one) all(derived[[one]]$inputs %in% stored), + logical(1) + )] + + unique(c(stored, reachable)) +} + +# 6. common_covariates() ---- + +#' Find the Covariates Several Taxa Share +#' +#' Cross-taxa comparisons must use only shared covariates, or +#' each taxon fits a different model. +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxa Character vector of taxon slugs. +#' @param block Character. Restrict to one block, or NULL. +#' @return A character vector of master column names present for +#' every taxon given, across all of their regions. +#' +#' @example # Example usage of the function +#' # common_covariates(data_dir, c("bryophyte", "bird"), +#' # block = "climate") +common_covariates <- function(data_dir, taxa, block = NULL) { + catalogue <- covariate_catalogue(data_dir) + + per_taxon <- lapply(taxa, function(one) { + keys <- unique(catalogue$taxon) + matching <- keys[ + keys == one | startsWith(keys, paste0(one, "_")) + ] + + if (length(matching) == 0) { + stop( + "No covariate catalogue entries for taxon `", one, "`.", + call. = FALSE + ) + } + + rows <- catalogue[catalogue$taxon %in% matching, ] + + if (!is.null(block)) { + rows <- rows[rows$block %in% block, ] + } + + # A split taxon must have the column in every region + per_key <- split(rows$master_column, rows$taxon) + + Reduce(intersect, lapply(per_key, unique)) + }) + + Reduce(intersect, per_taxon) +} + +# 7. term_map() ---- + +#' Map v2 Term Names onto Harmonized Column Names +#' +#' The harmonizer suffixed columns found in more than one block +#' with their block, because same-named columns hold different +#' values (e.g. `HardLin` in the veg and soil blocks). 84 plant +#' and 6 bird columns are affected. Unmapped, a v2 formula would +#' read another taxon's column as NA and silently lose terms. +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character. Region name, or NULL. +#' @param block Character. Restrict to one block, or NULL for +#' every block the taxon has. +#' @return A named character vector, source name to master name, +#' holding only the names that differ. +#' +#' @example # Example usage of the function +#' # term_map(data_dir, "lichen", block = "veg")[["HardLin"]] +term_map <- function( + data_dir, + taxon, + region = NULL, + block = NULL +) { + key <- covariate_key(taxon, region, data_dir) + catalogue <- covariate_catalogue(data_dir) + rows <- catalogue[catalogue$taxon == key, ] + + if (!is.null(block)) { + rows <- rows[rows$block %in% block, ] + } + + rows <- rows[rows$source_column != rows$master_column, ] + + if (nrow(rows) == 0) { + return(stats::setNames(character(0), character(0))) + } + + stats::setNames(rows$master_column, rows$source_column) +} + +# 8. apply_term_map() ---- + +#' Rewrite Source Names to Master Names +#' +#' Applied to formula text and prediction grid column names, so +#' v2 sets and grids keep their original names. +#' +#' @param x Character vector of formula text, or of column names. +#' @param map A named vector from term_map(). +#' @return `x`, with whole-word matches replaced. +#' +#' @example # Example usage of the function +#' # apply_term_map(". ~ . + HardLin", map) +apply_term_map <- function(x, map) { + if (length(map) == 0 || length(x) == 0) { + return(x) + } + + # Staged model sets are lists of groups + if (is.list(x)) { + return(lapply(x, apply_term_map, map = map)) + } + + # Longest names first, so `SurrHardLin` is not half-rewritten + # by the rule for `HardLin` + order_by_length <- order(nchar(names(map)), decreasing = TRUE) + + for (i in order_by_length) { + x <- gsub( + paste0("\\b", names(map)[i], "\\b"), map[[i]], x + ) + } + + x +} + +# 9. resolve_covariates() ---- + +#' Resolve Covariate Set Names to Master Columns +#' +#' An unavailable covariate is an error by default: dropping it +#' silently would misreport what an experiment tested. +#' +#' @param requested Character vector of set names, `block:` +#' references, or master column names. +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character. Region name, or NULL. +#' @param sets Named list of covariate sets. +#' @param strict Logical. FALSE drops unavailable covariates with +#' a warning, so each taxon fits a different set; never use it +#' for cross-taxa comparisons. +#' @param max_depth Integer. How far a set may reference another +#' set before the nesting is treated as circular. +#' @return A character vector of master column names, in the +#' order requested, without duplicates. +#' +#' @example # Example usage of the function +#' # resolve_covariates("climate_v2", data_dir, "bryophyte") +#' # resolve_covariates(c("block:veg", "MAT"), data_dir, "mite") +resolve_covariates <- function( + requested, + data_dir, + taxon, + region = NULL, + sets = covariate_sets(), + strict = TRUE, + max_depth = 10L +) { + available <- available_covariates(data_dir, taxon, region) + + # Step 1: Expand sets and blocks to columns. Depth-limited, so + # a self-referencing set fails rather than hanging. + expand <- function(names_in, depth) { + if (depth > max_depth) { + stop( + "Covariate sets nest more than ", max_depth, + " deep; is a set referencing itself?", + call. = FALSE + ) + } + + out <- character(0) + + for (one in names_in) { + if (startsWith(one, "block:")) { + block <- sub("^block:", "", one) + out <- c( + out, + available_covariates(data_dir, taxon, region, block) + ) + } else if (one %in% names(sets)) { + out <- c(out, expand(sets[[one]], depth + 1L)) + } else { + out <- c(out, one) + } + } + + out + } + + columns <- unique(expand(requested, 1L)) + + # Step 2: Report what this taxon lacks. Empty sets are named + # separately: they usually mean missing data, not a typo. + missing_columns <- setdiff(columns, available) + + if (length(missing_columns) > 0 && !strict) { + warning( + "Dropping ", length(missing_columns), " covariate(s) not ", + "available for ", taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ": ", paste(utils::head(missing_columns, 5), collapse = ", "), + call. = FALSE + ) + + return(intersect(columns, available)) + } + + if (length(missing_columns) > 0) { + empty_sets <- requested[ + requested %in% names(sets) & + vapply( + requested, + function(one) { + if (!one %in% names(sets)) { + return(FALSE) + } + length( + intersect(expand(sets[[one]], 1L), available) + ) == 0 + }, + logical(1) + ) + ] + + stop( + length(missing_columns), " covariate(s) not available for ", + taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ":\n ", + paste(utils::head(missing_columns, 10), collapse = "\n "), + if (length(empty_sets) > 0) { + paste0( + "\nThe set(s) ", paste(empty_sets, collapse = ", "), + " resolve to nothing for this taxon. If these are new", + "\ncovariates, add them to covariates.csv through a", + "\n1_code/_setup/ script first." + ) + } else { + "" + }, + call. = FALSE + ) + } + + columns +} + +# End of script ---- diff --git a/1_code/harness/data_load.R b/1_code/harness/data_load.R index b294470..80762a8 100644 --- a/1_code/harness/data_load.R +++ b/1_code/harness/data_load.R @@ -1,39 +1,949 @@ # --- -# title: Load the Frozen Test Dataset +# title: Load the Harmonized Test Dataset # author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none +# created: 2026-09-09 +# inputs: +# in the test dataset (see harness/data_source.R): +# - sites.csv +# - covariates.csv +# - each taxon's response and offset files, as named in +# lookup/dataset_manifest.csv +# - lookup/factor_levels.csv +# outputs: none; returns objects in memory # notes: -# - Placeholder. The frozen test dataset is not yet -# assembled, so this stops rather than returning -# a partial answer. -# - 0_data/manifest.md is the source of truth for the -# dataset version and paths. +# - Taxon-agnostic: file locations and covariate keys come from +# lookup/dataset_manifest.csv (_setup/09). The key is +# `_` for mammals, whose north and south files +# hold different values for the same deployment. +# - Reads are column-selective (covariates.csv is ~218 MB, 457 +# columns). build_model_data() loads once per taxon and +# region; model_frame() cuts per-species frames from it. +# - Derivable covariates are computed on load (needs +# covariate_sets.R); an experiment's covariate_files are +# joined on load, so 0_data/ is never changed. +# - TODO: a Parquet or duckdb store would allow row selection. # --- -# 1. load_test_data() ---- +# 1. Setup ---- -#' Load the Frozen Test Dataset +## 1.1 Load packages ---- +library(data.table) # column-selective CSV reading (version: 1.16.4) + +# 2. The dataset manifest ---- + +## 2.1 dataset_manifest() ---- + +#' Read Where Each Taxon's Files Are +#' +#' One row per taxon and region. +#' +#' @param data_dir Character. The test dataset folder. +#' @return A data frame. +#' +#' @example # Example usage of the function +#' # dataset_manifest(data_dir) +dataset_manifest <- function(data_dir) { + path <- file.path(data_dir, "lookup", "dataset_manifest.csv") + + if (!file.exists(path)) { + stop( + "Dataset manifest not found: + ", path, + " +Run 1_code/_setup/09_harmonize_lookups.R first.", + call. = FALSE + ) + } + + cached_read(path, function(p) { + as.data.frame(fread(p, na.strings = "", colClasses = "character")) + }) +} + +## 2.2 manifest_entry() ---- + +#' One Taxon's Manifest Row +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character, or NULL for the taxon's first region, +#' which is enough for anything that does not vary by region. +#' @return A one-row data frame. +#' +#' @example # Example usage of the function +#' # manifest_entry(data_dir, "mammal", "north")$covariate_key +manifest_entry <- function(data_dir, taxon, region = NULL) { + manifest <- dataset_manifest(data_dir) + rows <- manifest[manifest$taxon == taxon, ] + + if (nrow(rows) == 0) { + stop( + "Taxon `", taxon, "` is not in the dataset manifest. Taxa: ", + paste(unique(manifest$taxon), collapse = ", "), + call. = FALSE + ) + } + + if (!is.null(region)) { + rows <- rows[rows$region == region, ] + + if (nrow(rows) == 0) { + stop( + "The manifest has no region `", region, "` for ", taxon, + ".", call. = FALSE + ) + } + } + + rows[1, , drop = FALSE] +} + +## 2.3 covariate_key() ---- + +#' Name a Taxon's Key in covariates.csv +#' +#' @param taxon Character. Taxon slug. +#' @param region Character, or NULL when the taxon's covariates +#' are not stored per region. +#' @param data_dir Character. The test dataset folder. +#' @return Character. The value to match in the `taxon` column of +#' covariates.csv. +#' +#' @example # Example usage of the function +#' # covariate_key("mammal", "north", data_dir) # "mammal_north" +#' # covariate_key("bryophyte", NULL, data_dir) # "bryophyte" +covariate_key <- function(taxon, region = NULL, data_dir) { + if (is.null(region)) { + return(taxon) + } + + manifest_entry(data_dir, taxon, region)$covariate_key +} + +# 3. load_sites() ---- + +#' Load the Survey Unit Table +#' +#' One row per survey unit across every design, with an +#' `in_` coverage flag per taxon. +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Keep only units that taxon covers, or +#' NULL for every unit. +#' @param columns Character vector of columns to read, or NULL +#' for all of them. +#' @return A data frame, one row per survey unit. +#' +#' @example # Example usage of the function +#' # sites <- load_sites(test_dataset_dir(), taxon = "bird") +#' # nrow(sites) +load_sites <- function(data_dir, taxon = NULL, columns = NULL) { + path <- file.path(data_dir, "sites.csv") + check_dataset_file(path) + + # Step 1: Read the coverage flag even if not requested + flag <- if (is.null(taxon)) NULL else paste0("in_", taxon) + + if (!is.null(columns)) { + columns <- unique(c("survey_unit_id", columns, flag)) + sites <- as.data.frame(fread(path, select = columns)) + } else { + sites <- as.data.frame(fread(path)) + } + + # Step 2: Narrow to the units the taxon covers + if (!is.null(flag)) { + if (!flag %in% names(sites)) { + stop( + "sites.csv has no coverage flag `", flag, "`. Taxa in ", + "this dataset: ", + paste( + sub("^in_", "", grep("^in_", names(sites), value = TRUE)), + collapse = ", " + ), + call. = FALSE + ) + } + + sites <- sites[!is.na(sites[[flag]]) & sites[[flag]], ] + } + + rownames(sites) <- NULL + + sites +} + +# 4. load_response() ---- + +#' Load One Taxon's Response Table +#' +#' Values are as recorded (plant detections, mammal densities, +#' bird counts); model_frame() applies the spec's transform. +#' +#' @param taxon Character. Taxon slug. +#' @param data_dir Character. The test dataset folder. +#' @param species Character vector of species columns to read, or +#' NULL for all of them. +#' @return A data frame of survey_unit_id and species columns. +#' +#' @example # Example usage of the function +#' # y <- load_response("bryophyte", data_dir, +#' # species = "Aulacomnium.palustre") +load_response <- function(taxon, data_dir, species = NULL) { + path <- file.path( + data_dir, manifest_entry(data_dir, taxon)$response_file + ) + check_dataset_file(path) + + if (is.null(species)) { + return(as.data.frame(fread(path))) + } + + # Step 1: Fail on an unknown species + available <- names(fread(path, nrows = 0)) + unknown <- setdiff(species, available) + + if (length(unknown) > 0) { + stop( + length(unknown), " species not in ", basename(path), ":\n ", + paste(utils::head(unknown, 10), collapse = "\n "), + call. = FALSE + ) + } + + as.data.frame( + fread(path, select = unique(c("survey_unit_id", species))) + ) +} + +# 5. load_offsets() ---- + +#' Load One Taxon's Offsets +#' +#' Only birds have offsets (QPAD log-offsets per unit and +#' species). Other taxa return NULL, not zeros: a zero offset is +#' a modelling choice. +#' +#' @param taxon Character. Taxon slug. +#' @param data_dir Character. The test dataset folder. +#' @param species Character vector of species columns to read, or +#' NULL for all of them. +#' @return A data frame of survey_unit_id and species columns, or +#' NULL when the taxon has no offsets file. +#' +#' @example # Example usage of the function +#' # off <- load_offsets("bird", data_dir, species = "ALFL") +load_offsets <- function(taxon, data_dir, species = NULL) { + offset_file <- manifest_entry(data_dir, taxon)$offset_file + + if (is.na(offset_file)) { + return(NULL) + } + + path <- file.path(data_dir, offset_file) + check_dataset_file(path) + + if (is.null(species)) { + return(as.data.frame(fread(path))) + } + + available <- names(fread(path, nrows = 0)) + present <- intersect(species, available) + + if (length(present) == 0) { + return(NULL) + } + + as.data.frame( + fread(path, select = unique(c("survey_unit_id", present))) + ) +} + +# 6. load_covariates() ---- + +#' Load Covariates for One Taxon and Region +#' +#' +#' @param taxon Character. Taxon slug. +#' @param data_dir Character. The test dataset folder. +#' @param columns Character vector of master column names. +#' @param region Character. Region name, or NULL when the taxon's +#' covariates are not stored per region. +#' @return A data frame of survey_unit_id and the requested +#' columns. +#' +#' @example # Example usage of the function +#' # x <- load_covariates("mammal", data_dir, +#' # columns = c("MAT", "MAP"), +#' # region = "north") +load_covariates <- function( + taxon, + data_dir, + columns, + region = NULL +) { + path <- file.path(data_dir, "covariates.csv") + check_dataset_file(path) + + key <- covariate_key(taxon, region, data_dir) + + # Step 1: Check the taxon's catalogue, not the file header: the + # wide table holds other taxa's columns, which read back as all + # NA here. + stored <- available_covariates( + taxon, data_dir = data_dir, region = region, + include_derived = FALSE + ) + + derivable <- derivable_covariates(columns, stored) + to_read <- setdiff(columns, derivable) + + for (one in derivable) { + to_read <- unique(c(to_read, derived_covariates()[[one]]$inputs)) + } + + unknown <- setdiff(to_read, stored) + + if (length(unknown) > 0) { + stop( + length(unknown), " covariate(s) not available for ", taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ":\n ", + paste(utils::head(unknown, 10), collapse = "\n "), + "\nThey may exist for another taxon; covariates.csv is one", + "\nwide table, so this taxon's rows would be all NA.", + call. = FALSE + ) + } + + # Step 2: Read only columns not already cached for this key; + # stages request overlapping column sets. + info <- file.info(path) + cache_key <- paste( + "covariates", normalizePath(path, winslash = "/"), + format(info$mtime, "%Y%m%d%H%M%OS3"), info$size, key, + sep = "|" + ) + held <- if (exists(cache_key, envir = .sdm_cache)) { + get(cache_key, envir = .sdm_cache) + } else { + NULL + } + to_load <- setdiff(to_read, names(held)) + + if (is.null(held) || length(to_load) > 0) { + fresh <- fread( + path, select = unique(c("survey_unit_id", "taxon", to_load)) + ) + + fresh <- fresh[fresh$taxon == key, ] + + if (nrow(fresh) == 0) { + keys <- unique(fread(path, select = "taxon")$taxon) + stop( + "No covariate rows for key `", key, "`. Keys present: ", + paste(keys, collapse = ", "), + call. = FALSE + ) + } + + fresh[, taxon := NULL] + fresh <- as.data.frame(fresh) + + held <- if (is.null(held)) { + fresh + } else { + # Rows always come back in file order, so columns line up + cbind(held, fresh[, to_load, drop = FALSE]) + } + + assign(cache_key, held, envir = .sdm_cache) + } + + covariates <- held[, unique(c("survey_unit_id", to_read)), + drop = FALSE] + + # Step 3: Derive, then return exactly the requested columns + if (length(derivable) > 0) { + covariates <- apply_derivations(covariates, derivable) + } + + covariates[, unique(c("survey_unit_id", columns)), drop = FALSE] +} + +## 6.1 check_covariate_files() ---- + +#' Check the Covariate Files an Experiment Adds +#' +#' Each file must have a unique survey_unit_id key and only +#' columns no other source has. +#' +#' @param files Character vector of CSV paths. +#' @param data_dir Character. The test dataset folder. +#' @return `files`, invisibly; stops on the first problem. +#' +#' @example # Example usage of the function +#' # check_covariate_files("2_pipeline/exp_002/inputs/soil.csv", +#' # data_dir) +check_covariate_files <- function(files, data_dir) { + taken <- names(fread(file.path(data_dir, "covariates.csv"), + nrows = 0)) + + for (path in files) { + if (!file.exists(path)) { + stop( + "Covariate file not found: ", path, "\nRun the ", + "experiment's script that writes it first.", + call. = FALSE + ) + } + + header <- names(fread(path, nrows = 0)) + + if (!"survey_unit_id" %in% header) { + stop("Covariate file ", basename(path), " has no ", + "survey_unit_id column.", call. = FALSE) + } + + ids <- fread(path, select = "survey_unit_id", + colClasses = "character")$survey_unit_id + + if (anyDuplicated(ids) > 0) { + stop("Covariate file ", basename(path), " repeats a ", + "survey_unit_id; it needs one row per unit.", + call. = FALSE) + } + + added <- setdiff(header, "survey_unit_id") + clash <- intersect(added, taken) + + if (length(clash) > 0) { + stop( + "Covariate file ", basename(path), " repeats column(s) ", + "already in covariates.csv or another file: ", + paste(utils::head(clash, 10), collapse = ", "), + ". Give them new names.", + call. = FALSE + ) + } + + taken <- c(taken, added) + } + + invisible(files) +} + +## 6.2 covariate_file_columns() ---- + +#' The Columns a Set of Covariate Files Holds +#' +#' @param files Character vector of CSV paths, or NULL. +#' @return A character vector of column names, without +#' survey_unit_id. +#' +#' @example # Example usage of the function +#' # covariate_file_columns("2_pipeline/exp_002/inputs/soil.csv") +covariate_file_columns <- function(files) { + unique(unlist(lapply(files, function(path) { + setdiff(names(fread(path, nrows = 0)), "survey_unit_id") + }))) +} + +## 6.3 add_covariate_files() ---- + +#' Join Covariates from an Experiment's Own Files +#' +#' Units a file does not list get NA and drop out of models that +#' use the column. +#' +#' @param x A data frame with survey_unit_id, from +#' load_covariates(). +#' @param files Character vector of CSV paths, or NULL. +#' @param columns Character vector of the columns to add. +#' @return `x` with the columns added. +#' +#' @example # Example usage of the function +#' # add_covariate_files(x, "2_pipeline/exp_002/inputs/soil.csv", +#' # "sg_clay_0_5cm") +add_covariate_files <- function(x, files, columns) { + for (path in files) { + table <- cached_read(path, function(p) { + as.data.frame(fread( + p, colClasses = list(character = "survey_unit_id") + )) + }, tag = "covariate_file") + + wanted <- setdiff( + intersect(columns, names(table)), + c("survey_unit_id", names(x)) + ) + + if (length(wanted) == 0) { + next + } + + rows <- match(as.character(x$survey_unit_id), + table$survey_unit_id) + x[wanted] <- table[rows, wanted, drop = FALSE] + } + + x +} + +# 7. apply_factor_levels() ---- + +#' Restore Stored Factor Levels +#' +#' CSV reads categoricals back as character, and alphabetical +#' factoring would change the reference level and every contrast. +#' Restores the source order from lookup/factor_levels.csv. An +#' unknown level is an error: the lookup is stale. +#' +#' @param frame A data frame. +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @return The frame, with the recorded columns as factors. +#' +#' @example # Example usage of the function +#' # apply_factor_levels(frame, data_dir, "bird") +apply_factor_levels <- function(frame, data_dir, taxon) { + path <- file.path(data_dir, "lookup", "factor_levels.csv") + check_dataset_file(path) + + levels_table <- cached_read( + path, function(p) as.data.frame(fread(p)) + ) + levels_table <- levels_table[levels_table$taxon == taxon, ] + + if (nrow(levels_table) == 0) { + return(frame) + } + + # Also match block-suffixed columns (e.g. bird `method` as + # method_veg, method_soil) via covariate_columns.csv + map_path <- file.path(data_dir, "lookup", "covariate_columns.csv") + column_map <- if (file.exists(map_path)) { + map <- covariate_catalogue(data_dir) + map[map$taxon == taxon, c("source_column", "master_column")] + } else { + data.frame(source_column = character(0), + master_column = character(0)) + } + + targets_of <- function(column) { + masters <- column_map$master_column[ + column_map$source_column == column + ] + intersect(unique(c(column, masters)), names(frame)) + } + + for (source_column in unique(levels_table$column)) { + rows <- levels_table[levels_table$column == source_column, ] + ordered_levels <- rows$level[order(rows$level_order)] + + for (column in targets_of(source_column)) { + frame[[column]] <- restore_factor( + frame[[column]], ordered_levels, taxon, column + ) + } + } + + frame +} + +## 7.1 restore_factor() ---- + +#' Factor One Column to a Stored Level Order +#' +#' @param x A vector as read from CSV. +#' @param ordered_levels Character vector of levels, reference +#' first. +#' @param taxon,column Character. Named in any error. +#' @return A factor. +#' +#' @example # Example usage of the function +#' # restore_factor(c("PC", "eBird"), c("PC", "eBird"), "bird", "m") +restore_factor <- function(x, ordered_levels, taxon, column) { + values <- as.character(x) + + # Tables are written with `na = ""`, so a missing value reads + # back as "" and would fail the level guard (e.g. blank `soilc` + # in 194 southern bird surveys). Restoring NA matches v2, where + # glm drops those rows. + values[!nzchar(trimws(values))] <- NA_character_ + + unknown <- setdiff(stats::na.omit(unique(values)), ordered_levels) + + if (length(unknown) > 0) { + stop( + taxon, ": `", column, "` holds ", length(unknown), + " level(s) the factor lookup does not list: +", + paste(utils::head(unknown, 10), collapse = " +"), + " +The lookup is stale; admitting them would change the", + " +reference level and every contrast.", + call. = FALSE + ) + } + + factor(values, levels = ordered_levels) +} + +# 8. build_model_data() ---- + +#' Assemble Everything One Taxon and Region Needs +#' +#' Loaded once per taxon and region, aligned on survey_unit_id; +#' re-reading per species would cost more than fitting. +#' +#' @param taxon Character. Taxon slug. +#' @param data_dir Character. The test dataset folder. +#' @param species Character vector of species to model. +#' @param covariates Character vector of master column names. +#' @param region Character. Region name, or NULL. +#' @param region_filter A one-sided formula evaluated against the +#' assembled frame, or NULL. Rows where it is not TRUE are +#' dropped (e.g. ~ nr != "Grassland"). +#' @param weight_column Character. A covariate to use as model +#' weights; loaded automatically. +#' @param aliases Named list, alias to source column. Lets a +#' model set name a column the dataset stores otherwise. +#' @param site_columns Character vector of sites.csv columns to +#' carry, beyond survey_unit_id, or NULL for site_columns(). +#' @param covariate_files Character vector of an experiment's own +#' covariate CSVs, or NULL. Columns they hold are read from them +#' rather than from covariates.csv. +#' @return A list with `covariates` (one row per unit, including +#' the site columns), `response`, `offset` (or NULL), `units`, +#' `taxon` and `region`. +#' +#' @example # Example usage of the function +#' # md <- build_model_data( +#' # taxon = "bryophyte", data_dir = data_dir, +#' # species = "Aulacomnium.palustre", +#' # covariates = c("MAT", "MAP"), +#' # region_filter = ~ nr != "Grassland") +build_model_data <- function( + taxon, + data_dir, + species, + covariates, + region = NULL, + region_filter = NULL, + weight_column = NULL, + aliases = list(), + site_columns = NULL, + covariate_files = NULL +) { + site_columns <- site_columns %||% site_columns() + + # Step 1: Read each piece, narrowed to what was asked for + if (!is.null(weight_column)) { + covariates <- unique(c(covariates, weight_column)) + } + + from_files <- intersect( + covariates, covariate_file_columns(covariate_files) + ) + x <- load_covariates( + taxon, data_dir, setdiff(covariates, from_files), region + ) + x <- add_covariate_files(x, covariate_files, from_files) + y <- load_response(taxon, data_dir, species) + off <- load_offsets(taxon, data_dir, species) + sites <- load_sites(data_dir, taxon, site_columns) + + # Step 2: Keep units present in covariates, response and sites + units <- intersect( + as.character(x$survey_unit_id), as.character(y$survey_unit_id) + ) + units <- intersect(units, as.character(sites$survey_unit_id)) + + if (length(units) == 0) { + stop( + "No survey units shared between the covariates, the ", + "response and sites.csv for ", taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ".", + call. = FALSE + ) + } + + align <- function(frame) { + frame[match(units, as.character(frame$survey_unit_id)), , + drop = FALSE] + } + + x <- align(x) + site_rows <- align(sites) + + # Step 3: Join the site fields onto the covariates, so a region + # filter can name either + keep <- setdiff(names(site_rows), names(x)) + frame <- cbind(x, site_rows[, keep, drop = FALSE]) + rownames(frame) <- NULL + + # Step 3b: Restore factor levels before the region filter + frame <- apply_factor_levels(frame, data_dir, taxon) + + # Step 3c: Aliases, e.g. mammal `seas_days` is summer_days or + # winter_days depending on the season modelled + for (alias in names(aliases)) { + source_column <- aliases[[alias]] + + if (!source_column %in% names(frame)) { + stop( + "Cannot alias `", alias, "` to `", source_column, + "`: no such column.", + call. = FALSE + ) + } + + frame[[alias]] <- frame[[source_column]] + } + + # Step 4: Apply the spec's region filter + if (!is.null(region_filter)) { + keep_rows <- eval( + rlang_f_rhs(region_filter), + envir = frame, + enclos = parent.frame() + ) + + if (!is.logical(keep_rows) || length(keep_rows) != nrow(frame)) { + stop( + "region_filter must evaluate to one logical value per ", + "survey unit; got ", class(keep_rows)[1], " of length ", + length(keep_rows), ".", + call. = FALSE + ) + } + + keep_rows[is.na(keep_rows)] <- FALSE + frame <- frame[keep_rows, , drop = FALSE] + units <- units[keep_rows] + rownames(frame) <- NULL + } + + if (nrow(frame) == 0) { + stop( + "The region filter removed every survey unit for ", taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ".", + call. = FALSE + ) + } + + list( + covariates = frame, + response = align_to_units(y, units), + offset = if (is.null(off)) NULL else align_to_units(off, units), + units = units, + taxon = taxon, + region = region + ) +} + +# 9. model_frame() ---- + +#' Cut a One-Species Modelling Frame +#' +#' Adds one species' response, offset and weight under fixed +#' names, so formulas and engines never name the species. +#' +#' @param model_data A list from build_model_data(). +#' @param species Character. One species column. +#' @param transform Character or function. "identity", or +#' "detection" (value > 0 becomes 1, as in the plant scripts). +#' A function taking two arguments also gets the frame (e.g. +#' the mammal lure correction needs `lured` and `location`). +#' @param weight_column Character. A covariate column to use as +#' model weights, or NULL. +#' @param response_name,offset_name,weight_name Character. Column +#' names to write into the frame. +#' @return A data frame with the covariates plus the response, +#' and the offset and weight when they apply. +#' +#' @example # Example usage of the function +#' # d <- model_frame(md, "Aulacomnium.palustre", +#' # transform = "detection") +model_frame <- function( + model_data, + species, + transform = "identity", + weight_column = NULL, + response_name = "response", + offset_name = "offset", + weight_name = "weight" +) { + if (!species %in% names(model_data$response)) { + stop( + "`", species, "` is not a column of the ", + model_data$taxon, " response table.", + call. = FALSE + ) + } + + frame <- model_data$covariates + values <- model_data$response[[species]] + + # Step 1: Apply the response transform, keeping raw values for + # stages that transform differently (the mammal climate stage + # fits presence even in the abundance run) + frame[[paste0(response_name, "_raw")]] <- values + + frame[[response_name]] <- apply_response_transform( + values, transform, frame + ) + + # Step 2: Attach the offset. A species missing from the offsets + # file is an error, not a silent zero offset. + if (!is.null(model_data$offset)) { + if (!species %in% names(model_data$offset)) { + stop( + "`", species, "` has no offset in the ", model_data$taxon, + " offsets file, but the taxon uses offsets.", + call. = FALSE + ) + } + + frame[[offset_name]] <- model_data$offset[[species]] + } + + # Step 3: Attach weights, named as a covariate column + if (!is.null(weight_column)) { + if (!weight_column %in% names(frame)) { + stop( + "Weight column `", weight_column, "` is not among the ", + "loaded covariates.", + call. = FALSE + ) + } + + frame[[weight_name]] <- frame[[weight_column]] + } + + frame +} + +# 10. Helpers ---- + +## 10.1 check_dataset_file() ---- + +#' Fail Clearly on a Missing Dataset File #' -#' Loads the frozen cross-taxa test dataset for one taxon. +#' @param path Character. Path to check. +#' @return NULL, invisibly. Stops when the file is absent. #' -#' @param taxon Character. Taxon slug (e.g. "mite"). -#' @param version Character. Dataset version from -#' 0_data/manifest.md. -#' @return A data frame of response records. +#' @example # Example usage of the function +#' # check_dataset_file(file.path(data_dir, "sites.csv")) +check_dataset_file <- function(path) { + if (!file.exists(path)) { + stop( + "Test dataset file not found:\n ", path, + "\nRun 1_code/_setup/01_harmonize_model_ready_v2.R first.", + call. = FALSE + ) + } + + invisible(NULL) +} + +## 10.2 site_columns() ---- + +#' The Site Fields Every Model Frame Carries +#' +#' Read from sites.csv, so filters and formulas can name them +#' without loading them as covariates. +#' +#' @return A character vector of sites.csv column names. +#' +#' @example # Example usage of the function +#' # site_columns() +site_columns <- function() { + c( + "lat", "long", "easting", "northing", "nr", "nsr", "luf", "year", + "lured", "location", "summer_days", "winter_days" + ) +} + +## 10.3 align_to_units() ---- + +#' Put a Keyed Frame in a Given Survey Unit Order +#' +#' @param frame A data frame with a survey_unit_id column. +#' @param units Character vector of survey unit ids. +#' @return The frame, reordered, with survey_unit_id first. +#' +#' @example # Example usage of the function +#' # align_to_units(response, units) +align_to_units <- function(frame, units) { + out <- frame[ + match(units, as.character(frame$survey_unit_id)), , + drop = FALSE + ] + rownames(out) <- NULL + + out +} + +## 10.4 apply_response_transform() ---- + +#' Turn a Recorded Value into a Modelling Response #' -#' @example -#' # Example usage of the function -#' # load_test_data() -load_test_data <- function(taxon, version = NULL) { - # Step 1: Resolve the dataset path from the manifest - # Step 2: Read the records and validate the columns +#' @param values Numeric vector as recorded. +#' @param transform Character ("identity" or "detection") or a +#' function. +#' @param frame The assembled frame, passed to a transform that +#' takes a second argument. +#' @return A numeric vector. +#' +#' @example # Example usage of the function +#' # apply_response_transform(c(0, 0.4, 2), "detection") +apply_response_transform <- function( + values, transform, frame = NULL +) { + if (is.function(transform)) { + # A two-argument transform also gets the frame + if (length(formals(transform)) > 1) { + return(transform(values, frame)) + } + + return(transform(values)) + } - stop( - "load_test_data() is not implemented yet.", - call. = FALSE + switch( + transform, + identity = values, + detection = as.integer(ifelse(values > 0, 1L, 0L)), + stop( + "Unknown response transform `", transform, + "`. Use \"identity\", \"detection\", or a function.", + call. = FALSE + ) ) } +## 10.5 rlang_f_rhs() ---- + +#' Take the Right-Hand Side of a One-Sided Formula +#' +#' Local helper to avoid an rlang dependency. +#' +#' @param f A one-sided formula, e.g. ~ nr != "Grassland". +#' @return The unevaluated right-hand side. +#' +#' @example # Example usage of the function +#' # rlang_f_rhs(~ nr != "Grassland") +rlang_f_rhs <- function(f) { + if (!inherits(f, "formula")) { + stop("Expected a one-sided formula.", call. = FALSE) + } + + f[[length(f)]] +} + # End of script ---- diff --git a/1_code/harness/data_source.R b/1_code/harness/data_source.R new file mode 100644 index 0000000..c3d90ed --- /dev/null +++ b/1_code/harness/data_source.R @@ -0,0 +1,239 @@ +# --- +# title: Locate the Published Datasets +# author: Brendan Casey +# created: 2026-10-05 +# inputs: +# - the published datasets on ABMI-DATA2, each a versioned +# folder with its checksums.csv: +# //ABMI-DATA2/science/sdmMethodsDev/0_data/ +# test_dataset// the frozen test dataset +# v2_results// the v2 parity references +# - SDM_TEST_DATASET and SDM_V2_RESULTS, optional, folders to +# read instead +# outputs: none; returns the folder to read +# notes: +# - Runs read the copies published by +# _setup/10_publish_datasets.R, so only maintainers run +# _setup/. sdm_published$versions pins the version read; +# published versions are never overwritten. +# - The environment variables redirect to a local copy or to +# fresh _setup/ output in 0_data/. +# - Each call checks presence and size against checksums.csv +# (fast); verify_published() does the full md5 check. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # reads checksums.csv (version: 1.16.4) + +## 1.2 The pinned versions ---- +# `marker` is a file every copy holds, published or local, so a +# local folder without checksums.csv can still be recognized. +sdm_published <- list( + root = "//ABMI-DATA2/science/sdmMethodsDev/0_data", + versions = c( + test_dataset = "2026-10-05", + v2_results = "2026-10-05" + ), + env = c( + test_dataset = "SDM_TEST_DATASET", + v2_results = "SDM_V2_RESULTS" + ), + marker = c( + test_dataset = "lookup/dataset_manifest.csv", + v2_results = "abmiexplorer/v2_results.csv" + ) +) + +# 2. published_dir() ---- + +#' Resolve a Published Dataset Folder +#' +#' Precedence: `dir`, then the dataset's environment variable, +#' then the pinned published version. +#' +#' @param name Character. "test_dataset" or "v2_results". +#' @param dir Character or NULL. A folder to use as is. +#' @param check Logical. Check the folder before returning it. +#' @return Character. The folder, with forward slashes. +#' +#' @example # Example usage of the function +#' # published_dir("v2_results") +published_dir <- function(name, dir = NULL, check = TRUE) { + # Step 1: A dataset this file knows + if (!name %in% names(sdm_published$versions)) { + stop( + "Unknown dataset: ", name, ". Known: ", + paste(names(sdm_published$versions), collapse = ", "), + call. = FALSE + ) + } + + # Step 2: The first of argument, environment, pinned version + from_env <- Sys.getenv(sdm_published$env[[name]], unset = "") + + dir <- dir %||% + (if (nzchar(from_env)) from_env else NULL) %||% + file.path( + sdm_published$root, name, sdm_published$versions[[name]] + ) + + # normalizePath() keeps a share's leading backslashes; the run + # record reads better with the forward-slash form + dir <- normalizePath(dir, winslash = "/", mustWork = FALSE) + dir <- sub("^[\\\\/]{2}", "//", dir) + + # Step 3: Fail now, not partway into a run + if (isTRUE(check)) { + check_published(dir, name) + } + + dir +} + +# 3. test_dataset_dir() and v2_results_dir() ---- + +#' Resolve the Test Dataset Folder +#' +#' @param data_dir Character or NULL. A folder to use as is. +#' @param check Logical. Check the folder before returning it. +#' @return Character. The folder. +#' +#' @example # Example usage of the function +#' # data_dir <- test_dataset_dir() +#' # Sys.setenv(SDM_TEST_DATASET = "0_data/test_dataset") +#' # test_dataset_dir() # the local _setup/ output +test_dataset_dir <- function(data_dir = NULL, check = TRUE) { + published_dir("test_dataset", data_dir, check) +} + +#' Resolve the v2 Results Folder +#' +#' The parity reference, from _setup/08, is in abmiexplorer/. +#' Files at the top level of the 2026-10-05 version are the +#' retired network-drive build; nothing reads them. +#' +#' @param dir Character or NULL. A folder to use as is. +#' @param check Logical. Check the folder before returning it. +#' @return Character. The folder. +#' +#' @example # Example usage of the function +#' # file.path(v2_results_dir(), "abmiexplorer", "v2_results.csv") +v2_results_dir <- function(dir = NULL, check = TRUE) { + published_dir("v2_results", dir, check) +} + +# 4. check_published() ---- + +#' Check a Dataset Folder Is Complete +#' +#' Published copies are checked file by file against +#' checksums.csv (presence and size); a local copy without one is +#' only checked for the dataset's marker file. +#' +#' @param dir Character. The folder. +#' @param name Character. The dataset, for its marker file. +#' @return `dir`, invisibly; stops on a problem. +#' +#' @example # Example usage of the function +#' # check_published(test_dataset_dir(check = FALSE), +#' # "test_dataset") +check_published <- function(dir, name) { + # Step 1: The folder + if (!dir.exists(dir)) { + stop( + "Dataset ", name, " not found:\n ", dir, + "\nConnect to the ABMI network (or VPN), or set ", + sdm_published$env[[name]], " to a local copy.", + call. = FALSE + ) + } + + # Step 2: A local copy has no checksums; the marker will do + sums_path <- file.path(dir, "checksums.csv") + + if (!file.exists(sums_path)) { + marker <- sdm_published$marker[[name]] + + if (!file.exists(file.path(dir, marker))) { + stop( + "Not a copy of ", name, " (no ", marker, "):\n ", dir, + call. = FALSE + ) + } + + return(invisible(dir)) + } + + # Step 3: Every published file, at its published size + sums <- fread(sums_path, colClasses = "character") + sizes <- file.size(file.path(dir, sums$path)) + bad <- is.na(sizes) | sizes != as.numeric(sums$bytes) + + if (any(bad)) { + stop( + "Dataset ", name, " incomplete at ", dir, + "; missing or wrong size:\n ", + paste(head(sums$path[bad], 10), collapse = "\n "), + call. = FALSE + ) + } + + invisible(dir) +} + +# 5. verify_published() ---- + +#' Verify Every File in a Published Dataset by md5 +#' +#' Slow over the network (the test dataset is ~0.9 GB); use it +#' after publishing, or when a copy is in doubt. +#' +#' @param dir Character. A published folder. +#' @return Logical. TRUE when every md5 matches, invisibly; +#' stops otherwise. +#' +#' @example # Example usage of the function +#' # verify_published(test_dataset_dir()) +verify_published <- function(dir) { + sums_path <- file.path(dir, "checksums.csv") + + if (!file.exists(sums_path)) { + stop("No checksums.csv in ", dir, call. = FALSE) + } + + sums <- fread(sums_path, colClasses = "character") + found <- unname(tools::md5sum(file.path(dir, sums$path))) + bad <- is.na(found) | found != sums$md5 + + if (any(bad)) { + stop( + "md5 mismatch in ", dir, ":\n ", + paste(sums$path[bad], collapse = "\n "), + call. = FALSE + ) + } + + invisible(TRUE) +} + +# 6. published_label() ---- + +#' Name the Copy a Run Read, for the Run Record +#' +#' @param dir Character. The folder. +#' @return Character. "published ()" for a +#' published copy, "local ()" otherwise. +#' +#' @example # Example usage of the function +#' # published_label(test_dataset_dir()) +published_label <- function(dir) { + if (file.exists(file.path(dir, "checksums.csv"))) { + paste0("published ", basename(dir), " (", dir, ")") + } else { + paste0("local (", dir, ")") + } +} + +# End of script ---- diff --git a/1_code/harness/data_split.R b/1_code/harness/data_split.R deleted file mode 100644 index 3a3201f..0000000 --- a/1_code/harness/data_split.R +++ /dev/null @@ -1,39 +0,0 @@ -# --- -# title: Apply the Evaluation Split -# author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none -# notes: -# - Placeholder. The split is part of the frozen dataset, -# so it is read, never recomputed - recomputing it would -# break comparability across experiments. -# - The v2 pipeline does not use this; the v2 scripts carry -# their own bootstrap design in bootstrap.ids. -# --- - -# 1. apply_split() ---- - -#' Apply the Evaluation Split -#' -#' Applies the frozen evaluation split to a set of records. -#' -#' @param data Data frame of response records. -#' @param split Character. Which split to return, one of -#' "train", "test", or "all". -#' @return A data frame holding the requested split. -#' -#' @example -#' # Example usage of the function -#' # apply_split() -apply_split <- function(data, split = c("train", "test", "all")) { - # Step 1: Match the requested split - # Step 2: Join the frozen split assignment and subset - - stop( - "apply_split() is not implemented yet.", - call. = FALSE - ) -} - -# End of script ---- diff --git a/1_code/harness/engines.R b/1_code/harness/engines.R new file mode 100644 index 0000000..7bb25bf --- /dev/null +++ b/1_code/harness/engines.R @@ -0,0 +1,352 @@ +# --- +# title: Engine Interface +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; defines functions in memory +# notes: +# - The harness's interface to the engines in +# 1_code/methods/engines/, so swapping engines is a one-word +# spec change. The contract is in 1_code/methods/README.md; +# check_engine() tests an engine against it on synthetic data. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. get_engine() ---- + +#' Look Up One Engine +#' +#' @param name Character. A registered engine name. +#' @return The engine definition. +#' +#' @example # Example usage of the function +#' # get_engine("glm") +get_engine <- function(name) { + get_method("engine", name) +} + +# 3. Capabilities ---- + +## 3.1 engine_has() ---- + +#' Does an Engine Declare a Capability +#' +#' @param engine An engine definition. +#' @param capability Character. One of engine_capabilities(). +#' @return Logical. +#' +#' @example # Example usage of the function +#' # engine_has(get_engine("glm"), "se") +engine_has <- function(engine, capability) { + capability %in% engine$capabilities +} + +## 3.2 engine_coef() ---- + +#' Coefficients from a Fit, Where the Engine Has Them +#' +#' Reuses coefficients cached on the fit by fit_with(). +#' +#' @param engine An engine definition. +#' @param fit A fit from engine$fit(). +#' @return A data frame of term, estimate and se, or NULL. +#' +#' @example # Example usage of the function +#' # engine_coef(engine, fit) +engine_coef <- function(engine, fit) { + if (is.null(fit) || !isTRUE(fit$ok)) { + return(NULL) + } + + if (!is.null(fit$coefficients)) { + return(fit$coefficients) + } + + if (!engine_has(engine, "coefficients")) { + return(NULL) + } + + engine$coef(fit) +} + +## 3.3 engine_converged() ---- + +#' Did a Fit Converge, as Far as the Engine Can Say +#' +#' @param engine An engine definition. +#' @param fit A fit from engine$fit(). +#' @return Logical. FALSE for a failed fit; TRUE for a fit whose +#' engine cannot report convergence. +#' +#' @example # Example usage of the function +#' # engine_converged(engine, fit) +engine_converged <- function(engine, fit) { + if (is.null(fit) || !isTRUE(fit$ok)) { + return(FALSE) + } + + if (!is.function(engine$converged)) { + return(TRUE) + } + + isTRUE(engine$converged(fit)) +} + +## 3.4 engine_nobs() ---- + +#' Number of Observations a Fit Used +#' +#' @param engine An engine definition, or NULL. +#' @param fit A fit from engine$fit(). +#' @return An integer, or NA when it cannot be said. +#' +#' @example # Example usage of the function +#' # engine_nobs(engine, fit) +engine_nobs <- function(engine, fit) { + if (is.null(fit) || !isTRUE(fit$ok)) { + return(NA_integer_) + } + + if (!is.null(engine) && is.function(engine$nobs)) { + return(tryCatch( + as.integer(engine$nobs(fit)), + error = function(e) NA_integer_ + )) + } + + tryCatch( + as.integer(stats::nobs(fit$fit)), + error = function(e) NA_integer_ + ) +} + +## 3.5 fit_with() ---- + +#' Fit One Formula Through an Engine +#' +#' The one place a candidate is fitted. Coefficients are computed +#' once and cached on the fit (bayesglm's summary() is slow). +#' +#' @param engine An engine definition. +#' @param formula A model formula. +#' @param data,family,weights,offset,control As engine$fit takes. +#' @return The engine's fit list, with `coefficients` added when +#' the engine has them. +#' +#' @example # Example usage of the function +#' # fit_with(get_engine("glm"), response ~ MAP, d, "binomial") +fit_with <- function( + engine, formula, data, family, weights = NULL, offset = NULL, + control = list() +) { + fit <- engine$fit( + formula = formula, data = data, family = family, + weights = weights, offset = offset, control = control + ) + + if (isTRUE(fit$ok) && engine_has(engine, "coefficients")) { + fit$coefficients <- engine$coef(fit) + } + + fit +} + +# 4. check_engine() ---- + +#' Test an Engine Against the Contract +#' +#' Fits synthetic binomial and Poisson data (weights, a formula +#' offset, a factor) and checks each part of the contract the +#' engine declares. +#' +#' @param engine An engine definition, or a registered name. +#' @param n Integer. Rows of synthetic data. +#' @param seed Integer. Seed for the synthetic data. +#' @param quiet Logical. Suppress the printed table. +#' @return A data frame of check, family, pass and note, +#' invisibly. Every `pass` should be TRUE. +#' +#' @example # Example usage of the function +#' # check_engine("glm") +#' # check_engine(my_new_engine()) +check_engine <- function(engine, n = 400L, seed = 1L, quiet = FALSE) { + if (is.character(engine)) { + engine <- get_engine(engine) + } + + # Step 1: Synthetic data with a known signal + data <- with_seed(seed, { + x1 <- stats::rnorm(n) + x2 <- stats::runif(n) + habitat <- factor(sample(c("A", "B", "C"), n, replace = TRUE)) + effort <- stats::runif(n, 0.5, 2) + eta <- -0.5 + 0.8 * x1 - 0.6 * x2 + (habitat == "B") * 0.7 + + data.frame( + x1 = x1, x2 = x2, habitat = habitat, + offset = log(effort), + weight = stats::runif(n, 0.5, 1.5), + presence = stats::rbinom(n, 1, stats::plogis(eta)), + count = stats::rpois(n, exp(eta + log(effort))) + ) + }) + + checks <- list() + + record <- function(check, family, pass, note = "") { + checks[[length(checks) + 1]] <<- data.frame( + check = check, family = family, pass = isTRUE(pass), + note = note, stringsAsFactors = FALSE + ) + } + + newdata <- data[1:20, ] + + for (family in c("binomial", "poisson")) { + formula <- if (family == "binomial") { + presence ~ x1 + x2 + habitat + } else { + count ~ x1 + x2 + habitat + offset(offset) + } + + # Step 2: Fitting succeeds, weighted, and reports itself + fit <- tryCatch( + engine$fit( + formula = formula, data = data, family = family, + weights = data$weight, offset = NULL, control = list() + ), + error = function(e) { + list(ok = FALSE, message = conditionMessage(e)) + } + ) + record( + "fit returns list(fit, ok, message) with ok = TRUE", family, + is.list(fit) && isTRUE(fit$ok) && + all(c("fit", "ok", "message") %in% names(fit)), + if (!isTRUE(fit$ok)) format(fit$message) else "" + ) + + if (!isTRUE(fit$ok)) { + next + } + + # Step 3: Predictions on both scales + link <- tryCatch( + engine$predict(fit, newdata, "link"), + error = function(e) NULL + ) + response <- tryCatch( + engine$predict(fit, newdata, "response"), + error = function(e) NULL + ) + record( + "predict returns one finite value per row", family, + is.numeric(link) && length(link) == nrow(newdata) && + all(is.finite(link)) + ) + record( + "response-scale prediction is in range", family, + is.numeric(response) && length(response) == nrow(newdata) && + if (family == "binomial") { + all(response >= 0 & response <= 1) + } else { + all(response >= 0) + } + ) + + # Doubling effort on new data must double a Poisson prediction + if (family == "poisson") { + shifted <- newdata + shifted$offset <- shifted$offset + log(2) + doubled <- tryCatch( + engine$predict(fit, shifted, "response"), + error = function(e) NULL + ) + record( + "an offset in the formula is applied to new data", family, + is.numeric(doubled) && + isTRUE(all.equal(doubled, 2 * response, tolerance = 1e-6)) + ) + } + + # Step 4: The optional capabilities the engine declares + if (engine_has(engine, "coefficients")) { + cf <- tryCatch(engine$coef(fit), error = function(e) NULL) + record( + "coef returns term, estimate and se", family, + is.data.frame(cf) && + all(c("term", "estimate", "se") %in% names(cf)) && + nrow(cf) > 0 + ) + } + + if (engine_has(engine, "ic")) { + scores <- vapply( + c("AIC", "AICc", "BIC"), + function(type) { + tryCatch(engine$ic(fit, type), error = function(e) NA_real_) + }, + numeric(1) + ) + record( + "ic returns a finite AIC, AICc and BIC", family, + all(is.finite(scores)) + ) + } + + if (engine_has(engine, "se")) { + with_se <- tryCatch( + engine$predict(fit, newdata, "link", se = TRUE), + error = function(e) NULL + ) + record( + "predict(se = TRUE) returns fit and se.fit", family, + is.list(with_se) && + length(with_se$fit) == nrow(newdata) && + length(with_se$se.fit) == nrow(newdata) && + all(with_se$se.fit >= 0) + ) + } + } + + # Step 5: Failure is returned, not raised, so a selection rule + # can see which candidates failed + failed <- tryCatch( + engine$fit( + formula = presence ~ no_such_column, data = data, + family = "binomial", weights = NULL, offset = NULL, + control = list() + ), + error = function(e) "raised" + ) + record( + "a failed fit returns ok = FALSE rather than raising", "-", + is.list(failed) && identical(failed$ok, FALSE) + ) + + if (is.list(failed)) { + record( + "predict on a failed fit returns NULL", "-", + is.null(tryCatch( + engine$predict(failed, newdata, "response"), + error = function(e) "raised" + )) + ) + } + + result <- do.call(rbind, checks) + + if (!quiet) { + cat("Engine `", engine$name, "`: ", sum(result$pass), " of ", + nrow(result), " checks pass\n", sep = "") + print(result, row.names = FALSE, right = FALSE) + } + + invisible(result) +} + +# End of script ---- diff --git a/1_code/harness/eval_metrics.R b/1_code/harness/eval_metrics.R index 4b54222..100b875 100644 --- a/1_code/harness/eval_metrics.R +++ b/1_code/harness/eval_metrics.R @@ -1,40 +1,97 @@ # --- -# title: Compute Evaluation Metrics +# title: Evaluation Metrics # author: Brendan Casey -# created: 2026-09-05 +# created: 2026-09-09 # inputs: none -# outputs: none +# outputs: none; returns objects in memory # notes: -# - Placeholder. Metrics computed here are what experiments -# are compared on, so changes affect every past and future -# experiment and should be reviewed accordingly. -# - The v2 validation scripts compute their own AUC through -# model_validation(); this is for methods work that does -# not run the v2 code. +# - Experiments are compared on these metrics, so a change here +# affects every experiment. Metrics live in +# 1_code/methods/metrics/ and score response-scale +# predictions, never a fitted object, so all engines are +# scored alike. +# - An uncomputable metric returns NA rather than stopping (e.g. +# no AUC for a draw with no detections). # --- -# 1. eval_metrics() ---- +# 1. Setup ---- -#' Compute Evaluation Metrics +## 1.1 Load packages ---- +# Base R only. + +# 2. default_metrics() ---- + +#' The Metrics Scored When a Run Names None #' -#' Computes the shared evaluation metrics for a model's predictions. +#' Every registered metric: the seven original ones first, in +#' their original order, so tables stay stable; later additions +#' follow alphabetically. +#' +#' @return A character vector of metric names. +#' +#' @example # Example usage of the function +#' # default_metrics() +default_metrics <- function() { + core <- c( + "auc", "deviance_explained", "rmse", "spearman", + "calibration_slope", "prevalence", "n" + ) + registered <- registered_names("metric") + + c(intersect(core, registered), sort(setdiff(registered, core))) +} + +# 3. compute_metrics() ---- + +#' Score One Set of Predictions #' #' @param observed Numeric vector of observed values. -#' @param predicted Numeric vector of predicted values. -#' @param metrics Character vector of metric names to -#' compute, or NULL for the full set. -#' @return A named numeric vector of metric values. +#' @param predicted Numeric vector of predictions, on the +#' response scale. +#' @param metrics Character vector of metric names, or NULL for +#' default_metrics(). +#' @return A data frame of metric and value. #' -#' @example -#' # Example usage of the function -#' # eval_metrics() -eval_metrics <- function(observed, predicted, metrics = NULL) { - # Step 1: Validate that the two vectors align - # Step 2: Compute each requested metric - - stop( - "eval_metrics() is not implemented yet.", - call. = FALSE +#' @example # Example usage of the function +#' # compute_metrics(obs, pred, metrics = c("auc", "rmse")) +compute_metrics <- function(observed, predicted, metrics = NULL) { + if (is.null(metrics)) { + metrics <- default_metrics() + } + + # Looked up first, so a misspelt metric stops the run here + functions <- lapply( + stats::setNames(metrics, metrics), + function(name) get_method("metric", name) + ) + + # Step 1: Drop pairs where either side is non-finite, so every + # metric sees the same rows + keep <- is.finite(observed) & is.finite(predicted) + observed <- observed[keep] + predicted <- predicted[keep] + + # Step 2: Score, letting an uncomputable metric return NA. A + # warning is muffled rather than caught, so the metric is + # computed once. + values <- vapply( + metrics, + function(name) { + tryCatch( + withCallingHandlers( + as.numeric(functions[[name]](observed, predicted)), + warning = function(w) invokeRestart("muffleWarning") + ), + error = function(e) NA_real_ + ) + }, + numeric(1) + ) + + data.frame( + metric = metrics, + value = unname(values), + stringsAsFactors = FALSE ) } diff --git a/1_code/harness/experiment.R b/1_code/harness/experiment.R new file mode 100644 index 0000000..fc28df1 --- /dev/null +++ b/1_code/harness/experiment.R @@ -0,0 +1,541 @@ +# --- +# title: Configure and Run an Experiment +# author: Brendan Casey +# created: 2026-10-03 +# inputs: +# the published test dataset (see data_source.R) +# outputs: +# in 2_pipeline//: the result stores and run_log.csv +# in 3_output//: tables/, run_record.md, and whatever the +# experiment's own steps write +# notes: +# - The part every experiment shares, so each run.R is a short +# list of decisions. experiment_config() checks them before +# anything is fitted; run_experiment() fits, summarizes, +# compares with the baseline (exp_000, v2), runs the +# experiment's own steps and writes the run record. +# - Steps receive everything through `config` and `results`. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # run log writing (version: 1.16.4) + +# 2. experiment_config() ---- + +#' State and Check an Experiment's Configuration +#' +#' @param id Character. The experiment identifier, e.g. +#' "exp_001_covariate_scale". Names its 2_pipeline/ and +#' 3_output/ folders. +#' @param taxa Character vector of runs, from +#' names(standard_specs()), or NULL for all of them. +#' @param species A focal-species set name (see +#' focal_species_sets()), a species vector named by taxon, or +#' NULL for every species. +#' @param n_bootstraps Integer. Draws per species. 100 is v2's. +#' @param seed Integer or NULL. The base seed; NULL leaves the +#' draws unseeded, as v2 did. +#' @param stage_models Named list of replacement candidate sets, +#' or NULL for each spec's v2 sets; see apply_stage_models(). +#' @param covariate_files Character vector of CSVs holding +#' covariates the frozen dataset does not, keyed on +#' survey_unit_id, or NULL. Written by the experiment's own +#' scripts, never into 0_data/; their columns can then be named +#' in `stage_models`. +#' @param specs Named list of specs, or NULL for +#' standard_specs(plant_bootstrap). An experiment that changes +#' a spec builds its own and passes it here. +#' @param plant_bootstrap Character. Passed to standard_specs(). +#' @param workers Integer. Species fitted at once. +#' @param unit_predictions Character. "none", "oob" or "all". +#' @param baseline Character. The experiment every result is +#' compared with, by id; NULL for none. Ignored by the baseline +#' itself. +#' @param v2_bootstraps Integer. v2's draw count, which a run must +#' reach to be gated. +#' @param project_root Character. The repository root. +#' @param data_dir,pipeline_dir,out_dir Character, or NULL for +#' test_dataset_dir(), 2_pipeline/ and 3_output/. +#' @return A list of class `experiment_config`. +#' +#' @example # Example usage of the function +#' # config <- experiment_config("exp_001_test", taxa = "lichen", +#' # species = "one_each", +#' # n_bootstraps = 5) +experiment_config <- function( + id, + taxa = NULL, + species = NULL, + n_bootstraps = 100L, + seed = 20260909L, + stage_models = NULL, + covariate_files = NULL, + specs = NULL, + plant_bootstrap = "spatial_block", + workers = 1L, + unit_predictions = "none", + baseline = "exp_000_parity_v2", + v2_bootstraps = 100L, + project_root = getOption("sdm.project_root", "."), + data_dir = NULL, + pipeline_dir = NULL, + out_dir = NULL +) { + # Step 1: The runs + specs <- specs %||% standard_specs(plant_bootstrap) + taxa <- taxa %||% names(specs) + unknown <- setdiff(taxa, names(specs)) + + if (length(unknown) > 0) { + stop( + "Unknown run(s): ", paste(unknown, collapse = ", "), + ". Available: ", paste(names(specs), collapse = ", "), + call. = FALSE + ) + } + + specs <- specs[taxa] + + # Step 2: The draw count, checked now rather than hours in + if (!is.numeric(n_bootstraps) || length(n_bootstraps) != 1L || + is.na(n_bootstraps) || n_bootstraps < 1 || + n_bootstraps != round(n_bootstraps)) { + stop( + "n_bootstraps must be a single whole number of 1 or more.", + call. = FALSE + ) + } + + n_bootstraps <- as.integer(n_bootstraps) + data_dir <- test_dataset_dir(data_dir) + + # Stored draws have a hard ceiling; drawn ones do not + for (key in names(specs)) { + spec <- specs[[key]] + + if (!identical(spec$resample$scheme, "precomputed") || + isTRUE(spec$resample$per_species)) { + next + } + + location <- manifest_entry(data_dir, spec$taxon)$bootstrap_ids + stored <- length(names(fread( + file.path(data_dir, location), nrows = 0 + ))) + + if (n_bootstraps > stored) { + stop( + "n_bootstraps is ", n_bootstraps, " but only ", stored, + " ", spec$taxon, " draws are stored. Lower it, or drop `", + key, "`.", + call. = FALSE + ) + } + } + + if (n_bootstraps < v2_bootstraps) { + message( + "Note: running ", n_bootstraps, " of ", v2_bootstraps, + " v2 draws. This is a trial; its parity numbers are not a ", + "parity read." + ) + } + + # Step 3: Covariates the experiment adds from its own files. + # Absolute paths, so parallel workers find them too. + if (!is.null(covariate_files)) { + covariate_files <- normalizePath( + covariate_files, winslash = "/", mustWork = FALSE + ) + check_covariate_files(covariate_files, data_dir) + + specs <- lapply(specs, function(spec) { + spec$covariate_files <- covariate_files + spec + }) + } + + # Step 4: The species. A taxon the set does not name runs every + # species, so say so: it makes a partial set the longest run. + focal <- get_focal_species(species) + + if (!is.null(focal)) { + slugs <- vapply(specs, `[[`, character(1), "taxon") + unnamed <- names(slugs)[!slugs %in% names(focal)] + + if (length(unnamed) > 0) { + message( + "Note: ", paste(unnamed, collapse = ", "), " are not named ", + "in the species set, so every species will be run for ", + "them. Narrow `taxa` to avoid it." + ) + } + } + + structure( + list( + id = id, + taxa = taxa, + specs = specs, + # The set's name, for the record; "inline" for a vector + species_set = if (is.character(species) && + length(species) == 1L && + is.null(names(species))) { + species + } else { + "inline" + }, + focal_species = focal, + n_bootstraps = n_bootstraps, + v2_bootstraps = as.integer(v2_bootstraps), + seed = seed, + stage_models = stage_models, + covariate_files = covariate_files, + plant_bootstrap = plant_bootstrap, + workers = as.integer(workers), + unit_predictions = unit_predictions, + # The baseline does not compare with itself + baseline = if (identical(baseline, id)) NULL else baseline, + project_root = project_root, + data_dir = data_dir, + pipeline_dir = pipeline_dir %||% + file.path(project_root, "2_pipeline", id), + out_dir = out_dir %||% file.path(project_root, "3_output", id) + ), + class = "experiment_config" + ) +} + +## 2.1 print.experiment_config() ---- + +#' Print an Experiment's Configuration +#' +#' @param x An experiment_config(). +#' @param ... Unused. +#' @return `x`, invisibly. +#' +#' @example # Example usage of the function +#' # print(config) +print.experiment_config <- function(x, ...) { + cat("Experiment ", x$id, "\n", sep = "") + cat(" runs: ", paste(x$taxa, collapse = ", "), "\n", sep = "") + cat(" species: ", if (is.null(x$focal_species)) { + "every species" + } else { + paste0(length(x$focal_species), " focal (", x$species_set, ")") + }, "\n", sep = "") + cat(" draws: ", x$n_bootstraps, " (v2: ", x$v2_bootstraps, + ")\n", sep = "") + cat(" seed: ", x$seed %||% "unseeded", "\n", sep = "") + changes <- experiment_changes(x) + cat(" changes: ", if (length(changes) == 0) { + "none; every spec is v2's" + } else { + paste(changes, collapse = "\n ") + }, "\n", sep = "") + cat(" workers: ", x$workers, "\n", sep = "") + cat(" baseline: ", x$baseline %||% "none (this is the baseline)", + "\n", sep = "") + cat(" writes: ", x$pipeline_dir, "\n ", x$out_dir, + "\n", sep = "") + + invisible(x) +} + +# 3. run_experiment() ---- + +#' Fit, Summarize, Compare with the Baseline, Run the +#' Experiment's Steps, and Record +#' +#' @param config An experiment_config(). +#' @param fit Logical. FALSE skips fitting and re-summarizes the +#' stores already in pipeline_dir. +#' @param steps Named list of functions, run in order after the +#' summary tables are written. Each takes `config` and +#' `results` and returns `results`, which it may add to. +#' @param translate Named list of coefficient translations by +#' taxon, passed to collect_results(). +#' @param record Logical. Write run_record.md. +#' @return The results list, invisibly: the summary tables, the +#' run log, the comparison with the baseline, and whatever the +#' steps added. +#' +#' @example # Example usage of the function +#' # results <- run_experiment(config) +run_experiment <- function( + config, + fit = TRUE, + steps = list(), + translate = list(), + record = TRUE +) { + started <- Sys.time() + print(config) + + # Step 1: Fit + run_log <- NULL + + if (fit) { + run_log <- run_specs( + specs = config$specs, + data_dir = config$data_dir, + pipeline_dir = config$pipeline_dir, + species = config$focal_species, + iterations = seq_len(config$n_bootstraps), + stage_models = config$stage_models, + boot_seed = config$seed, + workers = config$workers, + unit_predictions = config$unit_predictions + ) + + fwrite(run_log, file.path(config$pipeline_dir, "run_log.csv"), + na = "") + cat("\nRun log:\n") + print(table(run_log$taxon, run_log$status)) + } + + # Step 2: Summarize the stores + results <- collect_results( + config$pipeline_dir, config$data_dir, translate = translate + ) + results$run_log <- run_log + write_summaries(results, config$out_dir) + + # Step 3: Compare with the baseline, for every experiment but + # the baseline itself + if (!is.null(config$baseline)) { + cat("\n== compare with ", config$baseline, " ==\n", sep = "") + results <- compare_to_baseline(config, results) + } + + # Step 4: The experiment's own steps, in order + for (name in names(steps)) { + cat("\n== ", name, " ==\n", sep = "") + results <- steps[[name]](config, results) + } + + # Step 5: The committed record of what ran + if (record) { + record_file <- run_record( + pipeline_dir = config$pipeline_dir, + out_file = file.path(config$out_dir, "run_record.md"), + exp_id = config$id, + config = record_config(config, run_log), + collected = results + ) + cat("Run record: ", record_file, "\n", sep = "") + } + + cat( + "\n", config$id, " complete in ", + format(round(Sys.time() - started, 1)), "\n", + "Intermediates: ", config$pipeline_dir, "\n", + "Deliverables: ", config$out_dir, "\n", + sep = "" + ) + + invisible(results) +} + +# 4. record_config() ---- + +#' The Settings a Run Record States +#' +#' Settings, not absolute paths, which differ between machines. +#' +#' @param config An experiment_config(). +#' @param run_log The run log, or NULL when nothing was fitted. +#' @return A named list. +#' +#' @example # Example usage of the function +#' # record_config(config, run_log) +record_config <- function(config, run_log = NULL) { + stage_values <- function(field) { + sort(unique(unlist(lapply(config$specs, function(spec) { + vapply(spec$stages, function(stage) { + value <- stage[[field]] + if (is.function(value)) "custom" else value + }, character(1)) + })))) + } + + out <- list( + taxa = sort(config$taxa), + focal_species = if (is.null(config$focal_species)) { + "all" + } else { + sort(paste0(names(config$focal_species), "=", + config$focal_species)) + }, + species_n = if (is.null(config$focal_species)) { + NA_integer_ + } else { + length(config$focal_species) + }, + n_bootstraps = config$n_bootstraps, + v2_bootstraps = config$v2_bootstraps, + boot_seed = config$seed %||% "unseeded", + plant_bootstrap = config$plant_bootstrap, + stage_models = if (is.null(config$stage_models)) { + "spec defaults (v2 candidate sets)" + } else { + sort(names(config$stage_models)) + }, + covariate_files = if (is.null(config$covariate_files)) { + "none" + } else { + basename(config$covariate_files) + }, + changes_from_v2 = { + changes <- experiment_changes(config) + if (length(changes) == 0) "none" else changes + }, + engines = stage_values("engine"), + selection = stage_values("selection"), + compared_with = config$baseline %||% "none (baseline)", + data_dir = published_label(config$data_dir) + ) + + # Record failures, or a run that lost jobs looks complete + if (!is.null(run_log)) { + ok <- sum(run_log$status == "ok", na.rm = TRUE) + out$jobs_total <- nrow(run_log) + out$jobs_ok <- ok + out$jobs_not_ok <- nrow(run_log) - ok + } + + out +} + +## 4.1 experiment_changes() ---- + +#' What an Experiment Changes from the v2 Specs +#' +#' Changes made through `stage_models`, and through specs changed +#' with replace_stage_method(), which records them. +#' +#' @param config An experiment_config(). +#' @return A character vector, one entry per run and change. +#' +#' @example # Example usage of the function +#' # experiment_changes(config) +experiment_changes <- function(config) { + from_specs <- unlist(lapply(names(config$specs), function(key) { + changed <- config$specs[[key]]$models_overridden + + if (is.null(changed)) NULL else paste0(key, ": ", changed) + })) + + from_models <- if (is.null(config$stage_models)) { + NULL + } else { + paste0("stage_models: ", names(config$stage_models)) + } + + from_files <- if (is.null(config$covariate_files)) { + NULL + } else { + paste0("covariate_files: ", basename(config$covariate_files)) + } + + c(from_specs, from_models, from_files) +} + +# 5. compare_to_baseline() ---- + +#' Compare an Experiment's Summaries with the Baseline's +#' +#' Writes tables/comparison_metrics.csv and prints the headline +#' (see compare_experiments()). A baseline not yet run is +#' reported and skipped, not an error. +#' +#' @param config An experiment_config(). +#' @param results The results so far. +#' @param baseline Character. The baseline experiment's id. +#' @return `results`, with `comparison` added when there was a +#' baseline to compare with. +#' +#' @example # Example usage of the function +#' # results <- compare_to_baseline(config, results) +compare_to_baseline <- function( + config, results, baseline = config$baseline +) { + baseline_dir <- file.path( + config$project_root, "3_output", baseline + ) + baseline_table <- file.path( + baseline_dir, "tables", "metric_summary.csv" + ) + + if (!file.exists(baseline_table)) { + message( + "No comparison: ", baseline, " has no summary tables yet. ", + "Run it first, then re-summarize this experiment with ", + "run_experiment(config, fit = FALSE)." + ) + return(results) + } + + comparison <- compare_experiments( + candidate_dir = config$out_dir, + baseline_dir = baseline_dir + ) + + # The headline, for the console; per-species rows are written + shown <- comparison$summary[ + comparison$summary$metric %in% c( + "oob_auc", "oob_deviance_explained", "oob_calibration_slope" + ), + c("taxon", "region", "metric", "median_baseline", + "median_candidate", "median_difference", "share_better") + ] + numbers <- vapply(shown, is.numeric, logical(1)) + shown[numbers] <- lapply(shown[numbers], round, 3) + + cat( + "Against ", baseline, + " (out-of-bag; per species in comparison_metrics.csv):\n", + sep = "" + ) + print(shown, row.names = FALSE) + + results$comparison <- comparison + results +} + +# 6. script_step() ---- + +#' Turn an Experiment Script into a Step +#' +#' Runs the script in a fresh environment (parent: global) +#' holding `config` and `results`, so it leaves nothing behind, +#' and returns the updated `results`. +#' +#' @param path Character. The script. +#' @return A function(config, results) for run_experiment()'s +#' `steps`. +#' +#' @example # Example usage of the function +#' # steps <- list(report = script_step("03_build_report.R")) +script_step <- function(path) { + force(path) + + if (!file.exists(path)) { + stop("Step script not found: + ", path, call. = FALSE) + } + + function(config, results) { + env <- new.env(parent = globalenv()) + env$config <- config + env$results <- results + + sys.source(path, envir = env, keep.source = FALSE) + + env$results + } +} + +# End of script ---- diff --git a/1_code/harness/harness.R b/1_code/harness/harness.R new file mode 100644 index 0000000..1531714 --- /dev/null +++ b/1_code/harness/harness.R @@ -0,0 +1,191 @@ +# --- +# title: Load the Framework +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# - the files in 1_code/harness/ +# - the files in 1_code/methods/ +# - the files in 1_code/modules/ +# outputs: none; defines the framework in the calling environment +# notes: +# - Single entry point: experiments source this file and call +# load_framework(). +# - Load order: harness/ (including the method registry), +# methods/ (each file registers itself), modules/, then +# experiments/_shared/. Files or folders starting with "_" +# are shared helpers and load first. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # used throughout (version: 1.16.4) + +# 2. load_harness() ---- + +#' Source Every Harness File +#' +#' @param harness_dir Character. Path to 1_code/harness. +#' @param envir Environment to source into. +#' @return Character vector of the files sourced, invisibly. +#' +#' @example # Example usage of the function +#' # load_harness("1_code/harness") +load_harness <- function( + harness_dir = "1_code/harness", + envir = parent.frame() +) { + # The registry and cache come first: method files register into + # the one, and loaders read through the other. run_model.R is + # last because it calls most of the rest. + files <- c( + "registry.R", + "cache.R", + "data_source.R", + "spec.R", + "data_load.R", + "covariate_sets.R", + "species.R", + "model_sets.R", + "resample.R", + "engines.R", + "selection.R", + "eval_metrics.R", + "predict_grid.R", + "result.R", + "run_record.R", + "run_model.R", + "summarise.R", + "compare.R", + "experiment.R", + "new_experiment.R" + ) + + source_all(file.path(harness_dir, files), envir) +} + +# 3. load_methods() ---- + +#' Source and Register Every Method +#' +#' @param methods_dir Character. Path to 1_code/methods. +#' @param envir Environment to source into. +#' @return Character vector of the files sourced, invisibly. +#' +#' @example # Example usage of the function +#' # load_methods("1_code/methods") +load_methods <- function( + methods_dir = "1_code/methods", + envir = parent.frame() +) { + kinds <- c("engines", "selection", "resampling", "metrics") + + paths <- unlist(lapply(kinds, function(kind) { + files <- sort(list.files( + file.path(methods_dir, kind), pattern = "\\.R$", + full.names = TRUE + )) + shared <- startsWith(basename(files), "_") + + c(files[shared], files[!shared]) + })) + + source_all(paths, envir) +} + +# 4. load_modules() ---- + +#' Source Every Taxon Module +#' +#' @param modules_dir Character. Path to 1_code/modules. +#' @param envir Environment to source into. +#' @return Character vector of the files sourced, invisibly. +#' +#' @example # Example usage of the function +#' # load_modules("1_code/modules") +load_modules <- function( + modules_dir = "1_code/modules", + envir = parent.frame() +) { + folders <- sort(list.dirs( + modules_dir, recursive = FALSE, full.names = TRUE + )) + shared <- startsWith(basename(folders), "_") + + paths <- unlist(lapply( + c(folders[shared], folders[!shared]), + function(folder) { + sort(list.files(folder, pattern = "\\.R$", full.names = TRUE)) + } + )) + + source_all(paths, envir) +} + +# 5. load_framework() ---- + +#' Load the Harness, Methods, Taxon Modules and Shared Settings +#' +#' What an experiment calls first. Everything is sourced into one +#' environment, the caller's by default. +#' +#' @param project_root Character. The repository root. +#' @param envir Environment to source into. +#' @return The project root, invisibly. +#' +#' @example # Example usage of the function +#' # source("1_code/harness/harness.R") +#' # load_framework() +#' # list_methods() +load_framework <- function( + project_root = ".", + envir = parent.frame() +) { + project_root <- normalizePath(project_root, winslash = "/") + code_dir <- file.path(project_root, "1_code") + + load_harness(file.path(code_dir, "harness"), envir) + load_methods(file.path(code_dir, "methods"), envir) + load_modules(file.path(code_dir, "modules"), envir) + + shared <- sort(list.files( + file.path(code_dir, "experiments", "_shared"), + pattern = "\\.R$", full.names = TRUE + )) + source_all(shared, envir) + + # Parallel workers load the framework from here themselves + options(sdm.project_root = project_root) + + invisible(project_root) +} + +# 6. source_all() ---- + +#' Source Files in Order, Failing Clearly on a Missing One +#' +#' @param paths Character vector of files. +#' @param envir Environment to source into. +#' @return The paths, invisibly. +#' +#' @example # Example usage of the function +#' # source_all(c("a.R", "b.R"), globalenv()) +source_all <- function(paths, envir) { + absent <- paths[!file.exists(paths)] + + if (length(absent) > 0) { + stop( + "Framework files not found:\n ", + paste(absent, collapse = "\n "), + call. = FALSE + ) + } + + for (path in paths) { + source(path, local = envir) + } + + invisible(paths) +} + +# End of script ---- diff --git a/1_code/harness/model_sets.R b/1_code/harness/model_sets.R new file mode 100644 index 0000000..db11d9a --- /dev/null +++ b/1_code/harness/model_sets.R @@ -0,0 +1,459 @@ +# --- +# title: Candidate Model Sets +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - v2's candidate formulas, named so a spec can refer to a set. +# Stored as text, not formula objects, so no environment is +# captured. Candidates are updates (`. ~ . + MAP`) applied to a +# base formula that supplies the response. +# - Plant and mammal formulas are spliced verbatim from +# 0_data/v2_scripts/, not retyped; long lines are kept so they +# match v2 line for line. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the selection layer turns these into formulas. + +# 2. model_sets() ---- + +#' Named Candidate Model Sets +#' +#' @return A named list of character vectors of model formulas. +#' +#' @example # Example usage of the function +#' # names(model_sets()) +#' # model_sets()$climate_bird_mammal_v2 +model_sets <- function() { + # Shared by the v2 bird and mammal climate stages. The null is + # a candidate because v2 averages over it too; dropping it + # would shift every weight. + climate_bird_mammal_v2 <- c( + ". ~ .", + ". ~ . + FFP", + ". ~ . + MAP", + ". ~ . + CMD", + ". ~ . + TD", + ". ~ . + TD + FFP", + ". ~ . + MAP + CMD", + ". ~ . + TD + FFP + CMD", + ". ~ . + MAP + FFP + TD + CMD" + ) + + # As 06.ModelClimate.R assembles it: 25 candidates (null, 8 + # climate, 8 + linear space, 8 + quadratic space). Spatial terms + # are in metres, as in v2, hence coefficients near 1e-12. + spatial_linear <- "Easting + Northing + Easting:Northing" + spatial_quadratic <- "I(Easting^2) + I(Northing^2)" + + climate_bird_v2 <- c( + climate_bird_mammal_v2, + paste(climate_bird_mammal_v2[-1], "+", spatial_linear), + paste( + climate_bird_mammal_v2[-1], "+", spatial_linear, "+", + spatial_quadratic + ) + ) + + climate_plant_v2 <- c( + ". ~ .", + ". ~ . + PET", + ". ~ . + CMD", + ". ~ . + MAT", + ". ~ . + FFP", + ". ~ . + MAP + FFP", + ". ~ . + MAP + FFP + CMD", + ". ~ . + MAP + PET + CMD + MAPPET", + ". ~ . + MAT + MAP + CMD + CMDMAT", + ". ~ . + MAT + MAP", + ". ~ . + MWMT + TD", + ". ~ . + CMD + PET", + ". ~ . + MAT + MAT2 + MWMT + MWMT2", + ". ~ . + TD + FFP + MAT" + ) + + # v2 averages over 58 candidates, not the 14 above: each with + # and without bioclim, plus spatial versions of the ten + # (five base, five bioclim) without MAT, TD or PET (v2's + # `model.update.id`). The 14 alone give coefficients not + # comparable with the published ones. + spatial_targets <- c(1, 3, 5, 6, 7) + + bioclim_plant <- paste0( + climate_plant_v2, " + bio9 + bio15" + ) + + space_terms <- c( + "Easting + Northing", + "Easting + Northing + EastingNorthing", + paste( + "Easting + Northing + Easting2 + Northing2 +", + "EastingNorthing" + ) + ) + + spatial_bases <- c( + climate_plant_v2[spatial_targets], + bioclim_plant[spatial_targets] + ) + + climate_plant_v2_full <- c( + climate_plant_v2, + bioclim_plant, + as.vector(outer( + spatial_bases, space_terms, + function(model, space) paste0(model, " + ", space) + )) + ) + + # Fitted with ivw_grid, so a "coefficient" is an effect per + # habitat type, not a regression coefficient. Protocol (in the + # bryophyte and lichen variants only) is added by + # plant_group_spec(). + habitat_veg_plant_v2 <- c( + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + BlackSpruce + TreedFen + TreedSwamp + GraminoidFen + ShrubbyFen + ShrubbyBog + ShrubbySwamp + Marsh + Grass + Shrub + CCWhiteSpruceR + CCWhiteSpruce1 + CCWhiteSpruce234 + CCPineR + CCPine1234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Peatland + Mineral + Grass + Shrub + CCWhiteSpruceR + CCWhiteSpruce1 + CCWhiteSpruce234 + CCPineR + CCPine1234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Bog + TreedFen + + NonTreedFen + TreedSwamp + ShrubbySwamp + Marsh + Grass + Shrub + CCWhiteSpruceR + CCWhiteSpruce1 + CCWhiteSpruce234 + CCPineR + CCPine1234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Bog + Fen + TreedSwamp + ShrubbySwamp + Marsh + Grass + Shrub + CCWhiteSpruceR + CCWhiteSpruce1 + CCWhiteSpruce234 + CCPineR + CCPine1234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Bog + Fen + Swamp + Marsh + GrassShrub + CCWhiteSprucePineR + CCWhiteSprucePine1 + CCWhiteSprucePine234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + SoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Peatland + Mineral + GrassShrub + CCWhiteSprucePineR1234 + CCDecidMixedR1234 + HardLin + SoftLin + UrbIndWellsites + Crop + Pasture", + ". ~ . + Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Lowland + GrassShrub + CCWhiteSprucePineR1234 + CCDecidMixedR1234 + SoftLin + Alien", + ". ~ . + Climate + Upland + BlackSpruce + TreedFen + TreedSwamp + GraminoidFen + ShrubbyFen + ShrubbyBog + ShrubbySwamp + Marsh + Grass + Shrub + CCR1234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + Upland + Bog + Fen + Swamp + Marsh + Grass + Shrub + CCR1234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + Upland + Peatland + Swamp + Marsh + GrassShrub + CCR1234 + HardLin + SoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + ". ~ . + Climate + Upland + Peatland + Mineral + GrassShrub + CCR1234 + HardLin + SoftLin + UrbIndWellsites + Crop + Pasture", + ". ~ . + Climate + Upland + Lowland + GrassShrub + CCR1234 + SoftLin + Alien" + ) + + # The south set. paspen enters half of these, which is why + # the south prediction grid carries no column for it. + habitat_soil_plant_v2 <- c( + ". ~ . + Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + ". ~ . + Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbInd+ Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + ". ~ . + Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + ". ~ . + Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbIndWellsites + Cult + SoftLin + HardLin", + ". ~ . + Climate + Productive + Nonproductive + Other + Alien + SoftLin", + ". ~ . + Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + ". ~ . + Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + ". ~ . + Climate + Blowout + ClaySub + Loamy +RapidDrain + SandyLoam + ThinBreak + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + ". ~ . + Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + ". ~ . + Climate + Productive + Nonproductive + Other + UrbIndWellsites + Cult + SoftLin + HardLin + paspen", + ". ~ . + Climate + Productive + Nonproductive + Other + Alien + SoftLin + paspen" + ) + + # staged_bic walks the groups in order, each updating the + # previous group's winner, so group order is part of the model. + # Terms are source names; term_map() rewrites them to the + # dataset's block-suffixed names. + landcover_bird_north_v2 <- list( + Hab = c( + ". ~ . + vegc" + ), + Age = c( + ". ~ . + wtAge", + ". ~ . + wtAge + wtAge2", + ". ~ . + wtAge + wtAge2 + wtAge:isCon + wtAge2:isCon", + ". ~ . + wtAge + wtAge2 + wtAge:isUpCon + wtAge:isBogFen + wtAge2:isUpCon + wtAge2:isBogFen", + ". ~ . + wtAge + wtAge2 + wtAge:isMix + wtAge:isPine + wtAge:isWSpruce + wtAge:isBogFen + wtAge2:isMix + wtAge2:isPine + wtAge2:isWSpruce + wtAge2:isBogFen", + ". ~ . + wtAge05", + ". ~ . + wtAge05 + wtAge05:isCon", + ". ~ . + wtAge05 + wtAge05:isUpCon + wtAge05:isBogFen", + ". ~ . + wtAge05 + wtAge05:isMix + wtAge05:isPine + wtAge05:isWSpruce + wtAge05:isBogFen", + ". ~ . + wtAge05 + wtAge", + ". ~ . + wtAge05 + wtAge + wtAge05:isCon + wtAge:isCon", + ". ~ . + wtAge05 + wtAge + wtAge05:isUpCon + wtAge05:isBogFen + wtAge:isUpCon + wtAge:isBogFen", + ". ~ . + wtAge05 + wtAge + wtAge05:isMix + wtAge05:isPine + wtAge05:isWSpruce + wtAge05:isBogFen + wtAge:isMix + wtAge:isPine + wtAge:isWSpruce + wtAge:isBogFen" + ), + CC = c( + ". ~ . + fcc2" + ), + Contrast = c( + ". ~ . + road", + ". ~ . + road + mWell", + ". ~ . + road + mWell + mSoft", + ". ~ . + road + mWell + mEnSft + mTrSft", + ". ~ . + road + mWell + mEnSft + mTrSft + mSeism" + ), + ARU = c( + ". ~ . + method" + ), + Water = c( + ". ~ . + pWater_KM", + ". ~ . + pWater_KM + pWater2_KM" + ) + ) + + landcover_bird_south_v2 <- list( + Hab = c( + ". ~ . + soilc", + ". ~ . + soilc + paspen" + ), + Contrast = c( + ". ~ . + road", + ". ~ . + road + mWell", + ". ~ . + road + mWell + mSoft" + ), + ARU = c( + ". ~ . + method" + ), + Water = c( + ". ~ . + pWater_KM", + ". ~ . + pWater_KM + pWater2_KM" + ) + ) + + # Presence half of the v2 mammal hurdle (see + # modules/mammals/hurdle.R), 17 candidates selected on AICc. + # intercept_mammal_north_pa_v2 names each model's omitted + # reference category, which the intercept absorbs; the two + # vectors are parallel and must stay so. + habitat_mammal_north_pa_v2 <- c( + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBog + TreedFen + TreedSwamp + GrassHerb + Shrub + Marsh + ShrubbySwamp + ShrubbyBogFen + CCDecidR + CCDecid1 + CCDecid2 + CCMixedwoodR + CCMixedwood1 + CCMixedwood2 + CCPineR + CCPine1 + CCSpruceR + CCSpruce1 + CCSpruce2 + EnSoftLin + EnSeismic + TrSoftLin + TameP + RoughP + Well + RurUrbInd + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBog + TreedFen + TreedSwamp + GrassHerb + Shrub + Marsh + ShrubbySwamp + ShrubbyBogFen + CCDecidMixed + CCPine + CCSpruce + EnSoftLin + EnSeismic + TrSoftLin + TameP + RoughP + Well + RurUrbInd + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBog + TreedFen + TreedSwamp + GrassHerb + Shrub + Marsh + ShrubbySwamp + ShrubbyBogFen + CCDecidMixed + CCPine + CCSpruce + EnSoftLin + EnSeismic + TrSoftLin + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBog + TreedFen + TreedSwamp + GrassHerb + Shrub + Marsh + ShrubbySwamp + ShrubbyBogFen + CCDecidMixed + CCPine + CCSpruce + SoftLin + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBog + TreedFen + TreedSwamp + GrassHerb + Shrub + Marsh + ShrubbySwamp + ShrubbyBogFen + CCAll + SoftLin + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedBogFen + TreedSwamp + GrassHerb + Shrub + OpenWet + CCAll + SoftLin + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedWet + GrassShrub + OpenWet + CCDecidR + CCDecid1 + CCDecid2 + CCMixedwoodR + CCMixedwood1 + CCMixedwood2 + CCPineR + CCPine1 + CCSpruceR + CCSpruce1 + CCSpruce2 + SoftLin + seas_days + Climate", + ". ~ . + Decid + Mixedwood + Pine + Spruce + TreedWet + GrassShrub + OpenWet + CCDecidMixed + CCConif + SoftLin + seas_days + Climate", + ". ~ . + DecidMixed + UpCon + TreedWet + GrassShrub + OpenWet + CCDecidMixed + CCConif + SoftLin + seas_days + Climate", + ". ~ . + DecidMixed + UpCon + TreedWet + GrassShrub + OpenWet + CCAll + SoftLin + TameP + RoughP + Well + RurUrbInd + seas_days + Climate", + ". ~ . + DecidMixed + UpCon + TreedWet + GrassShrub + OpenWet + CCAll + SoftLin + seas_days + Climate", + ". ~ . + DecidMixed + UpCon + TreedWet + GrassShrub + OpenWet + Succ + seas_days + Climate", + ". ~ . + Upland + Lowland + CCAll + SoftLin + seas_days + Climate", + ". ~ . + TreedAll + OpenAll + Succ + seas_days + Climate", + ". ~ . + UplandForest + Lowland + GrassShrub + Succ + seas_days + Climate", + ". ~ . + Upland + Lowland + Succ + seas_days + Climate", + ". ~ . + Boreal + GrassShrub + Succ + seas_days + Climate" + ) + + intercept_mammal_north_pa_v2 <- c( + "Crop", "Crop", "Alien", "Alien", "Alien", "Alien", "Alien", "Alien", "Alien", "Crop", "Alien", "Alien", "Alien", "Alien", "Alien", "Alien", "Alien" + ) + + # The mammal south presence set, spliced from + # south-models/00_models.R: 15 soil and footprint models, then + # the same 15 with pAspen. Each names the category it leaves + # out, which the one-hot rule reports alongside. + mammal_south_base <- c( + "ClayWet + SandyLoam + RapidDrain + ThinBlow + WetlandMargin + RurUrbInd + Well + RoughP + TameP + Crop + EnSoftLinSeismic + TrSoftLin", + "ClayWet + SandyRapid + ThinBlow + WetlandMargin + RurUrbInd + Well + RoughP + TameP + Crop + EnSoftLinSeismic + TrSoftLin", + "SandyLoam + Nonproductive + WetlandMargin + RurUrbInd + Well + RoughP + TameP + Crop + EnSoftLinSeismic + TrSoftLin", + "WetlandMargin + RurUrbInd + Well + RoughP + TameP + Crop + EnSoftLinSeismic + TrSoftLin", + "ClayWet + SandyRapid + ThinBlow + WetlandMargin + RurUrbInd + Well + Cult + EnSoftLinSeismic + TrSoftLin", + "SandyLoam + Nonproductive + WetlandMargin + RurUrbInd + Well + Cult + EnSoftLinSeismic + TrSoftLin", + "WetlandMargin + RurUrbInd + Well + Cult + EnSoftLinSeismic + TrSoftLin", + "ClayWet + SandyRapid + ThinBlow + WetlandMargin + NonAgAlien + Cult + Succ", + "SandyLoam + Nonproductive + WetlandMargin + NonAgAlien + Cult + Succ", + "WetlandMargin + NonAgAlien + Cult + Succ", + "ClayWet + SandyRapid + ThinBlow + WetlandMargin + Alien + Succ", + "SandyLoam + Nonproductive + WetlandMargin + Alien + Succ", + "WetlandMargin + Alien + Succ", + "WetlandMargin + Alien", + "WetlandMargin" + ) + + habitat_mammal_south_pa_v2 <- c( + paste0(". ~ . + ", mammal_south_base, " + seas_days + Climate"), + paste0( + ". ~ . + ", mammal_south_base, " + pAspen + seas_days + Climate" + ) + ) + + intercept_mammal_south_pa_v2 <- rep( + c("Loamy", "Loamy", "Loamy", "AllNative", "Loamy", "Loamy", + "AllNative", "Loamy", "Loamy", "AllNative", "Loamy", "Loamy", + "AllNative", "AllNativeSucc", "AllExceptMargin"), + 2 + ) + + list( + climate_bird_mammal_v2 = climate_bird_mammal_v2, + climate_bird_v2 = climate_bird_v2, + climate_plant_v2_full = climate_plant_v2_full, + climate_plant_v2 = climate_plant_v2, + habitat_mammal_north_pa_v2 = habitat_mammal_north_pa_v2, + intercept_mammal_north_pa_v2 = + intercept_mammal_north_pa_v2, + habitat_mammal_south_pa_v2 = habitat_mammal_south_pa_v2, + intercept_mammal_south_pa_v2 = + intercept_mammal_south_pa_v2, + landcover_bird_north_v2 = landcover_bird_north_v2, + landcover_bird_south_v2 = landcover_bird_south_v2, + habitat_veg_plant_v2 = habitat_veg_plant_v2, + habitat_soil_plant_v2 = habitat_soil_plant_v2 + ) +} + +# 3. Building model sets ---- +# A stage's `models` is a model_sets() name or a vector of +# formulas. Covariates are loaded from the terms the formulas +# name, so no separate declaration is needed. + +## 3.1 extend_models() ---- + +#' Add Terms to Every Candidate in a Set +#' +#' For include/exclude comparisons: two runs then differ only by +#' these terms. +#' +#' @param models Character vector of formulas, or a name in +#' model_sets(). +#' @param terms Character vector of terms to add. +#' @param sets Named list of model sets. +#' @return A character vector of formulas. +#' +#' @example # Example usage of the function +#' # extend_models("climate_bird_mammal_v2", +#' # c("elevation", "slope")) +extend_models <- function(models, terms, sets = model_sets()) { + models <- get_model_set(models, sets) + + if (length(terms) == 0) { + return(models) + } + + paste0(models, " + ", paste(terms, collapse = " + ")) +} + +## 3.2 models_from_covariates() ---- + +#' Build a Candidate Set from a List of Covariates +#' +#' `form` is a modelling choice: +#' +#' - `single`: one model with every covariate. +#' - `each`: one model per covariate. +#' - `ladder`: cumulative, in the order given (order matters). +#' - `all_subsets`: every combination, capped by `max_subsets` +#' (ten covariates is 1,023 models per species per draw). +#' +#' @param covariates Character vector of covariate names. +#' @param form Character. One of the shapes above. +#' @param include_null Logical. Prepend the intercept-only model. +#' @param max_subsets Integer. Refuse `all_subsets` beyond this +#' many candidates. +#' @return A character vector of formulas. +#' +#' @example # Example usage of the function +#' # models_from_covariates(c("MAP", "FFP"), form = "ladder") +models_from_covariates <- function( + covariates, + form = c("single", "each", "ladder", "all_subsets"), + include_null = TRUE, + max_subsets = 256L +) { + form <- match.arg(form) + + if (length(covariates) == 0) { + stop("No covariates given.", call. = FALSE) + } + + combine <- function(terms) { + paste0(". ~ . + ", paste(terms, collapse = " + ")) + } + + models <- switch( + form, + single = combine(covariates), + each = vapply(covariates, combine, character(1)), + ladder = vapply( + seq_along(covariates), + function(i) combine(covariates[seq_len(i)]), + character(1) + ), + all_subsets = { + n <- length(covariates) + total <- 2^n - 1 + + if (total > max_subsets) { + stop( + n, " covariates make ", total, " subsets, past the cap ", + "of ", max_subsets, ". Every one is fitted for every ", + "species and every draw, so raise max_subsets ", + "deliberately or use a smaller set.", + call. = FALSE + ) + } + + unlist(lapply(seq_len(n), function(k) { + apply( + utils::combn(covariates, k), 2, combine + ) + })) + } + ) + + models <- unname(models) + + if (include_null) { + models <- c(". ~ .", models) + } + + unique(models) +} + +## 3.3 models_union() ---- + +#' One Formula Holding Every Covariate a Candidate Set Uses +#' +#' For engines that find their own variables, curvature and +#' interactions (e.g. boosted trees). `I(x^2)` and `a:b` +#' contribute x, a and b as main effects. +#' +#' @param models Character vector of formulas, a list of groups of +#' them (a staged set), or a name in model_sets(). +#' @param sets Named list of model sets. +#' @return One formula, as text, in update form (". ~ . + ..."). +#' +#' @example # Example usage of the function +#' # models_union("climate_bird_v2") +models_union <- function(models, sets = model_sets()) { + formulas <- unlist(get_model_set(models, sets), use.names = FALSE) + + terms <- unique(unlist(lapply(formulas, function(one) { + all.vars(stats::as.formula(one)) + }))) + terms <- setdiff(terms, c(".", "response", "offset", "weight")) + + if (length(terms) == 0) { + return(". ~ .") + } + + paste0(". ~ . + ", paste(terms, collapse = " + ")) +} + +# 4. get_model_set() ---- + +#' Look Up One Model Set +#' +#' @param name Character. A name in model_sets(), or a character +#' vector of formulas to use as given. +#' @param sets Named list of model sets. +#' @return A character vector of model formulas. +#' +#' @example # Example usage of the function +#' # get_model_set("climate_bird_mammal_v2") +get_model_set <- function(name, sets = model_sets()) { + # Most stages declare no intercept-category set + if (is.null(name) || length(name) == 0) { + return(NULL) + } + + if (length(name) > 1 || !name %in% names(sets)) { + return(name) + } + + sets[[name]] +} + +# End of script ---- diff --git a/1_code/harness/new_experiment.R b/1_code/harness/new_experiment.R new file mode 100644 index 0000000..4e5752a --- /dev/null +++ b/1_code/harness/new_experiment.R @@ -0,0 +1,341 @@ +# --- +# title: Scaffold a New Experiment +# author: Brendan Casey +# created: 2026-10-06 +# inputs: +# - 1_code/experiments/_template/, the run.R and README.md every +# experiment starts from +# - the exp_NNN_* folders already in 1_code/experiments/, +# 2_pipeline/ and 3_output/, which set the next number +# outputs: +# - 1_code/experiments//: run.R and README.md, from the +# template with the id, title, author and date filled in +# - 2_pipeline// and its logs/, for the gitignored +# intermediates +# - 3_output//: figures/, tables/ and a stub report.md +# notes: +# - Usage: +# source("1_code/harness/new_experiment.R") +# new_experiment("covariate scale") +# - The number is one past the highest exp_NNN in any of the +# three folders, and gaps are not reused, so a new experiment +# never shares stores with a removed one. +# - Base R only, so it runs without load_framework(). Empty +# folders get a .gitkeep so the structure is committed. +# --- + +# 1. Setup ---- +# Base R only; no packages to load. + +# 2. experiment_slug() ---- + +#' Turn an Experiment Description into its Folder-Name Slug +#' +#' @param description Character. A short description, e.g. +#' "Covariate scale". +#' @return Character. The snake_case slug, e.g. "covariate_scale". +#' +#' @example # Example usage of the function +#' # experiment_slug("SoilGrids 0-5 cm") +#' # #> "soilgrids_0_5_cm" +experiment_slug <- function(description) { + if (!is.character(description) || length(description) != 1L || + is.na(description)) { + stop("description must be a single string.", call. = FALSE) + } + + slug <- tolower(trimws(description)) + slug <- gsub("[^a-z0-9]+", "_", slug) + slug <- gsub("^_+|_+$", "", slug) + + if (!nzchar(slug)) { + stop( + "description has no letters or digits to name a folder.", + call. = FALSE + ) + } + + # The number is assigned here, so a user-supplied one would be + # doubled or contradicted + if (grepl("^exp_[0-9]{3}_", slug)) { + stop( + "Give the description without the exp_NNN_ prefix; ", + "the number is assigned for you.", + call. = FALSE + ) + } + + slug +} + +# 3. next_experiment_number() ---- + +#' Find the Next Free Experiment Number +#' +#' @param project_root Character. The repository root. +#' @return Integer. One past the highest exp_NNN folder in +#' 1_code/experiments/, 2_pipeline/ or 3_output/; 0 if there is +#' none. +#' +#' @example # Example usage of the function +#' # next_experiment_number(".") +#' # #> 3 +next_experiment_number <- function(project_root = ".") { + roots <- file.path( + project_root, c("1_code/experiments", "2_pipeline", "3_output") + ) + + folders <- unlist(lapply(roots[dir.exists(roots)], function(root) { + list.dirs(root, recursive = FALSE, full.names = FALSE) + })) + folders <- folders[grepl("^exp_[0-9]{3}_", folders)] + + if (length(folders) == 0) { + return(0L) + } + + number <- max(as.integer(substr(folders, 5, 7))) + 1L + + if (number > 999L) { + stop( + "Experiment numbers are three digits; 999 is taken.", + call. = FALSE + ) + } + + number +} + +# 4. new_experiment() ---- + +#' Scaffold a New Experiment's Folders +#' +#' Creates 1_code/experiments// from the template, +#' 2_pipeline// with logs/, and 3_output// with figures/, +#' tables/ and a stub report.md, where is +#' exp__ and NNN is the next free number. +#' +#' @param description Character. A short description of the +#' question; becomes the id's slug and the run.R title. +#' @param author Character or NULL. For the run.R header; NULL +#' reads `git config user.name`, then the system user. +#' @param project_root Character. The repository root. +#' @param template_dir Character or NULL. The template folder; +#' NULL for 1_code/experiments/_template. +#' @param dry_run Logical. TRUE reports the id and paths without +#' writing anything. +#' @param open Logical. Open the new run.R for editing. +#' @return A list, invisibly: `id`, `number`, `code_dir`, +#' `pipeline_dir` and `out_dir`. +#' +#' @example # Example usage of the function +#' # source("1_code/harness/new_experiment.R") +#' # new_experiment("covariate scale", dry_run = TRUE) +#' # #> exp_003_covariate_scale (dry run; nothing written) +new_experiment <- function( + description, + author = NULL, + project_root = getOption("sdm.project_root", "."), + template_dir = NULL, + dry_run = FALSE, + open = interactive() +) { + # Step 1: The id and where it goes + slug <- experiment_slug(description) + number <- next_experiment_number(project_root) + id <- sprintf("exp_%03d_%s", number, slug) + + template_dir <- template_dir %||% + file.path(project_root, "1_code", "experiments", "_template") + dirs <- c( + code_dir = file.path(project_root, "1_code", "experiments", id), + pipeline_dir = file.path(project_root, "2_pipeline", id), + out_dir = file.path(project_root, "3_output", id) + ) + out <- c(list(id = id, number = number), as.list(dirs)) + + # Step 2: Check everything before writing anything + if (!dir.exists(template_dir)) { + stop("Template folder not found: ", template_dir, call. = FALSE) + } + + taken <- dirs[dir.exists(dirs)] + + if (length(taken) > 0) { + stop( + "Already exists, so ", id, " cannot be created:\n ", + paste(taken, collapse = "\n "), + call. = FALSE + ) + } + + if (dry_run) { + cat(id, " (dry run; nothing written)\n ", + paste(dirs, collapse = "\n "), "\n", sep = "") + return(invisible(out)) + } + + author <- author %||% git_user_name(project_root) + + # Step 3: Remove what this call made if a later step fails, so + # a half-built experiment does not hold the number + created <- character(0) + done <- FALSE + on.exit( + if (!done) unlink(created, recursive = TRUE), + add = TRUE + ) + + for (dir in dirs) { + dir.create(dir, recursive = TRUE) + created <- c(created, dir) + } + + # Step 4: The code, from the template with its placeholders + # filled in + fill_template( + template_dir, dirs[["code_dir"]], + id = id, number = number, slug = slug, author = author + ) + + # Step 5: The pipeline and output structure + for (sub in c( + dirs[["pipeline_dir"]], + file.path(dirs[["pipeline_dir"]], "logs"), + file.path(dirs[["out_dir"]], "figures"), + file.path(dirs[["out_dir"]], "tables") + )) { + dir.create(sub, recursive = TRUE, showWarnings = FALSE) + file.create(file.path(sub, ".gitkeep")) + } + + writeLines( + c( + paste("#", id), + "", + "_Not yet run._ The question and design are in", + paste0("`1_code/experiments/", id, "/README.md`."), + "Write the result here, or replace this file with a report", + "step; `run_record.md` is written beside it on every run." + ), + file.path(dirs[["out_dir"]], "report.md") + ) + + done <- TRUE + + cat( + "Created ", id, "\n ", + paste(dirs, collapse = "\n "), "\n", + "Next:\n", + " 1. State the question and design in its README.md.\n", + " 2. Set the one change in its run.R.\n", + " 3. Run it at 5 draws to check it works, then at 100.\n", + sep = "" + ) + + if (open) { + utils::file.edit(file.path(dirs[["code_dir"]], "run.R")) + } + + invisible(out) +} + +## 4.1 fill_template() ---- + +#' Copy the Template, Filling its Placeholders +#' +#' Also drops the template run.R's note on starting an +#' experiment. +#' +#' @param template_dir Character. The template folder. +#' @param code_dir Character. The new experiment's code folder. +#' @param id,slug,author Character. The experiment's values. +#' @param number Integer. The experiment's number. +#' @return The files written, invisibly. +#' +#' @example # Example usage of the function +#' # fill_template("1_code/experiments/_template", +#' # "1_code/experiments/exp_003_covariate_scale", +#' # id = "exp_003_covariate_scale", number = 3L, +#' # slug = "covariate_scale", author = "B. Casey") +fill_template <- function(template_dir, code_dir, id, number, slug, + author) { + # "covariate_scale" -> "Covariate Scale" + words <- strsplit(slug, "_", fixed = TRUE)[[1]] + title <- paste0( + "Experiment ", sprintf("%03d", number), " - ", + paste0(toupper(substr(words, 1, 1)), substring(words, 2), + collapse = " ") + ) + + placeholders <- c( + "exp_NNN_short_description" = id, + "Experiment NNN - [Short Description]" = title, + "[Your Name]" = author, + "[YYYY-MM-DD]" = format(Sys.Date(), "%Y-%m-%d") + ) + + files <- list.files(template_dir, recursive = TRUE) + + for (file in files) { + text <- readLines(file.path(template_dir, file), warn = FALSE) + + for (key in names(placeholders)) { + text <- gsub(key, placeholders[[key]], text, fixed = TRUE) + } + + # The note bullet and its continuation lines + start <- grep("^# - Start an experiment with new_experiment", + text) + + if (length(start) == 1L) { + end <- start + while (end < length(text) && grepl("^# ", text[end + 1])) { + end <- end + 1L + } + text <- text[-(start:end)] + } + + target <- file.path(code_dir, file) + dir.create(dirname(target), recursive = TRUE, + showWarnings = FALSE) + writeLines(text, target) + } + + invisible(file.path(code_dir, files)) +} + +## 4.2 git_user_name() ---- + +#' The Author for a New Script's Header +#' +#' @param project_root Character. The repository root. +#' @return Character. `git config user.name`, or the system user +#' when git is unavailable or has no name set. +#' +#' @example # Example usage of the function +#' # git_user_name(".") +git_user_name <- function(project_root = ".") { + name <- tryCatch( + suppressWarnings(system2( + "git", c("-C", shQuote(project_root), "config", "user.name"), + stdout = TRUE, stderr = FALSE + )), + error = function(e) character(0) + ) + + if (length(name) == 1L && nzchar(trimws(name))) { + trimws(name) + } else { + Sys.info()[["user"]] + } +} + +## 4.3 %||% ---- +# Defined here only when missing, so the file can be sourced on +# its own; R >= 4.4 and the harness both provide it. +if (!exists("%||%", mode = "function")) { + `%||%` <- function(x, y) if (is.null(x)) y else x +} + +# End of script ---- diff --git a/1_code/harness/predict_grid.R b/1_code/harness/predict_grid.R new file mode 100644 index 0000000..5b9e5cf --- /dev/null +++ b/1_code/harness/predict_grid.R @@ -0,0 +1,213 @@ +# --- +# title: Project a Fitted Model onto a Prediction Grid +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# in the test dataset's lookup/ (see data_source.R): +# - _prediction_matrix.csv +# outputs: none; returns objects in memory +# notes: +# - A grid row is a pure stand of one habitat type, so +# predicting onto it gives the per-habitat effect v2 reports. +# Every engine can predict (a tree has no coefficients), so +# grids are how engines are compared. Bird grids are rebuilt +# by _setup/09 from v2's coefficient translation matrix. +# - v2's later coefficient adjustments (e.g. plant stand-age +# splines) are in the coefficients, not the grid. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup table reading (version: 1.16.4) + +# 2. load_prediction_grid() ---- + +#' Read a Prediction Grid +#' +#' @param data_dir Character. The test dataset folder. +#' @param name Character. Grid name, without the +#' `_prediction_matrix.csv` suffix, or NULL for no grid. +#' @return A data frame with habitat types as rownames, or NULL. +#' +#' @example # Example usage of the function +#' # grid <- load_prediction_grid(data_dir, "veg") +load_prediction_grid <- function(data_dir, name) { + if (is.null(name) || is.na(name)) { + return(NULL) + } + + path <- file.path( + data_dir, "lookup", paste0(name, "_prediction_matrix.csv") + ) + + if (!file.exists(path)) { + stop( + "Prediction grid not found:\n ", path, + call. = FALSE + ) + } + + grid <- as.data.frame(fread(path)) + + if (!"VegType" %in% names(grid)) { + stop( + basename(path), " has no VegType column, so its rows ", + "cannot be named.", + call. = FALSE + ) + } + + rownames(grid) <- grid$VegType + grid$VegType <- NULL + + grid +} + +# 3. predict_grid() ---- + +#' Predict a Selection's Final Model onto a Grid +#' +#' Columns come from the grid, then the stage's constants (v2 +#' holds Climate at zero and Protocol at the new protocol), then +#' zero. Uses the selection's own predictor, so an averaged or +#' combined model is projected as a whole. +#' +#' @param selected A selection result, carrying `predict`. +#' @param grid A prediction grid, from load_prediction_grid(). +#' @param constants Named list of values for columns held fixed +#' across the grid. +#' @param type Character. "response" or "link". +#' @return A named numeric vector, one value per grid row, or +#' NULL when the model cannot be predicted. +#' +#' @example # Example usage of the function +#' # predict_grid(selected, grid, constants = list(Climate = 0)) +predict_grid <- function( + selected, + grid, + constants = list(), + type = "response" +) { + if (is.null(grid) || !is.function(selected$predict)) { + return(NULL) + } + + newdata <- grid + + # Step 1: Hold the stage's constants + for (one in names(constants)) { + newdata[[one]] <- constants[[one]] + } + + # Step 2: Every column any candidate formula reads, at zero + # where the grid and the constants have none. A grid row is a + # pure stand, so a term it omits is absent rather than unknown. + formulas <- selected$formulas %||% list(selected$formula) + needed <- unique(unlist(lapply( + Filter(function(f) !is.null(f) && !identical(f, NA_character_), + formulas), + formula_variables + ))) + + for (one in setdiff(needed, names(newdata))) { + newdata[[one]] <- 0 + } + + # Step 3: An offset is a property of a survey, not of a habitat + # type, so a grid prediction is made without one + newdata$offset <- 0 + + predicted <- tryCatch( + selected$predict(newdata, type), + error = function(e) NULL + ) + + if (is.null(predicted) || length(predicted) != nrow(grid)) { + return(NULL) + } + + stats::setNames(as.numeric(predicted), rownames(grid)) +} + +# 4. predict_from_coefficients() ---- + +#' Predict from a Coefficient Vector Rather Than a Fit +#' +#' Carries a stage forward as v2 does: the averaged coefficients +#' applied to the data, `plogis(X %*% b)`, so the next stage sees +#' a probability. A single candidate's prediction would discard +#' the averaging; the link scale would change what the next +#' stage's coefficient means. +#' +#' @param coefficients A data frame of term and estimate. +#' @param data A data frame carrying those terms. +#' @param scale Character. "response" applies the logistic, which +#' is what v2 does; "link" leaves the linear predictor. +#' @return A numeric vector, one per row of `data`. +#' +#' @example # Example usage of the function +#' # predict_from_coefficients(selected$coefficients, frame) +predict_from_coefficients <- function( + coefficients, + data, + scale = c("response", "link") +) { + scale <- match.arg(scale) + + estimates <- stats::setNames( + coefficients$estimate, coefficients$term + ) + + # Engines name the intercept "(Intercept)"; v2's coefficient + # vectors call it "Intercept" and carry a column of ones. + names(estimates) <- sub( + "^\\(Intercept\\)$", "Intercept", + names(estimates) + ) + + data$Intercept <- 1 + terms <- names(estimates) + + # A term is a column, an interaction of columns (a:b), or an + # expression such as I(Easting^2), which v2's bird climate + # formulas use. Each is evaluated against the frame. + term_value <- function(term) { + if (term %in% names(data)) { + return(as.numeric(data[[term]])) + } + + if (grepl(":", term, fixed = TRUE)) { + pieces <- strsplit(term, ":", fixed = TRUE)[[1]] + return(Reduce(`*`, lapply(pieces, term_value))) + } + + if (startsWith(term, "I(")) { + return(as.numeric(eval(parse(text = term)[[1]], data))) + } + + NULL + } + + columns <- lapply(terms, term_value) + absent <- terms[vapply(columns, is.null, logical(1))] + + if (length(absent) > 0) { + stop( + "Cannot carry the stage forward: ", length(absent), + " term(s) are not columns of the frame:\n ", + paste(utils::head(absent, 10), collapse = "\n "), + call. = FALSE + ) + } + + linear <- drop(do.call(cbind, columns) %*% estimates) + + if (scale == "response") { + return(stats::plogis(linear)) + } + + linear +} + +# End of script ---- diff --git a/1_code/harness/registry.R b/1_code/harness/registry.R new file mode 100644 index 0000000..f8e6c73 --- /dev/null +++ b/1_code/harness/registry.R @@ -0,0 +1,395 @@ +# --- +# title: Method Registry +# author: Brendan Casey +# created: 2026-10-03 +# inputs: none +# outputs: none; holds the registered methods in memory +# notes: +# - Engines, selection rules, resamplers and metrics register +# here by name, so adding a method is one new file in +# 1_code/methods/ with no harness change. Re-sourcing a method +# file replaces its entry. +# - Selection rules declare the engine capabilities they need; +# validate_spec() (spec.R) checks them before any data is read. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +## 1.2 The registry ---- +# Created only if absent, so re-sourcing this file keeps +# registered methods +if (!exists(".sdm_registry", inherits = FALSE)) { + .sdm_registry <- new.env(parent = emptyenv()) +} + +for (.kind in c("engine", "selection", "resampler", "metric")) { + if (!exists(.kind, envir = .sdm_registry, inherits = FALSE)) { + assign(.kind, list(), envir = .sdm_registry) + } +} +rm(.kind) + +# 2. Registering ---- + +## 2.1 method_kinds() ---- + +#' The Kinds of Method the Registry Holds +#' +#' @return A named character vector: kind to a readable label. +#' +#' @example # Example usage of the function +#' # method_kinds() +method_kinds <- function() { + c( + engine = "fitting engine", + selection = "selection rule", + resampler = "resampling scheme", + metric = "metric" + ) +} + +## 2.2 engine_capabilities() ---- + +#' The Capabilities an Engine Can Declare +#' +#' - `coefficients`: the engine returns a table of term, estimate +#' and standard error. Needed by rules that average or read +#' coefficients, and by a stage carried forward through them. +#' - `ic`: the engine scores a fit with AIC, AICc or BIC. Needed +#' by every rule that ranks or weights candidates. +#' - `se`: the engine's predict() returns standard errors. Needed +#' by inverse-variance averaging. +#' - `converged`: the engine reports whether a fit converged. +#' Optional; a fit is assumed converged when it cannot say. +#' +#' @return A character vector. +#' +#' @example # Example usage of the function +#' # engine_capabilities() +engine_capabilities <- function() { + c("coefficients", "ic", "se", "converged") +} + +## 2.3 register_method() ---- + +#' Add One Method to the Registry +#' +#' @param kind Character. One of names(method_kinds()). +#' @param name Character. The name a spec uses. +#' @param value The method: a function, or for an engine a list. +#' @param description Character. One line on what it does. +#' @param requires Character vector of engine capabilities the +#' method needs. Used by selection rules. +#' @return The name, invisibly. +#' +#' @example # Example usage of the function +#' # register_method("metric", "auc", metric_auc, "Area under ROC") +register_method <- function( + kind, + name, + value, + description, + requires = character(0) +) { + if (!kind %in% names(method_kinds())) { + stop( + "Unknown method kind `", kind, "`. Kinds: ", + paste(names(method_kinds()), collapse = ", "), + call. = FALSE + ) + } + + if (!is.character(name) || length(name) != 1L || !nzchar(name)) { + stop("A method name must be one non-empty string.", call. = FALSE) + } + + if (!is.character(description) || length(description) != 1L) { + stop( + "Method `", name, "` needs a one-line description.", + call. = FALSE + ) + } + + unknown <- setdiff(requires, engine_capabilities()) + + if (length(unknown) > 0) { + stop( + "Method `", name, "` requires unknown capabilities: ", + paste(unknown, collapse = ", "), ". Known: ", + paste(engine_capabilities(), collapse = ", "), + call. = FALSE + ) + } + + entries <- get(kind, envir = .sdm_registry) + entries[[name]] <- list( + name = name, + value = value, + description = description, + requires = requires + ) + assign(kind, entries, envir = .sdm_registry) + + invisible(name) +} + +## 2.4 register_engine() ---- + +#' Register a Fitting Engine +#' +#' See 1_code/methods/README.md for the contract. +#' +#' @param engine A list with `name`, `description`, +#' `capabilities`, `fit`, `predict`, and `coef`/`ic` where +#' declared. +#' @return The engine name, invisibly. +#' +#' @example # Example usage of the function +#' # register_engine(engine_glm()) +register_engine <- function(engine) { + required <- c("name", "description", "capabilities", "fit", + "predict") + absent <- setdiff(required, names(engine)) + + if (length(absent) > 0) { + stop( + "An engine needs ", paste(absent, collapse = ", "), ".", + call. = FALSE + ) + } + + if ("coefficients" %in% engine$capabilities && + !is.function(engine$coef)) { + stop( + "Engine `", engine$name, "` declares `coefficients` but has ", + "no coef() function.", + call. = FALSE + ) + } + + if ("ic" %in% engine$capabilities && !is.function(engine$ic)) { + stop( + "Engine `", engine$name, "` declares `ic` but has no ic() ", + "function.", + call. = FALSE + ) + } + + register_method( + "engine", engine$name, engine, engine$description + ) +} + +## 2.5 register_selection() ---- + +#' Register a Selection Rule +#' +#' Rules take `models`, `base`, `data`, `engine`, `family`, +#' `weights`, `offset`, `ic` and `control` and return +#' selection_result(). Further arguments are filled from the +#' stage field of the same name. +#' +#' @param name Character. The name a spec uses. +#' @param fn The rule function. +#' @param description Character. One line. +#' @param requires Character vector of engine capabilities. +#' @return The name, invisibly. +#' +#' @example # Example usage of the function +#' # register_selection("aic_best", select_aic_best, +#' # "Lowest-scoring candidate", "ic") +register_selection <- function(name, fn, description, + requires = character(0)) { + core <- c("models", "base", "data", "engine", "family") + absent <- setdiff(core, names(formals(fn))) + + if (length(absent) > 0) { + stop( + "Selection rule `", name, "` must take ", + paste(absent, collapse = ", "), ".", + call. = FALSE + ) + } + + register_method("selection", name, fn, description, requires) +} + +## 2.6 register_resampler() ---- + +#' Register a Resampling Scheme +#' +#' Resamplers take `frame`, `iterations`, `seed`, `context` and +#' any settings from `spec$resample`, and return one vector of +#' survey unit ids per iteration. Units left out are scored +#' out-of-bag. +#' +#' @param name Character. The name a spec's `resample$scheme` +#' uses. +#' @param fn The resampler function. +#' @param description Character. One line. +#' @return The name, invisibly. +#' +#' @example # Example usage of the function +#' # register_resampler("spatial_block", resampler_spatial_block, +#' # "Bootstrap within spatial blocks") +register_resampler <- function(name, fn, description) { + core <- c("frame", "iterations", "seed", "context") + absent <- setdiff(core, names(formals(fn))) + + if (length(absent) > 0) { + stop( + "Resampler `", name, "` must take ", + paste(absent, collapse = ", "), ".", + call. = FALSE + ) + } + + register_method("resampler", name, fn, description) +} + +## 2.7 register_metric() ---- + +#' Register a Metric +#' +#' Metrics take response-scale `observed` and `predicted` and +#' return one number. +#' +#' @param name Character. The name metrics are reported under. +#' @param fn The metric function. +#' @param description Character. One line. +#' @return The name, invisibly. +#' +#' @example # Example usage of the function +#' # register_metric("rmse", metric_rmse, "Root mean squared error") +register_metric <- function(name, fn, description) { + if (!all(c("observed", "predicted") %in% names(formals(fn)))) { + stop( + "Metric `", name, "` must take `observed` and `predicted`.", + call. = FALSE + ) + } + + register_method("metric", name, fn, description) +} + +## 2.8 unregister_method() ---- + +#' Remove One Method from the Registry +#' +#' For tests and interactive development; a run never needs it. +#' +#' @param kind Character. One of names(method_kinds()). +#' @param name Character. The registered name. +#' @return The name, invisibly. +#' +#' @example # Example usage of the function +#' # unregister_method("metric", "my_test_metric") +unregister_method <- function(kind, name) { + entries <- get(kind, envir = .sdm_registry) + entries[[name]] <- NULL + assign(kind, entries, envir = .sdm_registry) + + invisible(name) +} + +# 3. Looking up ---- + +## 3.1 get_method() ---- + +#' Look Up One Registered Method +#' +#' @param kind Character. One of names(method_kinds()). +#' @param name Character. The registered name. +#' @param entry Logical. Return the whole entry (value, +#' description, requires) rather than the method itself. +#' @return The method, or its entry. +#' +#' @example # Example usage of the function +#' # get_method("selection", "aic_average") +get_method <- function(kind, name, entry = FALSE) { + entries <- get(kind, envir = .sdm_registry) + + if (!is.character(name) || length(name) != 1L || + !name %in% names(entries)) { + stop( + "Unknown ", method_kinds()[[kind]], " `", + paste(format(name), collapse = " "), "`. Registered: ", + if (length(entries) == 0) { + "none - has 1_code/methods/ been loaded?" + } else { + paste(names(entries), collapse = ", ") + }, + call. = FALSE + ) + } + + if (entry) entries[[name]] else entries[[name]]$value +} + +## 3.2 registered_names() ---- + +#' Names Registered for One Kind of Method +#' +#' @param kind Character. One of names(method_kinds()). +#' @return A character vector. +#' +#' @example # Example usage of the function +#' # registered_names("engine") +registered_names <- function(kind) { + names(get(kind, envir = .sdm_registry)) +} + +## 3.3 list_methods() ---- + +#' Show Every Registered Method +#' +#' @param kind Character, or NULL for every kind. +#' @return A data frame of kind, name, requires and description, +#' printed and returned invisibly. +#' +#' @example # Example usage of the function +#' # list_methods() +#' # list_methods("engine") +list_methods <- function(kind = NULL) { + kinds <- if (is.null(kind)) names(method_kinds()) else kind + + rows <- lapply(kinds, function(one) { + entries <- get(one, envir = .sdm_registry) + + if (length(entries) == 0) { + return(NULL) + } + + data.frame( + kind = one, + name = names(entries), + requires = vapply( + entries, + function(e) { + capabilities <- if (one == "engine") { + e$value$capabilities + } else { + e$requires + } + paste(capabilities, collapse = ", ") + }, + character(1) + ), + description = vapply( + entries, `[[`, character(1), "description" + ), + stringsAsFactors = FALSE, + row.names = NULL + ) + }) + + table <- do.call(rbind, rows) + print(table, row.names = FALSE, right = FALSE) + + invisible(table) +} + +# End of script ---- diff --git a/1_code/harness/resample.R b/1_code/harness/resample.R new file mode 100644 index 0000000..4503358 --- /dev/null +++ b/1_code/harness/resample.R @@ -0,0 +1,211 @@ +# --- +# title: Resampling - Seeds, Blocks and Dispatch +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - Shared resampling plumbing: seeding, spatial blocks, and +# resample_for_species(), which dispatches to a scheme in +# 1_code/methods/resampling/. Every scheme returns a list of +# survey unit id vectors, one per draw. +# - Seeds default to harness_seed(), not NULL. v2 set no seed, +# so parity with v2 can only be distributional (see the +# parity ledger in docs/framework_design.md). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup table reading (version: 1.16.4) + +# 2. Seeding ---- + +## 2.1 harness_seed() ---- + +#' The Default Random Seed +#' +#' Used unless a run sets its own seed. Deliberately departs from +#' v2, which seeded nothing and so does not reproduce itself. +#' +#' @return An integer. +#' +#' @example # Example usage of the function +#' # harness_seed() +harness_seed <- function() { + 20260909L +} + +## 2.2 species_seed() ---- + +#' Derive One Species' Seed from the Experiment's Base Seed +#' +#' A shared seed would give every species identical draws. A +#' per-species seed keeps them independent, as in v2, and stable +#' when other species are added to or dropped from a run. The +#' rolling hash stays below 2^53, so it is exact in double +#' precision on every platform. Region is left out of the key +#' because v2 draws once per species across the province. +#' +#' @param base Integer or NULL. The experiment's base seed. NULL +#' leaves the draw unseeded, which is what v2 did. +#' @param taxon Character. Taxon slug. +#' @param species Character. Species name. +#' @return An integer seed, or NULL when `base` is NULL. +#' +#' @example # Example usage of the function +#' # species_seed(20260909L, "lichen", "Physcia.adscendens") +#' # species_seed(NULL, "lichen", "Physcia.adscendens") # NULL +species_seed <- function(base, taxon, species) { + if (is.null(base)) { + return(NULL) + } + + if (!is.numeric(base) || length(base) != 1L || is.na(base)) { + stop("A base seed must be a single number.", call. = FALSE) + } + + modulus <- 2147483629 # largest prime below .Machine$integer.max + hash <- 0 + + for (code in utf8ToInt(paste(taxon, species, sep = "::"))) { + hash <- (hash * 31 + code) %% modulus + } + + as.integer((base + hash) %% modulus) +} + +## 2.3 with_seed() ---- + +#' Evaluate Code Under a Seed, Then Restore the Random State +#' +#' Restoring the caller's state keeps resampling from changing +#' any later random call in the session. +#' +#' @param seed Integer or NULL. NULL evaluates the code without +#' seeding. +#' @param code An expression. Evaluated lazily, after the seed is +#' set. +#' @return The value of `code`. +#' +#' @example # Example usage of the function +#' # with_seed(42, sample(10)) +with_seed <- function(seed, code) { + if (is.null(seed)) { + return(code) + } + + env <- globalenv() + had_state <- exists(".Random.seed", envir = env, inherits = FALSE) + old_state <- if (had_state) get(".Random.seed", envir = env) + old_kind <- RNGkind() + + on.exit({ + # Restore the generator first: setting it reseeds + suppressWarnings(do.call(RNGkind, as.list(old_kind))) + + if (had_state) { + assign(".Random.seed", old_state, envir = env) + } else if (exists(".Random.seed", envir = env, + inherits = FALSE)) { + rm(".Random.seed", envir = env) + } + }, add = TRUE) + + # Name R's default generator explicitly; a package (e.g. a + # parallel backend) may have switched the session's + set.seed( + seed, kind = "Mersenne-Twister", normal.kind = "Inversion", + sample.kind = "Rejection" + ) + + code +} + +# 3. spatial_blocks() ---- + +#' Cut Survey Units into Coarse Spatial Blocks +#' +#' Default cut points are the v2 plant grid. +#' +#' @param long,lat Numeric vectors of coordinates. +#' @param long_breaks,lat_breaks Numeric vectors of cut points. +#' @return A character vector of block labels, one per unit. +#' Plain letters (or `b1`, `b2`, ... beyond 26), not interval +#' notation, so labels are safe in regexes and file names. +#' +#' @example # Example usage of the function +#' # blocks <- spatial_blocks(frame$long, frame$lat) +#' # table(blocks) +spatial_blocks <- function( + long, + lat, + long_breaks = c(-121, -116, -112, -109), + lat_breaks = c(48, 51, 54, 57, 61) +) { + cells <- interaction( + droplevels(cut(long, long_breaks)), + droplevels(cut(lat, lat_breaks)), + sep = "::", + drop = TRUE + ) + + present <- unique(cells[!is.na(cells)]) + + if (length(present) > length(letters)) { + labels <- paste0("b", seq_along(present)) + } else { + labels <- letters[seq_along(present)] + } + + labels[match(cells, present)] +} + + +# 4. resample_for_species() ---- + +#' Draw the Resampling Sets for One Species +#' +#' Passes the scheme every `spec$resample` setting except +#' `scheme`, `seed` and `scope`, which the harness consumes. +#' +#' @param spec A taxon spec. +#' @param frame The one-species frame, one row per unit that can +#' be drawn. +#' @param iterations Integer vector. +#' @param data_dir Character. +#' @param seed Integer or NULL. This species' seed, from +#' species_seed(). NULL leaves the draw unseeded. +#' @param species Character. Names the stored draws where they +#' are kept per species. +#' @return A list of character vectors of survey unit ids. +#' +#' @example # Example usage of the function +#' # resample_for_species(spec, frame, 1:10, data_dir, +#' # seed = 123L, species = "Physcia.adscendens") +resample_for_species <- function( + spec, frame, iterations, data_dir, seed = NULL, species = NULL +) { + scheme <- get_method("resampler", spec$resample$scheme) + settings <- spec$resample[ + setdiff(names(spec$resample), c("scheme", "seed", "scope")) + ] + + context <- list( + data_dir = data_dir, + taxon = spec$taxon, + species = species, + spec = spec, + response_name = spec$response_name %||% "response" + ) + + do.call(scheme, c( + list( + frame = frame, iterations = iterations, seed = seed, + context = context + ), + settings + )) +} + +# End of script ---- diff --git a/1_code/harness/result.R b/1_code/harness/result.R new file mode 100644 index 0000000..6e44bd0 --- /dev/null +++ b/1_code/harness/result.R @@ -0,0 +1,390 @@ +# --- +# title: The Standard Result Object +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none; writes to the store directory it is given +# outputs: +# in the store directory: +# - grid_predictions.csv +# - unit_predictions.csv +# - coefficients.csv +# - metrics.csv +# - meta.json +# notes: +# - Every engine writes the same files, so comparison code reads +# only this contract. grid_predictions.csv compares any +# engines; coefficients.csv is written only when the engine +# has coefficients (v2 parity is checked there). +# - Rows are appended per draw, so a failure late in a long run +# loses little. Parallel species write headerless shards; +# merge_result_shards() appends them in queue order, matching +# a serial run byte for byte. +# - unit_predictions.csv is opt-in: it can reach gigabytes +# (birds) and nothing downstream reads it. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # fast appending writes (version: 1.16.4) + +# 2. result_store() ---- + +## 2.1 result_columns() ---- + +#' The Columns of Each Result File +#' +#' @return A named list of character vectors. +#' +#' @example # Example usage of the function +#' # result_columns()$metrics +result_columns <- function() { + list( + grid_predictions = c( + "species", "region", "boot", "grid_unit", "prediction" + ), + unit_predictions = c( + "species", "region", "boot", "survey_unit_id", "prediction", + "observed" + ), + coefficients = c( + "species", "region", "stage", "boot", "term", "estimate", "se" + ), + metrics = c("species", "region", "boot", "metric", "value") + ) +} + +## 2.2 result_store() ---- + +#' Open a Result Store +#' +#' @param dir Character. Directory to write into. +#' @param overwrite Logical. Remove existing result files first. +#' FALSE continues a run that stopped part way. +#' @param header Logical. Write a header line when a file is +#' started. FALSE for a shard, which is merged under one header. +#' @param unit_predictions Character. "none" writes no unit +#' predictions, "oob" only the units a draw left out, "all" +#' every unit. +#' @return A store object. +#' +#' @example # Example usage of the function +#' # store <- result_store("2_pipeline/exp_001/bryophyte") +result_store <- function( + dir, + overwrite = TRUE, + header = TRUE, + unit_predictions = c("none", "oob", "all") +) { + unit_predictions <- match.arg(unit_predictions) + dir.create(dir, recursive = TRUE, showWarnings = FALSE) + + files <- paste0(names(result_columns()), ".csv") + + if (overwrite) { + existing <- file.path(dir, c(files, "meta.json")) + file.remove(existing[file.exists(existing)]) + } + + structure( + list( + dir = dir, files = files, header = header, + unit_predictions = unit_predictions + ), + class = "result_store" + ) +} + +## 2.3 merge_result_shards() ---- + +#' Combine Shard Stores into One Store +#' +#' @param store A result_store() to write into, with a header. +#' @param shard_dirs Character vector of shard directories, in the +#' order their rows should appear. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # merge_result_shards(store, file.path(shards, species)) +merge_result_shards <- function(store, shard_dirs) { + columns <- result_columns() + + for (what in names(columns)) { + target <- file.path(store$dir, paste0(what, ".csv")) + parts <- file.path(shard_dirs, paste0(what, ".csv")) + parts <- parts[file.exists(parts)] + + if (length(parts) == 0) { + next + } + + # The header is written by fwrite itself, from an empty table, + # so its line ending matches the rows appended under it + if (!file.exists(target)) { + empty <- stats::setNames( + as.data.frame( + rep(list(character(0)), length(columns[[what]])) + ), + columns[[what]] + ) + fwrite(empty, target) + } + + for (part in parts) { + file.append(target, part) + } + } + + invisible(NULL) +} + +# 3. result_append() ---- + +#' Append Rows to One Result File +#' +#' @param store A result_store(). +#' @param what Character. One of the store's file names, without +#' the extension. +#' @param rows A data frame. Nothing is written when it is NULL +#' or empty. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # result_append(store, "metrics", metric_rows) +result_append <- function(store, what, rows) { + if (is.null(rows) || nrow(rows) == 0) { + return(invisible(NULL)) + } + + path <- file.path(store$dir, paste0(what, ".csv")) + started <- file.exists(path) + + # Header on first write only; shards have none + fwrite( + rows, path, append = started, + col.names = store$header && !started, na = "" + ) + + invisible(NULL) +} + +# 4. Writers ---- + +## 4.1 write_grid_predictions() ---- + +#' Record Predictions onto the Prediction Grid +#' +#' @param store A result_store(). +#' @param species,region Character. What was fitted. +#' @param boot Integer. Resampling iteration. +#' @param grid_unit Character vector of prediction grid row names +#' (habitat types). +#' @param prediction Numeric vector, on the response scale. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # write_grid_predictions(store, "ALFL", "north", 1, +#' # rownames(pm), preds) +write_grid_predictions <- function( + store, species, region, boot, grid_unit, prediction +) { + result_append(store, "grid_predictions", data.frame( + species = species, + region = region, + boot = as.integer(boot), + grid_unit = as.character(grid_unit), + prediction = as.numeric(prediction), + stringsAsFactors = FALSE + )) +} + +## 4.2 write_unit_predictions() ---- + +#' Record Predictions at Survey Units +#' +#' @param store A result_store(). +#' @param species,region Character. +#' @param boot Integer. +#' @param survey_unit_id Character vector. +#' @param prediction,observed Numeric vectors. +#' @param in_bag Logical vector, TRUE where the unit was in the +#' draw. Used when the store keeps out-of-bag units only. +#' @return NULL, invisibly. Nothing is written when the store's +#' `unit_predictions` is "none". +#' +#' @example # Example usage of the function +#' # write_unit_predictions(store, "ALFL", "north", 1, ids, +#' # preds, obs) +write_unit_predictions <- function( + store, species, region, boot, survey_unit_id, prediction, + observed, in_bag = NULL +) { + if (store$unit_predictions == "none") { + return(invisible(NULL)) + } + + # Only the held-out units, where the run asks for those alone + if (store$unit_predictions == "oob" && !is.null(in_bag)) { + keep <- !in_bag + survey_unit_id <- survey_unit_id[keep] + prediction <- prediction[keep] + observed <- observed[keep] + } + + result_append(store, "unit_predictions", data.frame( + species = species, + region = region, + boot = as.integer(boot), + survey_unit_id = as.character(survey_unit_id), + prediction = as.numeric(prediction), + observed = as.numeric(observed), + stringsAsFactors = FALSE + )) +} + +## 4.3 write_coefficients() ---- + +#' Record Coefficients, Where the Engine Has Them +#' +#' @param store A result_store(). +#' @param species,region Character. +#' @param boot Integer. +#' @param coefficients A data frame of term, estimate and se, or +#' NULL for an engine that has none. +#' @param stage Character. The stage the coefficients came from; +#' every stage is recorded, not only the last. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # write_coefficients(store, "ALFL", "north", 1, coefs, +#' # stage = "climate") +write_coefficients <- function( + store, species, region, boot, coefficients, stage = NA_character_ +) { + if (is.null(coefficients) || nrow(coefficients) == 0) { + return(invisible(NULL)) + } + + result_append(store, "coefficients", data.frame( + species = species, + region = region, + stage = as.character(stage), + boot = as.integer(boot), + term = as.character(coefficients$term), + estimate = as.numeric(coefficients$estimate), + se = as.numeric(coefficients$se), + stringsAsFactors = FALSE + )) +} + +## 4.4 write_metrics() ---- + +#' Record Scores +#' +#' @param store A result_store(). +#' @param species,region Character. +#' @param boot Integer. +#' @param metrics A data frame of metric and value, from +#' compute_metrics(). +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # write_metrics(store, "ALFL", "north", 1, scores) +write_metrics <- function(store, species, region, boot, metrics) { + if (is.null(metrics) || nrow(metrics) == 0) { + return(invisible(NULL)) + } + + result_append(store, "metrics", data.frame( + species = species, + region = region, + boot = as.integer(boot), + metric = as.character(metrics$metric), + value = as.numeric(metrics$value), + stringsAsFactors = FALSE + )) +} + +## 4.5 write_meta() ---- + +#' Record What a Run Was +#' +#' Hand-written JSON, not jsonlite, to keep the harness to base R +#' plus data.table. +#' +#' @param store A result_store(). +#' @param meta A named list of scalars and character vectors. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # write_meta(store, list(engine = "glm", boot_n = 100)) +write_meta <- function(store, meta) { + escape <- function(x) { + x <- gsub("\\\\", "\\\\\\\\", as.character(x)) + x <- gsub('"', '\\\\"', x) + gsub("[\r\n]+", " ", x) + } + + render <- function(value) { + if (is.null(value) || length(value) == 0) { + return("null") + } + + if (is.numeric(value) && length(value) == 1 && + is.finite(value)) { + return(format(value, scientific = FALSE)) + } + + if (is.logical(value) && length(value) == 1 && !is.na(value)) { + return(if (value) "true" else "false") + } + + if (length(value) > 1) { + return(paste0( + "[", paste0('"', escape(value), '"', collapse = ", "), "]" + )) + } + + paste0('"', escape(value), '"') + } + + lines <- vapply( + names(meta), + function(name) { + paste0(' "', escape(name), '": ', render(meta[[name]])) + }, + character(1) + ) + + writeLines( + c("{", paste(lines, collapse = ",\n"), "}"), + file.path(store$dir, "meta.json") + ) + + invisible(NULL) +} + +# 5. read_results() ---- + +#' Read a Result Store Back +#' +#' A missing file returns NULL: an engine without coefficients +#' writes none. +#' +#' @param dir Character. A store directory. +#' @param what Character. Which file, without the extension. +#' @return A data frame, or NULL when the file is absent. +#' +#' @example # Example usage of the function +#' # read_results("2_pipeline/exp_001/bryophyte", "metrics") +read_results <- function(dir, what) { + path <- file.path(dir, paste0(what, ".csv")) + + if (!file.exists(path)) { + return(NULL) + } + + as.data.frame(fread(path)) +} + +# End of script ---- diff --git a/1_code/harness/run_model.R b/1_code/harness/run_model.R new file mode 100644 index 0000000..9c1c8de --- /dev/null +++ b/1_code/harness/run_model.R @@ -0,0 +1,1215 @@ +# --- +# title: Run Taxon Specs +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# specs from 1_code/modules//spec.R +# the harmonized test dataset +# outputs: +# in each run directory, one result store per region; see +# result.R +# notes: +# - The spec-driven loop; names no taxon. prepare_spec() loads +# each region once; fit_species() is the unit of (parallel) +# work; merge_spec_shards() joins shards in queue order. +# - Stages run in order; `carry_as` passes a stage's prediction +# forward (v2's `Climate` term). +# - Per-species seeds make parallel and serial runs identical. +# - A failed species or draw is logged and the run continues. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# parallel (base R), when `workers` is above 1. + +# 2. run_specs() and run_spec() ---- + +## 2.1 run_specs() ---- + +#' Run Several Specs Through One Pool of Workers +#' +#' Every species of every spec is one job, so few species per +#' taxon still keeps every worker busy. +#' +#' @param specs A named list of taxon specs. The names name the +#' runs, and so the folders under `pipeline_dir`. +#' @param data_dir Character. The test dataset folder. +#' @param pipeline_dir Character. Each spec writes to +#' `pipeline_dir///`. +#' @param species Character vector of focal species, named by +#' taxon (see taxon_values()), or NULL for every species each +#' spec's queue declares. +#' @param regions Character vector of regions to run, or NULL for +#' all each spec defines. +#' @param iterations Integer vector of resampling iterations. +#' @param stage_models Named list of replacement candidate sets, +#' or NULL; see apply_stage_models(). +#' @param metrics Character vector of metric names, or NULL for +#' default_metrics(). +#' @param boot_seed Integer or NULL. The base seed; NULL falls +#' back to `spec$resample$seed`, then to unseeded (as v2). +#' @param workers Integer. Species fitted at once. 1 runs in this +#' session; more start background R sessions. +#' @param unit_predictions Character. "none", "oob" or "all"; see +#' result_store(). +#' @param verbose Logical. Report progress. +#' @return A data frame, one row per spec, species, region and +#' draw, recording what happened. +#' +#' @example # Example usage of the function +#' # run_specs(list(lichen = lichen_spec()), data_dir, +#' # "2_pipeline/exp_001", iterations = 1:5, workers = 4) +run_specs <- function( + specs, + data_dir, + pipeline_dir, + species = NULL, + regions = NULL, + iterations = 1:100, + stage_models = NULL, + metrics = NULL, + boot_seed = NULL, + workers = 1L, + unit_predictions = c("none", "oob", "all"), + verbose = TRUE +) { + unit_predictions <- match.arg(unit_predictions) + + if (is.null(names(specs)) || any(!nzchar(names(specs)))) { + stop("`specs` must be a named list; the names name the runs.", + call. = FALSE) + } + + # Step 1: Prepare every spec first, so a bad spec fails early + prepared <- lapply(stats::setNames(names(specs), names(specs)), + function(key) { + prepare_spec( + spec = specs[[key]], key = key, data_dir = data_dir, + run_dir = file.path(pipeline_dir, key), species = species, + regions = regions, iterations = iterations, + stage_models = stage_models, metrics = metrics, + boot_seed = boot_seed, unit_predictions = unit_predictions + ) + }) + + # Step 2: One job per spec and species + jobs <- unlist(lapply(prepared, function(p) { + lapply(p$species, function(one) list(key = p$key, species = one)) + }), recursive = FALSE) + + if (verbose) { + cat( + "Fitting ", length(jobs), " species across ", length(specs), + " spec(s), ", length(iterations), " draw(s) each, on ", + workers, " worker(s)\n", + sep = "" + ) + } + + logs <- run_jobs(jobs, prepared, workers, verbose) + + # Step 3: Join each spec's shards into its region stores + for (p in prepared) { + merge_spec_shards(p) + } + + log <- do.call(rbind, logs) + rownames(log) <- NULL + + log +} + +## 2.2 run_spec() ---- + +#' Run One Spec +#' +#' run_specs() for a single spec, writing to `run_dir//`. +#' +#' @param spec A taxon spec. +#' @param data_dir Character. The test dataset folder. +#' @param run_dir Character. Where the region stores go. +#' @param ... Passed to run_specs(): species, regions, +#' iterations, stage_models, metrics, boot_seed, workers, +#' unit_predictions, verbose. +#' @return As run_specs(). +#' +#' @example # Example usage of the function +#' # run_spec(bryophyte_spec(), data_dir, run_dir, +#' # species = c("Aulacomnium.palustre"), +#' # iterations = 1:5) +run_spec <- function(spec, data_dir, run_dir, ...) { + run_specs( + specs = stats::setNames(list(spec), basename(run_dir)), + data_dir = data_dir, + pipeline_dir = dirname(run_dir), + ... + ) +} + +# 3. Preparing a spec ---- + +## 3.1 prepare_spec() ---- + +#' Check a Spec and Load What Its Regions Need +#' +#' @param spec A taxon spec. +#' @param key Character. The run's name. +#' @param data_dir,run_dir Character. +#' @param species,regions,iterations,stage_models,metrics,boot_seed +#' As in run_specs(). +#' @param unit_predictions Character. +#' @return A list: the spec, its regions (each with its data, +#' grid and species), the province-wide data, the species to +#' fit, and the run settings a worker needs. +#' +#' @example # Example usage of the function +#' # p <- prepare_spec(lichen_spec(), "lichen", data_dir, run_dir) +prepare_spec <- function( + spec, key, data_dir, run_dir, species = NULL, regions = NULL, + iterations = 1:100, stage_models = NULL, metrics = NULL, + boot_seed = NULL, unit_predictions = "none" +) { + # Before any read, so covariates follow the replacement sets + spec <- apply_stage_models(spec, stage_models) + + validate_spec(spec) + + # The experiment's seed wins over the spec's + base_seed <- boot_seed %||% spec$resample$seed + + # Step 1: The species. Named species are validated against the + # whole taxon, then intersected per region (a species may be + # modelled in one region only). + species <- taxon_values(species, spec$taxon) %||% species + + if (!is.null(species)) { + species <- unname(species) + resolve_species(species, data_dir, spec$taxon, tier = spec$tier) + } + + regions <- regions %||% names(spec$regions) + unknown_regions <- setdiff(regions, names(spec$regions)) + + if (length(unknown_regions) > 0) { + stop( + "Spec for ", spec$taxon, " defines no region(s) ", + paste(unknown_regions, collapse = ", "), ". Regions: ", + paste(names(spec$regions), collapse = ", "), + call. = FALSE + ) + } + + named_regions <- stats::setNames(regions, regions) + region_species <- lapply(named_regions, function(r) { + available <- list_species( + data_dir, spec$taxon, region = r, tier = spec$tier, + season = spec$season + ) + + if (is.null(species)) available else intersect(available, species) + }) + + all_species <- unique(unlist(region_species, use.names = FALSE)) + + # Step 2: Each region's stages, data and grid, loaded once + prepared_regions <- lapply( + regions[lengths(region_species[regions]) > 0], + function(r) { + prepare_region(spec, r, region_species[[r]], data_dir) + } + ) + names(prepared_regions) <- vapply( + prepared_regions, `[[`, character(1), "name" + ) + + list( + key = key, + spec = spec, + data_dir = data_dir, + run_dir = run_dir, + shard_dir = file.path(run_dir, "_shards"), + regions = prepared_regions, + province = province_context(spec, data_dir, all_species), + species = all_species, + iterations = iterations, + base_seed = base_seed, + metrics = metrics, + unit_predictions = unit_predictions + ) +} + +## 3.2 prepare_region() ---- + +#' Resolve One Region's Stages and Load Its Data and Grid +#' +#' A stage with no models takes the region's (veg in the north, +#' soil in the south). Formula terms are rewritten to the +#' dataset's block-suffixed names (see term_map()). +#' +#' @param spec A taxon spec. +#' @param region Character. +#' @param species Character vector of the region's species. +#' @param data_dir Character. +#' @return A list of the region's name, spec (with resolved +#' stages), species, model data, grid, grid name, weight column +#' and covariates. +#' +#' @example # Example usage of the function +#' # prepare_region(lichen_spec(), "north", "Physcia.adscendens", +#' # data_dir) +prepare_region <- function(spec, region, species, data_dir) { + region_spec <- spec$regions[[region]] + rename <- term_map( + data_dir, spec$taxon, region, block = region_spec$term_block + ) + + # Step 1: The stages, with the region's models where a stage + # takes them, and every formula in the dataset's names + spec$stages <- lapply(spec$stages, function(stage) { + if (is.null(stage$models)) { + # Plus what goes with them: reference categories, + # constants, and columns the age splines read + stage$models <- region_spec$habitat_models + stage$intercept_cats <- region_spec$intercept_cats %||% + stage$intercept_cats + stage$constants <- region_spec$constants %||% stage$constants + stage$extra_covariates <- c( + stage$extra_covariates, region_spec$extra_covariates + ) + + # Terms held fixed on the grid can be added per region: v2 + # predicts the south at pAspen = 0. + if (!is.null(region_spec$grid_constants)) { + stage$grid_constants <- c( + stage$grid_constants %||% list(), + region_spec$grid_constants + ) + } + } + + stage$models <- apply_term_map( + get_model_set(stage$models), rename + ) + + stage + }) + + # Step 2: The columns to load + weight_column <- region_spec$weight_column %||% spec$weight_column + covariates <- covariate_request( + spec, spec_covariates(spec), region_spec$filter + ) + + # Step 3: Load once for the region; species are cut from it + model_data <- build_model_data( + taxon = spec$taxon, + data_dir = data_dir, + species = species, + covariates = covariates, + region = region, + region_filter = region_spec$filter, + weight_column = weight_column, + aliases = spec$aliases %||% list(), + covariate_files = spec$covariate_files + ) + + # Step 4: The grid (the spec's, else the manifest's). Columns + # are renamed to the data's names; row names stay as v2 wrote + # them. + grid_name <- region_spec$grid %||% + manifest_entry(data_dir, spec$taxon, region)$grid + grid <- load_prediction_grid(data_dir, grid_name) + + if (!is.null(grid)) { + names(grid) <- apply_term_map(names(grid), rename) + + # e.g. v2 drops the mammal north's WetlandMargin and Climate + grid <- grid[ + !rownames(grid) %in% region_spec$grid_drop_rows, + !names(grid) %in% region_spec$grid_drop_cols, + drop = FALSE + ] + } + + list( + name = region, + spec = spec, + species = species, + model_data = model_data, + grid = grid, + grid_name = grid_name, + weight_column = weight_column, + covariates = covariates + ) +} + +## 3.3 province_context() ---- + +#' Assemble the Province-Wide Data a Spec's Province Scope Needs +#' +#' v2 fits plant and bird climate stages, and draws the plant +#' bootstrap, province-wide; only habitat is per region. Specs +#' declare this with `scope = "province"`. Loads the unfiltered +#' data once per spec. +#' +#' @param spec A taxon spec, with stage models already resolved. +#' @param data_dir Character. +#' @param species Character vector of the species to model. +#' @return A list of `model_data`, `stages` and `draws`, or NULL +#' when the spec has no province scope. +#' +#' @example # Example usage of the function +#' # province_context(spec, data_dir, c("Physcia.adscendens")) +province_context <- function(spec, data_dir, species) { + province_stages <- Filter( + function(s) identical(s$scope, "province"), spec$stages + ) + province_draws <- identical(spec$resample$scope, "province") + + if ((length(province_stages) == 0 && !province_draws) || + length(species) == 0) { + return(NULL) + } + + # Province stages run first, so cannot carry from region stages + for (stage in province_stages) { + if (!is.null(stage$carry_from) || is.null(stage$models)) { + stop( + "Stage `", stage$name, "` has province scope, so it must ", + "come first and name its own models.", + call. = FALSE + ) + } + } + + stage_names <- vapply(province_stages, `[[`, character(1), "name") + covariates <- if (length(stage_names) > 0) { + spec_covariates(spec, stage_names = stage_names) + } else { + character(0) + } + + # v2's redraw rule evaluates region filters on this frame + filters <- lapply(spec$regions, `[[`, "filter") + covariates <- covariate_request(spec, covariates, filters) + + list( + model_data = build_model_data( + taxon = spec$taxon, + data_dir = data_dir, + species = species, + covariates = covariates, + region = NULL, + region_filter = NULL, + weight_column = NULL, + aliases = spec$aliases %||% list(), + covariate_files = spec$covariate_files + ), + stages = province_stages, + draws = province_draws + ) +} + +## 3.4 covariate_request() ---- + +#' The Columns to Load, Given the Covariates the Formulas Name +#' +#' Adds the stored-draw key and region-filter columns; drops +#' aliases and site fields, which do not come from +#' covariates.csv. +#' +#' @param spec A taxon spec. +#' @param covariates Character vector from spec_covariates(). +#' @param filters A one-sided formula, a list of them, or NULL. +#' @return A character vector of covariate names. +#' +#' @example # Example usage of the function +#' # covariate_request(spec, spec_covariates(spec), ~ useNorth == 1) +covariate_request <- function(spec, covariates, filters = NULL) { + if (inherits(filters, "formula")) { + filters <- list(filters) + } + + filter_terms <- unlist(lapply(filters, function(one) { + if (is.null(one)) character(0) else all.vars(one) + })) + + covariates <- setdiff( + covariates, c(names(spec$aliases), unlist(spec$aliases)) + ) + + unique(c( + covariates, + spec$resample$id_column, + setdiff(filter_terms, c(site_columns(), "survey_unit_id")) + )) +} + +# 4. Fitting one species ---- + +## 4.1 run_jobs() ---- + +#' Fit Every Job, in This Session or in Parallel +#' +#' In parallel, jobs are handed out as workers free up, so a +#' slow species does not hold up the rest. +#' +#' @param jobs List of `key` and `species` pairs. +#' @param prepared Named list of prepare_spec() results. +#' @param workers Integer. +#' @param verbose Logical. +#' @return A list of log data frames, one per job, in job order. +#' +#' @example # Example usage of the function +#' # run_jobs(jobs, prepared, workers = 4) +run_jobs <- function(jobs, prepared, workers = 1L, verbose = TRUE) { + if (workers <= 1L || length(jobs) <= 1L) { + return(lapply(jobs, function(job) { + log <- fit_species(job$species, prepared[[job$key]]) + if (verbose) cat(".") + log + })) + } + + project_root <- getOption("sdm.project_root") + + if (is.null(project_root)) { + stop("Parallel runs need load_framework() to have been ", + "called, so workers can load it too.", call. = FALSE) + } + + # Step 1: Start the workers and load the framework + cluster <- parallel::makePSOCKcluster(min(workers, length(jobs))) + on.exit(parallel::stopCluster(cluster), add = TRUE) + + parallel::clusterCall(cluster, load_worker, project_root) + + # Step 2: Each job carries only its own spec's prepared data + tasks <- lapply(jobs, function(job) { + list(species = job$species, prepared = prepared[[job$key]]) + }) + + parallel::clusterApplyLB(cluster, tasks, fit_species_worker) +} + +## 4.2 load_worker() ---- + +#' Load the Framework in a Background Session +#' +#' @param project_root Character. The repository root. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # parallel::clusterCall(cluster, load_worker, root) +load_worker <- function(project_root) { + session <- globalenv() + + source( + file.path(project_root, "1_code", "harness", "harness.R"), + local = session + ) + load <- get("load_framework", envir = session) + load(project_root, envir = session) + + invisible(NULL) +} + +## 4.3 fit_species_worker() ---- + +#' Fit One Job in a Background Session +#' +#' Self-contained, so a worker needs only the job. +#' +#' @param task List of `species` and `prepared`. +#' @return The job's log data frame. +#' +#' @example # Example usage of the function +#' # fit_species_worker(task) +fit_species_worker <- function(task) { + get("fit_species", envir = globalenv())(task$species, task$prepared) +} + +## 4.4 fit_species() ---- + +#' Fit One Species in Every Region of a Spec +#' +#' Writes a shard store per region. Province-wide draws and +#' stage fits are made once and shared by the regions. +#' +#' @param species Character. +#' @param p A prepare_spec() result. +#' @return A data frame, one row per region and draw. +#' +#' @example # Example usage of the function +#' # fit_species("Physcia.adscendens", prepared$lichen) +fit_species <- function(species, p) { + spec <- p$spec + seed <- species_seed(p$base_seed, spec$taxon, species) + logs <- list() + + log_all <- function(region, status, note) { + data.frame( + taxon = spec$taxon, species = species, region = region, + boot = as.integer(p$iterations), status = status, note = note, + stringsAsFactors = FALSE + ) + } + + # Step 1: Province-wide frame and draws, if any. A species + # whose draws cannot be made is logged and skipped. + province <- NULL + province_fits <- list() + + if (!is.null(p$province)) { + province <- list(frame = model_frame( + p$province$model_data, species = species, + transform = spec$response_transform %||% "identity" + )) + + if (p$province$draws) { + province$draws <- tryCatch( + resample_for_species( + spec, province$frame, p$iterations, p$data_dir, + seed = seed, species = species + ), + error = function(e) conditionMessage(e) + ) + } + } + + for (region in p$regions) { + if (!species %in% region$species) { + next + } + + shard <- result_store( + file.path(p$shard_dir, region$name, safe_name(species)), + header = FALSE, unit_predictions = p$unit_predictions + ) + + frame <- model_frame( + region$model_data, species = species, + transform = spec$response_transform %||% "identity", + weight_column = region$weight_column + ) + + # Per-species columns (e.g. mammal precomputed climate) + if (is.function(spec$species_frame)) { + frame <- spec$species_frame(frame, species, p$data_dir, spec) + } + + # Step 2: The draws. Province-wide draws are filtered to the + # region's units when fitted, as v2 subsets them. + draws <- if (!is.null(province$draws)) { + province$draws + } else { + tryCatch( + resample_for_species( + spec, frame, p$iterations, p$data_dir, + seed = seed, species = species + ), + error = function(e) conditionMessage(e) + ) + } + + if (is.character(draws)) { + logs[[region$name]] <- log_all( + region$name, "resample_failed", draws + ) + next + } + + # Step 3: Every draw, fitting province stages once per draw + outcomes <- lapply(seq_along(p$iterations), function(i) { + boot <- p$iterations[i] + fixed <- NULL + + if (!is.null(province) && length(p$province$stages) > 0) { + key <- as.character(boot) + + if (is.null(province_fits[[key]])) { + province_fits[[key]] <<- fit_province_stages( + p$province$stages, province$frame, draws[[i]], spec, + species + ) + } + + fixed <- province_fits[[key]] + } + + run_one_draw( + spec = region$spec, frame = frame, draw = draws[[i]], + store = shard, species = species, region = region$name, + boot = boot, grid = region$grid, metrics = p$metrics, + fixed = fixed, + validation_frame = province$frame + ) + }) + + logs[[region$name]] <- do.call(rbind, outcomes) + } + + do.call(rbind, logs) +} + +## 4.5 fit_province_stages() ---- + +#' Fit the Province-Scope Stages on One Draw +#' +#' @param stages List of province-scope stages. +#' @param frame The species' province-wide frame. +#' @param draw Character vector of survey unit ids. +#' @param spec The taxon spec. +#' @param species Character. +#' @return A named list of fit_one_stage() results. +#' +#' @example # Example usage of the function +#' # fit_province_stages(stages, frame, draws[[1]], spec, sp) +fit_province_stages <- function(stages, frame, draw, spec, species) { + rows <- match(draw, frame$survey_unit_id) + fitting <- frame[rows[!is.na(rows)], , drop = FALSE] + + fits <- lapply(stages, function(stage) { + tryCatch( + fit_one_stage(stage, fitting, spec, NULL, species), + error = function(e) { + list(status = "error", note = conditionMessage(e), + selected = NULL) + } + ) + }) + + stats::setNames(fits, vapply(stages, `[[`, character(1), "name")) +} + +# 5. Fitting one draw ---- + +## 5.1 run_stage() ---- + +#' Fit One Stage on One Draw +#' +#' @param stage A stage definition from a spec. +#' @param data A data frame for one species and one draw. +#' @param spec The taxon spec. +#' @param offset Numeric vector or NULL. +#' @param weights Numeric vector or NULL. +#' @param grid A prediction grid, or NULL. +#' @param species Character. Passed to a rule that declares it. +#' @return A selection result. +#' +#' @example # Example usage of the function +#' # run_stage(spec$stages[[1]], d, spec) +run_stage <- function( + stage, data, spec, offset = NULL, weights = NULL, + grid = NULL, species = NA_character_ +) { + models <- get_model_set(stage$models) + response <- spec$response_name %||% "response" + + # Text to formulas; staged rules take groups + as_formulas <- function(x) { + if (is.list(x)) { + return(lapply(x, as_formulas)) + } + + lapply(x, stats::as.formula) + } + + # The offset goes in the formula: an offset argument is not + # applied by predict() to new data (R recycles the fitted one). + # `base_terms` start every candidate from given terms, as v2's + # bird landcover selection starts from `count ~ climate`. + base <- stats::as.formula(paste( + response, "~", paste(c("1", stage$base_terms), collapse = " + "), + if (is.null(offset)) "" else "+ offset(offset)" + )) + + # Stage fields the rule declares are passed by name + rule <- if (is.function(stage$selection)) { + stage$selection + } else { + get_method("selection", stage$selection) + } + + core <- c( + "models", "base", "data", "engine", "family", "weights", + "offset", "ic", "control" + ) + settings <- stage[ + setdiff(intersect(names(stage), names(formals(rule))), core) + ] + + if (!is.null(settings$intercept_cats)) { + settings$intercept_cats <- get_model_set(settings$intercept_cats) + } + + do.call(selection_run, c( + list( + rule = stage$selection, + models = as_formulas(models), + base = base, + data = data, + engine = get_engine(stage$engine), + family = stage$family %||% spec$family, + weights = weights, + offset = NULL, + ic = stage$ic %||% "AICc", + control = stage$control %||% list() + ), + settings, + # Harness-supplied, only to rules that declare them + list( + grid = grid, + species = species, + stage = stage, + calibrate_against = if (isTRUE(stage$calibrate)) { + data[[response]] + } else { + NULL + } + ) + )) +} + +## 5.2 fit_one_stage() ---- + +#' Prepare One Stage's Data and Fit It +#' +#' Shared by region-scope and province-scope stages. +#' +#' @param stage A stage definition. +#' @param fitting The draw's rows, with any carried stage added. +#' @param spec The taxon spec. +#' @param grid A prediction grid, or NULL. +#' @param species Character. Passed to a rule that declares it. +#' @return A list of `status` ("ok" or why not), `note` and +#' `selected`. +#' +#' @example # Example usage of the function +#' # fit_one_stage(spec$stages[[1]], fitting, spec, NULL) +fit_one_stage <- function(stage, fitting, spec, grid = NULL, + species = NA_character_) { + failed <- function(status) { + list(status = status, note = stage$name, selected = NULL) + } + + response_name <- spec$response_name %||% "response" + stage_data <- fitting + + # Stage-specific response transform, from the raw values + raw_name <- paste0(response_name, "_raw") + + if (!is.null(stage$response_transform) && + raw_name %in% names(stage_data)) { + stage_data[[response_name]] <- apply_response_transform( + stage_data[[raw_name]], stage$response_transform, stage_data + ) + } + + # Row subset, e.g. the mammal abundance half fits only units + # where the species was seen + if (!is.null(stage$row_filter)) { + keep <- stage$row_filter(stage_data) + keep[is.na(keep)] <- FALSE + stage_data <- stage_data[keep, , drop = FALSE] + + if (nrow(stage_data) < 2) { + return(failed("too_few_rows")) + } + } + + # v2 skips a plant habitat model with fewer than 20 + # detections in the filtered draw + if (!is.null(stage$min_detections)) { + detections <- sum(stage_data[[response_name]] > 0, na.rm = TRUE) + + if (detections < stage$min_detections) { + return(failed("too_few_detections")) + } + } + + # Weights apply unless a stage opts out. The bird climate stage + # is unweighted in v2; its landcover stage is weighted. + weights <- if (!isFALSE(stage$weighted) && + "weight" %in% names(stage_data)) { + stage_data$weight + } else { + NULL + } + + selected <- run_stage( + stage = stage, data = stage_data, spec = spec, grid = grid, + species = species, + offset = if ("offset" %in% names(stage_data)) { + stage_data$offset + } else { + NULL + }, + weights = weights + ) + + if (is.null(selected$fit) || !isTRUE(selected$fit$ok)) { + return(failed("stage_failed")) + } + + # Spec-supplied post-processing, in order (e.g. plant stand-age + # splines, cutblock convergence, footprint pooling). Steps that + # declare `grid`, `species` or `stage` are given them. + for (step in stage$post_process) { + context <- list(grid = grid, species = species, stage = stage) + context <- context[names(context) %in% names(formals(step))] + selected <- do.call(step, c(list(selected, stage_data), context)) + } + + list(status = "ok", note = NA_character_, selected = selected) +} + +## 5.3 carry_values() ---- + +#' The Value a Stage Hands the Next One +#' +#' From the stage's final (averaged) model, not its best +#' candidate: averaged coefficients applied to the data, as v2 +#' does, or the final model's prediction for engines without +#' coefficients. +#' +#' @param selected A selection result. +#' @param data The rows to compute it for. +#' @param stage The stage being carried. +#' @return A numeric vector, one per row. +#' +#' @example # Example usage of the function +#' # carry_values(selected, fitting, stage) +carry_values <- function(selected, data, stage) { + link <- if (!is.null(selected$coefficients)) { + predict_from_coefficients(selected$coefficients, data, "link") + } else { + selected$predict(data, "link") + } + + # v2's bird climate is carried without the QPAD offset, as + # MuMIn predicts it; a stage can ask for the offset to be added. + if (isTRUE(stage$carry_offset) && "offset" %in% names(data)) { + link <- link + data$offset + } + + switch( + stage$carry_scale %||% "response", + # v2's plant models carry the probability, 0 to 1 + response = stats::plogis(link), + link = link, + # v2's bird inv.link, bounded as v2 bounds it + exp = pmin(pmax(exp(link), .Machine$double.eps), + .Machine$double.xmax), + stop("Unknown carry_scale `", stage$carry_scale, "`.", + call. = FALSE) + ) +} + +## 5.4 run_one_draw() ---- + +#' Fit Every Stage on One Species and One Draw +#' +#' @param spec A taxon spec, with the region's stages. +#' @param frame The full one-species frame for the region. +#' @param draw Character vector of survey unit ids in the draw. +#' Ids not in the frame are dropped (repeats kept), as v2 +#' filters province-wide draws per region. +#' @param store A result_store(). +#' @param species,region Character. +#' @param boot Integer. +#' @param grid A prediction grid, or NULL. +#' @param metrics Character vector of metric names, or NULL. +#' @param fixed Named list of fit_one_stage() results for stages +#' already fitted at province scope, or NULL. +#' @param validation_frame The province-wide frame, or NULL; +#' passed to the spec's `validate` function. +#' @return A one-row data frame recording the outcome. +#' +#' @example # Example usage of the function +#' # run_one_draw(spec, frame, draw, store, sp, "north", 1, grid, +#' # NULL) +run_one_draw <- function( + spec, frame, draw, store, species, region, boot, grid, + metrics, fixed = NULL, validation_frame = NULL +) { + outcome <- function(status, note = NA_character_) { + data.frame( + taxon = spec$taxon, species = species, region = region, + boot = as.integer(boot), status = status, note = note, + stringsAsFactors = FALSE + ) + } + + rows <- match(draw, frame$survey_unit_id) + rows <- rows[!is.na(rows)] + + if (length(rows) == 0) { + return(outcome("empty_draw")) + } + + fitting <- frame[rows, , drop = FALSE] + response_name <- spec$response_name %||% "response" + + # Step 1: Fit the stages in order + result <- tryCatch({ + carried <- NULL + last <- NULL + stage_coefficients <- list() + + for (stage in spec$stages) { + # Carried stage as a column (v2's `Climate` term) + if (!is.null(stage$carry_from) && !is.null(carried)) { + column <- stage$carry_from_as %||% "Climate" + fitting[[column]] <- carried$fitting + frame[[column]] <- carried$full + } + + # Province-scope stages were fitted once per draw + fitted <- if (stage$name %in% names(fixed)) { + fixed[[stage$name]] + } else { + fit_one_stage(stage, fitting, spec, grid, species) + } + + if (fitted$status != "ok") { + return(outcome(fitted$status, fitted$note)) + } + + selected <- fitted$selected + + if (!is.null(stage$carry_as)) { + carried <- list( + fitting = carry_values(selected, fitting, stage), + full = carry_values(selected, frame, stage) + ) + } + + # Every stage's coefficients are kept, for per-stage v2 + # comparison. Multi-output rules (the mammal hurdle) write + # `_`. + if (!is.null(selected$outputs)) { + for (output in names(selected$outputs)) { + key <- paste(stage$name, output, sep = "_") + stage_coefficients[[key]] <- selected$outputs[[output]] + } + } else { + stage_coefficients[[stage$name]] <- selected$coefficients + } + + last <- list(selected = selected, stage = stage) + } + + last$stage_coefficients <- stage_coefficients + last$frame <- frame + + last + }, error = function(e) { + outcome("error", conditionMessage(e)) + }) + + if (is.data.frame(result)) { + return(result) + } + + frame <- result$frame + + # Step 2: The final model's prediction at every unit (or the + # spec's `final_prediction`, as the plant specs give v2's) + predicted <- tryCatch( + if (is.function(spec$final_prediction)) { + spec$final_prediction(result$stage_coefficients, frame) + } else { + result$selected$predict(frame, "response") + }, + error = function(e) NULL + ) + + if (is.null(predicted) || length(predicted) != nrow(frame)) { + return(outcome("predict_failed", result$stage$name)) + } + + # Written only once the whole draw succeeded + for (stage_name in names(result$stage_coefficients)) { + write_coefficients( + store, species, region, boot, + result$stage_coefficients[[stage_name]], + stage = stage_name + ) + } + + in_bag <- frame$survey_unit_id %in% draw + + write_unit_predictions( + store, species, region, boot, frame$survey_unit_id, + predicted, frame[[response_name]], in_bag = in_bag + ) + + # Step 3: Score in-sample and out-of-bag. A full-data draw + # (bootstrap iteration 1) has no out-of-bag units, so NA. + scored <- function(keep, prefix) { + out <- compute_metrics( + frame[[response_name]][keep], predicted[keep], metrics + ) + out$metric <- paste0(prefix, out$metric) + out + } + + metric_rows <- rbind( + scored(in_bag, "insample_"), + scored(!in_bag, "oob_") + ) + + # Spec validation, e.g. the plant specs' v2 validation AUCs + if (is.function(spec$validate)) { + extra <- tryCatch( + spec$validate( + result$stage_coefficients, frame, + validation_frame %||% frame, draw + ), + error = function(e) NULL + ) + + metric_rows <- rbind(metric_rows, extra) + } + + write_metrics(store, species, region, boot, metric_rows) + + # Step 4: Project the final model onto the prediction grid + if (!is.null(grid)) { + grid_prediction <- predict_grid( + result$selected, grid, + constants = c( + result$stage$constants %||% list(), + result$stage$grid_constants %||% list() + ) + ) + + if (!is.null(grid_prediction)) { + write_grid_predictions( + store, species, region, boot, + names(grid_prediction), grid_prediction + ) + } + } + + outcome("ok") +} + +# 6. Writing the stores ---- + +## 6.1 merge_spec_shards() ---- + +#' Join a Spec's Shards into One Store per Region +#' +#' Joins shards in queue order (matching a serial run), writes +#' meta.json, and removes the shards. +#' +#' @param p A prepare_spec() result. +#' @return NULL, invisibly. +#' +#' @example # Example usage of the function +#' # merge_spec_shards(prepared$lichen) +merge_spec_shards <- function(p) { + for (region in p$regions) { + store <- result_store( + file.path(p$run_dir, region$name), + unit_predictions = p$unit_predictions + ) + + merge_result_shards( + store, + file.path(p$shard_dir, region$name, safe_name(region$species)) + ) + + write_meta(store, run_meta(p, region)) + } + + unlink(p$shard_dir, recursive = TRUE) + + invisible(NULL) +} + +## 6.2 run_meta() ---- + +#' What a Region Store Records About Its Run +#' +#' @param p A prepare_spec() result. +#' @param region A prepare_region() result. +#' @return A named list for write_meta(). +#' +#' @example # Example usage of the function +#' # run_meta(prepared$lichen, prepared$lichen$regions$north) +run_meta <- function(p, region) { + spec <- p$spec + stages <- region$spec$stages + + list( + taxon = spec$taxon, + region = region$name, + # Mammals only: needed to find the right v2 reference + season = spec$season %||% NA_character_, + part = if (any(vapply( + stages, function(s) identical(s$selection, "hurdle"), logical(1) + ))) { + "hurdle" + } else { + NA_character_ + }, + species_n = length(region$species), + iterations = length(p$iterations), + stages = vapply(stages, `[[`, character(1), "name"), + stage_scope = vapply( + stages, function(s) s$scope %||% "region", character(1) + ), + engines = vapply(stages, `[[`, character(1), "engine"), + selection = vapply( + stages, + function(s) { + if (is.function(s$selection)) "custom" else s$selection + }, + character(1) + ), + covariates = region$covariates, + weight_column = region$weight_column %||% NA_character_, + resample_scheme = spec$resample$scheme, + resample_scope = spec$resample$scope %||% "region", + # The seed actually used, never a default that was not + seed = if (spec$resample$scheme == "precomputed") { + "not used (precomputed draws)" + } else if (!is.null(p$base_seed)) { + paste0(p$base_seed, " (per species, via species_seed())") + } else { + "unseeded" + }, + grid = region$grid_name %||% NA_character_, + unit_predictions = p$unit_predictions, + models_overridden = spec$models_overridden %||% NA_character_, + v2_coverage = if (is.null(spec$v2_coverage)) { + NA_character_ + } else { + paste0( + names(spec$v2_coverage), ": ", + vapply(spec$v2_coverage, `[[`, character(1), "status") + ) + }, + spec_notes = spec$notes %||% NA_character_ + ) +} + +## 6.3 safe_name() ---- + +#' Make a Species Name Safe as a Folder Name +#' +#' @param x Character vector. +#' @return `x` with anything but letters, digits, dots, hyphens +#' and underscores replaced. +#' +#' @example # Example usage of the function +#' # safe_name("Black Bear") # "Black_Bear" +safe_name <- function(x) { + gsub("[^A-Za-z0-9._-]", "_", x) +} + +# End of script ---- diff --git a/1_code/harness/run_record.R b/1_code/harness/run_record.R new file mode 100644 index 0000000..33d53f7 --- /dev/null +++ b/1_code/harness/run_record.R @@ -0,0 +1,290 @@ +# --- +# title: Write a Comparable Record of One Run +# author: Brendan Casey +# created: 2026-09-13 +# inputs: +# - a pipeline directory holding result stores, laid out as +# /// +# outputs: +# - one Markdown or plain-text file per run +# notes: +# - The committed record of a run (configuration, coverage, +# metrics); the result stores themselves are gitignored. +# - Built to diff: identical results render byte-identically. +# Volatile fields sit only in the Provenance section +# (`provenance = FALSE` drops it), numbers use fixed decimals, +# rows are ordered deterministically, and missing values are +# "-". An unseeded run (`seed = NULL`) still differs between +# runs. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # result store reading (version: 1.16.4) + +# 2. Formatting helpers ---- + +## 2.1 fmt_value() ---- + +#' Format One Value for a Record Table +#' +#' Fixed decimals for numbers and "-" for anything missing, so +#' that two runs which agree produce identical text. +#' +#' @param x A value of any type. +#' @param digits Integer. Decimal places for numeric values. +#' @return A character vector. +#' +#' @example # Example usage of the function +#' # fmt_value(c(0.68901, NA), digits = 4) +fmt_value <- function(x, digits = 4L) { + if (is.null(x) || length(x) == 0) { + return("-") + } + + # Format by type, not value, so a column never flips between + # "1" and "1.0000" across runs + if (is.integer(x)) { + out <- formatC(x, format = "d") + out[is.na(x)] <- "-" + + return(out) + } + + if (is.numeric(x)) { + out <- formatC( + x, format = "f", digits = digits, drop0trailing = FALSE + ) + out[!is.finite(x)] <- "-" + + return(out) + } + + out <- as.character(x) + out[is.na(out) | !nzchar(trimws(out))] <- "-" + + out +} + +## 2.2 md_table() ---- + +#' Render a Data Frame as a Markdown Table +#' +#' @param df A data frame. Zero rows renders as "_None._" so the +#' section still appears in a diff. +#' @param digits Integer. Decimal places for numeric columns. +#' @return A character vector of lines. +#' +#' @example # Example usage of the function +#' # md_table(data.frame(taxon = "bird", auc = 0.689)) +md_table <- function(df, digits = 4L) { + if (is.null(df) || nrow(df) == 0) { + return("_None._") + } + + cells <- lapply(df, fmt_value, digits = digits) + names(cells) <- names(df) + + header <- paste("|", paste(names(df), collapse = " | "), "|") + divider <- paste( + "|", paste(rep("---", length(df)), collapse = " | "), "|" + ) + + body <- vapply( + seq_len(nrow(df)), + function(i) { + paste( + "|", + paste(vapply(cells, function(x) x[i], character(1)), + collapse = " | "), + "|" + ) + }, + character(1) + ) + + c(header, divider, body) +} + +## 2.3 kv_lines() ---- + +#' Render a Named List as Stable Key-Value Lines +#' +#' Sorted by name, so that adding a setting does not reorder the +#' ones already there. +#' +#' @param values A named list. +#' @param digits Integer. Decimal places for numeric values. +#' @return A character vector of lines. +#' +#' @example # Example usage of the function +#' # kv_lines(list(engine = "glm", draws = 100)) +kv_lines <- function(values, digits = 4L) { + if (is.null(values) || length(values) == 0) { + return("_None recorded._") + } + + values <- values[order(names(values))] + + vapply( + names(values), + function(name) { + value <- values[[name]] + + rendered <- if (length(value) > 1) { + paste(fmt_value(value, digits), collapse = ", ") + } else { + fmt_value(value, digits) + } + + paste0("- **", name, "**: ", rendered) + }, + character(1) + ) +} + +# 3. run_record() ---- + +#' Write the Committed Record of One Run +#' +#' @param pipeline_dir Character. Where the result stores are. +#' @param out_file Character. Path to write. The extension sets +#' the format: ".txt" strips the Markdown table pipes, anything +#' else writes Markdown. +#' @param exp_id Character. The experiment identifier. +#' @param config Named list. What the run was configured to do - +#' taxa, species count, draws, engines, selection rules. +#' Rendered sorted by name. +#' @param provenance Logical. Include the volatile section. +#' FALSE gives a body byte-identical across identical runs. +#' @param digits Integer. Decimal places for every number. +#' @param collected collect_results() output for this pipeline +#' directory, or NULL to read the stores here. +#' @return The path written, invisibly. +#' +#' @example # Example usage of the function +#' # run_record("2_pipeline/exp_000_parity_v2", +#' # "3_output/exp_000_parity_v2/run_record.md", +#' # exp_id = "exp_000_parity_v2", +#' # config = list(draws = 100)) +run_record <- function( + pipeline_dir, + out_file, + exp_id, + config = list(), + provenance = TRUE, + digits = 4L, + collected = NULL +) { + if (is.null(collected)) { + collected <- collect_results(pipeline_dir) + } + + lines <- c( + paste("# Run record:", exp_id), + "", + paste0( + "Written by `run_record()`. The result stores this ", + "describes are gitignored; this file is what remains." + ), + "" + ) + + ## 3.1 Provenance ---- + if (provenance) { + commit <- tryCatch( + system2("git", c("rev-parse", "--short", "HEAD"), + stdout = TRUE, stderr = FALSE), + error = function(e) NA_character_, + warning = function(e) NA_character_ + ) + + lines <- c( + lines, + "## Provenance", + "", + "_Volatile. Excluded from cross-run comparison._", + "", + kv_lines(list( + written_at = format( + Sys.time(), "%Y-%m-%d %H:%M:%S", tz = "UTC" + ), + git_commit = if (length(commit) == 1) commit else "-", + r_version = paste( + R.version$major, R.version$minor, sep = "." + ), + pipeline_dir = pipeline_dir + ), digits), + "" + ) + } + + ## 3.2 Configuration ---- + lines <- c( + lines, "## Configuration", "", kv_lines(config, digits), "" + ) + + ## 3.3 Coverage and artefacts ---- + # Row counts, not file sizes: sizes vary between identical runs + coverage <- collected$store_rows + + if (!is.null(coverage)) { + names(coverage)[names(coverage) == "run"] <- "taxon" + coverage <- coverage[order(coverage$taxon, coverage$region), ] + coverage$coefficient_rows <- as.integer(coverage$coefficient_rows) + coverage$metric_rows <- as.integer(coverage$metric_rows) + coverage$grid_rows <- as.integer(coverage$grid_rows) + coverage$species <- as.integer(coverage$species) + coverage$draws <- as.integer(coverage$draws) + } + + lines <- c( + lines, "## Coverage", "", + md_table(coverage, digits), "" + ) + + ## 3.4 Metrics ---- + # Pooled over species and draws + metric_summary <- NULL + + if (!is.null(collected$metrics) && nrow(collected$metrics) > 0) { + pooled <- as.data.table(collected$metrics)[ + is.finite(value), + list( + n = .N, + median = stats::median(value), + p10 = stats::quantile(value, 0.1, names = FALSE), + p90 = stats::quantile(value, 0.9, names = FALSE), + mean = mean(value), + sd = if (.N < 2) NA_real_ else stats::sd(value) + ), + by = list(taxon = run, region, metric) + ] + setorder(pooled, taxon, region, metric) + metric_summary <- as.data.frame(pooled) + } + + lines <- c( + lines, "## Metrics", "", + md_table(metric_summary, digits), "" + ) + + ## 3.5 Write ---- + if (grepl("[.]txt$", out_file, ignore.case = TRUE)) { + # Drop dividers before the pipes, while still recognizable + lines <- lines[!grepl("^[|] --- ([|] --- )*[|]$", lines)] + lines <- gsub("^[|] | [|]$", "", lines) + lines <- gsub(" [|] ", " ", lines) + } + + dir.create( + dirname(out_file), recursive = TRUE, showWarnings = FALSE + ) + + writeLines(lines, out_file) + + invisible(out_file) +} + +# End of script ---- diff --git a/1_code/harness/selection.R b/1_code/harness/selection.R new file mode 100644 index 0000000..a211056 --- /dev/null +++ b/1_code/harness/selection.R @@ -0,0 +1,381 @@ +# --- +# title: Selection Plumbing +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; defines functions in memory +# notes: +# - Shared plumbing for the rules in 1_code/methods/selection/. +# Every rule returns selection_result(), so callers need not +# know which rule ran. +# - Rules fit their own candidates rather than receiving fits, +# because staged selection refits each stage on the previous +# stage's winner. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. selection_run() ---- + +#' Run One Selection Rule +#' +#' @param rule Character, a registered rule name, or a function a +#' spec supplies with the same arguments. +#' @param models A list of formulas, or for staged rules a list +#' of named groups of formulas. +#' @param base A formula the candidates update, e.g. +#' response ~ 1. Candidates given as `. ~ . + x` are applied to +#' it with update(). +#' @param data A data frame. +#' @param engine An engine definition from get_engine(). +#' @param family Character or family object. +#' @param weights,offset Numeric vectors or NULL. +#' @param ic Character. "AIC", "AICc" or "BIC". +#' @param control Named list passed to the engine. +#' @param ... Further arguments; only those the rule declares are +#' passed on. +#' @return A selection result; see selection_result(). `rule` is +#' set to the rule's name, and `predict` to a predictor for the +#' final model when the rule did not supply one. +#' +#' @example # Example usage of the function +#' # selection_run("aic_average", models, response ~ 1, d, +#' # get_engine("bayesglm"), "binomial") +selection_run <- function( + rule, + models, + base, + data, + engine, + family, + weights = NULL, + offset = NULL, + ic = "AICc", + control = list(), + ... +) { + # A function rule covers shapes the registry lacks (e.g. the v2 + # mammal hurdle) + if (is.function(rule)) { + rule_fn <- rule + rule_name <- "custom" + } else { + rule_fn <- get_method("selection", rule) + rule_name <- rule + } + + extra <- list(...) + extra <- extra[names(extra) %in% names(formals(rule_fn))] + + out <- do.call(rule_fn, c( + list( + models = models, base = base, data = data, engine = engine, + family = family, weights = weights, offset = offset, + ic = ic, control = control + ), + extra + )) + + out$rule <- rule_name + + # A rule that combines candidates supplies its own predictor; + # otherwise the final model is the chosen fit. + if (is.null(out$predict) && !is.null(out$fit)) { + chosen <- out$fit + + out$predict <- function(newdata, type = "response") { + engine$predict(chosen, newdata, type) + } + } + + out +} + +# 3. Candidate fitting ---- + +## 3.1 fit_candidates() ---- + +#' Fit Every Candidate in a Model Set +#' +#' @param models A list of formulas. +#' @param base A formula the candidates update. +#' @param data A data frame. +#' @param engine An engine definition. +#' @param family,weights,offset,ic,control As in selection_run(). +#' @return A list with `fits`, `formulas` and `scores`. Scores are +#' Inf where the engine has no information criterion. +#' +#' @example # Example usage of the function +#' # fit_candidates(models, response ~ 1, d, engine, "binomial") +fit_candidates <- function( + models, + base, + data, + engine, + family, + weights = NULL, + offset = NULL, + ic = "AICc", + control = list() +) { + formulas <- lapply(models, function(one) resolve_formula(one, base)) + + fits <- lapply(formulas, function(f) { + fit_with(engine, f, data, family, weights, offset, control) + }) + + scores <- vapply( + fits, + function(f) { + if (engine_has(engine, "ic")) engine$ic(f, ic) else Inf + }, + numeric(1) + ) + + list(fits = fits, formulas = formulas, scores = scores) +} + +## 3.2 resolve_formula() ---- + +#' Apply a Candidate to a Base Formula +#' +#' v2 model sets mix complete formulas and updates such as +#' `. ~ . + MAP`. +#' +#' @param model A formula. +#' @param base A formula to update. +#' @return A formula. +#' +#' @example # Example usage of the function +#' # resolve_formula(. ~ . + MAP, response ~ 1) +resolve_formula <- function(model, base) { + # One-sided or dot-left candidates are updates + left <- if (length(model) == 3) deparse(model[[2]]) else "." + + if (left == ".") { + return(stats::update(base, model)) + } + + model +} + +## 3.3 formula_variables() ---- + +#' The Data Columns a Formula Reads +#' +#' Read from the formula, not a fit, so it works for any engine. +#' Excludes response, offset and weight, which a prediction frame +#' never supplies as data. +#' +#' @param formula A formula, or formula text. +#' @return A character vector of column names. +#' +#' @example # Example usage of the function +#' # formula_variables(response ~ MAP + offset(offset)) +formula_variables <- function(formula) { + if (is.character(formula)) { + formula <- stats::as.formula(formula) + } + + setdiff(all.vars(formula), c("response", "offset", "weight")) +} + +## 3.4 candidate_table() ---- + +#' Summarize a Candidate Set +#' +#' @param fitted A list from fit_candidates(). +#' @param names_in Character vector of candidate names, or NULL. +#' @return A data frame of model, formula, ic, delta, weight, k +#' and ok. `k` counts coefficients, NA where the engine has +#' none. +#' +#' @example # Example usage of the function +#' # candidate_table(fitted) +candidate_table <- function(fitted, names_in = NULL) { + n <- length(fitted$fits) + + if (is.null(names_in)) { + names_in <- if (!is.null(names(fitted$fits))) { + names(fitted$fits) + } else { + paste0("model_", seq_len(n)) + } + } + + ok <- vapply(fitted$fits, function(f) isTRUE(f$ok), logical(1)) + k <- vapply( + fitted$fits, + function(f) { + cf <- if (isTRUE(f$ok)) f$coefficients else NULL + if (is.null(cf)) NA_integer_ else nrow(cf) + }, + integer(1) + ) + + scores <- fitted$scores + best <- suppressWarnings(min(scores, na.rm = TRUE)) + delta <- scores - best + + # Akaike weights; a failed model scores Inf and gets weight 0 + raw <- exp(-delta / 2) + raw[!is.finite(raw)] <- 0 + total <- sum(raw) + + data.frame( + model = names_in, + formula = vapply( + fitted$formulas, function(f) paste(deparse(f), collapse = " "), + character(1) + ), + ic = scores, + delta = delta, + weight = if (total > 0) raw / total else rep(0, n), + k = k, + ok = ok, + stringsAsFactors = FALSE + ) +} + +# 4. Combining predictions ---- + +## 4.1 family_linkinv() ---- + +#' The Inverse Link of a Family +#' +#' @param family Character (e.g. "binomial") or a family object. +#' @return A function from the link scale to the response scale. +#' +#' @example # Example usage of the function +#' # family_linkinv("poisson")(0) +family_linkinv <- function(family) { + if (is.character(family)) { + family <- get(family, mode = "function")() + } + + family$linkinv +} + +## 4.2 combined_predictor() ---- + +#' A Predictor That Averages Several Fits on the Link Scale +#' +#' Returned as `predict` by combining rules, so scoring and grid +#' projection use the combined model, not the best candidate. +#' +#' @param fits List of engine fits. +#' @param engine An engine definition. +#' @param family Character or family object. +#' @param weights Numeric vector of fixed weights, one per fit, or +#' NULL to weight each prediction by its own precision +#' (inverse-variance), which needs the `se` capability. +#' @return A function(newdata, type = "response") returning a +#' numeric vector. NULL when nothing can predict, or, under +#' fixed weights, when any weighted fit cannot. +#' +#' @example # Example usage of the function +#' # predict <- combined_predictor(fits, engine, "binomial", w) +#' # predict(newdata) +combined_predictor <- function(fits, engine, family, weights = NULL) { + linkinv <- family_linkinv(family) + + if (!is.null(weights)) { + keep <- weights > 0 + fits <- fits[keep] + weights <- weights[keep] / sum(weights[keep]) + } + + function(newdata, type = "response") { + if (length(fits) == 0) { + return(NULL) + } + + if (is.null(weights)) { + predictions <- lapply(fits, function(f) { + engine$predict(f, newdata, "link", se = TRUE) + }) + + # Precision weights renormalize, so a candidate that cannot + # predict is dropped, as v2 drops a failed fit + predictions <- predictions[ + !vapply(predictions, is.null, logical(1)) + ] + + if (length(predictions) == 0) { + return(NULL) + } + + estimate <- do.call(rbind, lapply(predictions, `[[`, "fit")) + error <- do.call(rbind, lapply(predictions, `[[`, "se.fit")) + link <- colSums(estimate / error^2) / colSums(1 / error^2) + } else { + predictions <- lapply(fits, function(f) { + engine$predict(f, newdata, "link") + }) + + if (any(vapply(predictions, is.null, logical(1)))) { + return(NULL) + } + + link <- drop(weights %*% do.call(rbind, predictions)) + } + + if (type == "link") link else linkinv(link) + } +} + +# 5. selection_result() ---- + +#' Build the Structure Every Rule Returns +#' +#' @param fit A fit from an engine, or NULL. +#' @param coefficients A data frame of term, estimate, se, or +#' NULL. +#' @param ic_table A data frame summarizing the candidates. +#' @param fitted The full candidate set, or NULL. +#' @param formula The chosen formula, or NULL to read it from +#' `fit`. +#' @param engine The engine, or NULL. Used to count observations. +#' @param predict A function(newdata, type) for the final model, +#' or NULL to predict from `fit` (set by selection_run()). +#' @return A list. +#' +#' @example # Example usage of the function +#' # selection_result(fit, coefs, table, fitted) +selection_result <- function( + fit, + coefficients, + ic_table, + fitted = NULL, + formula = NULL, + engine = NULL, + predict = NULL +) { + list( + fit = fit, + coefficients = coefficients, + ic_table = ic_table, + formula = if (!is.null(formula)) { + paste(deparse(formula), collapse = " ") + } else if (!is.null(fit) && isTRUE(fit$ok)) { + tryCatch( + paste(deparse(stats::formula(fit$fit)), collapse = " "), + error = function(e) NA_character_ + ) + } else { + NA_character_ + }, + # Every formula any candidate fitted, so a grid prediction can + # supply each term a combined predictor reads + formulas = if (is.null(fitted)) NULL else fitted$formulas, + n_fitted = if (is.null(ic_table)) 0L else sum(ic_table$ok), + n_failed = if (is.null(ic_table)) 0L else sum(!ic_table$ok), + nobs = engine_nobs(engine, fit), + predict = predict + ) +} + +# End of script ---- diff --git a/1_code/harness/spec.R b/1_code/harness/spec.R new file mode 100644 index 0000000..9f4ba9c --- /dev/null +++ b/1_code/harness/spec.R @@ -0,0 +1,639 @@ +# --- +# title: Taxon Specs - Validation and Helpers +# author: Brendan Casey +# created: 2026-10-03 +# inputs: none +# outputs: none; defines functions in memory +# notes: +# - A spec states one taxon's configuration as data; methods it +# names are looked up in the registry. Fields are documented +# in docs/getting_started.md. +# - validate_spec() reports every problem at once, before any +# data is read. Unknown fields are errors, because a misspelt +# field is otherwise silently ignored; arguments of the named +# rule or resampler count as known fields. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. Known fields ---- + +## 2.1 spec_fields() ---- + +#' The Fields a Spec, Region or Stage May Carry +#' +#' Fields the harness itself reads; method-specific settings are +#' known through the method's arguments. +#' +#' @return A named list of character vectors: `spec`, `region`, +#' `stage` and `resample`. +#' +#' @example # Example usage of the function +#' # spec_fields()$stage +spec_fields <- function() { + list( + spec = c( + "taxon", "response_name", "response_transform", "family", + "weight_column", "tier", "season", "aliases", + "regions", "stages", "resample", "v2_coverage", "validate", + "final_prediction", "species_frame", "supplied_columns", + "notes", "models_overridden", "covariate_files", + # The stage a methods experiment replaces by default + "habitat_stage", + # Recorded facts a module keeps for its own reports + "use_protocol", "protocol_is_v2", "climate_source" + ), + region = c( + "filter", "grid", "term_block", "habitat_models", + "grid_constants", "grid_drop_rows", "grid_drop_cols", + "constants", "intercept_cats", "extra_covariates", + "weight_column" + ), + stage = c( + "name", "models", "engine", "selection", "ic", "control", + "family", "scope", "weighted", "base_terms", + "response_transform", "row_filter", "min_detections", + "extra_covariates", "post_process", "calibrate", + "carry_as", "carry_scale", "carry_offset", "carry_from", + "carry_from_as", + # Values held fixed when the final model is projected onto + # the grid; rules that predict onto a grid read them too + "constants", "grid_constants" + ), + resample = c("scheme", "seed", "scope") + ) +} + +# 3. validate_spec() ---- + +#' Check a Spec Before Running It +#' +#' @param spec A taxon spec. +#' @param stop_on_error Logical. Stop with every problem listed, +#' or return the problems. +#' @return The spec, invisibly, when it is valid; otherwise stops, +#' or returns a character vector of problems when +#' `stop_on_error` is FALSE. +#' +#' @example # Example usage of the function +#' # validate_spec(lichen_spec()) +validate_spec <- function(spec, stop_on_error = TRUE) { + problems <- character(0) + problem <- function(...) { + problems <<- c(problems, paste0(...)) + } + fields <- spec_fields() + unknown_fields <- function(x, known, where) { + extra <- setdiff(names(x), known) + + if (length(extra) > 0) { + problem( + where, " has unknown field(s): ", + paste(extra, collapse = ", "), "." + ) + } + } + + # Step 1: The spec itself + if (!is.character(spec$taxon) || length(spec$taxon) != 1L) { + problem("`taxon` must be one data slug, such as \"lichen\".") + } + + label <- paste0("Spec `", spec$taxon %||% "?", "`") + unknown_fields(spec, fields$spec, label) + + # Step 2: Regions + if (!is.list(spec$regions) || length(spec$regions) == 0) { + problem(label, " defines no regions.") + } + + for (region in names(spec$regions)) { + one <- spec$regions[[region]] + unknown_fields( + one, fields$region, paste0("Region `", region, "`") + ) + + if (!is.null(one$filter) && !inherits(one$filter, "formula")) { + problem( + "Region `", region, "`: `filter` must be a one-sided ", + "formula, such as ~ nr != \"Grassland\"." + ) + } + } + + # Step 3: Stages, in order + stage_names <- character(0) + carried <- character(0) + + for (stage in spec$stages) { + name <- stage$name %||% "?" + where <- paste0("Stage `", name, "`") + + if (name %in% stage_names) { + problem(where, " appears twice; stage names must differ.") + } + stage_names <- c(stage_names, name) + + engine <- tryCatch( + get_engine(stage$engine), + error = function(e) { + problem(where, ": ", conditionMessage(e)) + NULL + } + ) + + rule <- if (is.function(stage$selection)) { + stage$selection + } else { + tryCatch( + get_method("selection", stage$selection), + error = function(e) { + problem(where, ": ", conditionMessage(e)) + NULL + } + ) + } + + # A field the rule takes as an argument is a rule setting + known <- c(fields$stage, if (!is.null(rule)) names(formals(rule))) + unknown_fields(stage, known, where) + + # The rule's requirements against the engine's capabilities + if (!is.null(engine) && is.character(stage$selection)) { + needs <- get_method( + "selection", stage$selection, entry = TRUE + )$requires + missing_capabilities <- setdiff(needs, engine$capabilities) + + if (length(missing_capabilities) > 0) { + problem( + where, ": selection rule `", stage$selection, + "` needs ", paste(missing_capabilities, collapse = ", "), + ", which engine `", engine$name, "` does not provide. ", + "Choose a rule that does not, such as `single`." + ) + } + } + + # A composite rule (the hurdle) runs an inner rule per part; + # that rule's requirements are checked against the engine too + if (!is.null(engine) && !is.null(rule) && + "part_selection" %in% names(formals(rule))) { + inner <- stage$part_selection %||% formals(rule)$part_selection + entry <- tryCatch( + get_method("selection", inner, entry = TRUE), + error = function(e) { + problem(where, ": `part_selection`: ", conditionMessage(e)) + NULL + } + ) + missing_capabilities <- setdiff( + entry$requires, engine$capabilities + ) + + if (!is.null(entry) && length(missing_capabilities) > 0) { + problem( + where, ": inner rule `", inner, "` needs ", + paste(missing_capabilities, collapse = ", "), + ", which engine `", engine$name, "` does not provide. ", + "Use `single` as the part_selection." + ) + } + } + + if (!is.null(stage$ic) && + !stage$ic %in% c("AIC", "AICc", "BIC")) { + problem(where, ": `ic` must be \"AIC\", \"AICc\" or \"BIC\".") + } + + # Or the carried column is attached per species via + # `supplied_columns` (mammal precomputed climate) + carried_column <- stage$carry_from_as %||% "Climate" + + if (!is.null(stage$carry_from) && + !stage$carry_from %in% carried && + !carried_column %in% spec$supplied_columns) { + problem( + where, " carries from `", stage$carry_from, "`, which is ", + "not an earlier stage with `carry_as`, and `", + carried_column, "` is not in `supplied_columns`." + ) + } + + if (!is.null(stage$carry_as)) { + carried <- c(carried, name) + } + + # Models: a registered set name, formulas, or NULL to take + # each region's habitat models + if (is.null(stage$models)) { + lacking <- names(spec$regions)[vapply( + spec$regions, function(r) is.null(r$habitat_models), + logical(1) + )] + + if (length(lacking) > 0) { + problem( + where, " takes its models from the region, but ", + paste(lacking, collapse = ", "), " define(s) no ", + "`habitat_models`." + ) + } + } else { + problems <- c(problems, check_model_set(stage$models, where)) + } + } + + # Step 4: Resampling + scheme <- spec$resample$scheme + + resampler <- tryCatch( + get_method("resampler", scheme %||% ""), + error = function(e) { + problem("`resample$scheme`: ", conditionMessage(e)) + NULL + } + ) + + if (!is.null(resampler)) { + unknown_fields( + spec$resample, + c(fields$resample, names(formals(resampler))), + "`resample`" + ) + } + + if (length(problems) == 0) { + return(invisible(spec)) + } + + if (!stop_on_error) { + return(problems) + } + + stop( + label, " has ", length(problems), " problem(s):\n - ", + paste(problems, collapse = "\n - "), + call. = FALSE + ) +} + +## 3.1 check_model_set() ---- + +#' Check a Stage's Models Name Something Real +#' +#' A lone string that is neither a set nor a formula is almost +#' always a misspelt set name. +#' +#' @param models A set name, or formulas as text. +#' @param where Character. Prefix for the message. +#' @return A character vector of problems, empty when fine. +#' +#' @example # Example usage of the function +#' # check_model_set("climate_plant_v2_ful", "Stage `climate`") +check_model_set <- function(models, where) { + if (is.list(models)) { + return(unlist(lapply(models, check_model_set, where = where))) + } + + if (!is.character(models)) { + return(paste0(where, ": `models` must be a set name or text.")) + } + + if (length(models) == 1L && !grepl("~", models, fixed = TRUE) && + !models %in% names(model_sets())) { + return(paste0( + where, ": `", models, "` is not a model set or a formula. ", + "Sets: see names(model_sets())." + )) + } + + character(0) +} + +# 4. spec_covariates() ---- + +#' Read the Covariates a Spec's Model Sets Name +#' +#' Read from the formulas, so a spec cannot name a term it forgot +#' to load. Excludes harness-supplied terms (response, offset, +#' weight, carried stages, `supplied_columns`). +#' +#' @param spec A taxon spec. +#' @param stage_names Character vector of stages to read, or NULL +#' for all of them. +#' @return A character vector of covariate names. +#' +#' @example # Example usage of the function +#' # spec_covariates(bryophyte_spec()) +spec_covariates <- function(spec, stage_names = NULL) { + stages <- spec$stages + + if (!is.null(stage_names)) { + stages <- stages[vapply( + stages, function(s) s$name %in% stage_names, logical(1) + )] + } + + supplied <- c( + spec$response_name %||% "response", + "offset", "weight", + vapply(spec$stages, function(s) s$carry_as %||% "", character(1)), + spec$supplied_columns + ) + + terms <- unlist(lapply(stages, function(stage) { + models <- unlist(get_model_set(stage$models), use.names = FALSE) + + unlist(lapply(models, function(one) { + all.vars(stats::as.formula(one)) + })) + })) + + covariates <- setdiff(unique(terms), c(supplied, ".")) + + # Columns no formula names, e.g. the plant age splines' aged + # stand-cover columns + extra <- unlist(lapply(stages, `[[`, "extra_covariates")) + + unique(c(covariates, extra, spec$weight_column)) +} + +# 5. apply_stage_models() ---- + +#' Swap a Spec's Candidate Sets for an Experiment's Own +#' +#' Keeps the spec as the record of v2 and the experiment as the +#' record of what changed. Entries are named `taxon.stage`, or +#' `stage` for every taxon; values are a model_sets() name or +#' formulas. +#' +#' \preformatted{ +#' stage_models <- list( +#' "lichen.climate" = extend_models( +#' "climate_plant_v2_full", "elevation" +#' ), +#' "climate" = models_from_covariates(c("MAP", "FFP")) +#' ) +#' } +#' +#' @param spec A taxon spec. +#' @param stage_models Named list of replacement model sets, or +#' NULL. +#' @return The spec, with matching stages replaced, and a record +#' of what changed in `models_overridden`. +#' +#' @example # Example usage of the function +#' # apply_stage_models(spec, list(climate = my_models)) +apply_stage_models <- function(spec, stage_models) { + if (is.null(stage_models) || length(stage_models) == 0) { + return(spec) + } + + changed <- character(0) + + for (i in seq_along(spec$stages)) { + stage <- spec$stages[[i]] + + # `taxon.stage` wins over a bare `stage` + keys <- c(paste(spec$taxon, stage$name, sep = "."), stage$name) + hit <- keys[keys %in% names(stage_models)][1] + + if (is.na(hit)) { + next + } + + spec$stages[[i]]$models <- stage_models[[hit]] + changed <- c(changed, paste0(stage$name, " <- ", hit)) + } + + # Recorded in meta.json; otherwise indistinguishable from v2 + spec$models_overridden <- if (length(changed) > 0) { + changed + } else { + NULL + } + + spec +} + +# 6. replace_stage_method() ---- + +#' Fit One Stage of a v2 Spec with a Different Method +#' +#' The rest of the spec stays v2's, so a difference in results is +#' the method's. By default the candidates become one formula of +#' all their covariates (models_union()). A composite rule (e.g. +#' the mammal `hurdle`) keeps its structure and runs the new rule +#' in each part. +#' +#' Removes what reads v2 coefficient tables a new engine may not +#' produce: the stage's `post_process`, fields only the old rule +#' took, and (for the last stage) `final_prediction` and +#' `validate`. The change is recorded in `v2_coverage` and +#' `models_overridden`. +#' +#' @param spec A taxon spec. +#' @param stage Character. The stage's name; the spec's +#' `habitat_stage` by default. +#' @param engine Character. A registered engine. +#' @param selection Character. A registered rule; "single" for an +#' engine with no information criterion. +#' @param control Named list of engine settings. +#' @param union Logical. Replace the candidate set with one formula +#' holding all its covariates. FALSE keeps the candidates, for a +#' rule that compares them. +#' @return The spec. +#' +#' @example # Example usage of the function +#' # spec <- replace_stage_method(lichen_spec(), engine = "xgboost") +replace_stage_method <- function( + spec, stage = spec$habitat_stage, engine, selection = "single", + control = list(), union = TRUE +) { + names_in <- vapply(spec$stages, `[[`, character(1), "name") + + if (is.null(stage)) { + stop( + "Spec `", spec$taxon, "` names no `habitat_stage`; pass ", + "`stage`. Stages: ", paste(names_in, collapse = ", "), + call. = FALSE + ) + } + + index <- match(stage, names_in) + + if (is.na(index)) { + stop( + "Spec `", spec$taxon, "` has no stage `", stage, "`. Stages: ", + paste(names_in, collapse = ", "), + call. = FALSE + ) + } + + get_method("selection", selection) + get_engine(engine) + old <- spec$stages[[index]] + + # A composite rule keeps its place and takes the new rule inside + old_rule <- if (is.function(old$selection)) { + old$selection + } else { + get_method("selection", old$selection) + } + composite <- "part_selection" %in% names(formals(old_rule)) + rule <- if (composite) { + old_rule + } else { + get_method("selection", selection) + } + + # Step 1: The candidate formulas, per region where the region + # supplies them + if (union) { + if (is.null(old$models)) { + for (region in names(spec$regions)) { + spec$regions[[region]]$habitat_models <- models_union( + spec$regions[[region]]$habitat_models + ) + spec$regions[[region]]$intercept_cats <- NULL + } + } else { + old$models <- models_union(old$models) + } + } + + # Step 2: The stage, keeping only what the harness and the new + # rule read + known <- c(spec_fields()$stage, names(formals(rule))) + new <- old[intersect(names(old), known)] + new$engine <- engine + new$control <- control + new$ic <- NULL + new$post_process <- NULL + + if (composite) { + new$part_selection <- selection + } else { + new$selection <- selection + } + + spec$stages[[index]] <- new + + # Step 3: Hooks that read v2 coefficient tables + if (index == length(spec$stages)) { + spec$final_prediction <- NULL + spec$validate <- NULL + } + + # Step 4: Say so + label <- paste0( + engine, " with `", selection, "`", + if (composite) paste0(" inside `", old$selection, "`") else "", + if (union) ", on every covariate the v2 candidates use" else "" + ) + spec$v2_coverage[[stage]] <- v2_status( + "not reproduced", paste0("Replaced: ", label, ".") + ) + spec$models_overridden <- c( + spec$models_overridden, paste0(stage, " <- ", label) + ) + spec$notes <- paste0( + spec$notes %||% "", " Stage `", stage, "` fitted with ", + label, "." + ) + + spec +} + +# 7. v2 coverage ---- + +## 7.1 v2_status() ---- + +#' State How Much of One v2 Stage a Spec Reproduces +#' +#' The status vocabulary is fixed, so a typo fails when the spec +#' is built. +#' +#' @param status Character. "reproduced", "partial" or +#' "not reproduced". +#' @param note Character. What is and is not reproduced, and why. +#' @return A list of `status` and `note`. +#' +#' @example # Example usage of the function +#' # v2_status("partial", "No age splines.") +v2_status <- function(status, note) { + allowed <- c("reproduced", "partial", "not reproduced") + + if (!is.character(status) || length(status) != 1L || + !status %in% allowed) { + stop( + "v2 status must be one of: ", + paste(allowed, collapse = ", "), ".", + call. = FALSE + ) + } + + if (!is.character(note) || length(note) != 1L || + !nzchar(note)) { + stop("A v2 status needs a one-line note.", call. = FALSE) + } + + list(status = status, note = note) +} + +## 7.2 spec_coverage() ---- + +#' Tabulate What a Set of Specs Reproduces of v2 +#' +#' +#' @param specs A named list of specs. +#' @return A data frame of taxon, stage, status and note. +#' +#' @example # Example usage of the function +#' # spec_coverage(list(lichen = lichen_spec())) +spec_coverage <- function(specs) { + rows <- lapply(names(specs), function(key) { + coverage <- specs[[key]]$v2_coverage + + if (is.null(coverage) || length(coverage) == 0) { + return(data.frame( + taxon = key, stage = NA_character_, + status = "not stated", + note = "The spec has no v2_coverage.", + stringsAsFactors = FALSE + )) + } + + data.frame( + taxon = key, + stage = names(coverage), + status = vapply(coverage, `[[`, character(1), "status"), + note = vapply(coverage, `[[`, character(1), "note"), + stringsAsFactors = FALSE, + row.names = NULL + ) + }) + + do.call(rbind, rows) +} + +# 8. Helpers ---- + +## 8.1 `%||%` ---- + +#' Default for NULL +#' +#' @param a,b Any values. +#' @return `a` unless it is NULL, in which case `b`. +#' +#' @example # Example usage of the function +#' # NULL %||% "default" +`%||%` <- function(a, b) { + if (is.null(a)) b else a +} + +# End of script ---- diff --git a/1_code/harness/species.R b/1_code/harness/species.R new file mode 100644 index 0000000..3d8c898 --- /dev/null +++ b/1_code/harness/species.R @@ -0,0 +1,240 @@ +# --- +# title: List and Select Focal Species +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# in the test dataset's lookup/ (see data_source.R): +# - species_queue.csv, from _setup/09_harmonize_lookups.R +# outputs: none; returns objects in memory +# notes: +# - One queue for every taxon, flattened from the taxon leads' +# lookups by _setup/09. `tier` separates model classes where a +# taxon has them (mammals) and is "modelled" elsewhere; +# `season` is empty except for mammals; `order` keeps v2's +# species order. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup table reading (version: 1.16.4) + +# 2. species_catalogue() ---- + +#' Read the Species Queue +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Keep one taxon, or NULL for all. +#' @return A data frame of taxon, region, season, tier, species, +#' order and source_name. +#' +#' @example # Example usage of the function +#' # species_catalogue(data_dir, taxon = "bryophyte") +species_catalogue <- function(data_dir, taxon = NULL) { + path <- file.path(data_dir, "lookup", "species_queue.csv") + + if (!file.exists(path)) { + stop( + "Species queue not found:\n ", path, + "\nRun 1_code/_setup/09_harmonize_lookups.R first.", + call. = FALSE + ) + } + + catalogue <- cached_read(path, function(p) { + queue <- as.data.frame(fread(p, na.strings = "")) + queue$season <- as.character(queue$season) + queue + }) + + if (!is.null(taxon)) { + known <- unique(catalogue$taxon) + + if (!taxon %in% known) { + stop( + "Unknown taxon `", taxon, "`. Taxa in the catalogue: ", + paste(known, collapse = ", "), + call. = FALSE + ) + } + + catalogue <- catalogue[catalogue$taxon == taxon, ] + rownames(catalogue) <- NULL + } + + catalogue +} + +# 3. list_species() ---- + +#' List the Species Available for a Taxon +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character. Restrict to one region, or NULL. +#' @param tier Character. Restrict to one model tier, or NULL. +#' @param season Character. Restrict to one season, or NULL. +#' Mammal specs must pass it, or a summer spec would also queue +#' the `_Winter` species and fit them with summer weights. +#' @return A character vector of species names, in source order. +#' +#' @example # Example usage of the function +#' # head(list_species(data_dir, "bryophyte", "north"), 3) +#' # list_species(data_dir, "mammal", "north", season = "winter") +list_species <- function( + data_dir, + taxon, + region = NULL, + tier = NULL, + season = NULL +) { + catalogue <- species_catalogue(data_dir, taxon) + + if (!is.null(region)) { + catalogue <- catalogue[catalogue$region == region, ] + } + + if (!is.null(tier)) { + catalogue <- catalogue[catalogue$tier == tier, ] + } + + if (!is.null(season)) { + catalogue <- catalogue[ + !is.na(catalogue$season) & catalogue$season == season, + ] + } + + catalogue <- catalogue[order(catalogue$order), ] + + unique(catalogue$species) +} + +# 4. species_source_name() ---- + +#' The Name a Source Pipeline Used for a Species +#' +#' v2's files sometimes name a species differently from the +#' dataset's column: mammals are "Black BearSummer" there and +#' "BlackBear_Summer" here. +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon,species Character. +#' @return Character, the source name. +#' +#' @example # Example usage of the function +#' # species_source_name(data_dir, "mammal", "BlackBear_Summer") +species_source_name <- function(data_dir, taxon, species) { + catalogue <- species_catalogue(data_dir, taxon) + name <- unique(catalogue$source_name[catalogue$species == species]) + + if (length(name) == 0) { + stop( + "`", species, "` is not in the ", taxon, " species queue.", + call. = FALSE + ) + } + + name[1] +} + +# 5. resolve_species() ---- + +#' Choose the Focal Species for a Run +#' +#' NULL means every modelled species. An unknown name stops the +#' run here rather than hours later inside a bootstrap. +#' +#' @param species Character vector of species, or NULL for all. +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param region Character. Restrict to one region, or NULL. +#' @param tier Character. Restrict to one model tier, or NULL. +#' @return A character vector of species, in source order. +#' +#' @example # Example usage of the function +#' # resolve_species(NULL, data_dir, "mite", region = "north") +#' # resolve_species(c("Oppiella.nova"), data_dir, "mite") +resolve_species <- function( + species, + data_dir, + taxon, + region = NULL, + tier = NULL +) { + available <- list_species(data_dir, taxon, region, tier) + + if (is.null(species)) { + return(available) + } + + if (!is.character(species) || length(species) == 0) { + stop( + "`species` must be a character vector or NULL.", + call. = FALSE + ) + } + + unknown <- setdiff(species, available) + + if (length(unknown) > 0) { + stop( + length(unknown), " species not modelled for ", taxon, + if (is.null(region)) "" else paste0(" (", region, ")"), + ":\n ", + paste(utils::head(unknown, 10), collapse = "\n "), + "\nSee list_species() for what is available.", + call. = FALSE + ) + } + + # Keeps source (v2) order rather than the caller's + intersect(available, species) +} + +# 6. taxon_values() ---- + +#' Read a Named Vector's Entries for One Taxon +#' +#' Experiments select species and covariates with a character +#' vector named by taxon. Names may repeat; unnamed entries apply +#' to every taxon. +#' +#' \preformatted{ +#' species <- c( +#' lichen = "Alectoria.sarmentosa", +#' lichen = "Bryoria.fremontii", +#' mite = "Oppiella.nova" +#' ) +#' } +#' +#' @param x A named character vector, or NULL. +#' @param taxon Character. The taxon to read. +#' @return A character vector of the entries that apply, or NULL +#' when none do. Callers read NULL as "everything". +#' +#' @example # Example usage of the function +#' # taxon_values(c(lichen = "a", mite = "b"), "lichen") +#' # taxon_values(c("shared", lichen = "a"), "mite") +taxon_values <- function(x, taxon) { + if (is.null(x) || length(x) == 0) { + return(NULL) + } + + labels <- names(x) + + # A wholly unnamed vector applies to every taxon + if (is.null(labels)) { + return(unname(x)) + } + + keep <- is.na(labels) | labels == "" | labels == taxon + out <- unname(x[keep]) + + if (length(out) == 0) { + return(NULL) + } + + out +} + +# End of script ---- diff --git a/1_code/harness/summarise.R b/1_code/harness/summarise.R new file mode 100644 index 0000000..f87882e --- /dev/null +++ b/1_code/harness/summarise.R @@ -0,0 +1,358 @@ +# --- +# title: Summarize Result Stores +# author: Brendan Casey +# created: 2026-10-03 +# inputs: +# in pipeline_dir///: +# - coefficients.csv, metrics.csv, grid_predictions.csv, +# meta.json +# outputs: +# collect_results() returns the summaries; write_summaries() +# writes them to out_dir/tables/: +# - coverage.csv, metric_summary.csv, grid_summary.csv +# (small; committed) +# - coefficient_summary.csv (large; gitignored) +# notes: +# - Reduces per-draw result stores to the per-species summaries +# experiments compare. `boot1` is the full-data fit, the +# like-for-like value where a reference fits once (v2 +# mammals). +# - `run` is the store's folder; taxon, season and part come +# from meta.json, so both mammal season runs share "mammal". +# - Taxa whose coefficients need translating (birds, onto v2's +# habitat template) pass a function in `translate`, keeping +# the harness taxon-agnostic. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # grouped summaries (version: 1.16.4) + +# 2. Finding stores ---- + +## 2.1 find_stores() ---- + +#' Find the Result Stores Under a Pipeline Directory +#' +#' A store is a directory holding a meta.json, laid out as +#' `///`. +#' +#' @param pipeline_dir Character. +#' @return A data frame of dir, run, region, taxon, season, part +#' and final_stage, ordered by run and region. +#' +#' @example # Example usage of the function +#' # find_stores("2_pipeline/exp_000_parity_v2") +find_stores <- function(pipeline_dir) { + dirs <- list.dirs(pipeline_dir, recursive = TRUE) + dirs <- dirs[file.exists(file.path(dirs, "meta.json"))] + + if (length(dirs) == 0) { + return(data.frame( + dir = character(0), run = character(0), region = character(0), + taxon = character(0), season = character(0), + part = character(0), final_stage = character(0), + stringsAsFactors = FALSE + )) + } + + rows <- lapply(dirs, function(dir) { + meta <- store_meta(dir) + + # Only the run comes from the path; the rest from meta.json + data.frame( + dir = dir, + run = basename(dirname(dir)), + region = if (is.na(meta$region)) basename(dir) else meta$region, + taxon = if (is.na(meta$taxon)) { + basename(dirname(dir)) + } else { + meta$taxon + }, + season = meta$season, + part = meta$part, + final_stage = meta$final_stage, + stringsAsFactors = FALSE + ) + }) + + stores <- do.call(rbind, rows) + stores[order(stores$run, stores$region), , drop = FALSE] +} + +## 2.2 store_meta() ---- + +#' Read a Store's meta.json, Tolerating a Missing Field +#' +#' @param dir Character. A result store directory. +#' @return A list with taxon, region, season, part and +#' final_stage; NA for what the file does not say. +#' +#' @example # Example usage of the function +#' # store_meta("2_pipeline/exp_000_parity_v2/lichen/north") +store_meta <- function(dir) { + if (!requireNamespace("jsonlite", quietly = TRUE)) { + stop("Reading meta.json needs the jsonlite package.", + call. = FALSE) + } + + meta <- jsonlite::fromJSON(file.path(dir, "meta.json")) + + field <- function(name) { + value <- meta[[name]] + + if (is.null(value) || length(value) == 0 || + identical(value, "NA") || all(is.na(value))) { + NA_character_ + } else { + as.character(value[1]) + } + } + + list( + taxon = field("taxon"), + region = field("region"), + season = field("season"), + part = field("part"), + final_stage = if (is.null(meta$stages)) { + NA_character_ + } else { + utils::tail(meta$stages, 1) + } + ) +} + +# 3. Summarizing draws ---- + +## 3.1 summarise_draws() ---- + +#' Summarize a Value over Bootstrap Draws, per Group +#' +#' @param rows A data frame with `boot` and the value column. +#' @param value Character. The column to summarize. +#' @param keys Character vector of grouping columns. +#' @return A data.table of the keys plus n, median, p10, p90, +#' boot1, mean and sd. n counts the finite values; boot1 is the +#' iteration-1 value where there is exactly one. +#' +#' @example # Example usage of the function +#' # summarise_draws(metrics, "value", c("species", "metric")) +summarise_draws <- function(rows, value, keys) { + rows <- as.data.table(rows) + + # The column is passed through .SDcols rather than named inside + # the call, because a column may itself be called `value` + rows[, draw_summary(.SD[[1L]], boot), + by = keys, .SDcols = value] +} + +## 3.2 draw_summary() ---- + +#' Summarize One Value over Its Draws +#' +#' Comparisons read the median and 10-90% band because draw +#' distributions are often skewed; mean and sd are added for +#' tools that expect them. +#' +#' @param x Numeric vector, one value per draw. +#' @param boot Integer vector of the draw each value came from. +#' @return A list of n, median, p10, p90, boot1, mean and sd. sd +#' is NA with fewer than two values. +#' +#' @example # Example usage of the function +#' # draw_summary(c(0.1, 0.3, 0.2), 1:3) +draw_summary <- function(x, boot) { + first <- x[boot == 1L] + first <- if (length(first) == 1 && is.finite(first)) { + first + } else { + NA_real_ + } + finite <- x[is.finite(x)] + + out <- if (length(finite) == 0) { + list(n = 0, median = NA_real_, p10 = NA_real_, + p90 = NA_real_, boot1 = first) + } else { + quantiles <- stats::quantile( + finite, c(0.1, 0.5, 0.9), names = FALSE + ) + + list(n = as.numeric(length(finite)), median = quantiles[2], + p10 = quantiles[1], p90 = quantiles[3], boot1 = first) + } + + # Appended, so the columns before them keep their positions + out$mean <- if (length(finite) == 0) NA_real_ else mean(finite) + out$sd <- if (length(finite) < 2) NA_real_ else stats::sd(finite) + + out +} + +# 4. collect_results() ---- + +#' Reduce Every Store in a Pipeline Directory to Summaries +#' +#' @param pipeline_dir Character. Where the stores are. +#' @param data_dir Character. Passed to `translate` functions. +#' @param translate Named list of functions, by taxon. Each takes +#' the store's coefficients, `data_dir` and the region, and +#' returns extra coefficient rows - a translation of them - to +#' summarize alongside. +#' @return A list of data frames: `coverage`, `coefficient_summary`, +#' `metric_summary`, `grid_summary`, and for the run record, +#' `store_rows` (row counts per store) and `metrics` (every +#' metric row, labelled with its run and region). +#' +#' @example # Example usage of the function +#' # results <- collect_results("2_pipeline/exp_000_parity_v2", +#' # data_dir, translate = list(bird = bird_habitat_translation)) +collect_results <- function(pipeline_dir, data_dir = NULL, + translate = list()) { + stores <- find_stores(pipeline_dir) + + if (nrow(stores) == 0) { + message("No result stores in ", pipeline_dir, ".") + } + + pieces <- lapply(seq_len(nrow(stores)), function(i) { + store <- stores[i, ] + labels <- store[, c("taxon", "run", "region", "season", "part")] + rownames(labels) <- NULL + + coefficients <- read_results(store$dir, "coefficients") + metrics <- read_results(store$dir, "metrics") + grid <- read_results(store$dir, "grid_predictions") + + counts <- data.frame( + run = store$run, region = store$region, + species = length(unique(c(coefficients$species, + metrics$species))), + draws = length(unique(c(coefficients$boot, metrics$boot))), + coefficient_rows = NROW(coefficients), + metric_rows = NROW(metrics), + grid_rows = NROW(grid), + stringsAsFactors = FALSE + ) + + # A store written before stages were recorded holds the final + # stage only + if (!is.null(coefficients) && !"stage" %in% names(coefficients)) { + coefficients$stage <- store$final_stage + } + + # Coefficients a taxon needs translated before comparing + translator <- translate[[store$taxon]] + + if (is.function(translator) && !is.null(coefficients)) { + extra <- translator(coefficients, data_dir, store$region) + + if (!is.null(extra) && nrow(extra) > 0) { + coefficients <- rbind( + coefficients, extra[, names(coefficients)] + ) + } + } + + summarised <- function(rows, value, keys) { + if (is.null(rows) || nrow(rows) == 0) { + return(NULL) + } + + cbind(labels, summarise_draws(rows, value, keys)) + } + + list( + coverage = cbind(labels, data.frame( + species = counts$species, + draws = counts$draws, + stages = if (is.null(coefficients)) { + "" + } else { + paste(unique(coefficients$stage), collapse = ", ") + }, + has_coefficients = !is.null(coefficients), + has_grid = !is.null(grid), + stringsAsFactors = FALSE + )), + coefficient_summary = summarised( + coefficients, "estimate", c("stage", "species", "term") + ), + metric_summary = summarised( + metrics, "value", c("species", "metric") + ), + grid_summary = summarised( + grid, "prediction", c("species", "grid_unit") + ), + store_rows = counts, + metrics = if (is.null(metrics)) { + NULL + } else { + cbind(run = store$run, metrics) + } + ) + }) + + combine <- function(name) { + parts <- lapply(pieces, `[[`, name) + parts <- parts[!vapply(parts, is.null, logical(1))] + + if (length(parts) == 0) { + return(NULL) + } + + out <- as.data.frame(rbindlist(parts, use.names = TRUE)) + rownames(out) <- NULL + out + } + + stats::setNames( + lapply( + c("coverage", "coefficient_summary", "metric_summary", + "grid_summary", "store_rows", "metrics"), + combine + ), + c("coverage", "coefficient_summary", "metric_summary", + "grid_summary", "store_rows", "metrics") + ) +} + +# 5. write_summaries() ---- + +#' Write the Summary Tables +#' +#' @param results From collect_results(). +#' @param out_dir Character. Tables go in `out_dir/tables/`. +#' @return The paths written, invisibly. +#' +#' @example # Example usage of the function +#' # write_summaries(results, "3_output/exp_000_parity_v2") +write_summaries <- function(results, out_dir) { + tables_dir <- file.path(out_dir, "tables") + dir.create(tables_dir, recursive = TRUE, showWarnings = FALSE) + + tables <- c( + "coverage", "metric_summary", "grid_summary", + "coefficient_summary" + ) + written <- character(0) + + for (name in tables) { + table <- results[[name]] + + if (is.null(table)) { + next + } + + path <- file.path(tables_dir, paste0(name, ".csv")) + fwrite(table, path, na = "") + cat("Wrote tables/", name, ".csv: ", nrow(table), " rows\n", + sep = "") + written <- c(written, path) + } + + invisible(written) +} + +# End of script ---- diff --git a/1_code/harness/utils/stage_v2_inputs.R b/1_code/harness/utils/stage_v2_inputs.R deleted file mode 100644 index 6092629..0000000 --- a/1_code/harness/utils/stage_v2_inputs.R +++ /dev/null @@ -1,197 +0,0 @@ -# --- -# title: Stage v2 Inputs for an Experiment Run -# author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none -# notes: -# - Builds the run root a v2 modelling script expects, under -# 2_pipeline///, so an experiment can run the -# untouched v2 code on its own species vector. -# - The v2 scripts take no arguments. They build their work -# queue from veg.species.list and soil.species.list, loaded -# from -model-data.Rdata, so a species selection is -# applied by rewriting those two vectors in a staged copy of -# that file. -# - Only those two vectors change. climate.data, veg.data and -# soil.data are staged untouched because 02x addresses -# covariates positionally, as colnames(veg.data)[1408:1494], -# and dropping species columns would shift those indices. -# - bootstrap.ids is staged whole rather than subset. The v2 -# code reads it as boot.data[[species]], so extra entries are -# ignored and the copy stays faithful to the source. -# - Function files are staged from this repository's copies in -# 0_data/v2_scripts/, which makes the repository the source -# of truth for the code that runs. -# - Requires resolve_v2_root() from v2_script_runner.R. -# --- - -# 1. stage_v2_inputs() ---- - -#' Stage v2 Inputs for One Taxon -#' -#' Creates a v2-shaped run root under 2_pipeline// and -#' fills it with the data, lookups, and function files the v2 -#' scripts read, with the species queue narrowed to `species`. -#' The returned path is what a module runner takes as `v2_root`. -#' -#' @param exp_id Character. Experiment identifier, used verbatim -#' as the folder name under 2_pipeline/ (e.g. -#' "exp_000_parity_v2"). -#' @param taxon Character. Taxon slug as it appears in the v2 -#' file names, one of "bryophyte", "lichen", "mite", or -#' "vascular-plant". -#' @param species Character vector of species to model, or NULL -#' to keep every species in the source data. -#' @param source_root Character. Path to the v2 project holding -#' the source data. Defaults to the SDM_V2_ROOT environment -#' variable. -#' @param project_root Character. Path to this repository. -#' @param code_dir Character. Directory holding this -#' repository's copies of the v2 scripts, relative to -#' `project_root`. -#' @param refresh Logical. Re-stage the model data even when a -#' staged copy exists. Set FALSE to reuse a staged file across -#' re-runs of the same species vector. -#' @return Character. Absolute path to the staged run root. -#' -#' @example -#' # Example usage of the function -#' v2_root <- stage_v2_inputs( -#' exp_id = "exp_000_parity_v2", -#' taxon = "mite", -#' species = c("Oppiella.nova", "Tectocepheus.velatus") -#' ) -stage_v2_inputs <- function( - exp_id, - taxon, - species = NULL, - source_root = NULL, - project_root = getwd(), - code_dir = "0_data/v2_scripts/plants", - refresh = TRUE -) { - # Step 1: Resolve both roots to absolute paths - project_root <- normalizePath(project_root, winslash = "/") - if (is.null(source_root)) { - source_root <- Sys.getenv("SDM_V2_ROOT", unset = NA_character_) - } - source_root <- resolve_v2_root(source_root) - - staged_root <- file.path( - project_root, "2_pipeline", exp_id, taxon - ) - - # Step 2: Create the v2 folder layout the scripts expect - layout <- c( - "0_data/species/processed", - "0_data/bootstrap", - "0_data/lookup/prediction-matrix", - "1_code/r-scripts", - "3_output/models", - "3_output/validation" - ) - for (sub_dir in layout) { - dir.create( - file.path(staged_root, sub_dir), - recursive = TRUE, showWarnings = FALSE - ) - } - - # Step 3: Stage the function files from this repository, so the - # code that runs is the code held here - function_files <- c( - "hierarchical-model_functions.R", - "model-validation_functions.R" - ) - file.copy( - file.path(project_root, code_dir, function_files), - file.path(staged_root, "1_code/r-scripts"), - overwrite = TRUE - ) - - # Step 4: Stage the lookups and bootstrap ids unchanged - lookups <- file.path( - "0_data/lookup/prediction-matrix", - c( - "veg-prediction-matrix-CC_2024.csv", - "soil-prediction-matrix_2024.csv" - ) - ) - boot_ids <- file.path( - "0_data/bootstrap", paste0(taxon, "-bootstrap-ids.Rdata") - ) - for (item in c(lookups, boot_ids)) { - file.copy( - file.path(source_root, item), - file.path(staged_root, item), - overwrite = TRUE - ) - } - - # Step 5: Stage the model data with the species queue narrowed. - # Every other object is written back untouched. - model_data <- file.path( - "0_data/species/processed", - paste0(taxon, "-model-data.Rdata") - ) - staged_data <- file.path(staged_root, model_data) - - if (refresh || !file.exists(staged_data)) { - staged_env <- new.env(parent = emptyenv()) - objects <- load( - file.path(source_root, model_data), - envir = staged_env - ) - - if (!is.null(species)) { - known <- unique(c( - staged_env$veg.species.list, - staged_env$soil.species.list - )) - unknown <- setdiff(species, known) - if (length(unknown) > 0) { - stop( - "Species not in the ", taxon, " data:\n ", - paste(unknown, collapse = "\n "), - call. = FALSE - ) - } - # intersect() keeps the source ordering, so a staged run - # queues species in the same order the v2 code would - staged_env$veg.species.list <- intersect( - staged_env$veg.species.list, species - ) - staged_env$soil.species.list <- intersect( - staged_env$soil.species.list, species - ) - } - - # Step 6: Warn on an empty queue. 02x still runs, but the - # matching model set comes back empty, which is easier to - # diagnose here than three hours later. - for (queue in c("veg.species.list", "soil.species.list")) { - if (length(staged_env[[queue]]) == 0) { - warning( - "No species left in ", queue, " for ", taxon, ".", - call. = FALSE - ) - } - } - - save( - list = objects, envir = staged_env, file = staged_data - ) - - cat( - "Staged ", taxon, " - ", - length(staged_env$veg.species.list), " vegetation and ", - length(staged_env$soil.species.list), " soil species\n", - sep = "" - ) - } - - staged_root -} - -# End of script ---- diff --git a/1_code/harness/utils/v2_script_runner.R b/1_code/harness/utils/v2_script_runner.R deleted file mode 100644 index 7dc4501..0000000 --- a/1_code/harness/utils/v2_script_runner.R +++ /dev/null @@ -1,308 +0,0 @@ -# --- -# title: v2 Script Runner Utilities -# author: Brendan Casey -# created: 2026-09-05 -# inputs: none -# outputs: none -# notes: -# - Taxon-agnostic helpers for running the unmodified v2 -# scripts in 0_data/v2_scripts/ from this repository. -# Sourced by the runners in 1_code/modules//. -# - The v2 scripts' paths are relative to the v2 project root, -# so run_step() switches the working directory to run_dir for -# the length of a step and restores it afterwards. -# - The v2 scripts open with rm(list = ls()), so run_step() -# snapshots the names in `protect` and restores them on exit. -# Objects a script leaves behind are not kept, so the next -# script's cleanup still frees them. -# - Scripts are sourced into the global environment on purpose; -# their clusterExport() calls read from .GlobalEnv. -# - Assumes the v2 layout - inputs under 0_data/, functions -# under 1_code/r-scripts/, outputs under 3_output/. -# --- - -# 1. resolve_v2_root() ---- - -#' Resolve and Validate a v2 Project Root -#' -#' Confirms the configured v2 project root exists and returns it -#' as an absolute path, so a run stops with a readable message -#' rather than failing on the first relative path inside a v2 -#' script. -#' -#' @param root Character. Path to the v2 project root, or NA when -#' it has not been configured. -#' @return Character. The normalized absolute path. Stops when -#' `root` is unset, empty, or not a directory. -#' -#' @example -#' # Example usage of the function -#' v2_root <- Sys.getenv("SDM_V2_ROOT", unset = NA_character_) -#' v2_root <- resolve_v2_root(v2_root) -resolve_v2_root <- function(root) { - # Step 1: Reject an unset, empty, or absent path. The tests are - # ordered so || short-circuits before dir.exists() sees an NA. - if (length(root) != 1 || is.na(root) || !nzchar(root) || - !dir.exists(root)) { - stop( - "The v2 project root is not a directory: ", root, "\n", - "Set SDM_V2_ROOT, or assign v2_root in the runner's ", - "section 1.2.", - call. = FALSE - ) - } - - # Step 2: Return an absolute path, since run_step() changes the - # working directory while a step runs - normalizePath(root, winslash = "/") -} - -# 2. check_inputs() ---- - -#' Check That Required Files Exist -#' -#' Confirms every file a pipeline step reads is present before the -#' step runs, so a missing input fails with a readable message -#' rather than partway through a long model fit. -#' -#' @param paths Character vector. File paths to check, relative to -#' `root`. -#' @param root Character. Directory the paths are relative to. -#' @param what Character. Label for the group of files, used in -#' the error message (e.g. "inputs for 02d"). -#' @return NULL, invisibly. Stops with the missing paths listed -#' when any file is absent. -#' -#' @example -#' # Example usage of the function -#' check_inputs( -#' c("0_data/bootstrap/mite-bootstrap-ids.Rdata"), -#' root = v2_root, -#' what = "inputs for 02c" -#' ) -check_inputs <- function(paths, root, what) { - # Step 1: Test each path against the given root - missing <- paths[!file.exists(file.path(root, paths))] - - # Step 2: Report every missing file at once, not just the first - if (length(missing) > 0) { - stop( - "Missing ", what, " under ", root, ":\n ", - paste(missing, collapse = "\n "), - call. = FALSE - ) - } - - invisible(NULL) -} - -# 3. create_v2_output_dirs() ---- - -#' Create the Output Folders a v2 Script Writes To -#' -#' The v2 scripts end in save(), which fails when the destination -#' folder does not exist. Creating the folders up front keeps a -#' finished model run from being lost on its last line. -#' -#' @param root Character. Path to the v2 project root. -#' @param dirs Character vector. Output folders to create, -#' relative to `root`. Defaults to the model and validation -#' folders the v2 modelling scripts write to. -#' @return NULL, invisibly. -#' -#' @example -#' # Example usage of the function -#' create_v2_output_dirs(v2_root) -create_v2_output_dirs <- function( - root, - dirs = c("3_output/models", "3_output/validation") -) { - # Step 1: Create each folder, leaving existing ones untouched - for (out_dir in dirs) { - out_path <- file.path(root, out_dir) - if (!dir.exists(out_path)) { - dir.create(out_path, recursive = TRUE) - } - } - - invisible(NULL) -} - -# 4. check_function_files() ---- - -#' Compare v2 Function Files With This Repository's Copies -#' -#' The v2 scripts are sourced from this repository but the -#' function files they source are read from the v2 project root, -#' so the two copies can drift. A mismatch means the run is not -#' reproducing the code held here, which matters for parity work. -#' -#' @param repo_dir Character. Directory holding this repository's -#' copies of the v2 scripts (e.g. -#' "0_data/v2_scripts/plants"). -#' @param root Character. Path to the v2 project root. -#' @param files Character vector. Function file names to compare. -#' Defaults to the two files the v2 modelling and validation -#' scripts source. -#' @param v2_dir Character. Directory holding the function files -#' inside the v2 project, relative to `root`. -#' @return Character vector of the file names that differ, -#' invisibly. Warns when the vector is non-empty. -#' -#' @example -#' # Example usage of the function -#' check_function_files( -#' repo_dir = v2_code_dir, -#' root = v2_root -#' ) -check_function_files <- function( - repo_dir, - root, - files = c( - "hierarchical-model_functions.R", - "model-validation_functions.R" - ), - v2_dir = "1_code/r-scripts" -) { - # Step 1: Checksum both copies of each file. md5sum() returns NA - # for a missing file, and NA != x is NA, so guard the comparison - # rather than letting it drop the file silently. - repo_sums <- tools::md5sum(file.path(repo_dir, files)) - v2_sums <- tools::md5sum(file.path(root, v2_dir, files)) - - # Step 2: Flag every file that differs or could not be read - differs <- is.na(repo_sums) | is.na(v2_sums) | - repo_sums != v2_sums - drifted <- files[differs] - - # Step 3: Warn rather than stop, since a deliberate v2 patch is - # a legitimate reason to run with different function files - if (length(drifted) > 0) { - warning( - "Function files under ", root, " differ from the copies ", - "in ", repo_dir, ":\n ", - paste(drifted, collapse = "\n "), - call. = FALSE - ) - } - - invisible(drifted) -} - -# 5. run_step() ---- - -#' Run a Pipeline Step -#' -#' Sources a v2 script from `code_dir` with the working directory -#' set to `run_dir`, reporting its label and the time it took to -#' run. Mirrors console output to a timestamped log file so an -#' unattended run leaves a record, and restores the objects named -#' in `protect` after the script clears the global environment. -#' -#' @param label Character. A descriptive label for the step, used -#' in the console output and in the log file name -#' (e.g. "02c: Hierarchical models (mites)"). -#' @param script Character. The filename of the script to run, -#' relative to `code_dir`. -#' @param code_dir Character. Absolute path to the directory -#' holding the v2 scripts. -#' @param run_dir Character. Absolute path to the working -#' directory the sourced script's own relative paths resolve -#' against, normally the v2 project root. -#' @param log_dir Character. Directory for log files, or NULL to -#' print to the console only. -#' @param protect Character vector. Names of global objects to -#' restore after the script runs, since the v2 scripts open with -#' rm(list = ls()). Names that do not exist are skipped. -#' @return NULL, invisibly. Output is printed to the console and, -#' when `log_dir` is set, copied to a log file. -#' -#' @example -#' # Example usage of the function -#' run_step( -#' label = "02c: Hierarchical models (mites)", -#' script = "02c_hierarchical-models-mites.R", -#' code_dir = v2_code_dir, -#' run_dir = v2_root, -#' log_dir = log_path, -#' protect = runner_objects -#' ) -#' -#' # Run without writing a log file -#' run_step( -#' label = "02c: Hierarchical models (mites)", -#' script = "02c_hierarchical-models-mites.R", -#' code_dir = v2_code_dir, -#' run_dir = v2_root, -#' log_dir = NULL, -#' protect = runner_objects -#' ) -run_step <- function( - label, - script, - code_dir, - run_dir, - log_dir = NULL, - protect = character(0) -) { - # Step 1: Announce the step and record the start time - cat("\n--- Running ", label, " ---\n", sep = "") - start <- Sys.time() - - # Step 2: Snapshot the caller's own objects. The v2 scripts open - # with rm(list = ls()), which would otherwise delete the flags - # and helpers partway through the run. Only the named objects - # are kept, so whatever a script leaves behind is still freed by - # the next script's cleanup. - present <- protect[ - vapply( - protect, exists, logical(1), - envir = globalenv(), inherits = FALSE - ) - ] - keep <- mget(present, envir = globalenv()) - on.exit(list2env(keep, envir = globalenv()), add = TRUE) - - # Step 3: Run from the v2 project root, since the script's paths - # are relative to that root rather than to this repository - old_wd <- getwd() - setwd(run_dir) - on.exit(setwd(old_wd), add = TRUE) - - # Step 4: Mirror output to a timestamped log. split = TRUE keeps - # it on the console too, and on.exit() closes the connection - # even if the script errors. - if (!is.null(log_dir)) { - if (!dir.exists(log_dir)) { - dir.create(log_dir, recursive = TRUE) - } - stamp <- format(Sys.time(), "%Y-%m-%d_%H-%M-%S") - safe_label <- gsub("[^A-Za-z0-9_]+", "_", label) - log_file <- file.path( - log_dir, - paste0(stamp, "_", safe_label, ".log") - ) - log_con <- file(log_file, open = "wt") - sink(log_con, split = TRUE) - on.exit( - { - sink() - close(log_con) - }, - add = TRUE - ) - cat("Logging to ", log_file, "\n", sep = "") - } - - # Step 5: Source into the global environment, which is where the - # v2 scripts' clusterExport() calls look for their objects - source(file.path(code_dir, script)) - - # Step 6: Report how long the step took - elapsed <- format(round(Sys.time() - start, 1)) - cat("Completed ", label, " in ", elapsed, "\n", sep = "") - - invisible(NULL) -} - -# End of script ---- diff --git a/1_code/methods/README.md b/1_code/methods/README.md new file mode 100644 index 0000000..6c5788c --- /dev/null +++ b/1_code/methods/README.md @@ -0,0 +1,151 @@ +# Methods + +Every method a spec can name lives here, one file each. A file +defines its method and registers it under a name; a spec names it; +the harness looks it up. Adding a method is adding a file. No +harness file changes. + +```r +source("1_code/harness/harness.R") +load_framework() +list_methods() # everything registered, with what it needs +list_methods("engine") # one kind +``` + +| Folder | Kind | Registered with | Named in a spec as | +| --- | --- | --- | --- | +| `engines/` | How a model is fitted | `register_engine()` | `stage$engine` | +| `selection/` | How a candidate set becomes one result | `register_selection()` | `stage$selection` | +| `resampling/` | Which survey units each draw fits | `register_resampler()` | `resample$scheme` | +| `metrics/` | How a prediction is scored | `register_metric()` | scored for every run | + +Files whose names start with `_` are shared helpers and load first +(`engines/_glm_family.R`). `_templates/` holds a copy-and-fill +skeleton for an engine and a selection rule; it is not loaded. + +## What is registered + +| Kind | Name | What it does | Needs | +| --- | --- | --- | --- | +| engine | `glm` | `stats::glm` (v2 mammals, birds) | | +| engine | `bayesglm` | `arm::bayesglm`, weakly informative priors (v2 plants) | | +| engine | `xgboost` | Boosted regression trees, `xgboost::xgb.train`; binomial (proportions too), Poisson, log-link Gamma, Gaussian; no coefficients, information criterion or standard errors, so use the `single` rule | | +| selection | `single` | Fit the first candidate; no ranking | | +| selection | `aic_best` | Keep the lowest-scoring candidate | ic | +| selection | `aic_average` | Average coefficients by Akaike weight (v2 climate) | ic, coefficients | +| selection | `staged_bic` | Forward selection through groups (v2 bird landcover) | ic, coefficients | +| selection | `ivw_grid` | Inverse-variance average onto the habitat grid (v2 plant habitat) | coefficients, se | +| selection | `hurdle` | Presence, then abundance given presence, each through an inner rule (`part_selection`); reports both and their product on the grid (v2 mammals) | those of `part_selection` | +| resampler | `precomputed` | Replay draws stored with the dataset (v2 birds; plant `v2_ids`) | | +| resampler | `spatial_block` | Bootstrap within coarse spatial blocks (v2 plants, mammals) | | +| resampler | `spatial_cv` | Spatial block cross-validation; each draw holds out one fold | | +| metric | `auc`, `deviance_explained`, `rmse`, `spearman`, `calibration_slope`, `prevalence`, `n` | Scored in-sample and out-of-bag for every draw | | + +`validate_spec()` checks a spec against this table before any data +is read. A rule paired with an engine that lacks what it needs, an +unregistered name, or a misspelt field stops the run with a +sentence saying which. + +## The engine contract + +An engine is a list: + +| Element | Required | Contract | +| --- | --- | --- | +| `name`, `description` | yes | The registered name, and one line for `list_methods()` | +| `capabilities` | yes | A subset of `"coefficients"`, `"ic"`, `"se"`, `"converged"` | +| `fit(formula, data, family, weights, offset, control)` | yes | Returns `list(fit, ok, message)`. **Never raises**: a failure returns `ok = FALSE` and the message, because candidate sets hold models that cannot be fitted for every species and draw | +| `predict(fit, newdata, type, se)` | yes | `type` is `"link"` or `"response"`. Returns one number per row, or `NULL` when it cannot. With `se = TRUE` (only if declared), `list(fit, se.fit)`. An offset in the formula, `+ offset(offset)`, must be applied to new data | +| `coef(fit)` | with `coefficients` | A data frame of `term`, `estimate`, `se` | +| `ic(fit, type)` | with `ic` | AIC, AICc or BIC; `Inf` for a failed fit | +| `converged(fit)`, `nobs(fit)` | no | Assumed converged, and observations read with `stats::nobs`, when absent | + +The harness passes the offset in the formula, never as an +argument: an offset argument is not carried onto new data by +`predict()`, so every prediction outside the draw would be wrong. + +`family` arrives as a name (`"binomial"`, `"poisson"`) or a family +object (`Gamma(link = "log")`). An engine with its own vocabulary, +such as `xgboost`'s `objective = "binary:logistic"`, translates it. + +### Testing an engine + +```r +check_engine(my_engine()) # a definition, or a registered name +check_engine("glm") +``` + +`check_engine()` fits small synthetic binomial and Poisson data, +with weights, an offset and a factor, and checks every part of the +contract the engine declares. Every row should read `TRUE` before +the engine meets the dataset. + +### Which rules an engine can use + +An engine without an information criterion or coefficients (a +boosted regression tree, a random forest) can still run any +stage, using the `single` rule: one formula, fitted as given. To +compare it with v2 on a stage v2 fits with model averaging, +replace that stage's engine, selection and models together. The +v2 post-processing steps that read coefficients (the plant +stand-age splines, say) then do not apply, and the stage should +drop them; see +[`docs/getting_started.md`](../../docs/getting_started.md#2-a-different-engine-or-rule-specs). + +`replace_stage_method()` does all of this in one call. Its stage +defaults to the spec's `habitat_stage`, so the same call serves +every taxon: + +```r +specs <- lapply(standard_specs(), replace_stage_method, + engine = "xgboost") +``` + +A **composite** rule (one that declares `part_selection`, as +`hurdle` does) keeps its place, and the new rule becomes the one +each part runs. The mammal hurdle's structure (presence on every +unit, abundance where the species was found) is a property of the +data, so it stays; the new engine fits both halves, and v2's +table-building (`post_process`) is removed. + +A `post_process` step is a function of the selection result and +the stage's data. A step that also declares `grid`, `species` or +`stage` is given them. + +A stage carried into the next one (`carry_as`) is carried from the +stage's final model: its averaged coefficients where it has them, +its prediction otherwise. + +## The other contracts + +**Selection rule.** A function taking `models` (formulas, or named +groups of them), `base`, `data`, `engine`, `family`, `weights`, +`offset`, `ic` and `control`, returning `selection_result()`. Any +further argument is a setting, filled from the stage field of the +same name. Fit candidates with `fit_candidates()`; read +coefficients with `engine_coef()`. A rule that combines candidates +passes `predict` (see `combined_predictor()`) so metrics and grid +predictions use the combined model. Register with the capabilities +it `requires`. + +**Resampler.** A function of `frame`, `iterations`, `seed` and +`context` (data directory, taxon, species, spec), plus any setting +from the spec's `resample` list, returning one character vector of +survey unit ids per draw: the units that draw fits. Units left out +are scored out-of-bag. Draw under `with_seed(seed, ...)` so a +species' draws depend only on its seed. + +**Metric.** A function of `observed` and `predicted`, both on the +response scale, returning one number. Return `NA` rather than +stopping when the metric does not apply to a draw. + +## Checklist for a new method + +- [ ] One file in the right folder, from `_templates/` where there + is one, with the standard header. +- [ ] Registered with a one-line description and, for a rule, what + it `requires`. +- [ ] `check_engine()` passes, for an engine. +- [ ] `Rscript 1_code/tests/run_tests.R` passes. +- [ ] Tried on one species and a few draws (`species = "one_each"`, + `n_bootstraps = 5`) before a full run. diff --git a/1_code/methods/_templates/engine_template.R b/1_code/methods/_templates/engine_template.R new file mode 100644 index 0000000..4e89add --- /dev/null +++ b/1_code/methods/_templates/engine_template.R @@ -0,0 +1,94 @@ +# --- +# title: Engine - [Name] +# author: [Your Name] +# created: [YYYY-MM-DD] +# inputs: none +# outputs: registers the `[name]` engine +# notes: +# - A template. Copy to 1_code/methods/engines/[name].R, fill in +# the four functions, and run check_engine(engine_[name]()) +# until every check passes. Then name it in a spec stage: +# `engine = "[name]"`. +# - The contract, in full, is in 1_code/methods/README.md. In +# short: +# - fit() never raises. It returns list(fit, ok, message), +# with ok = FALSE and the error message when fitting fails, +# because a candidate set is expected to hold models that +# cannot be fitted for every species and draw. +# - predict() returns one number per row of newdata, or NULL +# when it cannot. An offset in the formula +# (`+ offset(offset)`) must be applied to new data. +# - Declare only the capabilities the engine really has. +# Selection rules check them: a rule that ranks candidates +# needs `ic`; one that averages coefficients needs +# `coefficients`; inverse-variance averaging needs `se`. +# With none of them, use the `single` rule. +# - Load any package lazily with requireNamespace(), so a run +# that does not use this engine does not need the package. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# [package], lazily; see the header. + +# 2. engine_[name]() ---- + +#' [One-line title of the method] +#' +#' [What it fits, and any setting it takes through `control`.] +#' +#' @return An engine definition. +#' +#' @example # Example usage of the function +#' # check_engine(engine_[name]()) +engine_template <- function() { + list( + name = "[name]", + description = "[One line for list_methods()]", + + # A subset of engine_capabilities(): "coefficients", "ic", + # "se", "converged" + capabilities = character(0), + + # Step 1: Fit. Never raise; return the failure instead. + fit = function(formula, data, family, weights = NULL, + offset = NULL, control = list()) { + tryCatch( + { + fit <- NULL # [fit the model with formula and data] + list(fit = fit, ok = TRUE, message = NA_character_) + }, + error = function(e) { + list(fit = NULL, ok = FALSE, message = conditionMessage(e)) + } + ) + }, + + # Step 2: Predict. `type` is "link" or "response"; with + # se = TRUE (only when declared), list(fit, se.fit). + predict = function(fit, newdata, type = "link", se = FALSE) { + if (is.null(fit) || !isTRUE(fit$ok)) { + return(NULL) + } + + tryCatch( + NULL, # [predict fit$fit onto newdata, one value per row] + error = function(e) NULL + ) + }, + + # Step 3, when declared: a data frame of term, estimate, se + coef = NULL, + + # Step 4, when declared: a number for type "AIC", "AICc" or + # "BIC"; Inf for a failed fit, so it never wins + ic = NULL + ) +} + +# 3. Register ---- +# Uncomment once check_engine() passes: +# register_engine(engine_template()) + +# End of script ---- diff --git a/1_code/methods/_templates/selection_template.R b/1_code/methods/_templates/selection_template.R new file mode 100644 index 0000000..6aa36c6 --- /dev/null +++ b/1_code/methods/_templates/selection_template.R @@ -0,0 +1,80 @@ +# --- +# title: Selection Rule - [Name] +# author: [Your Name] +# created: [YYYY-MM-DD] +# inputs: none +# outputs: registers the `[name]` rule +# notes: +# - A template. Copy to 1_code/methods/selection/[name].R and +# fill it in. Then name it in a spec stage: +# `selection = "[name]"`. +# - A rule turns a candidate set into one result. It fits its +# own candidates, with fit_candidates(), and returns +# selection_result(). +# - Any argument beyond the standard nine is a setting, filled +# from the stage field of the same name. A stage with +# `my_threshold = 3` passes 3 to a rule declaring +# `my_threshold`. No harness change is needed. +# - Read coefficients with engine_coef(engine, fit), never with +# coef() on the fitted object, so the rule works with any +# engine that declares `coefficients`. +# - When the rule combines candidates, pass `predict` to +# selection_result() - combined_predictor() builds one - so +# metrics and grid predictions use the combined model rather +# than one candidate. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_[name]() ---- + +#' [One-line title of the rule] +#' +#' @inheritParams select_single +#' @param [setting] [What the stage field sets.] +#' @return A selection result. +#' +#' @example # Example usage of the function +#' # select_[name](models, response ~ 1, d, get_engine("glm"), +#' # "binomial") +select_template <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list() +) { + # Step 1: Fit every candidate + fitted <- fit_candidates( + models, base, data, engine, family, weights, offset, ic, + control + ) + table <- candidate_table(fitted) + + if (!any(table$ok)) { + return(selection_result(NULL, NULL, table, fitted)) + } + + # Step 2: Choose or combine. [Replace with the rule.] + chosen <- which(table$ok)[1] + + # Step 3: Return the result + selection_result( + fit = fitted$fits[[chosen]], + coefficients = engine_coef(engine, fitted$fits[[chosen]]), + ic_table = table, + fitted = fitted, + engine = engine + ) +} + +# 3. Register ---- +# Name the engine capabilities the rule needs in `requires`. +# Uncomment when ready: +# register_selection( +# "[name]", select_template, +# "[One line for list_methods()]", +# requires = character(0) +# ) + +# End of script ---- diff --git a/1_code/methods/engines/_glm_family.R b/1_code/methods/engines/_glm_family.R new file mode 100644 index 0000000..1f054e1 --- /dev/null +++ b/1_code/methods/engines/_glm_family.R @@ -0,0 +1,256 @@ +# --- +# title: Shared Implementation for GLM-Family Engines +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; defines functions in memory +# notes: +# - Shared by glm and bayesglm, which take and return the same +# shapes. The leading underscore makes it load first. +# - Fitting failures are returned, not raised, so selection +# rules can see which candidates failed. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. fit_glm_family() ---- + +#' Fit a GLM-Family Model, Catching Failure +#' +#' @param fitter Function. stats::glm or arm::bayesglm. +#' @param formula A model formula. +#' @param data A data frame. +#' @param family Character or family object. +#' @param weights Numeric vector or NULL. +#' @param offset Numeric vector or NULL. +#' @param control Named list of extra arguments to the fitter. +#' @return A list with `fit` (or NULL), `ok`, and `message`. +#' +#' @example # Example usage of the function +#' # fit_glm_family(stats::glm, y ~ x, d, "binomial") +fit_glm_family <- function( + fitter, + formula, + data, + family, + weights = NULL, + offset = NULL, + control = list() +) { + args <- c( + list(formula = formula, data = data, family = family), + control + ) + + # Passed as values so one formula serves taxa with and without + # weights. The harness passes offset = NULL and puts offsets in + # the formula instead (see run_stage()). + if (!is.null(weights)) { + args$weights <- weights + } + + if (!is.null(offset)) { + args$offset <- offset + } + + # Gamma fits start at the mean response, as v2's mammal + # abundance models do: starting at y diverges for skewed + # densities + family_name <- if (is.character(family)) family else family$family + starts <- c("mustart", "start", "etastart") + + if (identical(family_name, "Gamma") && + !any(starts %in% names(control))) { + y <- data[[all.vars(formula[[2]])[1]]] + args$mustart <- rep(mean(y, na.rm = TRUE), nrow(data)) + } + + # Warnings (e.g. non-convergence) are recorded, not failures; + # muffled rather than caught so the model is fitted once + warnings_seen <- character(0) + + tryCatch( + { + fit <- withCallingHandlers( + do.call(fitter, args), + warning = function(w) { + warnings_seen <<- c(warnings_seen, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + + list( + fit = fit, + ok = TRUE, + message = if (length(warnings_seen) == 0) { + NA_character_ + } else { + paste(unique(warnings_seen), collapse = "; ") + } + ) + }, + error = function(e) { + list(fit = NULL, ok = FALSE, message = conditionMessage(e)) + } + ) +} + +# 3. fit_coefficients() ---- + +#' Take Coefficients and Standard Errors from a Fit +#' +#' @param fit A list from fit_glm_family(). +#' @return A data frame of term, estimate and se, or NULL when +#' the fit failed. +#' +#' @example # Example usage of the function +#' # fit_coefficients(fit) +fit_coefficients <- function(fit) { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit)) { + return(NULL) + } + + estimates <- stats::coef(fit$fit) + errors <- tryCatch( + stats::coef(summary(fit$fit))[, "Std. Error"], + error = function(e) rep(NA_real_, length(estimates)) + ) + + data.frame( + term = names(estimates), + estimate = as.numeric(estimates), + se = as.numeric(errors[match(names(estimates), names(errors))]), + stringsAsFactors = FALSE + ) +} + +# 4. fit_predict() ---- + +#' Predict from a Fit +#' +#' @param fit A list from fit_glm_family(). +#' @param newdata A data frame to predict onto. +#' @param type Character. "link" or "response". +#' @param se Logical. Return standard errors alongside the fit. +#' @return A numeric vector, or when `se` is TRUE a list of `fit` +#' and `se.fit`. NULL when the fit failed. +#' +#' @example # Example usage of the function +#' # fit_predict(fit, prediction_grid, type = "response") +#' # fit_predict(fit, grid, "link", se = TRUE)$se.fit +fit_predict <- function(fit, newdata, type = "link", se = FALSE) { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit)) { + return(NULL) + } + + tryCatch( + { + predicted <- stats::predict( + fit$fit, newdata = newdata, type = type, se.fit = se + ) + + if (!se) { + return(as.numeric(predicted)) + } + + list( + fit = as.numeric(predicted$fit), + se.fit = as.numeric(predicted$se.fit) + ) + }, + error = function(e) NULL + ) +} + +# 5. information_criterion() ---- + +#' Score a Fit for Model Selection +#' +#' AICc by default: candidate sets are large relative to a rare +#' species' detections. +#' +#' @param fit A list from fit_glm_family(). +#' @param type Character. "AIC", "AICc" or "BIC". +#' @return A numeric value; Inf when the fit failed, so a failed +#' model never wins a selection. +#' +#' @example # Example usage of the function +#' # information_criterion(fit, "BIC") +information_criterion <- function(fit, type = "AICc") { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit)) { + return(Inf) + } + + value <- tryCatch( + switch( + type, + AIC = stats::AIC(fit$fit), + BIC = stats::BIC(fit$fit), + AICc = { + # k from logLik df, as MuMIn, so aliased (NA) terms are + # not counted + k <- attr(stats::logLik(fit$fit), "df") + n <- stats::nobs(fit$fit) + # Undefined once k + 1 >= n; Inf excludes the model + if (is.na(n) || n - k - 1 <= 0) { + Inf + } else { + stats::AIC(fit$fit) + (2 * k * (k + 1)) / (n - k - 1) + } + }, + stop( + "Unknown information criterion `", type, "`.", + call. = FALSE + ) + ), + error = function(e) Inf + ) + + if (is.na(value)) Inf else value +} + +# 6. fit_converged() ---- + +#' Did a Fit Converge +#' +#' @param fit A list from fit_glm_family(). +#' @return Logical. FALSE when the fit failed or did not +#' converge. +#' +#' @example # Example usage of the function +#' # fit_converged(fit) +fit_converged <- function(fit) { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit)) { + return(FALSE) + } + + converged <- fit$fit$converged + + if (is.null(converged)) { + return(TRUE) + } + + isTRUE(converged) +} + +# 7. fit_nobs() ---- + +#' Number of Observations a Fit Used +#' +#' @param fit A list from fit_glm_family(). +#' @return An integer, or NA when the fit failed. +#' +#' @example # Example usage of the function +#' # fit_nobs(fit) +fit_nobs <- function(fit) { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit)) { + return(NA_integer_) + } + + as.integer(stats::nobs(fit$fit)) +} + +# End of script ---- diff --git a/1_code/methods/engines/bayesglm.R b/1_code/methods/engines/bayesglm.R new file mode 100644 index 0000000..164507a --- /dev/null +++ b/1_code/methods/engines/bayesglm.R @@ -0,0 +1,74 @@ +# --- +# title: Engine - Penalized GLM with Weakly Informative Priors +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `bayesglm` engine +# notes: +# - arm::bayesglm with default Cauchy priors, as the v2 plant +# models use. It is penalized maximum likelihood (point +# estimate and SE, no posterior), so glm vs bayesglm is a +# regularization contrast, not frequentist vs Bayesian. +# - Rare plant species separate completely under 30-term habitat +# formulas, so plain glm fails for them; the penalty is +# load-bearing. +# - arm is loaded lazily, only when this engine is used. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# arm, lazily; see the header. + +# 2. engine_bayesglm() ---- + +#' Penalized GLM with Weakly Informative Priors +#' +#' @return An engine definition. +#' +#' @example # Example usage of the function +#' # e <- engine_bayesglm() +engine_bayesglm <- function() { + list( + name = "bayesglm", + description = paste( + "Penalized GLM, weakly informative Cauchy priors", + "(arm::bayesglm)" + ), + capabilities = c("coefficients", "ic", "se", "converged"), + fit = function(formula, data, family, weights = NULL, + offset = NULL, control = list()) { + if (!requireNamespace("arm", quietly = TRUE)) { + stop( + "The bayesglm engine needs the arm package.", + call. = FALSE + ) + } + + # maxit defaults to the v2 value, which was raised from the + # arm default because rare species converge slowly + if (is.null(control$maxit)) { + control$maxit <- 250 + } + + fit_glm_family( + arm::bayesglm, formula, data, family, weights, offset, + control + ) + }, + coef = fit_coefficients, + predict = function(fit, newdata, type = "link", se = FALSE) { + fit_predict(fit, newdata, type, se) + }, + ic = function(fit, type = "AICc") { + information_criterion(fit, type) + }, + converged = fit_converged, + nobs = fit_nobs + ) +} + +# 3. Register ---- +register_engine(engine_bayesglm()) + +# End of script ---- diff --git a/1_code/methods/engines/glm.R b/1_code/methods/engines/glm.R new file mode 100644 index 0000000..fe859fc --- /dev/null +++ b/1_code/methods/engines/glm.R @@ -0,0 +1,55 @@ +# --- +# title: Engine - Generalized Linear Model (glm) +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `glm` engine +# notes: +# - stats::glm. The engine the v2 mammal and bird models fit +# with. +# - Shares its implementation with bayesglm; see +# _glm_family.R. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. engine_glm() ---- + +#' Plain Generalized Linear Model +#' +#' @return An engine definition. +#' +#' @example # Example usage of the function +#' # e <- engine_glm() +#' # fit <- e$fit(response ~ MAP, data, family = "binomial") +engine_glm <- function() { + list( + name = "glm", + description = "Generalized linear model (stats::glm)", + capabilities = c("coefficients", "ic", "se", "converged"), + fit = function(formula, data, family, weights = NULL, + offset = NULL, control = list()) { + fit_glm_family( + stats::glm, formula, data, family, weights, offset, + control + ) + }, + coef = fit_coefficients, + predict = function(fit, newdata, type = "link", se = FALSE) { + fit_predict(fit, newdata, type, se) + }, + ic = function(fit, type = "AICc") { + information_criterion(fit, type) + }, + converged = fit_converged, + nobs = fit_nobs + ) +} + +# 3. Register ---- +register_engine(engine_glm()) + +# End of script ---- diff --git a/1_code/methods/engines/xgboost.R b/1_code/methods/engines/xgboost.R new file mode 100644 index 0000000..e3e5cf9 --- /dev/null +++ b/1_code/methods/engines/xgboost.R @@ -0,0 +1,345 @@ +# --- +# title: Engine - Boosted Regression Trees (xgboost) +# author: Brendan Casey +# created: 2026-10-05 +# inputs: none +# outputs: registers the `xgboost` engine +# notes: +# - Use via replace_stage_method() (one models_union() formula, +# `single` rule): it declares no coefficients, IC or SE. +# - Replaces gbm, which cannot fit the mammal hurdle (no 0-1 +# proportion response, no Gamma); xgboost has +# `binary:logistic` with proportions and log-link `reg:gamma`. +# - Only formula variables are used (`I(x^2)`, `a:b` give x, a, +# b). Categoricals are one-hot coded with the fitted levels; +# NAs stay NA. The offset is the `base_margin`, in fitting and +# prediction. +# - Rounds are chosen by early stopping on a seeded holdout +# (`valid_fraction`), then refitted on all rows. Noisy on +# small draws. +# - `control` settings: nrounds, eta, max_depth, subsample, +# colsample_bytree, min_child_weight, early_stopping_rounds, +# valid_fraction, seed. Defaults are untuned and quick (eta +# 0.05 is higher than Elith, Leathwick and Hastie 2008 +# advise); tune before judging the method. +# - One thread per fit; the harness parallelizes over species. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# xgboost (version: 3.2.1), loaded lazily + +# 2. engine_xgboost() ---- + +#' Boosted Regression Trees with xgboost +#' +#' @return An engine definition. +#' +#' @example # Example usage of the function +#' # check_engine(engine_xgboost()) +engine_xgboost <- function() { + list( + name = "xgboost", + description = "Boosted regression trees (xgboost::xgb.train)", + capabilities = character(0), + fit = xgboost_fit, + predict = xgboost_predict + ) +} + +# 3. xgboost_fit() ---- + +#' Fit Boosted Regression Trees, Catching Failure +#' +#' @param formula A model formula. Only its variables and any +#' `offset(offset)` term are used. +#' @param data A data frame. +#' @param family Character ("binomial", "poisson", "gaussian") or +#' a family object (Gamma with a log link). +#' @param weights Numeric vector or NULL. +#' @param offset Unused; the offset comes from the formula. +#' @param control Named list of settings; see the header. +#' @return A list with `fit` (or NULL), `ok` and `message`. +#' +#' @example # Example usage of the function +#' # xgboost_fit(response ~ MAP + FFP, d, "binomial") +xgboost_fit <- function(formula, data, family, weights = NULL, + offset = NULL, control = list()) { + tryCatch( + { + if (!requireNamespace("xgboost", quietly = TRUE)) { + stop("The xgboost engine needs the xgboost package.", + call. = FALSE) + } + + settings <- utils::modifyList( + list( + nrounds = 1000, eta = 0.05, max_depth = 3, + subsample = 0.5, colsample_bytree = 1, + min_child_weight = 1, early_stopping_rounds = 50, + valid_fraction = 0.2, seed = 20260909L + ), + control + ) + + # Step 1: Drop rows missing response, weight or offset (as a + # GLM does); missing predictors are kept + terms <- xgboost_terms(formula) + w_all <- if (is.null(weights)) rep(1, nrow(data)) else weights + keep <- !is.na(data[[terms$response]]) & !is.na(w_all) + + if (terms$offset) { + keep <- keep & !is.na(data$offset) + } + + rows <- data[keep, , drop = FALSE] + design <- xgboost_design(rows, terms$variables) + y <- rows[[terms$response]] + w <- w_all[keep] + margin <- if (terms$offset) rows$offset else NULL + + params <- list( + objective = xgboost_objective(family), + eta = settings$eta, + max_depth = settings$max_depth, + subsample = settings$subsample, + colsample_bytree = settings$colsample_bytree, + min_child_weight = settings$min_child_weight, + nthread = 1 + ) + + matrix_of <- function(index) { + xgboost::xgb.DMatrix( + design$x[index, , drop = FALSE], label = y[index], + weight = w[index], + base_margin = if (is.null(margin)) NULL else margin[index] + ) + } + + # Step 2: Rounds by early stopping, then refit on every row + model <- with_seed(settings$seed, { + n <- length(y) + held <- sample.int( + n, max(1L, floor(n * settings$valid_fraction)) + ) + trial <- xgboost::xgb.train( + params = params, data = matrix_of(-held), + nrounds = settings$nrounds, + evals = list(valid = matrix_of(held)), + early_stopping_rounds = settings$early_stopping_rounds, + verbose = 0 + ) + rounds <- xgboost_best_rounds(trial, settings$nrounds) + + xgboost::xgb.train( + params = params, data = matrix_of(seq_len(n)), + nrounds = rounds, verbose = 0 + ) + }) + + list( + fit = list( + model = model, + variables = terms$variables, + columns = colnames(design$x), + levels = design$levels, + offset = terms$offset, + linkinv = family_linkinv(family) + ), + ok = TRUE, + message = NA_character_ + ) + }, + error = function(e) { + list(fit = NULL, ok = FALSE, message = conditionMessage(e)) + } + ) +} + +# 4. xgboost_predict() ---- + +#' Predict from an xgboost Fit +#' +#' @param fit A list from xgboost_fit(). +#' @param newdata A data frame to predict onto. +#' @param type Character. "link" or "response". +#' @param se Logical. Not supported; NULL is returned when TRUE. +#' @return A numeric vector, or NULL when the fit failed. +#' +#' @example # Example usage of the function +#' # xgboost_predict(fit, newdata, "response") +xgboost_predict <- function(fit, newdata, type = "link", se = FALSE) { + if (is.null(fit) || !isTRUE(fit$ok) || is.null(fit$fit) || se) { + return(NULL) + } + + tryCatch( + { + tree <- fit$fit + design <- xgboost_design(newdata, tree$variables, tree$levels) + + # Without base_margin xgboost uses its own fitted intercept + matrix <- xgboost::xgb.DMatrix( + design$x[, tree$columns, drop = FALSE], + base_margin = if (tree$offset) newdata$offset else NULL + ) + + link <- stats::predict(tree$model, matrix, outputmargin = TRUE) + + if (type == "link") { + as.numeric(link) + } else { + as.numeric(tree$linkinv(link)) + } + }, + error = function(e) NULL + ) +} + +# 5. Helpers ---- + +## 5.1 xgboost_terms() ---- + +#' Read a Formula as the Engine Uses It +#' +#' @param formula A model formula. +#' @return A list of `response`, `variables` and `offset` (TRUE +#' when the formula has an `offset(offset)` term). +#' +#' @example # Example usage of the function +#' # xgboost_terms(count ~ MAP + I(MAP^2) + offset(offset)) +xgboost_terms <- function(formula) { + text <- paste(deparse(formula), collapse = " ") + + list( + response = all.vars(formula[[2]]), + variables = setdiff( + all.vars(formula[[3]]), c("offset", "weight") + ), + offset = grepl("offset(offset)", text, fixed = TRUE) + ) +} + +## 5.2 xgboost_design() ---- + +#' The Numeric Matrix xgboost Takes +#' +#' Text, logical and factor columns become one indicator per +#' fitted level; a missing category is NA in every indicator. +#' +#' @param data A data frame. +#' @param variables Character vector of column names. +#' @param levels Named list of factor levels from the fit, or +#' NULL when fitting. +#' @return A list of `x` (a numeric matrix) and `levels`. +#' +#' @example # Example usage of the function +#' # xgboost_design(d, c("MAP", "Protocol"))$x +xgboost_design <- function(data, variables, levels = NULL) { + absent <- setdiff(variables, names(data)) + + if (length(absent) > 0) { + stop("Columns not in the data: ", paste(absent, collapse = ", "), + call. = FALSE) + } + + fitting <- is.null(levels) + levels <- levels %||% list() + columns <- list() + + for (column in variables) { + value <- data[[column]] + categorical <- column %in% names(levels) || + (fitting && (is.character(value) || is.logical(value) || + is.factor(value))) + + if (!categorical) { + columns[[column]] <- as.numeric(value) + next + } + + if (fitting) { + levels[[column]] <- sort(unique(as.character( + value[!is.na(value)] + ))) + } + + text <- as.character(value) + + for (level in levels[[column]]) { + columns[[paste0(column, "_", level)]] <- ifelse( + is.na(text), NA_real_, as.numeric(text == level) + ) + } + } + + x <- do.call(cbind, columns) + + if (is.null(dim(x))) { + x <- matrix(x, ncol = length(columns)) + } + + colnames(x) <- names(columns) + + list(x = x, levels = levels) +} + +## 5.3 xgboost_objective() ---- + +#' The xgboost Objective for a GLM Family +#' +#' @param family Character or family object. +#' @return Character, an xgboost objective. +#' +#' @example # Example usage of the function +#' # xgboost_objective("binomial") # "binary:logistic" +xgboost_objective <- function(family) { + name <- if (is.character(family)) family else family$family + link <- if (is.character(family)) NA_character_ else family$link + + if (name == "Gamma" && !identical(link, "log")) { + stop("The xgboost engine fits Gamma on the log link only.", + call. = FALSE) + } + + switch( + name, + binomial = "binary:logistic", + poisson = "count:poisson", + Gamma = "reg:gamma", + gaussian = "reg:squarederror", + stop( + "The xgboost engine has no objective for family `", name, + "`. It supports binomial, poisson, Gamma and gaussian.", + call. = FALSE + ) + ) +} + +## 5.4 xgboost_best_rounds() ---- + +#' The Number of Rounds Early Stopping Chose +#' +#' @param model An xgb.Booster trained with early stopping. +#' @param most Integer. The ceiling, used when none was recorded. +#' @return An integer of at least 1. +#' +#' @example # Example usage of the function +#' # xgboost_best_rounds(trial, 1000) +xgboost_best_rounds <- function(model, most) { + best <- suppressWarnings(as.integer( + xgboost::xgb.attr(model, "best_iteration") + )) + + if (length(best) != 1L || is.na(best)) { + best <- most + } + + max(1L, best) +} + +# 6. Register ---- +register_engine(engine_xgboost()) + +# End of script ---- diff --git a/1_code/methods/metrics/auc.R b/1_code/methods/metrics/auc.R new file mode 100644 index 0000000..a7ffb0c --- /dev/null +++ b/1_code/methods/metrics/auc.R @@ -0,0 +1,54 @@ +# --- +# title: Metric - Area Under the ROC Curve +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `auc` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_auc() ---- + +#' Area Under the ROC Curve +#' +#' Mann-Whitney form (ties count a half). Values above zero are +#' detections, so counts and densities score like presences. +#' +#' @param observed,predicted Numeric vectors. +#' @return A number between 0 and 1, or NA when the observations +#' are all detections or all non-detections. +#' +#' @example # Example usage of the function +#' # metric_auc(c(0, 0, 1, 1), c(0.1, 0.3, 0.4, 0.9)) +metric_auc <- function(observed, predicted) { + positive <- observed > 0 + + # Both classes are needed; a draw without detections has none + if (!any(positive) || all(positive)) { + return(NA_real_) + } + + ranks <- rank(predicted, ties.method = "average") + + # Doubles, not integers: at bird scale the product of the class + # counts (~3.3e9) overflows 32-bit integers to NA + n_pos <- as.numeric(sum(positive)) + n_neg <- as.numeric(sum(!positive)) + + (sum(ranks[positive]) - n_pos * (n_pos + 1) / 2) / + (n_pos * n_neg) +} + +# 3. Register ---- +register_metric( + "auc", metric_auc, + "Area under the ROC curve (Mann-Whitney, ties count a half)" +) + +# End of script ---- diff --git a/1_code/methods/metrics/calibration_slope.R b/1_code/methods/metrics/calibration_slope.R new file mode 100644 index 0000000..fe181dc --- /dev/null +++ b/1_code/methods/metrics/calibration_slope.R @@ -0,0 +1,42 @@ +# --- +# title: Metric - Calibration Slope +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `calibration_slope` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_calibration_slope() ---- + +#' Calibration Slope +#' +#' Slope of observed on predicted. One is perfect; below one +#' means predictions are too extreme (typical of overfitting). +#' +#' @param observed,predicted Numeric vectors. +#' @return A number. +#' +#' @example # Example usage of the function +#' # metric_calibration_slope(c(0, 1, 1), c(0.2, 0.6, 0.8)) +metric_calibration_slope <- function(observed, predicted) { + if (stats::sd(predicted) == 0) { + return(NA_real_) + } + + unname(stats::coef(stats::lm(observed ~ predicted))[2]) +} + +# 3. Register ---- +register_metric( + "calibration_slope", metric_calibration_slope, + "Slope of observed on predicted; 1 is well calibrated" +) + +# End of script ---- diff --git a/1_code/methods/metrics/deviance_explained.R b/1_code/methods/metrics/deviance_explained.R new file mode 100644 index 0000000..cc12998 --- /dev/null +++ b/1_code/methods/metrics/deviance_explained.R @@ -0,0 +1,60 @@ +# --- +# title: Metric - Deviance Explained +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `deviance_explained` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_deviance_explained() ---- + +#' Proportion of Null Deviance Explained +#' +#' Poisson deviance for counts, Bernoulli for detections, chosen +#' from whether the observations are all zero or one. +#' +#' @param observed,predicted Numeric vectors. +#' @return A number, or NA when the null deviance is zero. +#' +#' @example # Example usage of the function +#' # metric_deviance_explained(c(0, 1, 2), c(0.2, 0.9, 1.8)) +metric_deviance_explained <- function(observed, predicted) { + binary <- all(observed %in% c(0, 1)) + + deviance <- function(y, mu) { + mu <- pmax(mu, 1e-10) + + if (binary) { + mu <- pmin(mu, 1 - 1e-10) + -2 * sum(y * log(mu) + (1 - y) * log(1 - mu)) + } else { + terms <- ifelse(y > 0, y * log(y / mu), 0) + 2 * sum(terms - (y - mu)) + } + } + + null_deviance <- deviance( + observed, rep(mean(observed), length(observed)) + ) + + if (!is.finite(null_deviance) || null_deviance <= 0) { + return(NA_real_) + } + + 1 - deviance(observed, predicted) / null_deviance +} + +# 3. Register ---- +register_metric( + "deviance_explained", metric_deviance_explained, + "Share of null deviance explained (Bernoulli or Poisson)" +) + +# End of script ---- diff --git a/1_code/methods/metrics/n.R b/1_code/methods/metrics/n.R new file mode 100644 index 0000000..6239db4 --- /dev/null +++ b/1_code/methods/metrics/n.R @@ -0,0 +1,35 @@ +# --- +# title: Metric - Units Scored +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `n` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_n() ---- + +#' Number of Survey Units Scored +#' +#' @param observed,predicted Numeric vectors. +#' @return An integer. +#' +#' @example # Example usage of the function +#' # metric_n(c(0, 1), c(0.2, 0.7)) +metric_n <- function(observed, predicted) { + length(observed) +} + +# 3. Register ---- +register_metric( + "n", metric_n, + "Number of units scored" +) + +# End of script ---- diff --git a/1_code/methods/metrics/prevalence.R b/1_code/methods/metrics/prevalence.R new file mode 100644 index 0000000..b133506 --- /dev/null +++ b/1_code/methods/metrics/prevalence.R @@ -0,0 +1,38 @@ +# --- +# title: Metric - Prevalence +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `prevalence` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_prevalence() ---- + +#' Proportion of Survey Units with a Detection +#' +#' Reported because most scores are only interpretable against +#' it. +#' +#' @param observed,predicted Numeric vectors. +#' @return A number between 0 and 1. +#' +#' @example # Example usage of the function +#' # metric_prevalence(c(0, 0, 1), c(0, 0, 0)) +metric_prevalence <- function(observed, predicted) { + mean(observed > 0) +} + +# 3. Register ---- +register_metric( + "prevalence", metric_prevalence, + "Proportion of units with a detection" +) + +# End of script ---- diff --git a/1_code/methods/metrics/rmse.R b/1_code/methods/metrics/rmse.R new file mode 100644 index 0000000..eb1d8d6 --- /dev/null +++ b/1_code/methods/metrics/rmse.R @@ -0,0 +1,35 @@ +# --- +# title: Metric - Root Mean Squared Error +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `rmse` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_rmse() ---- + +#' Root Mean Squared Error +#' +#' @param observed,predicted Numeric vectors. +#' @return A number. +#' +#' @example # Example usage of the function +#' # metric_rmse(c(0, 1), c(0.1, 0.8)) +metric_rmse <- function(observed, predicted) { + sqrt(mean((observed - predicted)^2)) +} + +# 3. Register ---- +register_metric( + "rmse", metric_rmse, + "Root mean squared error" +) + +# End of script ---- diff --git a/1_code/methods/metrics/spearman.R b/1_code/methods/metrics/spearman.R new file mode 100644 index 0000000..97edab2 --- /dev/null +++ b/1_code/methods/metrics/spearman.R @@ -0,0 +1,41 @@ +# --- +# title: Metric - Spearman Correlation +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `spearman` metric +# notes: +# - Metric contract: see register_metric() (harness/registry.R). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. metric_spearman() ---- + +#' Rank Correlation of Observed and Predicted +#' +#' Scale-free, so density and count models compare directly. +#' +#' @param observed,predicted Numeric vectors. +#' @return A number between -1 and 1. +#' +#' @example # Example usage of the function +#' # metric_spearman(c(0, 1, 2), c(0.1, 0.5, 0.9)) +metric_spearman <- function(observed, predicted) { + if (stats::sd(observed) == 0 || stats::sd(predicted) == 0) { + return(NA_real_) + } + + stats::cor(observed, predicted, method = "spearman") +} + +# 3. Register ---- +register_metric( + "spearman", metric_spearman, + "Rank correlation of observed and predicted" +) + +# End of script ---- diff --git a/1_code/methods/resampling/precomputed.R b/1_code/methods/resampling/precomputed.R new file mode 100644 index 0000000..8f104f2 --- /dev/null +++ b/1_code/methods/resampling/precomputed.R @@ -0,0 +1,190 @@ +# --- +# title: Resampling Scheme - Precomputed Draws +# author: Brendan Casey +# created: 2026-09-09 +# inputs: +# in the test dataset (see harness/data_source.R), where +# lookup/dataset_manifest.csv says (`bootstrap_ids`, +# `bootstrap_layout`): +# - per_taxon_csv: one table, one column per draw (birds) +# - per_species_rds: one file per species (plant groups) +# outputs: registers the `precomputed` scheme +# notes: +# - Replays v2's stored draws, so parity can be numerical rather +# than distributional. Birds: one table keyed on `surveyid`. +# Plant groups: per species, as v2 drew them (written by +# _setup/07_harmonize_v2_plant_bootstrap_ids.R). +# - The seed is ignored. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup table reading (version: 1.16.4) + +# 2. resample_precomputed() ---- + +#' Read Bootstrap Ids the Source Pipeline Generated +#' +#' @param data_dir Character. The test dataset folder. +#' @param taxon Character. Taxon slug. +#' @param iterations Integer vector of bootstrap iterations. +#' @param id_column Character. The column in the covariate frame +#' the stored ids refer to, when they are not survey unit ids. +#' @param frame A data frame carrying `survey_unit_id` and +#' `id_column`, used to translate stored ids into survey unit +#' ids. NULL when the stored ids are already unit ids. +#' @param species Character. The species, for per-species ids. +#' @param per_species Logical. Read the per-species layout. +#' @param unique_ids Logical. Keep each unit once per draw. v2's +#' bird scripts select a draw with `%in%`, so a unit drawn twice +#' is fitted once; the plant scripts index rows, so repeats +#' count. +#' @return A list of character vectors, one per iteration. +#' +#' @example # Example usage of the function +#' # ids <- resample_precomputed(data_dir, "bird", 1:3, +#' # id_column = "surveyid", +#' # frame = frame, unique_ids = TRUE) +resample_precomputed <- function( + data_dir, + taxon, + iterations, + id_column = NULL, + frame = NULL, + species = NULL, + per_species = FALSE, + unique_ids = FALSE +) { + # Step 1: Read the stored draws, as a list of id vectors + stored <- read_stored_draws(data_dir, taxon, species, per_species) + + if (max(iterations) > length(stored)) { + stop( + taxon, " has ", length(stored), " precomputed bootstrap ", + "iterations; ", max(iterations), " were requested.", + call. = FALSE + ) + } + + lapply(iterations, function(i) { + ids <- stored[[i]] + ids <- ids[!is.na(ids)] + + if (unique_ids) { + ids <- unique(ids) + } + + # Step 2: Translate other keys (birds) to survey unit ids + if (is.null(id_column)) { + return(as.character(ids)) + } + + if (is.null(frame) || !id_column %in% names(frame)) { + stop( + "Translating precomputed ids needs a frame carrying `", + id_column, "`.", + call. = FALSE + ) + } + + matched <- match(ids, frame[[id_column]]) + as.character(frame$survey_unit_id[matched[!is.na(matched)]]) + }) +} + +## 2.1 read_stored_draws() ---- + +#' Read One Taxon's or Species' Stored Draws +#' +#' Cached: the bird draw table (~38 MB) is otherwise re-read per +#' species. +#' +#' @param data_dir,taxon,species,per_species As in +#' resample_precomputed(). +#' @return A list of id vectors, one per stored draw. +#' +#' @example # Example usage of the function +#' # length(read_stored_draws(data_dir, "bird", NULL, FALSE)) +read_stored_draws <- function(data_dir, taxon, species, per_species) { + location <- manifest_entry(data_dir, taxon)$bootstrap_ids + + if (is.na(location)) { + stop( + "The dataset manifest records no stored bootstrap draws ", + "for ", taxon, ". Use a scheme that draws them, such as ", + "spatial_block.", + call. = FALSE + ) + } + + if (per_species) { + path <- file.path(data_dir, location, paste0(species, ".rds")) + + if (is.null(species) || !file.exists(path)) { + stop( + "No stored v2 bootstrap ids for ", taxon, " ", + species, ":\n ", path, + "\nRun 1_code/_setup/07_harmonize_v2_plant_bootstrap_ids.R", + " for this species, or use the spatial_block scheme.", + call. = FALSE + ) + } + + stored <- readRDS(path) + + # v2 stores a species' draws as a matrix, units by draws + if (is.matrix(stored)) { + stored <- lapply(seq_len(ncol(stored)), function(j) stored[, j]) + } + + return(stored) + } + + path <- file.path(data_dir, location) + + if (!file.exists(path)) { + stop( + "No precomputed bootstrap ids for ", taxon, ":\n ", path, + "\nUse a different resampling scheme, or generate them.", + call. = FALSE + ) + } + + cached_read(path, function(p) as.list(fread(p))) +} + +# 3. resampler_precomputed() ---- + +#' The Registered Form of the Precomputed Scheme +#' +#' @param frame The one-species frame. +#' @param iterations Integer vector. +#' @param seed Ignored; the draws are stored. +#' @param context List with `data_dir`, `taxon` and `species`. +#' @param id_column,per_species,unique_ids Settings from the +#' spec's `resample` list; see resample_precomputed(). +#' @return A list of character vectors of survey unit ids. +#' +#' @example # Example usage of the function +#' # resampler_precomputed(frame, 1:5, NULL, context, +#' # id_column = "surveyid") +resampler_precomputed <- function( + frame, iterations, seed, context, + id_column = NULL, per_species = FALSE, unique_ids = FALSE +) { + resample_precomputed( + data_dir = context$data_dir, taxon = context$taxon, + iterations = iterations, id_column = id_column, frame = frame, + species = context$species, per_species = per_species, + unique_ids = unique_ids + ) +} + +# 4. Register ---- +register_resampler( + "precomputed", resampler_precomputed, + "Replay draws stored with the dataset (v2 birds; plant v2_ids)" +) + +# End of script ---- diff --git a/1_code/methods/resampling/spatial_block.R b/1_code/methods/resampling/spatial_block.R new file mode 100644 index 0000000..19717e0 --- /dev/null +++ b/1_code/methods/resampling/spatial_block.R @@ -0,0 +1,169 @@ +# --- +# title: Resampling Scheme - Spatially Blocked Bootstrap +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `spatial_block` scheme +# notes: +# - The v2 plant bootstrap: resample units with replacement +# within coarse lat/long blocks, keeping the geographic spread. +# - Iteration 1 is the complete data, as in v2. +# - One seeded stream per species, so draws 1-5 of a 5-draw run +# equal draws 1-5 of a 100-draw run. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. resample_spatial_block() ---- + +#' Draw a Spatially Blocked Bootstrap +#' +#' Each block keeps its original number of units. +#' +#' @param frame A data frame with `survey_unit_id` and the +#' coordinate columns. +#' @param iterations Integer vector of bootstrap iterations. +#' @param long_column,lat_column Character. Coordinate columns. +#' @param min_detections Integer. Redraw a block set until at +#' least this many detections are present, or 0 to skip the +#' check. +#' @param response Numeric vector, one per row of `frame`, used +#' only for the detection check. +#' @param max_attempts Integer. Redraws before failing. +#' @param seed Integer or NULL. NULL leaves the stream unseeded, +#' which is what v2 did. +#' @return A list of character vectors, one per iteration. +#' +#' @example # Example usage of the function +#' # ids <- resample_spatial_block(frame, 1:5, seed = 42) +resample_spatial_block <- function( + frame, + iterations, + long_column = "long", + lat_column = "lat", + min_detections = 0L, + response = NULL, + max_attempts = 100L, + seed = harness_seed() +) { + for (one in c(long_column, lat_column)) { + if (!one %in% names(frame)) { + stop( + "Spatial blocking needs `", one, "` in the frame.", + call. = FALSE + ) + } + } + + units <- as.character(frame$survey_unit_id) + blocks <- spatial_blocks( + frame[[long_column]], frame[[lat_column]] + ) + by_block <- split(seq_along(units), blocks) + + draw_once <- function() { + unlist( + lapply( + by_block, + function(rows) sample(rows, length(rows), replace = TRUE) + ), + use.names = FALSE + ) + } + + with_seed(seed, lapply(iterations, function(i) { + # Step 1: Iteration 1 is the complete data, as in v2 + if (i == 1L) { + return(units) + } + + # Step 2: Redraw until the sample has enough detections + for (attempt in seq_len(max_attempts)) { + rows <- draw_once() + + if (min_detections <= 0L || is.null(response)) { + return(units[rows]) + } + + if (sum(response[rows] > 0, na.rm = TRUE) >= min_detections) { + return(units[rows]) + } + } + + stop( + "No spatially blocked draw reached ", min_detections, + " detections in ", max_attempts, " attempts. The species ", + "is probably too rare to bootstrap at this threshold.", + call. = FALSE + ) + })) +} + +# 3. resampler_spatial_block() ---- + +#' The Registered Form of the Spatially Blocked Bootstrap +#' +#' Adds v2's redraw rule: redraw for detections only if the full +#' data meets the threshold in at least one region; otherwise +#' take the first draw. +#' +#' @param frame The one-species frame. +#' @param iterations Integer vector. +#' @param seed Integer or NULL. This species' seed. +#' @param context List with `spec` and `response_name`. +#' @param min_detections,long_column,lat_column,max_attempts +#' Settings from the spec's `resample` list. +#' @return A list of character vectors of survey unit ids. +#' +#' @example # Example usage of the function +#' # resampler_spatial_block(frame, 1:5, 42L, context, +#' # min_detections = 20L) +resampler_spatial_block <- function( + frame, iterations, seed, context, + min_detections = 0L, long_column = "long", lat_column = "lat", + max_attempts = 100L +) { + response <- frame[[context$response_name]] + + if (min_detections > 0) { + viable <- any(vapply(context$spec$regions, function(region) { + # Skip regions whose filter columns this frame lacks + if (!is.null(region$filter) && + !all(all.vars(region$filter) %in% names(frame))) { + return(FALSE) + } + + in_region <- if (is.null(region$filter)) { + rep(TRUE, nrow(frame)) + } else { + keep <- eval(rlang_f_rhs(region$filter), frame) + !is.na(keep) & keep + } + + sum(response[in_region] > 0, na.rm = TRUE) >= min_detections + }, logical(1))) + + if (!viable) { + min_detections <- 0L + } + } + + # Pass NULL through: unseeded, not the harness_seed() default + resample_spatial_block( + frame = frame, iterations = iterations, + long_column = long_column, lat_column = lat_column, + min_detections = min_detections, response = response, + max_attempts = max_attempts, seed = seed + ) +} + +# 4. Register ---- +register_resampler( + "spatial_block", resampler_spatial_block, + "Bootstrap within coarse spatial blocks (v2 plants, mammals)" +) + +# End of script ---- diff --git a/1_code/methods/resampling/spatial_cv.R b/1_code/methods/resampling/spatial_cv.R new file mode 100644 index 0000000..2d63b3f --- /dev/null +++ b/1_code/methods/resampling/spatial_cv.R @@ -0,0 +1,105 @@ +# --- +# title: Resampling Scheme - Spatial Cross-Validation +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `spatial_cv` scheme +# notes: +# - Holds out whole spatial blocks, so held-out scores are not +# inflated by spatial autocorrelation. No v2 equivalent. +# - One iteration per fold; each draw is the fold's training +# units, so `oob_` metrics score its test units. Set +# `n_bootstraps` to the number of folds. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. resample_spatial_cv() ---- + +#' Split Survey Units into Spatial Cross-Validation Folds +#' +#' @param frame A data frame with `survey_unit_id` and the +#' coordinate columns. +#' @param folds Integer. Number of folds. +#' @param long_column,lat_column Character. Coordinate columns. +#' @param seed Integer or NULL. Defaults to harness_seed(). +#' @return A list of lists, each with `train` and `test` +#' character vectors of survey unit ids. +#' +#' @example # Example usage of the function +#' # cv <- resample_spatial_cv(frame, folds = 5, seed = 42) +#' # length(cv[[1]]$train) +resample_spatial_cv <- function( + frame, + folds = 5L, + long_column = "long", + lat_column = "lat", + seed = harness_seed() +) { + units <- as.character(frame$survey_unit_id) + blocks <- spatial_blocks( + frame[[long_column]], frame[[lat_column]] + ) + present <- unique(blocks[!is.na(blocks)]) + + if (length(present) < folds) { + stop( + "Only ", length(present), " spatial block(s) present; ", + folds, " folds were asked for. Use finer block breaks or ", + "fewer folds.", + call. = FALSE + ) + } + + # Step 1: Deal whole blocks into folds + assignment <- with_seed( + seed, sample(rep_len(seq_len(folds), length(present))) + ) + fold_of_block <- assignment[match(blocks, present)] + + lapply(seq_len(folds), function(k) { + list( + train = units[!is.na(fold_of_block) & fold_of_block != k], + test = units[!is.na(fold_of_block) & fold_of_block == k] + ) + }) +} + +# 3. resampler_spatial_cv() ---- + +#' The Registered Form of Spatial Cross-Validation +#' +#' @param frame The one-species frame. +#' @param iterations Integer vector; its length is the number of +#' folds. +#' @param seed Integer or NULL. +#' @param context Unused. +#' @param long_column,lat_column Settings from the spec's +#' `resample` list. +#' @return A list of character vectors: each fold's training +#' units. +#' +#' @example # Example usage of the function +#' # resampler_spatial_cv(frame, 1:5, 42L, list()) +resampler_spatial_cv <- function( + frame, iterations, seed, context, + long_column = "long", lat_column = "lat" +) { + splits <- resample_spatial_cv( + frame, folds = length(iterations), long_column = long_column, + lat_column = lat_column, seed = seed + ) + + lapply(splits, `[[`, "train") +} + +# 4. Register ---- +register_resampler( + "spatial_cv", resampler_spatial_cv, + "Spatial block cross-validation; each draw holds out one fold" +) + +# End of script ---- diff --git a/1_code/methods/selection/aic_average.R b/1_code/methods/selection/aic_average.R new file mode 100644 index 0000000..503c540 --- /dev/null +++ b/1_code/methods/selection/aic_average.R @@ -0,0 +1,103 @@ +# --- +# title: Selection Rule - Information-Criterion Model Averaging +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `aic_average` rule +# notes: +# - The v2 plant and bird climate rule: Akaike-weighted +# coefficients, absent terms counting as zero (MuMIn's "full" +# average). The predictor averages link predictions, which +# equals applying the averaged coefficients. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_aic_average() ---- + +#' Average Candidates by Information-Criterion Weight +#' +#' @inheritParams select_single +#' @return A selection result. `fit` is the best single candidate; +#' `coefficients` are the averaged ones; `predict` is the +#' weighted average of the candidates. +#' +#' @example # Example usage of the function +#' # select_aic_average(models, response ~ 1, d, engine, +#' # "binomial") +select_aic_average <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list() +) { + fitted <- fit_candidates( + models, base, data, engine, family, weights, offset, ic, + control + ) + + table <- candidate_table(fitted) + + if (!any(table$ok) || sum(table$weight) == 0) { + return(selection_result(NULL, NULL, table, fitted)) + } + + # Step 1: Collect every term any candidate estimated + per_model <- lapply(fitted$fits, function(f) engine_coef(engine, f)) + terms <- unique(unlist(lapply(per_model, function(x) x$term))) + + # Step 2: Weighted mean per term, absent terms counting as zero + averaged <- do.call(rbind, lapply(terms, function(term) { + estimate <- 0 + variance <- 0 + + for (i in seq_along(per_model)) { + cf <- per_model[[i]] + w <- table$weight[i] + + if (is.null(cf) || w == 0) { + next + } + + # Absent or aliased (NA) terms count as zero + row <- match(term, cf$term) + absent <- is.na(row) || is.na(cf$estimate[row]) + value <- if (absent) 0 else cf$estimate[row] + se <- if (absent) 0 else cf$se[row] + + estimate <- estimate + w * value + variance <- variance + w * ifelse(is.na(se), 0, se^2) + } + + data.frame( + term = term, + estimate = estimate, + se = sqrt(variance), + stringsAsFactors = FALSE + ) + })) + + selection_result( + fit = fitted$fits[[which.min(fitted$scores)]], + coefficients = averaged, + ic_table = table, + fitted = fitted, + engine = engine, + predict = combined_predictor( + fitted$fits, engine, family, weights = table$weight + ) + ) +} + +# 3. Register ---- +register_selection( + "aic_average", select_aic_average, + paste( + "Average coefficients over candidates by Akaike weight", + "(v2 climate)" + ), + requires = c("ic", "coefficients") +) + +# End of script ---- diff --git a/1_code/methods/selection/aic_best.R b/1_code/methods/selection/aic_best.R new file mode 100644 index 0000000..f24c29d --- /dev/null +++ b/1_code/methods/selection/aic_best.R @@ -0,0 +1,59 @@ +# --- +# title: Selection Rule - Best by Information Criterion +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `aic_best` rule +# notes: +# - Keeps the single candidate with the lowest score (AICc by +# default; the stage's `ic` sets it). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_aic_best() ---- + +#' Keep the Single Best-Scoring Candidate +#' +#' @inheritParams select_single +#' @return A selection result. +#' +#' @example # Example usage of the function +#' # select_aic_best(models, response ~ 1, d, engine, "binomial") +select_aic_best <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list() +) { + fitted <- fit_candidates( + models, base, data, engine, family, weights, offset, ic, + control + ) + + table <- candidate_table(fitted) + + if (!any(table$ok)) { + return(selection_result(NULL, NULL, table, fitted)) + } + + winner <- which.min(fitted$scores) + + selection_result( + fit = fitted$fits[[winner]], + coefficients = engine_coef(engine, fitted$fits[[winner]]), + ic_table = table, + fitted = fitted, + engine = engine + ) +} + +# 3. Register ---- +register_selection( + "aic_best", select_aic_best, + "Keep the lowest-scoring candidate (AICc, AIC or BIC)", + requires = "ic" +) + +# End of script ---- diff --git a/1_code/methods/selection/hurdle.R b/1_code/methods/selection/hurdle.R new file mode 100644 index 0000000..d1b7746 --- /dev/null +++ b/1_code/methods/selection/hurdle.R @@ -0,0 +1,244 @@ +# --- +# title: Selection Rule - Hurdle: Presence, Then Abundance Given +# Presence +# author: Brendan Casey +# created: 2026-10-05 +# inputs: none +# outputs: registers the `hurdle` rule +# notes: +# - v2's mammal habitat shape: presence on every unit, abundance +# given presence where detected; their product is total +# abundance. Both halves use the stage's engine via the inner +# `part_selection` rule, so any engine works. +# - Outputs are each half and the product on the grid, written +# as `_presence`, `_abundance` and `_total` +# (modules/mammals/hurdle.R swaps in v2's tables for v2 GLMs). +# The scored final model is the presence half. +# - Abundance candidates are the presence ones minus +# `abundance_drop` (v2: climate effects on abundance are +# minimal) plus a null. With coefficients, a candidate whose +# cover terms sum to all the cover is dropped, as in v2: it is +# not identifiable with an intercept. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_hurdle() ---- + +#' Fit a Hurdle Model: Presence, Then Abundance Given Presence +#' +#' @inheritParams select_single +#' @param grid A prediction grid, or NULL; without one there are +#' no outputs, only the presence half's coefficients. +#' @param constants,grid_constants Named lists of values held +#' fixed on the grid: sampling effort, Climate, pAspen. Their +#' names are also the terms that are not cover. +#' @param intercept_cats Character vector, parallel to `models`, +#' naming each candidate's reference category, or NULL. +#' @param part_selection Character. The rule each half runs. +#' @param abundance_family A family for the abundance half. +#' @param abundance_response A function(values, data) computing +#' the abundance response from the raw values, or NULL to take +#' the raw values as they are. +#' @param abundance_drop Character vector of terms the abundance +#' half leaves out. +#' @param abundance_null Character. An extra abundance candidate, +#' or NULL for none. +#' @param abundance_weighted Logical. Weight the abundance half +#' as the presence half is weighted. v2 does not. +#' @return A selection result for the presence half, with `parts` +#' (both halves' selection results), `winner` (the presence +#' candidate chosen), `reference_category` and `outputs`. +#' +#' @example # Example usage of the function +#' # select_hurdle(models, response ~ 1, d, get_engine("glm"), +#' # "binomial", grid = grid) +select_hurdle <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list(), + grid = NULL, constants = list(), grid_constants = list(), + intercept_cats = NULL, + part_selection = "aic_best", + abundance_family = stats::Gamma(link = "log"), + abundance_response = NULL, + abundance_drop = "Climate", + abundance_null = ". ~ . + seas_days", + abundance_weighted = FALSE +) { + response <- all.vars(base[[2]]) + raw <- if ("response_raw" %in% names(data)) { + data$response_raw + } else { + data[[response]] + } + failed <- function(table) { + selection_result(NULL, NULL, table) + } + + # Step 1: Presence, on every unit + presence <- selection_run( + part_selection, models, base, data, engine, family, + weights, offset, ic, control + ) + + if (is.null(presence$fit) || !isTRUE(presence$fit$ok)) { + return(failed(presence$ic_table)) + } + + scores <- presence$ic_table$ic + winner <- if (any(is.finite(scores))) which.min(scores) else 1L + + # Step 2: Abundance given presence, on the units with any + present <- !is.na(raw) & raw > 0 + + if (sum(present) < 2) { + return(failed(presence$ic_table)) + } + + d_p <- data[present, , drop = FALSE] + d_p[[response]] <- if (is.function(abundance_response)) { + abundance_response(raw[present], d_p) + } else { + raw[present] + } + + abundance_models <- hurdle_abundance_models( + presence, models, base, d_p, engine, abundance_drop, + abundance_null, held = names(c(constants, grid_constants)) + ) + + abundance <- selection_run( + part_selection, abundance_models, base, d_p, engine, + abundance_family, + weights = if (abundance_weighted && !is.null(weights)) { + weights[present] + } else { + NULL + }, + offset = NULL, ic = ic, control = control + ) + + if (is.null(abundance$fit) || !isTRUE(abundance$fit$ok)) { + return(failed(presence$ic_table)) + } + + # Step 3: Each half, and their product, on the grid + result <- presence + result$parts <- list(presence = presence, abundance = abundance) + result$winner <- winner + result$reference_category <- if (is.null(intercept_cats)) { + NULL + } else { + intercept_cats[winner] + } + + if (!is.null(grid)) { + held <- c(constants, grid_constants) + on_grid <- lapply(result$parts, predict_grid, grid = grid, + constants = held) + + if (!any(vapply(on_grid, is.null, logical(1)))) { + table_of <- function(values) { + data.frame( + term = names(values), estimate = unname(values), + se = NA_real_, stringsAsFactors = FALSE + ) + } + + result$outputs <- list( + presence = table_of(on_grid$presence), + abundance = table_of(on_grid$abundance), + total = table_of(on_grid$presence * on_grid$abundance) + ) + } + } + + result +} + +# 3. hurdle_abundance_models() ---- + +#' The Abundance Half's Candidates +#' +#' @param presence The presence half's selection result. +#' @param models The presence candidates as given. +#' @param base The base formula. +#' @param d_p The units where the species was present. +#' @param engine An engine definition. +#' @param drop,null As `abundance_drop` and `abundance_null`. +#' @param held Character vector of terms that are not cover. +#' @return A list of formulas. +#' +#' @example # Example usage of the function +#' # hurdle_abundance_models(presence, models, response ~ 1, d_p, +#' # engine, "Climate", NULL, "seas_days") +hurdle_abundance_models <- function(presence, models, base, d_p, + engine, drop, null, held) { + response <- all.vars(base[[2]]) + base_text <- paste(deparse(base[[3]]), collapse = " ") + has_offset <- grepl("offset(offset)", base_text, fixed = TRUE) + + # Only fitted presence candidates get an abundance counterpart, + # as in v2; `single` fits only the first + table <- presence$ic_table + formulas <- lapply(models, resolve_formula, base = base) + + fitted_n <- if (is.null(table)) 1L else nrow(table) + + formulas <- if (fitted_n == length(formulas)) { + formulas[table$ok] + } else { + formulas[seq_len(min(fitted_n, length(formulas)))] + } + + check_cover <- engine_has(engine, "coefficients") + + candidates <- lapply(formulas, function(f) { + terms <- attr(stats::terms(f), "term.labels") + + # Identifiable with an intercept only if some cover is left + # unaccounted for at some unit + if (check_cover) { + cover <- intersect(setdiff(terms, held), names(d_p)) + used <- sum(colSums(d_p[, cover, drop = FALSE])) + + if ((nrow(d_p) - used) <= 0) { + return(NULL) + } + } + + kept <- setdiff(terms, drop) + + stats::as.formula(paste( + response, "~", + paste(c(if (length(kept) == 0) "1" else kept, + if (has_offset) "offset(offset)"), + collapse = " + ") + )) + }) + + candidates <- Filter(Negate(is.null), candidates) + + if (!is.null(null)) { + candidates <- c( + candidates, list(resolve_formula(stats::as.formula(null), base)) + ) + } + + candidates +} + +# 4. Register ---- +register_selection( + "hurdle", select_hurdle, + paste( + "Presence, then abundance given presence, each with an inner", + "rule (v2 mammals)" + ), + requires = character(0) +) + +# End of script ---- diff --git a/1_code/methods/selection/ivw_grid.R b/1_code/methods/selection/ivw_grid.R new file mode 100644 index 0000000..d540db7 --- /dev/null +++ b/1_code/methods/selection/ivw_grid.R @@ -0,0 +1,181 @@ +# --- +# title: Selection Rule - Inverse-Variance Averaging onto a Grid +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `ivw_grid` rule +# notes: +# - The v2 plant habitat rule. Candidates are predicted onto the +# grid and combined per habitat type by inverse variance, so a +# "coefficient" is a link-scale effect per habitat type. +# - Unlike AICc weighting, a candidate confident about one +# habitat type dominates there even if it is poor overall. +# - Non-converged candidates are dropped from the grid average +# (as v2). Zero SEs are floored at 1e-4. +# - `predict()` gives v2's site-level `data$prediction` (offset +# of the stand-age splines): every fitted candidate, converged +# or not, as v2; failed fits are left out (v2 would give NaN). +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_ivw_grid() ---- + +#' Inverse-Variance Average Predictions onto a Grid +#' +#' @inheritParams select_single +#' @param grid A prediction grid, one row per habitat type. +#' @param grid_constants Named list of values for terms the grid +#' has no column for - v2 predicts at `Climate = 0` and, where +#' Protocol is fitted, at the new protocol. +#' @param head_terms Character vector of leading model +#' coefficients to average separately and prepend, which is how +#' v2 carries Intercept, Climate and Protocol. +#' @return A selection result whose `coefficients` are the +#' averaged per-habitat-type effects, with +#' `candidate_coefficients` for steps that average a term the +#' grid does not carry. +#' +#' @example # Example usage of the function +#' # select_ivw_grid(models, response ~ 1, d, engine, "binomial", +#' # grid = veg_grid, +#' # grid_constants = list(Climate = 0)) +select_ivw_grid <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list(), + grid = NULL, grid_constants = list(), + head_terms = c("Intercept", "Climate") +) { + if (is.null(grid)) { + stop( + "The ivw_grid rule needs a prediction grid; the spec's ", + "region defines one with `grid`.", + call. = FALSE + ) + } + + fitted <- fit_candidates( + models, base, data, engine, family, weights, offset, ic, + control + ) + + table <- candidate_table(fitted) + converged <- vapply( + fitted$fits, function(f) engine_converged(engine, f), logical(1) + ) + + if (!any(converged)) { + return(selection_result(NULL, NULL, table, fitted)) + } + + # Step 1: Predict every converged candidate onto the grid, at + # the constants v2 holds the non-habitat terms at + newdata <- grid + + for (one in names(grid_constants)) { + newdata[[one]] <- grid_constants[[one]] + } + + predictions <- lapply(seq_along(fitted$fits), function(i) { + if (!converged[i]) { + return(NULL) + } + + engine$predict(fitted$fits[[i]], newdata, "link", se = TRUE) + }) + + usable <- !vapply(predictions, is.null, logical(1)) + + if (!any(usable)) { + return(selection_result(NULL, NULL, table, fitted)) + } + + estimate <- do.call( + rbind, lapply(predictions[usable], function(x) x$fit) + ) + error <- do.call( + rbind, lapply(predictions[usable], function(x) x$se.fit) + ) + + error[error == 0] <- 1e-4 + + grid_coefficients <- ivw_combine(estimate, error) + + # Step 2: Head terms, from each model's coefficient table, read + # by position as v2 does (they lead every formula) + head_estimate <- do.call(rbind, lapply( + which(converged), function(i) { + fitted$fits[[i]]$coefficients$estimate[seq_along(head_terms)] + } + )) + head_error <- do.call(rbind, lapply( + which(converged), function(i) { + fitted$fits[[i]]$coefficients$se[seq_along(head_terms)] + } + )) + head_error[head_error == 0 | is.na(head_error)] <- 1e-4 + + head_coefficients <- ivw_combine(head_estimate, head_error) + + coefficients <- data.frame( + term = c(head_terms, rownames(grid)), + estimate = c(head_coefficients$estimate, + grid_coefficients$estimate), + se = c(head_coefficients$se, grid_coefficients$se), + stringsAsFactors = FALSE + ) + + result <- selection_result( + fit = fitted$fits[[which.min(fitted$scores)]], + coefficients = coefficients, + ic_table = table, + fitted = fitted, + engine = engine, + # Step 3: The final model, averaged per site the same way + predict = combined_predictor( + fitted$fits[table$ok], engine, family + ) + ) + + # For steps averaging a term the grid lacks (v2's pAspen) + result$candidate_coefficients <- lapply( + which(table$ok), function(i) fitted$fits[[i]]$coefficients + ) + + result +} + +# 3. ivw_combine() ---- + +#' Combine Estimates by Inverse-Variance Weight +#' +#' @param estimate Matrix of candidates by columns. +#' @param error Matrix of standard errors, the same shape. +#' @return A list of `estimate` and `se`, one per column. +#' +#' @example # Example usage of the function +#' # ivw_combine(rbind(c(1, 2), c(1.2, 2.1)), +#' # rbind(c(0.1, 0.2), c(0.3, 0.1))) +ivw_combine <- function(estimate, error) { + precision <- 1 / error^2 + + list( + estimate = colSums(estimate * precision) / colSums(precision), + se = sqrt(1 / colSums(precision)) + ) +} + +# 4. Register ---- +register_selection( + "ivw_grid", select_ivw_grid, + paste( + "Inverse-variance average of candidate predictions onto a", + "habitat grid (v2 plant habitat)" + ), + requires = c("coefficients", "se") +) + +# End of script ---- diff --git a/1_code/methods/selection/single.R b/1_code/methods/selection/single.R new file mode 100644 index 0000000..0bd52c3 --- /dev/null +++ b/1_code/methods/selection/single.R @@ -0,0 +1,57 @@ +# --- +# title: Selection Rule - Single Model +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `single` rule +# notes: +# - Fits the first formula only. Needs only fit and predict, so +# it suits engines without an information criterion. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_single() ---- + +#' Fit One Model, No Selection +#' +#' @param models A list holding one formula, or a single formula. +#' @param base,data,engine,family,weights,offset,ic,control As in +#' selection_run(). +#' @return A selection result. +#' +#' @example # Example usage of the function +#' # select_single(list(. ~ . + MAP), response ~ 1, d, engine, +#' # "binomial") +select_single <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "AICc", control = list() +) { + if (inherits(models, "formula")) { + models <- list(models) + } + + fitted <- fit_candidates( + models[1], base, data, engine, family, weights, offset, ic, + control + ) + + selection_result( + fit = fitted$fits[[1]], + coefficients = engine_coef(engine, fitted$fits[[1]]), + ic_table = candidate_table(fitted), + fitted = fitted, + engine = engine + ) +} + +# 3. Register ---- +register_selection( + "single", select_single, + "Fit the first candidate only; no ranking" +) + +# End of script ---- diff --git a/1_code/methods/selection/staged_bic.R b/1_code/methods/selection/staged_bic.R new file mode 100644 index 0000000..c8964b6 --- /dev/null +++ b/1_code/methods/selection/staged_bic.R @@ -0,0 +1,116 @@ +# --- +# title: Selection Rule - Staged Forward Selection by BIC +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: registers the `staged_bic` rule +# notes: +# - The v2 bird landcover rule. Each group of `models` updates +# the previous group's winner: the smallest model within +# `threshold` of the best score. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. select_staged_bic() ---- + +#' Walk Groups of Candidates, Carrying the Winner Forward +#' +#' @inheritParams select_single +#' @param threshold Numeric. How far above the best score a +#' candidate may sit and still be eligible. +#' @param always_advance Logical. TRUE, v2's rule, takes each +#' group's winner as the next base whatever its score; FALSE +#' takes it only when it improves on the running model. +#' @return A selection result, with `ic_table` carrying a `stage` +#' column. +#' +#' @example # Example usage of the function +#' # select_staged_bic(model_groups, response ~ 1, d, engine, +#' # "poisson", ic = "BIC") +select_staged_bic <- function( + models, base, data, engine, family, + weights = NULL, offset = NULL, ic = "BIC", control = list(), + threshold = 2, always_advance = TRUE +) { + # Step 1: Fit the base model, the fallback if no group improves + current <- fit_with( + engine, base, data, family, weights, offset, control + ) + current_formula <- base + current_score <- engine$ic(current, ic) + tables <- list() + + if (!isTRUE(current$ok)) { + return(selection_result( + NULL, NULL, + data.frame( + stage = "base", model = "base", formula = deparse(base), + ic = Inf, delta = NA_real_, weight = 0, k = NA_integer_, + ok = FALSE, stringsAsFactors = FALSE + ), + NULL + )) + } + + group_names <- names(models) + + if (is.null(group_names)) { + group_names <- paste0("stage_", seq_along(models)) + } + + # Step 2: Each group updates the running winner + for (i in seq_along(models)) { + fitted <- fit_candidates( + models[[i]], current_formula, data, engine, family, + weights, offset, ic, control + ) + + table <- candidate_table(fitted) + table$stage <- group_names[i] + tables[[i]] <- table + + eligible <- which(table$ok & is.finite(fitted$scores)) + + if (length(eligible) == 0) { + next + } + + # Step 3: Fewest parameters within `threshold` of the best + best <- min(fitted$scores[eligible]) + close <- eligible[fitted$scores[eligible] <= best + threshold] + winner <- close[which.min(table$k[close])] + + # Step 4: Carry the winner forward. v2 always does, even when + # it scores worse (07.ModelLandcover.R, section 14) + if (always_advance || fitted$scores[winner] < current_score) { + current <- fitted$fits[[winner]] + current_formula <- fitted$formulas[[winner]] + current_score <- fitted$scores[winner] + } + } + + selection_result( + fit = current, + coefficients = engine_coef(engine, current), + ic_table = do.call(rbind, tables), + fitted = NULL, + formula = current_formula, + engine = engine + ) +} + +# 3. Register ---- +register_selection( + "staged_bic", select_staged_bic, + paste( + "Forward selection through groups of candidates, fewest", + "parameters within `threshold` (v2 birds)" + ), + requires = c("ic", "coefficients") +) + +# End of script ---- diff --git a/1_code/modules/.gitkeep b/1_code/modules/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/modules/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/modules/README.md b/1_code/modules/README.md new file mode 100644 index 0000000..45fad3b --- /dev/null +++ b/1_code/modules/README.md @@ -0,0 +1,78 @@ +# modules + +One v2 spec per taxon. A module holds configuration, not modelling +code: it states what v2 does for a taxon as a spec list, and the +[harness](../harness/) runs it. A change here affects every +experiment; review it as such. + +`load_framework()` sources `_shared/` first, then every other folder, +each in file-name order. + +## Files + +| Folder | File | Defines | +| --- | --- | --- | +| `_shared/` | `plant_group.R` | `plant_group_spec()`, the builder for the four plant-group taxa, and their v2 post-processing (`plant_age_splines()`, `plant_cutblock_convergence()`, `plant_paspen()`, `plant_footprint_pooling()`) | +| `_shared/` | `standard_specs.R` | `standard_specs(plant_bootstrap)`: every run in its v2 configuration | +| `bryophytes/` | `spec.R` | `bryophyte_spec(use_protocol, bootstrap)` | +| `lichens/` | `spec.R` | `lichen_spec(use_protocol, bootstrap)` | +| `soil_mites/` | `spec.R` | `soil_mite_spec(use_protocol, bootstrap)` | +| `vascular_plants/` | `spec.R` | `vascular_plant_spec(use_protocol, bootstrap)` | +| `mammals/` | `spec.R` | `mammal_spec(climate_source, season, tier)` | +| `mammals/` | `hurdle.R` | v2's hurdle tables: presence and abundance effects, splines, calibration, convergence | +| `birds/` | `spec.R` | `bird_spec()` | +| `birds/` | `standardize.R` | `bird_habitat_translation()`: landcover coefficients onto v2's standardized habitat types (port of v2's `08.PackageCoefficients.R`) | + +`standard_specs()` returns seven runs: `bryophyte`, `lichen`, `mite`, +`vascular_plant`, `mammal_summer`, `mammal_winter` and `bird`. + +## The module interface + +A taxon module must: + +1. Define a function `_spec(...)` in + `modules//spec.R` that returns a spec list. +2. Return a spec that passes `validate_spec()`. Unknown fields are + errors, and every named engine, rule and resampler must be + registered. +3. Add its run to `standard_specs()` in `_shared/standard_specs.R`. + +Spec fields the harness reads (full list: `spec_fields()` in +`harness/spec.R`): + +| Field | Sets | +| --- | --- | +| `taxon` | Data slug that keys the response file, covariates and lookups | +| `response_name`, `response_transform`, `family`, `weight_column` | How the recorded value becomes a response; error family; weights | +| `regions` | Per region: `filter` (one-sided formula), `grid`, `habitat_models`, constants | +| `stages` | In order: `name`, `models`, `engine`, `selection`, `ic`, `post_process`, and `carry_as` for the stage carried into the next as `Climate` | +| `habitat_stage` | The stage `replace_stage_method()` replaces by default | +| `resample` | `scheme` and its settings | +| `final_prediction` | Optional. The model scored and projected | +| `v2_coverage` | Per stage, what the spec reproduces of v2. The one place coverage is stated; `report.md` prints it | +| `notes` | Configuration facts, such as whether `Protocol` is fitted | + +Fields that a stage's selection rule or resampler takes as arguments +are also accepted, as settings for that method. + +## Adding a taxon module + +1. Put the v2 scripts as received in `0_data/v2_scripts//` and + log the source and commit in its README. +2. Extend `_setup/01` to write the taxon's response, covariates, + lookups, and any grid or stored draws; extend `_setup/02` to trace + them to the source. +3. Add the taxon's species queue and manifest rows to `_setup/09`, + and re-run it. +4. Splice the v2 candidate formulas into `harness/model_sets.R`, + verbatim. +5. Add `spec.R`, modelled on `lichens/spec.R` (plant group), + `birds/spec.R` or `mammals/spec.R`, and add the run to + `standard_specs()`. If v2 does something no registered method + covers, add one to [`methods/`](../methods/README.md). +6. Add the taxon's published v2 results to `_setup/08`, if + ABMIexploreR publishes them. +7. Check that `validate_spec()` passes and + `Rscript 1_code/tests/run_tests.R` runs clean. Record each + taxon-specific behaviour in + [`docs/taxon_quirks.md`](../../docs/taxon_quirks.md). diff --git a/1_code/modules/_shared/plant_group.R b/1_code/modules/_shared/plant_group.R new file mode 100644 index 0000000..f7c3fff --- /dev/null +++ b/1_code/modules/_shared/plant_group.R @@ -0,0 +1,1039 @@ +# --- +# title: Shared Builder for the Plant-Group Taxon Specs +# author: Brendan Casey +# created: 2026-09-10 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - The v2 pipeline shape shared by the four plant-group taxa +# (a survey design, not a taxonomy). Taxon quirks live in each +# taxon's module, which calls this builder. +# - `v2_coverage` below is the single statement of what is +# reproduced; the report reads it. Detail is in +# docs/taxon_quirks.md. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. plant_group_spec() ---- + +#' Build a v2 Spec for One Plant-Group Taxon +#' +#' Called by each taxon module rather than directly. +#' +#' @param taxon Character. The data slug ("mite" for soil mites). +#' @param protocol_in_v2 Logical. Whether v2 fits Protocol for +#' this taxon. +#' @param use_protocol Logical, or NULL to take the v2 value. +#' @param reference_note Character, or NULL. One clause on where +#' this taxon's v2 reference comes from, appended to the spec +#' notes. Bryophytes differ from the other three. +#' @param bootstrap Character. "spatial_block" draws afresh; +#' "v2_ids" replays v2's stored draws (_setup/07), making +#' parity numerical. +#' @return A spec list, as run_spec() consumes. +#' +#' @example # Example usage of the function +#' # spec <- plant_group_spec("lichen", protocol_in_v2 = TRUE) +#' # spec$stages[[1]]$engine +plant_group_spec <- function( + taxon, + protocol_in_v2, + use_protocol = NULL, + reference_note = NULL, + bootstrap = c("spatial_block", "v2_ids") +) { + bootstrap <- match.arg(bootstrap) + + if (!is.character(taxon) || length(taxon) != 1L) { + stop("`taxon` must be a single character slug.", call. = FALSE) + } + + if (!is.logical(protocol_in_v2) || + length(protocol_in_v2) != 1L || + is.na(protocol_in_v2)) { + stop( + "`protocol_in_v2` must be TRUE or FALSE.", + call. = FALSE + ) + } + + if (is.null(use_protocol)) { + use_protocol <- protocol_in_v2 + } + + # The habitat sets come from the mite script (no Protocol); the + # bryophyte and lichen scripts differ only by Protocol directly + # after Climate. No climate set carries Protocol. + with_protocol <- function(set) { + models <- get_model_set(set) + + if (!use_protocol) { + return(models) + } + + sub( + ". ~ . + Climate", ". ~ . + Climate + Protocol", + models, fixed = TRUE + ) + } + + list( + taxon = taxon, + response_name = "response", + # The stage a methods experiment replaces by default + habitat_stage = "habitat", + + # v2 models presence: any value above zero is a detection + response_transform = "detection", + family = "binomial", + weight_column = NULL, + tier = NULL, + + regions = list( + north = list( + filter = ~ nr != "Grassland", + grid = "veg", + term_block = "veg", + habitat_models = with_protocol("habitat_veg_plant_v2") + ), + south = list( + filter = ~ nr %in% c("Grassland", "Parkland"), + grid = "soil", + term_block = "soil", + habitat_models = with_protocol("habitat_soil_plant_v2"), + # v2 predicts the south candidates at pAspen = 0 + grid_constants = list(paspen = 0) + ) + ), + + stages = list( + list( + name = "climate", + models = "climate_plant_v2_full", + engine = "bayesglm", + selection = "aic_average", + ic = "AICc", + control = list(maxit = 250), + # Province-wide, as v2's climate_models() + scope = "province", + # Carried into the habitat stage as `Climate`, as in v2 + carry_as = "Climate" + ), + list( + name = "habitat", + # Per region below: veg in the north, soil in the south + models = NULL, + engine = "bayesglm", + selection = "ivw_grid", + ic = "AICc", + control = list(maxit = 250), + carry_from = "climate", + carry_from_as = "Climate", + # v2 predicts the grid at Climate = 0 and the new protocol + grid_constants = if (use_protocol) { + list( + Climate = 0, + Protocol = factor("New", levels = c("New", "Old")) + ) + } else { + list(Climate = 0) + }, + head_terms = if (use_protocol) { + c("Intercept", "Climate", "Protocol") + } else { + c("Intercept", "Climate") + }, + # v2's post-averaging steps, in v2's order (pooling + # borrows from a spline-fitted age class). The splines + # read aged stand-cover columns no formula names. + post_process = list( + plant_age_splines, plant_cutblock_convergence, + plant_paspen, plant_footprint_pooling + ), + # The validation also weights each fine cutblock class by + # its own effect, and the formulas name only lumped ones. + extra_covariates = c( + plant_age_columns(), + as.vector(t(outer( + paste0("CC", c("WhiteSpruce", "Pine", "Deciduous", + "Mixedwood")), + c("R", 1:4), paste0 + ))) + ), + min_detections = 20L + ) + ), + + # One province-wide draw per species, as v2's + # bootstrap_data(). No seed here: the experiment's seed is + # used. + resample = if (bootstrap == "v2_ids") { + list( + scheme = "precomputed", + per_species = TRUE, + scope = "province" + ) + } else { + list( + scheme = "spatial_block", + min_detections = 20L, + scope = "province" + ) + }, + + v2_coverage = list( + climate = v2_status( + "reproduced", + paste( + "The v2 58-model set, bayesglm, full AICc averaging,", + "fitted once per draw on every unit and shared by both", + "regions, as v2 fits it." + ) + ), + habitat = v2_status( + "reproduced", + paste( + "IVW on the prediction grid, the stand-age splines,", + "cutblock convergence, footprint pooling, the south", + "pAspen and the 20-detection skip. Matches v2 to 2e-12", + "on the full-data draw, north and south." + ) + ), + validation = v2_status( + "reproduced", + paste( + "v2's seven validation AUCs, in-bag as v2 scores them", + "and out-of-bag as well. South exact; north within 2e-4,", + "a residual v2's own coefficients show too." + ) + ), + resampling = if (bootstrap == "v2_ids") { + v2_status( + "reproduced", + "v2's own stored draws, replayed per species." + ) + } else { + v2_status( + "reproduced", + paste( + "v2's spatial-block bootstrap, drawn once per species", + "across the province with its 20-detection redraw rule.", + "The same method, not the same draws: v2 is unseeded." + ) + ) + } + ), + + # v2's seven validation AUCs, scored in-bag as v2 does and + # out-of-bag as well; see plant_v2_validation(). + validate = plant_v2_validation, + + # The final model the harness scores and reports: v2's own + # prediction from the published coefficient tables + final_prediction = plant_v2_full_prediction, + + use_protocol = use_protocol, + protocol_is_v2 = identical(use_protocol, protocol_in_v2), + + notes = paste0( + "Protocol ", if (use_protocol) "fitted" else "not fitted", + if (identical(use_protocol, protocol_in_v2)) { + " (the v2 setting for this taxon)." + } else { + " (overridden; v2 does the opposite for this taxon)." + }, + if (is.null(reference_note)) "" else paste0(" ", reference_note) + ) + ) +} + +# 3. plant_v2_term_labels() ---- + +#' Relabel Plant Habitat Terms as v2's Published Coefficients Are +#' +#' v2 does not publish its habitat coefficients under the names +#' it fits them with. 04a_coefficient_standardization.R relabels +#' them for cross-taxa use before they reach COEFS.RData, which +#' is what 0_data/v2_results/v2_results.csv is built from: +#' +#' - `BlackSpruce` becomes `TreedBog`, and `Grass` `GrassHerb`. +#' - `UrbInd` is copied to `Urban`, `Industrial` and `Rural`. +#' - `TreedFen` is copied to each age class, `TreedFenR` to +#' `TreedFen8`, as it is not fitted by age. +#' - In the south, `paspen` becomes `pAspen`. +#' +#' A copied term appears once per copy, each compared against +#' v2's copy. +#' +#' @param terms Character vector of harness habitat terms. +#' @return A data frame of `term` (as fitted) and `v2_term`, one +#' row per published label. +#' +#' @example # Example usage of the function +#' # plant_v2_term_labels(c("BlackSpruce", "UrbInd", "Crop")) +plant_v2_term_labels <- function(terms) { + renamed <- c( + BlackSpruce = "TreedBog", + Grass = "GrassHerb", + paspen = "pAspen" + ) + + copied <- list( + UrbInd = c("Urban", "Industrial", "Rural"), + TreedFen = paste0("TreedFen", c("R", 1:8)) + ) + + rows <- lapply(unique(terms), function(one) { + v2 <- if (one %in% names(copied)) { + copied[[one]] + } else if (one %in% names(renamed)) { + renamed[[one]] + } else if (startsWith(one, "BlackSpruce")) { + # 04a relabels by substitution, so the spline-fitted age + # classes BlackSpruceR to BlackSpruce8 become TreedBogR to + # TreedBog8 + sub("^BlackSpruce", "TreedBog", one) + } else { + one + } + + data.frame(term = one, v2_term = v2, stringsAsFactors = FALSE) + }) + + do.call(rbind, rows) +} + +# 4. v2 habitat machinery ---- +# Ports of the steps v2's vegetation_models() applies after the +# inverse-variance weighting (hierarchical-model_functions.R), +# in v2's order: the stand-age splines (section 7), the cutblock +# convergence (7.5), and the footprint pooling (8.0). Each takes +# and returns the selection result, so the habitat stage runs +# them as `post_process` steps. + +## 4.1 plant_stand_types() ---- + +#' The Five Aged Stand Types v2 Models with Splines +#' +#' @return Character vector. +#' +#' @example # Example usage of the function +#' # plant_stand_types() +plant_stand_types <- function() { + c("WhiteSpruce", "Pine", "Deciduous", "Mixedwood", "BlackSpruce") +} + +## 4.2 plant_age_columns() ---- + +#' The Aged Stand-Cover Columns the Splines Read +#' +#' @return Character vector, R and 1 to 8 per stand type. +#' +#' @example # Example usage of the function +#' # head(plant_age_columns()) +plant_age_columns <- function() { + as.vector(t(outer(plant_stand_types(), c("R", 1:8), paste0))) +} + +## 4.3 plant_age_splines() ---- + +#' Replace the Aged Stand Effects with v2's Stand-Age Splines +#' +#' v2 fits the unaged stand types by inverse-variance weighting, +#' then models detection against stand age within each type and +#' writes the result over the 45 aged effects, R and 1 to 8 for +#' five types: +#' +#' 1. One frame per type from units where an age class covers +#' more than 10%, each carrying detection, age (0.5 for R), +#' the cover as weight, and the site-level IVW prediction as +#' an offset. Grassy units join the four upland types at age +#' 0.5 and shrubby units at age 1, at half weight, in +#' proportion to the type's share of the stand. v2 computes the +#' mixedwood share from white spruce; that is reproduced. +#' 2. A binomial GAM, `s(sqrt(age), k = 3, m = 2)` with the +#' offset, per type, per pair (white spruce with pine, +#' deciduous with mixedwood) and for all five together; +#' intercept-only where there are 8 or fewer detections. A +#' ninth, intercept-only over all five. +#' 3. The grouping with the lowest summed AIC, less one per extra +#' variance: separate (-4), paired (-2), all, or none. +#' 4. Predictions at ages 0.5 and 1 to 8, with the type's IVW +#' effect as offset. +#' +#' A region with no aged stand types - the south - is returned +#' unchanged. +#' +#' @param selected A selection result from the ivw_grid rule, +#' whose `predict()` gives the site-level IVW prediction. +#' @param data The stage's data: detection in `response`, and the +#' unaged and aged stand-cover columns, `Grass` and `Shrub`. +#' @return The selection result with the 45 aged effects added. +#' +#' @example # Example usage of the function +#' # selected <- plant_age_splines(selected, stage_data) +plant_age_splines <- function(selected, data) { + types <- plant_stand_types() + estimate <- stats::setNames( + selected$coefficients$estimate, selected$coefficients$term + ) + + if (!all(types %in% names(estimate))) { + return(selected) + } + + # Site-level IVW prediction (link scale), computed only where + # aged stand types exist + prediction <- if (is.function(selected$predict)) { + selected$predict(data, "link") + } else { + NULL + } + + if (is.null(prediction) || length(prediction) != nrow(data)) { + stop("The age splines need the site-level IVW prediction.", + call. = FALSE) + } + + cutoff <- 0.1 + count <- data$response + + # Step 1: One frame per stand type + stand <- stats::setNames(vector("list", length(types)), types) + + for (i in 0:8) { + label <- if (i == 0) "R" else i + age <- if (i == 0) 0.5 else i + + for (type in types) { + cover <- data[[paste0(type, label)]] + rows <- which(cover > cutoff) + + if (length(rows) > 0) { + stand[[type]] <- rbind(stand[[type]], data.frame( + pCount = count[rows], age = age, wt1 = cover[rows], + p = prediction[rows] + )) + } + } + } + + # Grassy (age 0.5) and shrubby (age 1) units join the upland + # types at half weight, by the type's share of the stand + open_join <- function(column, age) { + rows <- which(data[[column]] > cutoff) + total <- data$WhiteSpruce[rows] + data$Pine[rows] + + data$Deciduous[rows] + data$Mixedwood[rows] + + data$BlackSpruce[rows] + 0.01 + + share <- list( + WhiteSpruce = data$WhiteSpruce[rows] / total, + Pine = data$Pine[rows] / total, + Deciduous = data$Deciduous[rows] / total, + # v2 divides white spruce here, not mixedwood + Mixedwood = data$WhiteSpruce[rows] / total + ) + + for (type in names(share)) { + p_type <- share[[type]] + + if (sum(p_type) != 0) { + keep <- p_type > 0 + stand[[type]] <<- rbind(stand[[type]], data.frame( + pCount = count[rows][keep], age = age, + wt1 = data[[column]][rows][keep] / 2 * p_type[keep], + p = prediction[rows][keep] + )) + } + } + } + + open_join("Grass", 0.5) + open_join("Shrub", 1) + + frames <- c( + stand, + list( + Conifpine = rbind(stand$WhiteSpruce, stand$Pine), + Decidmixed = rbind(stand$Deciduous, stand$Mixedwood), + All = do.call(rbind, stand) + ) + ) + + # Step 2: The nine fits + fit_age <- function(frame, spline = TRUE) { + formula <- if (spline && sum(sign(frame$pCount)) > 8) { + pCount ~ s(sqrt(age), k = 3, m = 2) + offset(p) + } else { + pCount ~ 1 + offset(p) + } + + suppressWarnings(mgcv::gam( + formula, data = frame, family = "binomial", weights = frame$wt1 + )) + } + + models <- lapply(frames, fit_age) + models$None <- fit_age(frames$All, spline = FALSE) + + aic <- vapply(models, stats::AIC, numeric(1)) + + # Step 3: Choose the grouping + grouping <- which.min(c( + separate = sum(aic[types]) - 4, + paired = aic[["BlackSpruce"]] + aic[["Conifpine"]] + + aic[["Decidmixed"]] - 2, + all = aic[["All"]], + none = aic[["None"]] + )) + + model_for <- switch( + names(grouping), + separate = stats::setNames(types, types), + paired = c( + WhiteSpruce = "Conifpine", Pine = "Conifpine", + Deciduous = "Decidmixed", Mixedwood = "Decidmixed", + BlackSpruce = "BlackSpruce" + ), + all = stats::setNames(rep("All", 5), types), + none = stats::setNames(rep("None", 5), types) + ) + + # Step 4: Predict each type's age classes, offset by its IVW + # effect + aged <- do.call(rbind, lapply(types, function(type) { + predicted <- stats::predict( + models[[model_for[[type]]]], + newdata = data.frame(age = c(0.5, 1:8), p = estimate[[type]]), + se.fit = TRUE + ) + + data.frame( + term = paste0(type, c("R", 1:8)), + estimate = as.numeric(predicted$fit), + se = as.numeric(predicted$se.fit), + stringsAsFactors = FALSE + ) + })) + + selected$coefficients <- rbind( + selected$coefficients[ + !selected$coefficients$term %in% aged$term, + ], + aged + ) + selected$age_grouping <- names(grouping) + + selected +} + +## 4.4 plant_cutblock_convergence() ---- + +#' Move Older Cutblocks Toward the Natural Stand of the Same Age +#' +#' v2's section 7.5. Cutblock classes 2, 3 and 4 are replaced by +#' a weighted average, on the probability scale, of themselves +#' and the natural stand of the same age class, with fixed +#' recovery weights. Standard errors are averaged linearly, as v2 +#' does. Needs the age splines to have run first, for the +#' natural age classes. +#' +#' @param selected A selection result. +#' @param data Unused; the post_process signature. +#' @return The selection result with the 12 cutblock effects +#' converged. +#' +#' @example # Example usage of the function +#' # selected <- plant_cutblock_convergence(selected, stage_data) +plant_cutblock_convergence <- function(selected, data = NULL) { + coefficients <- selected$coefficients + recovery <- cutblock_recovery_weights() + weights <- list( + WhiteSpruce = recovery$conifer, + Pine = recovery$conifer, + Deciduous = recovery$deciduous, + Mixedwood = recovery$deciduous + ) + + for (type in names(weights)) { + for (k in 1:3) { + age <- k + 1 + w <- weights[[type]][k] + cc <- match(paste0("CC", type, age), coefficients$term) + natural <- match(paste0(type, age), coefficients$term) + + if (is.na(cc) || is.na(natural)) { + next + } + + coefficients$estimate[cc] <- stats::qlogis( + stats::plogis(coefficients$estimate[natural]) * w + + stats::plogis(coefficients$estimate[cc]) * (1 - w) + ) + coefficients$se[cc] <- coefficients$se[natural] * w + + coefficients$se[cc] * (1 - w) + } + } + + selected$coefficients <- coefficients + + selected +} + +## 4.5 plant_paspen() ---- + +#' Add v2's Averaged pAspen Effect to a South Habitat Result +#' +#' v2's soil_models() predicts every candidate at pAspen = 0 and +#' reports pAspen separately: an inverse-variance average of the +#' coefficient over the candidates that carry it. It keeps only +#' positive estimates and positive standard errors, filtering the +#' two separately, so a negative estimate shifts which error it +#' is paired with. Reproduced as written. +#' +#' @param selected A selection result from the ivw_grid rule, +#' carrying `candidate_coefficients`. +#' @param data Unused; the post_process signature. +#' @return The selection result with a `paspen` term, or +#' unchanged when no candidate fits pAspen. +#' +#' @example # Example usage of the function +#' # selected <- plant_paspen(selected, stage_data) +plant_paspen <- function(selected, data = NULL) { + candidates <- selected$candidate_coefficients + + estimate <- vapply(candidates, function(cf) { + row <- match("paspen", cf$term) + if (is.na(row)) 0 else cf$estimate[row] + }, numeric(1)) + se <- vapply(candidates, function(cf) { + row <- match("paspen", cf$term) + if (is.na(row)) 0 else cf$se[row] + }, numeric(1)) + + if (all(estimate == 0)) { + return(selected) + } + + estimate <- estimate[estimate > 0] + se <- se[se > 0] + + mean_paspen <- suppressWarnings( + sum(estimate / se^2) / sum(1 / se^2) + ) + + selected$coefficients <- rbind( + selected$coefficients[selected$coefficients$term != "paspen", ], + data.frame( + term = "paspen", estimate = mean_paspen, + se = sqrt(1 / sum(1 / se^2)), stringsAsFactors = FALSE + ) + ) + + selected +} + +## 4.6 plant_footprint_pooling() ---- + +#' Pool Poorly Sampled Footprint Effects, as a Post-Process Step +#' +#' v2's section 8.0, applied after the stand-age splines and the +#' cutblock convergence because it borrows from a spline-fitted +#' age class. See coef_adjust_plant_veg() for what is pooled. +#' +#' @param selected A selection result. +#' @param data Unused; the post_process signature. +#' @return The selection result with the four footprint effects +#' pooled. +#' +#' @example # Example usage of the function +#' # selected <- plant_footprint_pooling(selected, stage_data) +plant_footprint_pooling <- function(selected, data = NULL) { + selected$coefficients <- coef_adjust_plant_veg( + selected$coefficients + ) + + selected +} + +## 4.7 coef_adjust_plant_veg() ---- + +#' Borrow Strength for Poorly Sampled Footprint Types +#' +#' v2's `coef.adjust`. Some human footprint types are rarely the +#' dominant cover at a survey unit, so their effect is estimated +#' from little data. v2 pools each with a type it is assumed to +#' resemble, by inverse-variance weight: +#' +#' - `HardLin` borrows from `UrbInd`. +#' - The three soft linear types - `EnSoftLin`, `EnSeismic` and +#' `TrSoftLin` - each borrow from a composite of young +#' regenerating stands, weighted by how much those stand types +#' overlap soft linear features in the provincial summary. +#' +#' The weights are v2's, measured from a 1 km summary and fixed +#' since 2020-11-17. They are an assumption about which habitats +#' resemble which, not an estimate, so they are stated here +#' rather than derived. +#' +#' @param coefficients A data frame of term, estimate and se. +#' @param overlap Numeric vector of four proportions, for +#' white spruce, pine, deciduous and black spruce regeneration. +#' @return The coefficients, with the four terms adjusted. +#' +#' @example # Example usage of the function +#' # coef_adjust_plant_veg(selected$coefficients) +coef_adjust_plant_veg <- function( + coefficients, + overlap = c(0.049, 0.0893, 0.434, 0.396) +) { + if (is.null(coefficients)) { + return(NULL) + } + + value <- stats::setNames( + coefficients$estimate, coefficients$term + ) + error <- stats::setNames(coefficients$se, coefficients$term) + + # Pool two estimates by precision. + pool <- function(a, a_se, b, b_se) { + precision <- 1 / a_se^2 + 1 / b_se^2 + + list( + estimate = (a / a_se^2 + b / b_se^2) / precision, + se = sqrt(1 / precision) + ) + } + + present <- function(...) { + all(c(...) %in% names(value)) && + all(is.finite(value[c(...)])) && + all(is.finite(error[c(...)])) + } + + # Step 1: Hard linear features borrow from urban and industrial + if (present("HardLin", "UrbInd")) { + pooled <- pool( + value["HardLin"], error["HardLin"], + value["UrbInd"], error["UrbInd"] + ) + value["HardLin"] <- pooled$estimate + error["HardLin"] <- pooled$se + } + + # Step 2: Soft linear features borrow from young regeneration + young_types <- c( + "CCWhiteSpruceR", "CCPineR", "CCDeciduousR", "BlackSpruce1" + ) + + if (present(young_types)) { + weights <- overlap / sum(overlap) + + young <- sum(weights * value[young_types]) + # The weighted variance carries no between-type component, + # because the weights are fixed rather than estimated. + young_se <- sqrt(sum(weights * error[young_types]^2)) + + for (one in c("EnSoftLin", "EnSeismic", "TrSoftLin")) { + if (!present(one)) { + next + } + + pooled <- pool(value[one], error[one], young, young_se) + value[one] <- pooled$estimate + error[one] <- pooled$se + } + } + + coefficients$estimate <- unname(value[coefficients$term]) + coefficients$se <- unname(error[coefficients$term]) + + coefficients +} + +## 4.8 plant_v2_parts() ---- + +#' The Pieces of v2's Plant Prediction at a Set of Units +#' +#' v2 predicts a plant from its coefficient tables, not from a +#' fitted model: the climate prediction, and a landcover +#' prediction that weights each habitat type's effect by its +#' cover at the unit. Shared by the validation AUCs and by the +#' final prediction, so the two cannot drift apart. +#' +#' The cover terms are the published effects, less the unaged +#' stand types, which v2 publishes only by age class. A term's +#' column may carry the block suffix the harmonizer gave columns +#' in more than one block (UrbInd_veg, UrbInd_soil). +#' +#' Reproduced as written: the protocol coefficient, a logit, is +#' subtracted from an "Old" survey's landcover prediction on the +#' probability scale. +#' +#' @param stage_coefficients Named list of data frames of term +#' and estimate: `climate` and `habitat`. +#' @param data The units to predict at. +#' @return A list: `climate` (probability), `raw` (landcover, +#' probability scale), `landcover` (`raw` with the protocol +#' adjustment), `slope` (the Climate effect), `aspen`, the cover +#' matrix `x` and the cover terms' `effects` (logit scale). +#' +#' @example # Example usage of the function +#' # parts <- plant_v2_parts(stage_coefficients, region_frame) +plant_v2_parts <- function(stage_coefficients, data) { + climate <- stage_coefficients$climate + habitat <- stage_coefficients$habitat + + estimate <- stats::setNames(habitat$estimate, habitat$term) + head_terms <- c("Intercept", "Climate", "Protocol", "paspen") + + column_of <- function(term) { + candidates <- c(term, paste0(term, c("_veg", "_soil"))) + hit <- candidates[candidates %in% names(data)] + if (length(hit) == 0) NA_character_ else hit[1] + } + + cover <- setdiff( + names(estimate), c(head_terms, plant_stand_types()) + ) + cover <- cover[is.finite(estimate[cover])] + cover_columns <- vapply(cover, column_of, character(1)) + cover <- cover[!is.na(cover_columns)] + cover_columns <- cover_columns[!is.na(cover_columns)] + + x <- as.matrix(data[, cover_columns, drop = FALSE]) + raw <- drop(x %*% stats::plogis(estimate[cover])) + landcover <- raw + + if ("Protocol" %in% names(estimate) && + "Protocol" %in% names(data)) { + old <- as.character(data$Protocol) == "Old" + landcover[old] <- landcover[old] - estimate[["Protocol"]] + } + + list( + climate = stats::plogis( + predict_from_coefficients(climate, data, "link") + ), + raw = raw, + landcover = landcover, + slope = estimate[["Climate"]], + aspen = if ("paspen" %in% names(estimate) && + "paspen" %in% names(data)) { + data$paspen * estimate[["paspen"]] + } else { + 0 + }, + x = x, + effects = estimate[cover] + ) +} + +## 4.9 plant_v2_full_prediction() ---- + +#' v2's Final Plant Prediction: Landcover and Climate Together +#' +#' The prediction v2's "Full" validation AUC scores. The plant +#' specs name it as their `final_prediction`, so the harness's +#' own metrics score the model v2 reports, after its stand-age +#' splines, cutblock convergence and footprint pooling, rather +#' than any single fitted candidate. +#' +#' @param stage_coefficients Named list with `climate` and +#' `habitat` coefficient tables. +#' @param frame The units to predict at. +#' @return A numeric vector of probabilities, one per row. +#' +#' @example # Example usage of the function +#' # plant_v2_full_prediction(stage_coefficients, frame) +plant_v2_full_prediction <- function(stage_coefficients, frame) { + parts <- plant_v2_parts(stage_coefficients, frame) + + stats::plogis( + stats::qlogis(parts$raw) + parts$climate * parts$slope + + parts$aspen + ) +} + +## 4.10 plant_v2_validation() ---- + +#' v2's Plant Validation AUCs, In-Bag and Out-of-Bag +#' +#' A port of model_validation() (model-validation_functions.R). +#' v2 scores each draw from its published coefficient tables, +#' not from a fitted model, with seven AUCs: climate alone, and +#' truncated at its 99th percentile; landcover alone; landcover +#' plus climate; and landcover and climate joined per habitat +#' type, each with and without the truncation. Climate is scored +#' over every unit in the draw, the others over the region's. +#' +#' v2 scores the units in the draw, once each (`%in%`), which is +#' in-sample. The same seven are also scored on the units the +#' draw left out, which is the held-out read v2 does not have. +#' Iteration 1 is the full data and has no out-of-bag units. +#' +#' @param stage_coefficients Named list of data frames of term +#' and estimate: `climate` and `habitat`. +#' @param frame The region's frame. +#' @param province_frame The province-wide frame, for the climate +#' AUCs; the region's frame when there is none. +#' @param draw Character vector of survey unit ids in the draw. +#' @return A data frame of metric and value. +#' +#' @example # Example usage of the function +#' # plant_v2_validation(coefs, frame, province, draw) +plant_v2_validation <- function( + stage_coefficients, frame, province_frame, draw +) { + climate <- stage_coefficients$climate + habitat <- stage_coefficients$habitat + + if (is.null(climate) || is.null(habitat) || + !requireNamespace("pROC", quietly = TRUE)) { + return(NULL) + } + + auc <- function(observed, predicted) { + tryCatch( + as.numeric(suppressMessages(pROC::auc(observed, predicted))), + error = function(e) NA_real_ + ) + } + + truncate <- function(x) { + cap <- stats::quantile(x, 0.99, names = FALSE) + ifelse(x >= cap, cap, x) + } + + score <- function(in_units) { + all_units <- province_frame[ + province_frame$survey_unit_id %in% in_units, , drop = FALSE + ] + region <- frame[ + frame$survey_unit_id %in% in_units, , drop = FALSE + ] + + if (nrow(region) == 0 || nrow(all_units) == 0) { + return(rep(NA_real_, 7)) + } + + parts <- plant_v2_parts(stage_coefficients, region) + climate_all <- stats::plogis( + predict_from_coefficients(climate, all_units, "link") + ) + + # The truncation caps the region's climate at the 99th + # percentile over every unit in the draw + cap <- stats::quantile(climate_all, 0.99, names = FALSE) + climate_region_trunc <- ifelse( + parts$climate >= cap, cap, parts$climate + ) + + component <- parts$climate * parts$slope + parts$aspen + component_trunc <- climate_region_trunc * parts$slope + + parts$aspen + + joint <- function(shift) { + shifted <- outer(shift, parts$effects, `+`) + rowSums(parts$x * stats::plogis(shifted)) + } + + observed <- as.integer(region$response > 0) + observed_all <- as.integer(all_units$response > 0) + + c( + Climate = auc(observed_all, climate_all), + Climate_Truncated = auc(observed_all, truncate(climate_all)), + Landcover = auc(observed, parts$landcover), + Full = auc( + observed, stats::plogis(stats::qlogis(parts$raw) + component) + ), + Full_Truncated = auc( + observed, + stats::plogis(stats::qlogis(parts$raw) + component_trunc) + ), + Full_Joint = auc(observed, joint(component)), + Full_Joint_Truncated = auc(observed, joint(component_trunc)) + ) + } + + in_bag <- unique(draw) + out_of_bag <- setdiff( + union(province_frame$survey_unit_id, frame$survey_unit_id), + in_bag + ) + + in_scores <- score(in_bag) + out_scores <- if (length(out_of_bag) == 0) { + rep(NA_real_, 7) + } else { + score(out_of_bag) + } + + names_out <- c( + "Climate", "Climate_Truncated", "Landcover", "Full", + "Full_Truncated", "Full_Joint", "Full_Joint_Truncated" + ) + + data.frame( + metric = c(paste0("v2val_", names_out), + paste0("oob_v2val_", names_out)), + value = c(unname(in_scores), unname(out_scores)), + stringsAsFactors = FALSE + ) +} + +# 5. cutblock_recovery_weights() ---- + +#' v2's Cutblock Recovery Weights +#' +#' How far a cutblock of age class 2, 3 and 4 has converged on the +#' natural stand of the same age, by stand group. Fixed in v2 and +#' shared by its plant (section 7.5) and mammal (section 6.11) +#' pipelines, so stated once for both modules. +#' +#' The two pipelines' stand-age splines are not shared: their +#' parameters differ (spline basis, detection threshold, model +#' choice), and merging them would put parity at risk. +#' +#' @return A list of `conifer` and `deciduous` weights, one per +#' age class 2 to 4. +#' +#' @example # Example usage of the function +#' # cutblock_recovery_weights()$conifer +cutblock_recovery_weights <- function() { + list( + conifer = c(0.500, 0.849, 0.960), + deciduous = c(0.705, 0.912, 0.970) + ) +} + +# 6. plant_group_specs() ---- + +#' Every Plant-Group Spec +#' +#' Each taxon module must already be sourced. +#' +#' @param use_protocol Logical, or NULL for the v2 setting per +#' taxon. +#' @return A named list of specs, keyed on the data slug. +#' +#' @example # Example usage of the function +#' # names(plant_group_specs()) +plant_group_specs <- function(use_protocol = NULL) { + list( + bryophyte = bryophyte_spec(use_protocol = use_protocol), + lichen = lichen_spec(use_protocol = use_protocol), + mite = soil_mite_spec(use_protocol = use_protocol), + vascular_plant = vascular_plant_spec( + use_protocol = use_protocol + ) + ) +} + +# End of script ---- diff --git a/1_code/modules/_shared/standard_specs.R b/1_code/modules/_shared/standard_specs.R new file mode 100644 index 0000000..e1cf499 --- /dev/null +++ b/1_code/modules/_shared/standard_specs.R @@ -0,0 +1,45 @@ +# --- +# title: The v2 Spec of Every Run +# author: Brendan Casey +# created: 2026-10-03 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - The runs an experiment can name (`taxa = c("lichen", +# "bird")`), each in its v2 configuration. Run names are the +# result folder names. Mammals run once per season (v2's +# references average summer and winter), both with slug +# "mammal". A new taxon module adds its run here. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only. + +# 2. standard_specs() ---- + +#' Every Run's Spec, in Its v2 Configuration +#' +#' @param plant_bootstrap Character. "spatial_block" draws v2's +#' plant bootstrap afresh, so parity is distributional; +#' "v2_ids" replays the draws v2 stored (needs +#' _setup/07_harmonize_v2_plant_bootstrap_ids.R run for every +#' species in the run). +#' @return A named list of specs, one per run. +#' +#' @example # Example usage of the function +#' # names(standard_specs()) +standard_specs <- function(plant_bootstrap = "spatial_block") { + list( + bryophyte = bryophyte_spec(bootstrap = plant_bootstrap), + lichen = lichen_spec(bootstrap = plant_bootstrap), + mite = soil_mite_spec(bootstrap = plant_bootstrap), + vascular_plant = vascular_plant_spec(bootstrap = plant_bootstrap), + mammal_summer = mammal_spec(season = "summer"), + mammal_winter = mammal_spec(season = "winter"), + bird = bird_spec() + ) +} + +# End of script ---- diff --git a/1_code/modules/birds/.gitkeep b/1_code/modules/birds/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/modules/birds/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/modules/birds/spec.R b/1_code/modules/birds/spec.R new file mode 100644 index 0000000..51145c6 --- /dev/null +++ b/1_code/modules/birds/spec.R @@ -0,0 +1,156 @@ +# --- +# title: Bird Taxon Spec +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - Counts with a QPAD log-offset (required: it separates +# effort and detectability from abundance). +# - Climate: v2's 25 candidates averaged by AICc, province-wide +# per draw. Landcover: staged_bic, smallest model within 2 +# BIC of the best. +# - v2's stored draws are keyed on surveyid and translated to +# survey units. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. bird_spec() ---- + +#' Build the v2 Spec for Birds +#' +#' @return A spec list, as run_spec() consumes. +#' +#' @example # Example usage of the function +#' # spec <- bird_spec() +#' # spec$stages[[1]]$selection +bird_spec <- function() { + list( + taxon = "bird", + # The stage a methods experiment replaces by default + habitat_stage = "landcover", + response_name = "response", + + # Counts are modelled as given; the offset carries effort. + response_transform = "identity", + family = "poisson", + weight_column = NULL, + tier = NULL, + + # v2's spatial terms: UTM easting and northing, in metres + aliases = list(Easting = "easting", Northing = "northing"), + + regions = list( + north = list( + filter = ~ useNorth == 1, + # One row per habitat type, rebuilt by _setup/09 from + # v2's coefficient translation matrix + grid = "bird_north", + term_block = "veg", + habitat_models = "landcover_bird_north_v2", + # v2 weights the landcover models by region + weight_column = "vegw" + ), + south = list( + filter = ~ useSouth == 1, + # One row per habitat type, rebuilt by _setup/09 from + # v2's coefficient translation matrix + grid = "bird_south", + term_block = "soil", + habitat_models = "landcover_bird_south_v2", + weight_column = "soilw" + ) + ), + + stages = list( + list( + name = "climate", + # 06.ModelClimate.R + models = "climate_bird_v2", + engine = "glm", + selection = "aic_average", + ic = "AICc", + # Province-wide and unweighted, as in v2 + scope = "province", + weighted = FALSE, + # v2 carries exp(link) WITHOUT the QPAD offset: MuMIn's + # averaged predict(type = "link") drops it. Evidence (AMRO + # draw 1): v2's stored prediction mean 0.118 = exp(link); + # exp(link + offset) = 0.315, and carrying the offset cut + # the landcover Climate coefficient from 4.91 (v2) to + # 1.60. + carry_as = "Climate", + carry_scale = "exp", + carry_offset = FALSE + ), + list( + name = "landcover", + # Per region: veg in the north, soil in the south + models = NULL, + engine = "glm", + selection = "staged_bic", + ic = "BIC", + # v2 always moves on to each group's winner + always_advance = TRUE, + # Every candidate starts from v2's `count ~ climate` + base_terms = "Climate", + carry_from = "climate", + carry_from_as = "Climate" + ) + ), + + resample = list( + scheme = "precomputed", + id_column = "surveyid", + # v2 selects a draw with %in%: repeats are fitted once + unique_ids = TRUE, + # One draw for the whole province, filtered per region. + scope = "province" + ), + + v2_coverage = list( + climate = v2_status( + "reproduced", + paste( + "v2's 25 candidates, AICc averaged, fitted once on the", + "province-wide draw, unweighted, and carried as", + "exp(link) without the offset, as MuMIn predicts it." + ) + ), + landcover = v2_status( + "reproduced", + paste( + "Staged BIC over v2's groups, weighted by vegw or", + "soilw, always advancing to each group's winner.", + "Raw coefficients are translated onto v2's", + "standardized template by standardize.R, a port", + "checked exact against v2's packaged output." + ) + ), + resampling = v2_status( + "reproduced", + paste( + "v2's 100 stored draws, keyed on surveyid, each survey", + "once per draw as v2's %in% selects them. Only when", + "harmonized from the Stratified.Rdata v2 was fitted on", + "(58,210 surveys per draw); the BirdModels", + "Data/Archive/2025 copy was rewritten on 2026-08-19 with", + "different draws." + ) + ) + ), + + notes = paste0( + "QPAD offset inside the formula. The landcover groups' ", + "derived terms (wtAge, isCon, fcc2) are all present; ", + "columns in both the north and south blocks are ", + "suffixed by the harmonizer and resolved by term_map()." + ) + ) +} + +# End of script ---- diff --git a/1_code/modules/birds/standardize.R b/1_code/modules/birds/standardize.R new file mode 100644 index 0000000..772da70 --- /dev/null +++ b/1_code/modules/birds/standardize.R @@ -0,0 +1,513 @@ +# --- +# title: Translate Bird Coefficients to the Standardized Template +# author: Brendan Casey; translation logic by Elly Knight (v2) +# created: 2026-09-29 +# inputs: +# in the test dataset (see harness/data_source.R): +# - covariates.csv, the bird rows +# - lookup/bird_veg_age_matrix.csv, from +# 1_code/_setup/06_harmonize_bird_translation_lookup.R +# - lookup/covariate_columns.csv, lookup/bird_factor_levels.csv +# outputs: none; returns objects in memory +# notes: +# - Port of v2's 08.PackageCoefficients.R translation. v2 +# publishes bird landcover effects on the standardized +# cross-taxa habitat types, not raw glm coefficients, so the +# harness's coefficients are translated the same way. +# - North: the raw coefficients are multiplied by v2's `age` +# matrix, one row per standardized type. Linear features and +# wellsites are re-expressed as the mean predicted abundance +# where the feature is present, then capped at the most +# abundant open or footprint type. +# - South: soil types are the intercept plus each soil +# contrast; the linear features are re-expressed and capped +# the same way against the full south design. +# - Everything is on the log scale, as v2 stores it, and +# clamped to +/- 10,000 as v2 does, so a zero-abundance type +# reads -10,000 rather than -Inf. +# - Standard errors are not translated. The gate compares +# estimates only. +# - v2 quirks reproduced for parity: +# - The mSoft substitution tests for zero after the +# coefficients are exponentiated, so it never fires. +# - The NESP north Climate effect is multiplied by 0.1 twice, +# because v2 applies the truncation once after the north +# loop and again after the south loop. +# - One deviation. v2 indexes a model matrix built with the +# default na.action by the row numbers of the unfiltered +# data, which misaligns the rows if any modelled column has +# a missing value. Here the design is built with na.pass and +# missing rows are left out of the means. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # lookup reading (version: 1.16.4) + +# 2. Naming ---- + +## 2.1 bird_sort_interaction() ---- + +#' Put Interaction Pieces in a Fixed Order +#' +#' v2's `fix_names()`: `wtAge:isCon` and `isCon:wtAge` are the +#' same term, so both are written with their pieces sorted. +#' +#' @param x Character vector of term names. +#' @return The names with interaction pieces sorted. +#' +#' @example # Example usage of the function +#' # bird_sort_interaction("wtAge:isCon") # "isCon:wtAge" +bird_sort_interaction <- function(x) { + vapply( + strsplit(x, ":", fixed = TRUE), + function(pieces) paste(sort(pieces), collapse = ":"), + character(1) + ) +} + +## 2.2 bird_column_map() ---- + +#' Map the Harness's Column Names Back to v2's +#' +#' The harmonizer suffixed columns that sit in more than one +#' block - `road` became `road_veg` and `road_soil` - so model +#' terms carry the suffix and v2's lookups do not. +#' +#' @param data_dir Character. The test dataset folder. +#' @param block Character. "veg" for north, "soil" for south. +#' @return A data frame of source and master names, one row per +#' source column, preferring the given block. +#' +#' @example # Example usage of the function +#' # bird_column_map(data_dir, "veg") +bird_column_map <- function(data_dir, block) { + map <- as.data.frame(fread( + file.path(data_dir, "lookup", "covariate_columns.csv") + )) + map <- map[map$taxon == "bird", ] + + # The block's own copy wins; a column in no other block is + # taken from wherever it is. + map <- map[order(map$block != block), ] + map[!duplicated(map$source_column), + c("source_column", "master_column")] +} + +## 2.3 bird_v2_term_names() ---- + +#' Rename Harness Model Terms to v2's Raw Names +#' +#' @param terms Character vector of harness coefficient names. +#' @param column_map From bird_column_map(). +#' @return Character vector of v2 names: `Intercept`, `climate`, +#' unsuffixed columns, sorted interactions. +#' +#' @example # Example usage of the function +#' # bird_v2_term_names(c("(Intercept)", "method_veg1SPT"), map) +bird_v2_term_names <- function(terms, column_map) { + suffixed <- column_map[ + column_map$master_column != column_map$source_column, + ] + # Longest first, so mWell_veg is not caught by a shorter name + suffixed <- suffixed[ + order(-nchar(suffixed$master_column)), + ] + + rename_piece <- function(piece) { + if (piece == "(Intercept)") { + return("Intercept") + } + + if (piece == "Climate") { + return("climate") + } + + for (i in seq_len(nrow(suffixed))) { + master <- suffixed$master_column[i] + + if (startsWith(piece, master)) { + return(paste0( + suffixed$source_column[i], + substring(piece, nchar(master) + 1) + )) + } + } + + piece + } + + renamed <- vapply( + strsplit(terms, ":", fixed = TRUE), + function(pieces) { + paste(vapply(pieces, rename_piece, character(1)), + collapse = ":") + }, + character(1) + ) + + bird_sort_interaction(renamed) +} + +# 3. Translation context ---- + +## 3.1 bird_model_terms() ---- + +#' Every Term in a Bird Landcover Model Set +#' +#' v2's `get_terms()`: the union of the terms across every +#' candidate, which is the design v2 predicts from. +#' +#' @param set Character. A model set name. +#' @return Character vector of terms, in source naming. +#' +#' @example # Example usage of the function +#' # bird_model_terms("landcover_bird_south_v2") +bird_model_terms <- function(set) { + formulas <- unlist(get_model_set(set), use.names = FALSE) + terms <- sub("^\\s*\\.\\s*~\\s*\\.\\s*\\+", "", formulas) + terms <- unlist(strsplit(terms, "[+*]")) + terms <- trimws(terms) + unique(terms[nzchar(terms)]) +} + +## 3.2 bird_translation_context() ---- + +#' Assemble What the Translation Needs for One Region +#' +#' Built once per region and reused for every species and draw: +#' the covariates under v2's names, the design matrix, and the +#' row sets the linear-feature adjustment averages over. +#' +#' @param data_dir Character. The test dataset folder. +#' @param region Character. "north" or "south". +#' @return A list. +#' +#' @example # Example usage of the function +#' # ctx <- bird_translation_context(data_dir, "north") +bird_translation_context <- function(data_dir, region) { + block <- if (region == "north") "veg" else "soil" + column_map <- bird_column_map(data_dir, block) + set <- paste0("landcover_bird_", region, "_v2") + model_terms <- bird_model_terms(set) + + # Step 1: The columns the design and the row filters need, + # under v2's names + source_columns <- unique(c( + unlist(strsplit(model_terms, ":", fixed = TRUE)), + "vegc", "fcc2", + if (region == "north") "useNorth" else c("useSouth", "soilc") + )) + source_columns <- intersect( + source_columns, column_map$source_column + ) + master_columns <- column_map$master_column[ + match(source_columns, column_map$source_column) + ] + + covariates <- load_covariates( + "bird", data_dir, unique(master_columns) + ) + names(covariates) <- c( + "survey_unit_id", + column_map$source_column[ + match(names(covariates)[-1], column_map$master_column) + ] + ) + covariates <- apply_factor_levels(covariates, data_dir, "bird") + + # Step 2: The region's rows, as v2 selects them + keep <- if (region == "north") { + covariates$useNorth %in% c(1, TRUE) + } else { + covariates$useSouth %in% c(1, TRUE) & !is.na(covariates$soilc) + } + covariates <- covariates[keep, , drop = FALSE] + + # Step 3: The design matrix, with v2's column names + design <- stats::model.matrix( + stats::as.formula( + paste("~", paste(model_terms, collapse = " + ")) + ), + stats::model.frame( + stats::as.formula( + paste("~", paste(model_terms, collapse = " + ")) + ), + covariates, na.action = stats::na.pass + ) + ) + colnames(design) <- bird_sort_interaction( + sub("^\\(Intercept\\)$", "Intercept", colnames(design)) + ) + + # Step 4: v2's human-modified types, excluded from the linear + # adjustment so they do not interfere with it + human <- c( + "Crop", "Industrial", "Mine", "RoughP", "Rural", "TameP", + "Urban" + ) + not_human <- !(as.character(covariates$vegc) %in% human) + + linear_vars <- if (region == "north") { + c("mWell", "mEnSft", "mTrSft", "mSeism") + } else { + c("mWell", "mSoft") + } + + # Rows where the feature is present (v2's anti-join on zero + # keeps missing values), off human-modified types, and in the + # north outside harvest + linear_rows <- lapply( + stats::setNames(linear_vars, linear_vars), + function(one) { + present <- is.na(covariates[[one]]) | covariates[[one]] != 0 + rows <- present & not_human + + if (region == "north") { + rows <- rows & !is.na(covariates$fcc2) & covariates$fcc2 == 0 + } + + which(rows) + } + ) + + age <- NULL + + if (region == "north") { + age_table <- as.data.frame(fread( + file.path(data_dir, "lookup", "bird_veg_age_matrix.csv") + )) + age <- as.matrix(age_table[, -1]) + rownames(age) <- age_table$type + colnames(age) <- bird_sort_interaction(colnames(age)) + } + + list( + region = region, + column_map = column_map, + design = design, + linear_rows = linear_rows, + age = age, + soil_levels = if (region == "south") { + levels(covariates$soilc) + } else { + NULL + } + ) +} + +# 4. Translation ---- + +## 4.1 standardize_bird_draw() ---- + +#' Translate One Draw's Raw Coefficients +#' +#' @param raw Named numeric vector, v2 raw names. +#' @param context From bird_translation_context(). +#' @param species Character. For v2's NESP adjustment. +#' @return Named numeric vector on the standardized template, +#' log scale. +#' +#' @example # Example usage of the function +#' # standardize_bird_draw(raw, ctx, "AMRO") +standardize_bird_draw <- function(raw, context, species) { + # Absent terms are zero, as v2's full join fills them + value <- function(names_in) { + out <- raw[names_in] + out[is.na(out)] <- 0 + stats::setNames(out, names_in) + } + + design <- context$design + + mean_abundance <- function(rows, multiplier) { + x <- design[rows, , drop = FALSE] + eta <- drop(x %*% value(colnames(x))) + mean(exp(eta) * multiplier, na.rm = TRUE) + } + + if (context$region == "north") { + age <- context$age + + # Step 1: Standardized habitat types from the age matrix + lam <- exp(drop(age %*% value(colnames(age)))) + + # Step 2: Linear features. The mSoft substitution never fires + # (v2 tests for zero after exponentiating); kept as in v2. + hf <- exp(value(c("mWell", "mSoft", "mEnSft", "mTrSft", + "mSeism"))) + + for (one in c("mEnSft", "mTrSft", "mSeism")) { + if (hf[["mSoft"]] != 0 && hf[[one]] == 0) { + hf[[one]] <- hf[["mSoft"]] + } + } + + # v2 predicts from the age-matrix columns only + design <- design[, colnames(age), drop = FALSE] + + linear <- vapply( + c("mWell", "mEnSft", "mTrSft", "mSeism"), + function(one) { + mean_abundance(context$linear_rows[[one]], hf[[one]]) + }, + numeric(1) + ) + + # Step 3: Cap at the most abundant open or footprint type + open <- max(lam[c( + names(lam)[endsWith(names(lam), "R")], + "GrassHerb", "Shrub", "GraminoidFen", "Marsh" + )]) + footprint <- max(lam[c("Industrial", "Rural", "Urban")]) + linear <- pmin(linear, max(open, footprint)) + names(linear) <- c("Wellsites", "EnSoftLin", "TrSoftLin", + "EnSeismic") + + out <- c( + Climate = exp(value("climate")[[1]]), + lam[names(lam) != "Mine"], + linear, + HardLin = 0, Water = 0, Bare = 0, SnowIce = 0, Mine = 0, + MineV = unname(lam["Mine"]) + ) + + names(out) <- gsub("Spruce", "WhiteSpruce", names(out)) + names(out) <- gsub("Decid", "Deciduous", names(out)) + names(out) <- gsub("TreedBog", "BlackSpruce", names(out)) + } else { + soil_levels <- context$soil_levels + + # Step 1: Soil types, the intercept plus each contrast + contrasts <- c(0, value(paste0("soilc", soil_levels[-1]))) + lam <- exp(value("Intercept")[[1]] + contrasts) + names(lam) <- soil_levels + + # Step 2: Linear features, against the full south design + linear <- vapply( + c("mWell", "mSoft"), + function(one) { + mean_abundance( + context$linear_rows[[one]], exp(value(one)[[1]]) + ) + }, + numeric(1) + ) + + # Step 3: Cap at the most abundant open or footprint type + open <- max(lam[c("Loamy", "Blowout", "ClaySub", "RapidDrain", + "SandyLoam", "ThinBreak", "Other")]) + footprint <- max(lam[c("Industrial", "Rural", "Urban")]) + linear <- pmin(linear, max(open, footprint)) + + out <- c( + Climate = exp(value("climate")[[1]]), + lam[!names(lam) %in% c("Mine", "Water", "Wellsites")], + pAspen = exp(value("paspen")[[1]]), + Wellsites = linear[["mWell"]], + EnSeismic = linear[["mSoft"]], + EnSoftLin = linear[["mSoft"]], + TrSoftLin = linear[["mSoft"]], + HardLin = 0, Water = 0, Mine = 0, + MineV = unname(lam["Mine"]) + ) + } + + # Step 4: Back to the log scale, clamped as v2 does + out <- log(out) + out[out > 1e4] <- 1e4 + out[out < -1e4] <- -1e4 + + # v2 truncates the NESP north Climate effect, twice + if (context$region == "north" && species == "NESP") { + out[["Climate"]] <- out[["Climate"]] * 0.1 * 0.1 + } + + out +} + +## 4.2 standardize_bird_coefficients() ---- + +#' Translate a Store's Bird Landcover Coefficients +#' +#' @param coefficients A data frame of species, region, boot, +#' term and estimate: the landcover stage, one region. +#' @param data_dir Character. The test dataset folder. +#' @param region Character. "north" or "south". +#' @return A data frame of the same columns, on the standardized +#' template, with stage "habitat" and se NA. +#' +#' @example # Example usage of the function +#' # standardize_bird_coefficients(landcover, data_dir, "north") +standardize_bird_coefficients <- function( + coefficients, data_dir, region +) { + if (is.null(coefficients) || nrow(coefficients) == 0) { + return(NULL) + } + + context <- bird_translation_context(data_dir, region) + + coefficients$v2_term <- bird_v2_term_names( + coefficients$term, context$column_map + ) + + draws <- split( + coefficients, + list(coefficients$species, coefficients$boot), + drop = TRUE + ) + + rows <- lapply(draws, function(one) { + raw <- stats::setNames(one$estimate, one$v2_term) + translated <- standardize_bird_draw( + raw, context, one$species[1] + ) + + data.frame( + species = one$species[1], + region = region, + stage = "habitat", + boot = one$boot[1], + term = names(translated), + estimate = unname(translated), + se = NA_real_, + stringsAsFactors = FALSE + ) + }) + + out <- do.call(rbind, rows) + rownames(out) <- NULL + + out +} + +# 5. bird_habitat_translation() ---- + +#' Translate a Store's Bird Landcover onto v2's Habitat Template +#' +#' The form collect_results() takes in `translate`: given a +#' store's coefficients, returns the landcover stage translated +#' onto v2's standardized habitat types as extra rows, stage +#' "habitat". The raw "landcover" rows stay as they are. +#' +#' @param coefficients A store's coefficients. +#' @param data_dir Character. The test dataset folder. +#' @param region Character. "north" or "south". +#' @return A data frame of coefficient rows, or NULL. +#' +#' @example # Example usage of the function +#' # collect_results(pipeline_dir, data_dir, +#' # translate = list(bird = bird_habitat_translation)) +bird_habitat_translation <- function(coefficients, data_dir, region) { + landcover <- coefficients[coefficients$stage == "landcover", ] + + if (nrow(landcover) == 0) { + return(NULL) + } + + standardize_bird_coefficients(landcover, data_dir, region) +} + +# End of script ---- diff --git a/1_code/modules/bryophytes/spec.R b/1_code/modules/bryophytes/spec.R new file mode 100644 index 0000000..8183d7a --- /dev/null +++ b/1_code/modules/bryophytes/spec.R @@ -0,0 +1,52 @@ +# --- +# title: Bryophyte Taxon Spec +# author: Brendan Casey +# created: 2026-09-10 +# inputs: +# - 1_code/modules/_shared/plant_group.R +# outputs: none; returns objects in memory +# notes: +# - Data slug: "bryophyte". Response file bryophyte.csv. +# - v2 fits Protocol for this taxon (bryophytes and lichens +# only); `use_protocol` can equalize it across taxa. +# - The published bryophyte model file is unusable (every entry +# is a `could not find function "model.avg"` error; 3 stored +# draws, not 100). The parity reference is ABMIexploreR's +# arrays (_setup/08), matching v2's COEFS.RData to ~1e-15. +# _setup/03 regenerated the climate stage into +# 2_pipeline/v2_reference/ for v2_self_agreement.R. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. bryophyte_spec() ---- + +#' Build the v2 Spec for Bryophytes +#' +#' @param use_protocol Logical, or NULL to take the v2 value, +#' which is TRUE for this taxon. +#' @param bootstrap Character. "spatial_block" or "v2_ids"; see +#' plant_group_spec(). +#' @return A spec list, as run_spec() consumes. +#' +#' @example # Example usage of the function +#' # spec <- bryophyte_spec() +#' # spec$use_protocol # TRUE +bryophyte_spec <- function(use_protocol = NULL, + bootstrap = "spatial_block") { + plant_group_spec( + taxon = "bryophyte", + protocol_in_v2 = TRUE, + use_protocol = use_protocol, + bootstrap = bootstrap, + reference_note = paste0( + "The published v2 model file is unusable; the v2 ", + "reference is ABMIexploreR's, via v2_results.csv." + ) + ) +} + +# End of script ---- diff --git a/1_code/modules/lichens/spec.R b/1_code/modules/lichens/spec.R new file mode 100644 index 0000000..3eadb1b --- /dev/null +++ b/1_code/modules/lichens/spec.R @@ -0,0 +1,44 @@ +# --- +# title: Lichen Taxon Spec +# author: Brendan Casey +# created: 2026-09-10 +# inputs: +# - 1_code/modules/_shared/plant_group.R +# outputs: none; returns objects in memory +# notes: +# - Data slug: "lichen". Response file lichen.csv. +# - v2 fits Protocol for this taxon (bryophytes and lichens +# only); `use_protocol` can equalize it across taxa. +# - The v2 reference is the published file on ABMI-DATA2 and is +# intact, unlike the bryophyte one. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. lichen_spec() ---- + +#' Build the v2 Spec for Lichens +#' +#' @param use_protocol Logical, or NULL to take the v2 value, +#' which is TRUE for this taxon. +#' @param bootstrap Character. "spatial_block" or "v2_ids"; see +#' plant_group_spec(). +#' @return A spec list, as run_spec() consumes. +#' +#' @example # Example usage of the function +#' # spec <- lichen_spec() +#' # spec$use_protocol # TRUE +lichen_spec <- function(use_protocol = NULL, + bootstrap = "spatial_block") { + plant_group_spec( + taxon = "lichen", + protocol_in_v2 = TRUE, + use_protocol = use_protocol, + bootstrap = bootstrap + ) +} + +# End of script ---- diff --git a/1_code/modules/mammals/.gitkeep b/1_code/modules/mammals/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/modules/mammals/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/modules/mammals/hurdle.R b/1_code/modules/mammals/hurdle.R new file mode 100644 index 0000000..d52fd4d --- /dev/null +++ b/1_code/modules/mammals/hurdle.R @@ -0,0 +1,649 @@ +# --- +# title: The v2 Mammal Hurdle Tables +# author: Brendan Casey; model logic by Marcus Becker and David J. +# Huggard (v2) +# created: 2026-09-29 +# inputs: +# in the test dataset's lookup/ (see data_source.R): +# - mammal_climate_predictions.csv +# - species_queue.csv (each species' v2 name) +# outputs: none; returns objects in memory +# notes: +# - Ports how v2 turns the two hurdle GLMs into its published +# tables: 03_basic-models.R after the fits, north sections +# 6.3-6.6 and 6.11, south 6.3-6.6. The hurdle itself is fitted +# by methods/selection/hurdle.R. +# - mammal_v2_habitat_tables() is a post_process step, removed +# by replace_stage_method(); it stops if a half is not a GLM. +# - Effects are reported on v2's full habitat set, not the +# winning model's categories: each category is spread over +# the fine types the prediction matrix assigns to it. +# - Three outputs, one per v2 table: presence (Coef.pa, a +# probability), abundance (Coef.agp, on the response scale) +# and total (Coef.mean). Seasons are averaged later, by the +# comparison, as v2 averages them into its `.all` tables. +# - Cutblock convergence is applied per season. It is linear, +# so converging each season and then averaging equals v2's +# averaging and then converging. +# - v2 quirks reproduced: the one-hot predictions are read at +# seas_days = 100 and Climate = 0 whatever the candidate; +# the abundance candidates are unweighted; the Mule Deer +# adjustment to old pine (and, in winter, deciduous) stands. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# mgcv for the age splines and MuMIn for AICc, both loaded +# lazily so a run without mammals does not need them. + +# 2. Precomputed climate ---- + +## 2.1 mammal_precomputed_climate() ---- + +#' Attach v2's Precomputed Climate Prediction to a Mammal Frame +#' +#' As v2: drops deployments without a prediction, then recomputes +#' the response, since lure correction and scaling depend on the +#' rows kept. +#' +#' @param frame A one-species frame from model_frame(). +#' @param species Character. The harness species name, e.g. +#' "BlackBear_Summer". +#' @param data_dir Character. +#' @param spec The mammal spec. +#' @return The frame, with `Climate` and without rows lacking it. +#' +#' @example # Example usage of the function +#' # frame <- mammal_precomputed_climate(frame, sp, data_dir, spec) +mammal_precomputed_climate <- function(frame, species, data_dir, + spec) { + # The climate file names species as v2 did, without the season + v2_name <- sub( + "(Summer|Winter)$", "", + species_source_name(data_dir, "mammal", species) + ) + + # Read whole once per session; every species reads a column + climate <- cached_read( + file.path(data_dir, "lookup", "mammal_climate_predictions.csv"), + function(p) as.data.frame(data.table::fread(p)) + ) + + if (!v2_name %in% names(climate)) { + stop("No precomputed climate for mammal `", v2_name, "`.", + call. = FALSE) + } + + frame$Climate <- climate[[v2_name]][ + match(frame$survey_unit_id, climate$survey_unit_id) + ] + frame <- frame[!is.na(frame$Climate) & !is.na(frame$response_raw), ] + + frame$response <- apply_response_transform( + frame$response_raw, spec$response_transform, frame + ) + + frame +} + +# 3. Helpers ---- + +## 3.1 mammal_aicc() ---- + +#' AICc as v2 Computes It +#' +#' @param model A fitted glm or gam, or a try-error. +#' @return A number; Inf for a failed fit. +#' +#' @example # Example usage of the function +#' # mammal_aicc(fit) +mammal_aicc <- function(model) { + if (is.null(model) || inherits(model, "try-error")) { + return(Inf) + } + + value <- tryCatch(MuMIn::AICc(model), error = function(e) Inf) + if (is.finite(value)) value else Inf +} + +## 3.2 mammal_lure_ratio() ---- + +#' v2's Lure Effect: Lured Mean over Unlured Mean on the Grid +#' +#' @param values Numeric vector. +#' @param lured Character vector, "Yes" or "No". +#' @param location Character vector. +#' @return A number, NA when either group is absent, as in v2. +#' +#' @example # Example usage of the function +#' # mammal_lure_ratio(sign(count), d$lured, d$location) +mammal_lure_ratio <- function(values, lured, location) { + grid_site <- grepl("^[[:digit:]]+", location) + q <- tapply(values[grid_site], lured[grid_site], mean) + unname(q["Yes"] / q["No"]) +} + +## 3.3 mammal_held_constants() ---- + +#' The Values v2 Holds Fixed for Its One-Hot Predictions +#' +#' @param has_aspen Logical. Whether the region fits pAspen (the +#' south). +#' @return A named list. +#' +#' @example # Example usage of the function +#' # mammal_held_constants(TRUE) +mammal_held_constants <- function(has_aspen) { + constants <- list(seas_days = 100, Climate = 0) + if (has_aspen) constants$pAspen <- 0 + constants +} + +# 4. The v2 tables ---- + +## 4.1 mammal_v2_habitat_tables() ---- + +#' Turn the Fitted Hurdle into v2's Three Habitat Tables +#' +#' Replaces the `hurdle` rule's outputs with v2's presence, +#' abundance and total tables. +#' +#' @param selected The `hurdle` rule's selection result. +#' @param data The stage's data: `response` is the lure-scaled +#' presence, `response_raw` the count, `weight` the season +#' weight, and `lured`, `location`, `seas_days`, `Climate`, the +#' habitat columns and, in the north, the aged stand-cover +#' columns. +#' @param grid The prediction matrix, with v2's rows dropped. +#' @param species Character. The harness species name. +#' @return The selection result, with `coefficients` the presence +#' table and `outputs` v2's three tables. +#' +#' @example # Example usage of the function +#' # selected <- mammal_v2_habitat_tables(selected, d, pm, +#' # "MuleDeer_Summer") +mammal_v2_habitat_tables <- function(selected, data, grid, + species = NA_character_) { + if (!requireNamespace("MuMIn", quietly = TRUE) || + !requireNamespace("mgcv", quietly = TRUE)) { + stop("The mammal v2 tables need MuMIn and mgcv.", call. = FALSE) + } + + pa <- selected$parts$presence$fit$fit + agp <- selected$parts$abundance$fit$fit + + # Needs GLM coefficients; other engines should not reach here + if (!inherits(pa, "glm") || !inherits(agp, "glm")) { + stop( + "The mammal v2 tables read GLM fits, but this hurdle was ", + "fitted with another engine. Replace the stage's method ", + "with replace_stage_method(), which removes this step.", + call. = FALSE + ) + } + + if (is.null(grid)) { + stop("The mammal v2 tables need the prediction matrix.", + call. = FALSE) + } + + # The north carries the aged stand-cover columns; the south, + # which has no stand ages, does not + ages <- "SpruceR" %in% names(data) + has_aspen <- "pAspen" %in% names(data) + count <- data$response_raw + lure_pa <- mammal_lure_ratio(sign(count), data$lured, data$location) + lure_agp <- mammal_lure_ratio( + count[count > 0], data$lured[count > 0], data$location[count > 0] + ) + + # Step 1: Presence effects, one category at a time (6.3) + presence <- mammal_presence_effects( + pa, data, selected$reference_category, lure_pa, has_aspen + ) + + # Site-level logits: the age splines' offset + data$p <- stats::predict(pa, newdata = data) + + # Step 2: Abundance effects on the prediction matrix (6.4) + abundance <- mammal_abundance_effects(agp, grid, has_aspen) + + # Step 3: Stand-age splines, north only (6.5) + aged <- if (ages) { + mammal_age_splines(data, presence$coef, presence$terms) + } else { + list(p_age = list(), p_age_se = list()) + } + + # Step 4: Spread each category over its fine types (6.5) + spread <- mammal_spread( + presence, abundance$coef, aged, grid, ages + ) + + # Step 5: v2's Mule Deer adjustment + spread$mean <- mammal_mule_deer(spread$mean, species) + + # Step 6: Calibrate total abundance to the observed mean (6.6) + spread$mean <- spread$mean * mammal_total_calibration( + pa, agp, data, presence$at_constants, lure_pa, lure_agp, + has_aspen + ) + + # Step 7: Cutblock convergence, north only (6.11) + if (ages) { + spread$mean <- mammal_cutblock_convergence(spread$mean) + } + + # v2 adds Bare and Water at zero to every table (7.1) + coef_agp <- abundance$coef + coef_agp_se <- abundance$se + spread$pa[c("Bare", "Water")] <- 0 + spread$pa_se[c("Bare", "Water")] <- 0 + spread$mean[c("Bare", "Water")] <- 0 + coef_agp[c("Bare", "Water")] <- 0 + coef_agp_se[c("Bare", "Water")] <- 0 + + table_of <- function(values, se = NA_real_) { + data.frame( + term = names(values), estimate = unname(values), + se = if (length(se) == length(values)) unname(se) else NA_real_, + stringsAsFactors = FALSE + ) + } + + presence_table <- table_of(spread$pa, spread$pa_se) + + selected$coefficients <- presence_table + selected$outputs <- list( + presence = presence_table, + abundance = table_of(coef_agp, coef_agp_se), + total = table_of(spread$mean) + ) + + selected +} + +## 4.2 mammal_presence_effects() ---- + +#' Presence per Habitat Category, Calibrated (v2 6.3) +#' +#' Every one-hot row is read at seas_days = 100, Climate = 0 and +#' pAspen = 0, including the rows for those terms themselves, as +#' v2's duplicated data-frame columns make it. The level is then +#' shifted on the logit scale so mean fitted presence matches mean +#' observed; Climate is a slope and keeps its own coefficient. +#' +#' @param pa The presence GLM. +#' @param data The stage's data. +#' @param reference Character. The category the winning presence +#' candidate leaves out. +#' @param lure_pa Numeric. The presence lure ratio. +#' @param has_aspen Logical. +#' @return A list of `coef` and `se` (named by term), `terms`, and +#' `at_constants` (the data at v2's held values). +#' +#' @example # Example usage of the function +#' # mammal_presence_effects(pa, d, "Shrub", 1.4, FALSE) +mammal_presence_effects <- function(pa, data, reference, lure_pa, + has_aspen) { + count <- data$response_raw + terms_pa <- c(attr(pa$terms, "term.labels"), reference) + constants <- mammal_held_constants(has_aspen) + held <- names(constants) + + pa_link <- vapply(terms_pa, function(term) { + onehot <- stats::setNames( + as.list(as.numeric(terms_pa == term)), terms_pa + ) + onehot[held] <- constants[held] + predicted <- stats::predict( + pa, newdata = as.data.frame(onehot), se.fit = TRUE + ) + c(fit = unname(predicted$fit), se = unname(predicted$se.fit)) + }, c(fit = 0, se = 0)) + + coef_pa <- stats::plogis(pa_link["fit", ]) + coef_pa_se <- pa_link["se", ] + names(coef_pa) <- names(coef_pa_se) <- terms_pa + + coef_pa[["Climate"]] <- stats::plogis(stats::coef(pa)[["Climate"]]) + climate_se <- coef_pa_se[["Climate"]] + + # Calibrate the level: mean fitted presence to mean observed + at_constants <- data + at_constants$seas_days <- 100 + if (has_aspen) at_constants$pAspen <- 0 + + p_obs <- sign(count) / ifelse(data$lured == "Yes", lure_pa, 1) + p_obs <- p_obs / max(p_obs) + adj <- stats::qlogis(mean(p_obs)) - + stats::qlogis(mean(stats::plogis( + stats::predict(pa, newdata = at_constants) + ))) + + climate_pa <- coef_pa[["Climate"]] + coef_pa <- stats::plogis(stats::qlogis(coef_pa) + adj) + coef_pa[["Climate"]] <- climate_pa + coef_pa_se[["Climate"]] <- climate_se + + list( + coef = coef_pa, se = coef_pa_se, terms = terms_pa, + at_constants = at_constants + ) +} + +## 4.3 mammal_abundance_effects() ---- + +#' Abundance Given Presence on the Prediction Matrix (v2 6.4) +#' +#' @param agp The abundance GLM. +#' @param grid The prediction matrix. +#' @param has_aspen Logical. +#' @return A list of `coef` and `se`, on the response scale, with +#' Climate first at 1 (no effect on abundance). +#' +#' @example # Example usage of the function +#' # mammal_abundance_effects(agp, pm, FALSE) +mammal_abundance_effects <- function(agp, grid, has_aspen) { + constants <- mammal_held_constants(has_aspen) + newdata <- grid + for (one in names(constants)) newdata[[one]] <- constants[[one]] + + agp_pred <- stats::predict(agp, newdata = newdata, se.fit = TRUE) + t_mean_agp <- stats::setNames( + as.numeric(agp_pred$fit), rownames(grid) + ) + t_se_agp <- stats::setNames( + as.numeric(agp_pred$se.fit), rownames(grid) + ) + + list( + coef = c(Climate = 1, exp(t_mean_agp)), + se = c(Climate = 0, t_se_agp) + ) +} + +## 4.4 mammal_age_splines() ---- + +#' Presence by Stand Age, from v2's Splines (v2 6.5) +#' +#' One frame per stand type from units where an age class covers +#' more than 10%, a binomial GAM on sqrt(age) with the site-level +#' presence logit as offset, used where it beats the +#' intercept-only model by AICc weight. +#' +#' @param data The stage's data, with `p`, the site-level logits. +#' @param coef_pa Named numeric. Calibrated presence per term. +#' @param terms_pa Character. The presence terms. +#' @return A list of `p_age` and `p_age_se`, per term that took a +#' spline: nine values, R and 1 to 8. +#' +#' @example # Example usage of the function +#' # mammal_age_splines(d, coef_pa, names(coef_pa)) +mammal_age_splines <- function(data, coef_pa, terms_pa) { + stand_types <- c("Spruce", "Pine", "Decid", "Mixedwood", "TreedBog") + seas_wt <- data$weight + p_age <- p_age_se <- list() + stand <- stats::setNames(vector("list", 5), stand_types) + + for (i in 0:8) { + label <- if (i == 0) "R" else i + age <- if (i == 0) 0.5 else i + + for (type in stand_types) { + column <- paste0(type, label) + if (!column %in% names(data)) next + rows <- which(data[[column]] > 0.1) + if (length(rows) == 0) next + + stand[[type]] <- rbind(stand[[type]], data.frame( + p_count = data$response[rows], age = age, + wt1 = data[[column]][rows] * seas_wt[rows], + p = data$p[rows] + )) + } + } + + frames <- c(stand, list( + UpCon = rbind(stand$Spruce, stand$Pine), + DecidMixed = rbind(stand$Decid, stand$Mixedwood), + TreedAll = do.call(rbind, stand) + )) + + fit_gam <- function(df, spline) { + f <- if (spline) { + p_count ~ s(sqrt(age), k = 4, m = 2) + offset(p) + } else { + p_count ~ 1 + offset(p) + } + suppressWarnings(mgcv::gam( + f, data = df, family = "binomial", weights = df$wt1 + )) + } + + null_age <- lapply(frames, fit_gam, spline = FALSE) + spline_age <- lapply(seq_along(frames), function(i) { + if (sum(sign(frames[[i]]$p_count)) > 4) { + fit_gam(frames[[i]], TRUE) + } else { + null_age[[i]] + } + }) + names(spline_age) <- names(frames) + + # The spline is used where it beats the null by AICc weight + spline_weight <- vapply(names(frames), function(nm) { + q <- c(mammal_aicc(spline_age[[nm]]), mammal_aicc(null_age[[nm]])) + q <- q - min(q) + exp(-0.5 * q[1]) / sum(exp(-0.5 * q)) + }, numeric(1)) + + age_map <- list( + Spruce = "Spruce", Pine = "Pine", Decid = "Decid", + Mixedwood = "Mixedwood", TreedBog = "TreedBog", + TreedWet = "TreedBog", UpCon = "UpCon", + DecidMixed = "DecidMixed", UplandForest = "TreedAll", + TreedAll = "TreedAll" + ) + + smooth <- function(y) { + c(mean(y[1:2]), y[2:4], mean(y[4:6]), mean(y[5:7]), + mean(y[6:8]), mean(y[7:9]), mean(y[8:9])) + } + + for (term in names(age_map)) { + model_key <- age_map[[term]] + if (!term %in% terms_pa) next + if (spline_weight[[model_key]] <= 0.5) next + + predicted <- stats::predict( + spline_age[[model_key]], + newdata = data.frame( + age = c(0.5, 1:8), p = stats::qlogis(coef_pa[[term]]) + ), + se.fit = TRUE + ) + p_age[[term]] <- smooth(stats::plogis(as.numeric(predicted$fit))) + p_age_se[[term]] <- smooth(as.numeric(predicted$se.fit)) + } + + list(p_age = p_age, p_age_se = p_age_se) +} + +## 4.5 mammal_spread() ---- + +#' Spread Each Category over Its Fine Types (v2 6.5) +#' +#' @param presence A mammal_presence_effects() result. +#' @param coef_agp Named numeric. Abundance per fine type. +#' @param aged A mammal_age_splines() result. +#' @param grid The prediction matrix. +#' @param ages Logical. Whether the region has stand ages. +#' @return A list of `pa`, `pa_se` and `mean` (presence times +#' abundance), each named by fine type. +#' +#' @example # Example usage of the function +#' # mammal_spread(presence, coef_agp, aged, pm, TRUE) +mammal_spread <- function(presence, coef_agp, aged, grid, ages) { + stand_types <- c("Spruce", "Pine", "Decid", "Mixedwood", "TreedBog") + coef_pa <- presence$coef + coef_pa_se <- presence$se + out_pa <- out_pa_se <- out_mean <- numeric(0) + terms_pa1 <- setdiff(presence$terms, c("seas_days", "pAspen")) + + put <- function(names_in, pa_values, pa_se, agp_value) { + out_pa[names_in] <<- pa_values + out_pa_se[names_in] <<- pa_se + out_mean[names_in] <<- pa_values * agp_value + } + + for (term in terms_pa1) { + if (term == "Climate") { + put("Climate", coef_pa[["Climate"]], coef_pa_se[["Climate"]], 1) + next + } + + if (!term %in% names(grid)) next + fine_types <- rownames(grid)[grid[[term]] == 1] + + for (fine in fine_types) { + agp_value <- if (fine %in% names(coef_agp)) { + coef_agp[[fine]] + } else { + 0 + } + + if (ages && fine %in% stand_types) { + age_names <- paste0(fine, c("R", 1:8)) + + if (!is.null(aged$p_age[[term]])) { + put(age_names, aged$p_age[[term]], aged$p_age_se[[term]], + agp_value) + } else { + put(age_names, rep(coef_pa[[term]], 9), + rep(coef_pa_se[[term]], 9), agp_value) + } + } else { + put(fine, coef_pa[[term]], coef_pa_se[[term]], agp_value) + } + } + } + + list(pa = out_pa, pa_se = out_pa_se, mean = out_mean) +} + +## 4.6 mammal_mule_deer() ---- + +#' v2's Mule Deer Adjustment to Old Stands +#' +#' Old pine, and in winter old deciduous, stands are pulled +#' toward the 100-119 class. +#' +#' @param out_mean Named numeric. Total abundance per fine type. +#' @param species Character. The harness species name. +#' @return `out_mean`, adjusted for Mule Deer and unchanged +#' otherwise. +#' +#' @example # Example usage of the function +#' # mammal_mule_deer(out_mean, "MuleDeer_Winter") +mammal_mule_deer <- function(out_mean, species) { + base_species <- sub("_(Summer|Winter)$", "", species) + + if (!identical(base_species, "MuleDeer")) { + return(out_mean) + } + + types <- c("Pine", if (grepl("_Winter$", species)) "Decid") + + for (type in types) { + old <- paste0(type, c("7", "8")) + ref <- paste0(type, "6") + if (all(c(old, ref) %in% names(out_mean))) { + out_mean[old] <- (out_mean[old] + out_mean[[ref]]) / 2 + } + } + + out_mean +} + +## 4.7 mammal_total_calibration() ---- + +#' The Factor That Calibrates Total Abundance (v2 6.6) +#' +#' Mean observed lure-corrected count over mean predicted +#' presence times abundance, both at v2's held values with the +#' pAspen slopes added back. +#' +#' @param pa,agp The presence and abundance GLMs. +#' @param data The stage's data. +#' @param at_constants The data at v2's held values. +#' @param lure_pa,lure_agp Numeric. The two lure ratios. +#' @param has_aspen Logical. +#' @return A number. +#' +#' @example # Example usage of the function +#' # mammal_total_calibration(pa, agp, d, at, 1.4, 1.1, FALSE) +mammal_total_calibration <- function(pa, agp, data, at_constants, + lure_pa, lure_agp, has_aspen) { + slope <- function(model) { + if ("pAspen" %in% names(stats::coef(model))) { + stats::coef(model)[["pAspen"]] + } else { + 0 + } + } + aspen <- if (has_aspen) data$pAspen else 0 + count <- data$response_raw + + t_p_pa <- stats::plogis( + stats::predict(pa, newdata = at_constants) + slope(pa) * aspen + ) + t_p_agp <- stats::predict(agp, newdata = at_constants) + + slope(agp) * aspen + p_obs_total <- ifelse( + data$lured == "Yes", count / (lure_pa * lure_agp), count + ) + + mean(p_obs_total) / mean(t_p_pa * exp(t_p_agp)) +} + +## 4.8 mammal_cutblock_convergence() ---- + +#' Converge Young Cutblocks onto Natural Stands (v2 6.11) +#' +#' The same recovery weights as the plant pipeline, applied to +#' age classes 2 to 4. +#' +#' @param out_mean Named numeric. Total abundance per fine type. +#' @return `out_mean`, converged. +#' +#' @example # Example usage of the function +#' # mammal_cutblock_convergence(out_mean) +mammal_cutblock_convergence <- function(out_mean) { + recovery <- cutblock_recovery_weights() + convergence <- list( + CCSpruce = list("Spruce", recovery$conifer), + CCPine = list("Pine", recovery$conifer), + CCMixedwood = list("Mixedwood", recovery$deciduous), + CCDecid = list("Decid", recovery$deciduous) + ) + + for (cc in names(convergence)) { + for (k in 1:3) { + age <- k + 1 + w <- convergence[[cc]][[2]][k] + cc_name <- paste0(cc, age) + natural <- paste0(convergence[[cc]][[1]], age) + + if (all(c(cc_name, natural) %in% names(out_mean))) { + out_mean[[cc_name]] <- out_mean[[cc_name]] * (1 - w) + + out_mean[[natural]] * w + } + } + } + + out_mean +} + +# End of script ---- diff --git a/1_code/modules/mammals/spec.R b/1_code/modules/mammals/spec.R new file mode 100644 index 0000000..fd62ed4 --- /dev/null +++ b/1_code/modules/mammals/spec.R @@ -0,0 +1,334 @@ +# --- +# title: Mammal Taxon Spec +# author: Brendan Casey +# created: 2026-09-09 +# inputs: none +# outputs: none; returns objects in memory +# notes: +# - v2 reads mammal climate from mammal_climate_predictions.csv +# (ABbiodiversity/MammalModels, 1_code/2_habitat-modeling/ +# climate/: nine binomial GLMs over FFP, MAP, CMD, TD, AICc +# averaged). `climate_source = "fitted"` instead fits that set +# as a stage, on the climate from +# abmi-camera-climate_2023.Rdata that v2 used. +# - North and south are separate covariate keys: overlapping +# deployments with disagreeing covariates. +# - Weights are season days, so the weight column follows the +# season in the species name. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +# Base R only; the harness supplies everything else. + +# 2. mammal_pa_response() ---- + +#' Standardise Detections to the No-Lure Scale +#' +#' As v2: lured detections are divided by the lure ratio +#' estimated from the numbered ABMI grid sites (matched lured and +#' unlured pairs), then scaled to a maximum of one for a binomial +#' model. If the ratio cannot be estimated, detections are left +#' uncorrected. +#' +#' @param values Numeric vector of counts. +#' @param frame The assembled frame, carrying `lured` and +#' `location`. +#' @return A numeric vector between 0 and 1. +#' +#' @example # Example usage of the function +#' # mammal_pa_response(d$Count, d) +mammal_pa_response <- function(values, frame) { + detected <- sign(values) + + # Numbered locations are the ABMI grid + grid_site <- grepl("^[[:digit:]]+", as.character(frame$location)) + lured <- as.character(frame$lured) == "Yes" + + usable <- grid_site & !is.na(lured) + lure_ratio <- NA_real_ + + if (any(usable & lured) && any(usable & !lured)) { + lure_ratio <- mean(detected[usable & lured], na.rm = TRUE) / + mean(detected[usable & !lured], na.rm = TRUE) + } + + corrected <- if (is.finite(lure_ratio) && lure_ratio > 0) { + detected / ifelse(lured %in% TRUE, lure_ratio, 1) + } else { + detected + } + + peak <- max(corrected, na.rm = TRUE) + + if (!is.finite(peak) || peak <= 0) { + return(corrected) + } + + corrected / peak +} + +# 3. mammal_agp_response() ---- + +#' Standardise Abundance to the No-Lure Scale +#' +#' Lure-corrected from the ratio of mean counts, then winsorized +#' at the 99th percentile of positive counts: a few enormous +#' densities would otherwise dominate the log-link Gamma fit. +#' +#' @param values Numeric vector of counts. +#' @param frame The assembled frame, carrying `lured` and +#' `location`. +#' @return A numeric vector; zero where the species was absent, +#' which the abundance stage then filters out. +#' +#' @example # Example usage of the function +#' # mammal_agp_response(d$Count, d) +mammal_agp_response <- function(values, frame) { + present <- values > 0 + grid_site <- grepl("^[[:digit:]]+", as.character(frame$location)) + lured <- as.character(frame$lured) == "Yes" + + usable <- grid_site & present & !is.na(lured) + lure_ratio <- NA_real_ + + if (any(usable & lured) && any(usable & !lured)) { + lure_ratio <- mean(values[usable & lured], na.rm = TRUE) / + mean(values[usable & !lured], na.rm = TRUE) + } + + corrected <- if (is.finite(lure_ratio) && lure_ratio > 0) { + values / ifelse(lured %in% TRUE, lure_ratio, 1) + } else { + values + } + + positive <- corrected[corrected > 0 & is.finite(corrected)] + + if (length(positive) == 0) { + return(corrected) + } + + cap <- stats::quantile(positive, 0.99, names = FALSE) + + pmin(corrected, cap) +} + +# 4. mammal_spec() ---- + +#' Build the v2 Spec for Mammals +#' +#' The habitat stage is the generic `hurdle` rule with v2's GLMs +#' (best by AICc), turned into v2's tables by +#' mammal_v2_habitat_tables() (hurdle.R). +#' +#' @param climate_source Character. "precomputed", the v2 +#' default, reads each species' climate prediction from +#' mammal_climate_predictions.csv and drops the deployments +#' without one, as v2 does; "fitted" fits the adapted climate +#' stage instead. +#' @param season Character. "summer" or "winter"; selects the +#' weight column and the species queue. +#' @param tier Character. "modelled" is the full habitat model, +#' fitted for species with at least 20 detections; "ua" is the +#' use-availability model, at least 3. +#' @return A spec list, as run_spec() consumes. +#' +#' @example # Example usage of the function +#' # spec <- mammal_spec() +#' # spec <- mammal_spec(climate_source = "fitted") +mammal_spec <- function( + climate_source = c("precomputed", "fitted"), + season = c("summer", "winter"), + tier = "modelled" +) { + climate_source <- match.arg(climate_source) + season <- match.arg(season) + + stages <- list() + + if (climate_source == "fitted") { + stages <- list( + list( + name = "climate", + # The full v2 set (CMD and TD from the camera climate file) + models = "climate_bird_mammal_v2", + engine = "glm", + selection = "aic_average", + ic = "AICc", + carry_as = "Climate", + # Fitted on presence; the abundance half reuses it + response_transform = mammal_pa_response + ) + ) + } + + list( + taxon = "mammal", + response_name = "response", + # The stage a methods experiment replaces by default + habitat_stage = "habitat", + + # Presence; the abundance half reads the raw count + response_transform = mammal_pa_response, + + # v2 reads climate from a separate pipeline's prediction + species_frame = if (climate_source == "precomputed") { + mammal_precomputed_climate + } else { + NULL + }, + supplied_columns = if (climate_source == "precomputed") { + "Climate" + } else { + NULL + }, + family = "binomial", + weight_column = paste0("wt_", season), + + # `seas_days` is the season's days column + aliases = list(seas_days = paste0(season, "_days")), + tier = tier, + season = season, + + regions = list( + north = list( + # v2 drops deployments with too little sampling effort + # to estimate from, and in the north the wetland-margin + # deployments (section 5.1). + filter = if (season == "summer") { + ~ summer_days > 10 & WetlandMargin != 1 + } else { + ~ winter_days > 10 & WetlandMargin != 1 + }, + grid = "mammal_north", + # v2's prediction matrix without WetlandMargin, and + # without the Climate row (section 5.2) + grid_drop_rows = c("WetlandMargin", "Climate"), + grid_drop_cols = "WetlandMargin", + term_block = "veg", + habitat_models = "habitat_mammal_north_pa_v2", + intercept_cats = "intercept_mammal_north_pa_v2", + # The v2 stand-age splines read the aged cover columns + extra_covariates = as.vector(t(outer( + c("Spruce", "Pine", "Decid", "Mixedwood", "TreedBog"), + c("R", 1:8), paste0 + ))) + ), + south = list( + # The south drops all-water deployments instead + filter = if (season == "summer") { + ~ summer_days > 10 & Water == 0 + } else { + ~ winter_days > 10 & Water == 0 + }, + grid = "mammal_south", + grid_drop_rows = "Climate", + term_block = "soil", + # v2's 30 south candidates, from south-models/00_models.R + habitat_models = "habitat_mammal_south_pa_v2", + intercept_cats = "intercept_mammal_south_pa_v2", + # pAspen (in half the candidates) is held fixed on the + # grid and is not cover + constants = list(seas_days = 100, Climate = 0, pAspen = 0) + ) + ), + + stages = c(stages, list( + list( + name = "habitat", + models = NULL, + engine = "glm", + # Each half best by AICc; see methods/selection/hurdle.R + selection = "hurdle", + part_selection = "aic_best", + ic = "AICc", + carry_from = "climate", + carry_from_as = "Climate", + # The presence response, recomputed on each draw because + # the lure ratio and scaling depend on which units are in + response_transform = mammal_pa_response, + # Abundance given presence: the lure-corrected count, + # winsorized, on a log-link Gamma, unweighted, without + # Climate, plus an effort-only null - all as v2 + abundance_response = mammal_agp_response, + abundance_family = stats::Gamma(link = "log"), + abundance_drop = "Climate", + abundance_null = ". ~ . + seas_days", + abundance_weighted = FALSE, + # Each habitat type is read at v2's 100 sampling days and + # zero climate + grid_constants = list(seas_days = 100, Climate = 0), + # v2's own tables from the two GLMs: the full habitat + # set, calibration, stand-age splines, Mule Deer and + # cutblock convergence. Removed by replace_stage_method(). + post_process = list(mammal_v2_habitat_tables) + ) + )), + + resample = list( + scheme = "spatial_block", + min_detections = 20L + # No seed here: the experiment's seed is used + ), + + climate_source = climate_source, + + v2_coverage = list( + climate = if (climate_source == "precomputed") { + v2_status( + "reproduced", + paste( + "v2's precomputed climate prediction, read per species;", + "deployments without one are dropped, as in v2." + ) + ) + } else { + v2_status( + "partial", + paste( + "The full v2 9-model set, fitted as a stage. v2 fits", + "it once, in a separate pipeline, and reads back a", + "prediction; use climate_source = \"precomputed\"." + ) + ) + }, + habitat = v2_status( + "reproduced", + paste( + "v2's hurdle: presence, abundance and total abundance", + "on the full habitat set, with the stand-age splines,", + "calibration and cutblock convergence. Matches v2's", + "published tables to 2e-14, north and south." + ) + ), + resampling = v2_status( + "partial", + paste( + "Spatial-block bootstrap. v2 fits the habitat stage", + "once, so only iteration 1, the full data, is like for", + "like." + ) + ), + season = v2_status( + "reproduced", + paste( + "One season per spec; run.R runs both, and the gate", + "averages them as v2's `.all` references do." + ) + ) + ), + + notes = paste0( + if (climate_source == "fitted") { + "Climate fitted with the full 9-model v2 set." + } else { + "Climate read from v2's precomputed predictions." + }, + " Season: ", season, ". Tier: ", tier, "." + ) + ) +} + +# End of script ---- diff --git a/1_code/modules/plants/.gitkeep b/1_code/modules/plants/.gitkeep deleted file mode 100644 index 8b13789..0000000 --- a/1_code/modules/plants/.gitkeep +++ /dev/null @@ -1 +0,0 @@ - diff --git a/1_code/modules/plants/run_v2_bryophytes.R b/1_code/modules/plants/run_v2_bryophytes.R deleted file mode 100644 index a9f7f40..0000000 --- a/1_code/modules/plants/run_v2_bryophytes.R +++ /dev/null @@ -1,203 +0,0 @@ -# --- -# title: Run v2 Bryophyte Modelling Pipeline -# author: Brendan Casey -# created: 2026-09-05 -# inputs: -# scripts, in 0_data/v2_scripts/plants/: -# - 02a_hierarchical-models-bryophytes.R -# - 03a_model-validation-bryophytes.R -# data and functions, in v2_root: -# - 0_data/species/processed/bryophyte-model-data.Rdata -# - 0_data/bootstrap/bryophyte-bootstrap-ids.Rdata -# - 0_data/lookup/prediction-matrix/ (veg and soil, 2024) -# - 1_code/r-scripts/hierarchical-model_functions.R -# - 1_code/r-scripts/model-validation_functions.R -# outputs: -# in v2_root: -# - 3_output/models/bryophyte-species-models.Rdata -# - 3_output/validation/bryophyte-models-validation.Rdata -# in this repository: -# - 2_pipeline/plants/logs/_