From 150d47a028a805bf61236e845d4b981a320ea672 Mon Sep 17 00:00:00 2001 From: bgcasey Date: Tue, 8 Sep 2026 08:44:42 -0600 Subject: [PATCH 01/33] Refactor scratch workspace by moving script to a new file for better organization --- 1_code/_scratch.R | 28 +++ 1_code/_setup/_scratch.R | 507 --------------------------------------- 2 files changed, 28 insertions(+), 507 deletions(-) create mode 100644 1_code/_scratch.R delete mode 100644 1_code/_setup/_scratch.R 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/_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 ---- From 0dd4dbea5fe6f4227e4e33176541599da3347871 Mon Sep 17 00:00:00 2001 From: bgcasey Date: Tue, 8 Sep 2026 08:45:05 -0600 Subject: [PATCH 02/33] Add validation script for harmonized test dataset to ensure data integrity and consistency --- 1_code/_setup/02_validate_test_dataset.R | 544 +++++++++++++++++++++++ 1 file changed, 544 insertions(+) create mode 100644 1_code/_setup/02_validate_test_dataset.R 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..414536a --- /dev/null +++ b/1_code/_setup/02_validate_test_dataset.R @@ -0,0 +1,544 @@ +# --- +# title: Validate the Harmonized Test Dataset +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# 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 +# from 0_data/data_snapshots/model_ready_v2/ on ABMI-DATA2: +# - the four plant-group .Rdata files +# - the two mammal SpTable .RData files +# outputs: +# - none; every result is printed to the console +# notes: +# Two passes over the harmonized dataset. Section 2 describes +# it: sizes, coverage, value ranges, and whether the two-file +# layout joins the way it is meant to. Section 3 traces every +# written value back to the snapshot it came from. +# +# Run after 01_harmonize_model_ready_v2.R, and again whenever +# the snapshot or that script changes. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) + +## 1.2 Configure paths ---- +# 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 = paste0( + "//ABMI-DATA2/science/sc/sdmMethodsDev/0_data/", + "data_snapshots/model_ready_v2" + ) +) + +taxa <- c( + "vascular_plant", + "bryophyte", + "lichen", + "mite", + "mammal" +) + +## 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 + +# 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.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)) + +# 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 ---- +# Plants are 0/1 presence-absence, with no NAs. +# Mammals are densities. A mammal NA is not a missing +# record either. 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. +# 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" +) + +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 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 ---- From dc9b7ecadcbe67b6d8af8fd9f16f80dbe2419bb8 Mon Sep 17 00:00:00 2001 From: bgcasey Date: Tue, 8 Sep 2026 08:46:18 -0600 Subject: [PATCH 03/33] Enhance documentation for read_plant_taxon function to clarify density handling and NA preservation --- 1_code/_setup/01_harmonize_model_ready_v2.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/1_code/_setup/01_harmonize_model_ready_v2.R b/1_code/_setup/01_harmonize_model_ready_v2.R index 0695052..65b9ed3 100644 --- a/1_code/_setup/01_harmonize_model_ready_v2.R +++ b/1_code/_setup/01_harmonize_model_ready_v2.R @@ -535,7 +535,12 @@ read_plant_taxon <- function(path, taxon) { #' Read One Mammal Snapshot File #' #' Reads the camera tibble `d` and harmonizes its species-season -#' column names. NAs in the species cells are preserved. +#' column names. The values are densities. +#' +#' 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 an NA records too little effort to estimate +#' from. #' #' @param path Character. Path to a mammal .RData file. #' @param region Character. "north" or "south". From db1f5832eb5ffaaf866aeb6ef4b325df39c727d4 Mon Sep 17 00:00:00 2001 From: bgcasey Date: Tue, 8 Sep 2026 13:14:28 -0600 Subject: [PATCH 04/33] Remove outdated v2 modelling scripts for mites and vascular plants; update README to reflect current project status, known gaps, and setup instructions. --- 0_data/v2_scripts/README.md | 53 + 0_data/v2_scripts/birds/.gitignore | 56 + 0_data/v2_scripts/birds/LICENSE | 21 + 0_data/v2_scripts/birds/README.md | 13 + .../v2_scripts/birds/src/00.ClimateModels.R | 9 + 0_data/v2_scripts/birds/src/00.Functions.R | 62 ++ 0_data/v2_scripts/birds/src/00.NorthModels.R | 35 + 0_data/v2_scripts/birds/src/00.SouthModels.R | 13 + .../v2_scripts/birds/src/01.GetWildTraxData.R | 145 +++ .../v2_scripts/birds/src/02.FilterEBirdData.R | 45 + 0_data/v2_scripts/birds/src/03.Harmonize.R | 560 ++++++++++ 0_data/v2_scripts/birds/src/04.WrangleData.R | 437 ++++++++ 0_data/v2_scripts/birds/src/05.StratifyData.R | 199 ++++ 0_data/v2_scripts/birds/src/06.ModelClimate.R | 229 ++++ .../v2_scripts/birds/src/07.ModelLandcover.R | 244 +++++ .../birds/src/08.PackageCoefficients.R | 771 ++++++++++++++ 0_data/v2_scripts/birds/src/09.Predict.R | 247 +++++ 0_data/v2_scripts/birds/src/10.Visualize.R | 236 +++++ 0_data/v2_scripts/birds/src/11.Compare.R | 109 ++ .../birds/temp_functions/wt_make_wide_fixed.R | 72 ++ .../temp_functions/wt_replace_tmtt_fixed.R | 73 ++ .../temp_functions/wt_tidy_species_fixed.R | 210 ++++ 1_code/_setup/01_harmonize_model_ready_v2.R | 825 ++++++++++++++- 1_code/_setup/02_validate_test_dataset.R | 529 +++++++++- .../exp_000_parity_v2/01_collect_results.R | 29 +- .../experiments/exp_000_parity_v2/README.md | 71 +- 1_code/experiments/exp_000_parity_v2/run.R | 248 +++-- .../exp_000_parity_v2/utils/species_lists.R | 43 +- 1_code/harness/utils/stage_v2_inputs.R | 197 ---- 1_code/harness/utils/step_runner.R | 109 ++ 1_code/harness/utils/v2_script_runner.R | 308 ------ 1_code/modules/plants/01_bootstrap_ids.R | 233 +++++ .../modules/plants/02_hierarchical_models.R | 525 ++++++++++ 1_code/modules/plants/03_model_validation.R | 285 +++++ .../functions/bootstrapping_functions.R | 130 +++ .../functions/hierarchical-model_functions.R | 981 ++++++++++++++++++ .../functions/model-validation_functions.R | 232 +++++ 1_code/modules/plants/load_model_data.R | 443 ++++++++ 1_code/modules/plants/run_v2_bryophytes.R | 203 ---- 1_code/modules/plants/run_v2_lichens.R | 201 ---- 1_code/modules/plants/run_v2_mites.R | 201 ---- .../modules/plants/run_v2_vascular_plants.R | 199 ---- README.md | 348 +++++-- 43 files changed, 8634 insertions(+), 1545 deletions(-) create mode 100644 0_data/v2_scripts/README.md create mode 100644 0_data/v2_scripts/birds/.gitignore create mode 100644 0_data/v2_scripts/birds/LICENSE create mode 100644 0_data/v2_scripts/birds/README.md create mode 100644 0_data/v2_scripts/birds/src/00.ClimateModels.R create mode 100644 0_data/v2_scripts/birds/src/00.Functions.R create mode 100644 0_data/v2_scripts/birds/src/00.NorthModels.R create mode 100644 0_data/v2_scripts/birds/src/00.SouthModels.R create mode 100644 0_data/v2_scripts/birds/src/01.GetWildTraxData.R create mode 100644 0_data/v2_scripts/birds/src/02.FilterEBirdData.R create mode 100644 0_data/v2_scripts/birds/src/03.Harmonize.R create mode 100644 0_data/v2_scripts/birds/src/04.WrangleData.R create mode 100644 0_data/v2_scripts/birds/src/05.StratifyData.R create mode 100644 0_data/v2_scripts/birds/src/06.ModelClimate.R create mode 100644 0_data/v2_scripts/birds/src/07.ModelLandcover.R create mode 100644 0_data/v2_scripts/birds/src/08.PackageCoefficients.R create mode 100644 0_data/v2_scripts/birds/src/09.Predict.R create mode 100644 0_data/v2_scripts/birds/src/10.Visualize.R create mode 100644 0_data/v2_scripts/birds/src/11.Compare.R create mode 100644 0_data/v2_scripts/birds/temp_functions/wt_make_wide_fixed.R create mode 100644 0_data/v2_scripts/birds/temp_functions/wt_replace_tmtt_fixed.R create mode 100644 0_data/v2_scripts/birds/temp_functions/wt_tidy_species_fixed.R delete mode 100644 1_code/harness/utils/stage_v2_inputs.R create mode 100644 1_code/harness/utils/step_runner.R delete mode 100644 1_code/harness/utils/v2_script_runner.R create mode 100644 1_code/modules/plants/01_bootstrap_ids.R create mode 100644 1_code/modules/plants/02_hierarchical_models.R create mode 100644 1_code/modules/plants/03_model_validation.R create mode 100644 1_code/modules/plants/functions/bootstrapping_functions.R create mode 100644 1_code/modules/plants/functions/hierarchical-model_functions.R create mode 100644 1_code/modules/plants/functions/model-validation_functions.R create mode 100644 1_code/modules/plants/load_model_data.R delete mode 100644 1_code/modules/plants/run_v2_bryophytes.R delete mode 100644 1_code/modules/plants/run_v2_lichens.R delete mode 100644 1_code/modules/plants/run_v2_mites.R delete mode 100644 1_code/modules/plants/run_v2_vascular_plants.R 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/.gitignore b/0_data/v2_scripts/birds/.gitignore new file mode 100644 index 0000000..30b1a52 --- /dev/null +++ b/0_data/v2_scripts/birds/.gitignore @@ -0,0 +1,56 @@ +# History files +.Rhistory +.Rapp.history + +# Session Data files +.RData + +# User-specific files +.Ruserdata + +# Example code in package build process +*-Ex.R + +# Output files from R CMD build +/*.tar.gz + +# Output files from R CMD check +/*.Rcheck/ + +# RStudio files +.Rproj.user/ +*.Rproj + +# produced vignettes +vignettes/*.html +vignettes/*.pdf + +# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 +.httr-oauth + +# knitr and R markdown default cache directories +*_cache/ +/cache/ + +# Temporary files created by R markdown +*.utf8.md +*.knit.md + +# R Environment Variables +.Renviron + +# wildRtrax login file +00.WTlogin.R + +# folders to ignore +data/* +figs/* + +# stupid OneDrive thing +OneDrive* + +# test output +out/* +.Rproj.user +.Rdata +.DS_Store \ No newline at end of file diff --git a/0_data/v2_scripts/birds/LICENSE b/0_data/v2_scripts/birds/LICENSE new file mode 100644 index 0000000..13394fa --- /dev/null +++ b/0_data/v2_scripts/birds/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Alberta Biodiversity Monitoring Institute + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/0_data/v2_scripts/birds/README.md b/0_data/v2_scripts/birds/README.md new file mode 100644 index 0000000..489c3ed --- /dev/null +++ b/0_data/v2_scripts/birds/README.md @@ -0,0 +1,13 @@ +# ABMI Bird Models + +## Overview + +The Alberta Biodiversity Monitoring Institute (ABMI) has developed a set of models for landbird species in Alberta. This repository contains code to source raw data, wrangle those data, fit models, evaluate the models, and package them for use. Future versions of this repository will also contain a bookdown document describing how data was collected, processed, and analysed. Readers can find the most up-to-date results on the [ABMI Biodiversity Browser](https://www.abmi.ca/home/data-analytics/biobrowser-home). + +## Acknowledgements + +Data used in the ABMI bird models comes from a variety of sources including academic partners, industry partners, and community scientists from the [North American Breeding Bird Survey](https://www.canada.ca/en/environment-climate-change/services/bird-surveys/landbird/north-american-breeding/overview.html) and [eBird](https://ebird.org/home) (eBird Basic Dataset. Version: EBD_relOct-2022. Cornell Lab of Ornithology, Ithaca, New York. Oct 2022). In particular, we would like to acknowledge the contributions of Dr. Erin Bayne, the [Bioacoustic Unit](https://abmi.ca/abmi-home/working-together/projects-collaborations/bioacoustic-unit#), and the [Boreal Avian Modelling Centre](https://borealbirds.ca/). We would also like to acknowledge that this work would not be possible without the dedication of the ABMI staff, both past and present. Without our field staff, geospatial experts, taxonomists, and ecologists, we would not be able to perform this work. + +## Contact + +For any questions regarding the contents of this repository or data access, please contact Brandon Allen at brandon.allen@ualberta.ca. diff --git a/0_data/v2_scripts/birds/src/00.ClimateModels.R b/0_data/v2_scripts/birds/src/00.ClimateModels.R new file mode 100644 index 0000000..9d5ea06 --- /dev/null +++ b/0_data/v2_scripts/birds/src/00.ClimateModels.R @@ -0,0 +1,9 @@ +modelsclimate <- list( + . ~ . + FFP, + . ~ . + MAP, + . ~ . + CMD, + . ~ . + TD, + . ~ . + TD + FFP, + . ~ . + MAP + CMD, + . ~ . + TD + FFP + CMD, + . ~ . + MAP + FFP + TD + CMD) diff --git a/0_data/v2_scripts/birds/src/00.Functions.R b/0_data/v2_scripts/birds/src/00.Functions.R new file mode 100644 index 0000000..73cb62d --- /dev/null +++ b/0_data/v2_scripts/birds/src/00.Functions.R @@ -0,0 +1,62 @@ +# +# Title: Data cleaning functions +# Created: June 13th, 2019 +# Last Updated: January 24th, 2022 +# Author: Brandon Allen +# Objectives: Functions required to summarize the landscape long-form data +# Keywords: Landscape summaries, Kgrid Initialization +# + +####################### +# Landscape summaries # +#######################~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +landscape_hf_summary <- function(data.in, landscape.lookup, class.in, class.out) { + + # Matching of lookup tables and merging native features + landscape.lookup <- landscape.lookup[landscape.lookup[, class.in] %in% colnames(data.in), ] + landscape.clean <- matrix(nrow = nrow(data.in), ncol = length(unique(landscape.lookup[, class.out]))) + + for (abmi.coef in 1:length(unique(landscape.lookup[, class.out]))) { + + coef.temp <- as.character(landscape.lookup[landscape.lookup[, class.out] %in% as.character(unique(landscape.lookup[, class.out]))[abmi.coef], class.in]) + + if(length(coef.temp) == 1) { + + landscape.clean[, abmi.coef] <- data.in[, coef.temp] + + } else { + + landscape.clean[, abmi.coef] <- rowSums(data.in[, coef.temp]) + + } + + } + + colnames(landscape.clean) <- as.character(unique(landscape.lookup[, class.out])) + rownames(landscape.clean) <- rownames(data.in) + + return(landscape.clean) + +} + +######################## +# Kgrid Initialization # +########################~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +create_kgrid <- function(kgrid.data) { + + load(kgrid.data) + names(kgrid)[which(names(kgrid)=="POINT_X")]<-"Long" + names(kgrid)[which(names(kgrid)=="POINT_Y")]<-"Lat" + return(data.frame(LinkID=rownames(kgrid), + Lat=kgrid$Lat, + Long=kgrid$Long, + NR=kgrid$NRNAME, + NSR=kgrid$NSRNAME, + LUF=kgrid$LUF_NAME, + Col=kgrid$Col, + Row=kgrid$Row)) + gc() + +} \ No newline at end of file diff --git a/0_data/v2_scripts/birds/src/00.NorthModels.R b/0_data/v2_scripts/birds/src/00.NorthModels.R new file mode 100644 index 0000000..24014c1 --- /dev/null +++ b/0_data/v2_scripts/birds/src/00.NorthModels.R @@ -0,0 +1,35 @@ +modelsnorth <- list( + "Hab"=list( + .~. + vegc), + "Age"=list( + .~. + wtAge, + .~. + wtAge + wtAge2, + ## here dec+mix are both intercepts + .~. + 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"=list( + .~. + fcc2), + "Contrast"=list( + .~. + road, + .~. + road + mWell, + .~. + road + mWell + mSoft, + .~. + road + mWell + mEnSft + mTrSft, + .~. + road + mWell + mEnSft + mTrSft + mSeism), + "ARU"=list( + .~. + method), + "Water"=list( + .~. + pWater_KM, + .~. + pWater_KM + pWater2_KM)) diff --git a/0_data/v2_scripts/birds/src/00.SouthModels.R b/0_data/v2_scripts/birds/src/00.SouthModels.R new file mode 100644 index 0000000..84f10ee --- /dev/null +++ b/0_data/v2_scripts/birds/src/00.SouthModels.R @@ -0,0 +1,13 @@ +modelssouth <- list( + "Hab"=list( + .~. + soilc, + .~. + soilc + paspen), + "Contrast"=list( + .~. + road, + .~. + road + mWell, + .~. + road + mWell + mSoft), + "ARU"=list( + .~. + method), + "Water"=list( + .~. + pWater_KM, + .~. + pWater_KM + pWater2_KM)) diff --git a/0_data/v2_scripts/birds/src/01.GetWildTraxData.R b/0_data/v2_scripts/birds/src/01.GetWildTraxData.R new file mode 100644 index 0000000..7442494 --- /dev/null +++ b/0_data/v2_scripts/birds/src/01.GetWildTraxData.R @@ -0,0 +1,145 @@ +# --- +# title: ABMI models - get WildTRax data +# author: Elly Knight +# created: November 29, 2022 +# modified: March 9, 2026 +# modified by: Richard Hedley +# --- + +#NOTES################################ + +#PURPOSE: This script downloads WildTrax data for modelling. This script should be run once per modelling version and the date-stamped raw object output from this script should be archived for reproducibility. + +#The "projectInstructions.csv" file is a list of all projects currently in WildTrax should not be used in ABMI models (instructions=="DO NOT USE"). This file should be updated for each iteration of in collaboration with Erin Bayne. Future versions of this spreadsheet can hopefully be derived by a combination of organization and a google form poll for consent from other organizations. + +#The "projectInstructions.csv" file also contains information on which ARU projects are processed for a single species or taxa (instructions=="DO NOT USE") and therefore those visits should only be used for models for the appropriate taxa. This file should be updated for each iteration of the national models in collaboration with Erin Bayne. These projects are currently not included in the models. + +#There are a handful of projects that are not downloading properly via wildRtrax. An issue is open on this. These projects are listed in the error.log object. These files should be downloaded manually. + +#FUTURE VERSION: Some components of this workflow may require revision to comply with the current version of wildRtrax and associated data cleaning functions. + +#PREAMBLE############################ + +#1. Load packages---- + +library(tidyverse) #basic data wrangling +library(wildrtrax) #to download data from wildtrax +library(data.table) #for binding lists into dataframes + +#2. Set root path for data on google drive---- + +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Login to WildTrax---- +config <- "src/00.WTlogin.R" +source(config) +rm(config) + +#4. Authenticate---- +wt_auth() + +#A. DOWNLOAD DATA FROM WILDTRAX####################### + +#1. Get list of projects from WildTrax---- +#sensor = PC gives all ARU and point count projects +projects <- rbind(wt_get_projects(sensor = 'PC'), wt_get_projects(sensor = 'ARU')) + +#2. Filter out projects that shouldn't be used---- +#nothing in BU training & all "DO NOT USE" projects in projectInventory file +#filter out 'NONE' method ARU projects later after this field is parsed out + +instructions <- read.csv(file.path(root, "Data", "projectInventory", "Projects_WildTrax_Use_CheckedByEMB_2026-02-15.csv")) %>% + dplyr::filter(Richard.To.Use=="Yes") + +projects.use <- projects %>% + dplyr::filter(project_id %in% instructions$project_id) + +rm(instructions) + +#3. Loop through projects to download data---- +aru.list <- list() +pc.list <- list() +error.log <- data.frame() +for(i in 1:nrow(projects.use)){ + + #authenticate each time because this loop takes forever + wt_auth() + + #Do each sensor type separately because the reports have different columns and we need different things for each sensor type + dat.try <- try(wt_download_report(project_id = projects.use$project_id[i], sensor_id = projects.use$project_sensor[i], reports = "main")) + + #If the function call returned a data frame, store the results, otherwise log the error. + if("data.frame" %in% class(dat.try)){ + if(projects.use$project_sensor[i]=="ARU"){ + + #If the sensor is an ARU, store in aru.list. + aru.list[[i]] <- as.data.frame(dat.try) + + } + if(projects.use$project_sensor[i]=="PC"){ + + #If the sensor is a PC, store in pc.list. + pc.list[[i]] <- as.data.frame(dat.try) + + } + } else { + + #Construct error log. + error.log <- rbind(error.log, + projects.use[i,]) + + } + + print(paste0("Finished dataset ", projects.use$project[i], " : ", i, " of ", nrow(projects.use), " projects")) + + rm(dat.try) +} + +#DEAL WITH ERRORED PROJECT############ + +#1. Go download error projects from wildtrax.ca---- +error.log %>% + inner_join(projects.use %>% + mutate(i = row_number())) %>% + View() + +#2. Read in error projects---- +error.files.aru <- list.files(file.path(root, "Data", "WildTrax", "errorFiles", "ARU"), full.names = TRUE, pattern = '*.csv') + +aru.error <- data.frame() +for(i in 1:length(error.files.aru)){ + aru.error <- read.csv(error.files.aru[i]) %>% + rbind(aru.error) +} + +error.files.pc <- list.files(file.path(root, "Data", "WildTrax", "errorFiles", "PC"), full.names = TRUE, pattern = '*.csv') + +pc.error <- data.frame() +for(i in 1:length(error.files.pc)){ + pc.error <- read.csv(error.files.pc[i]) %>% + rbind(pc.error) +} + +#Fix issue that arises due to combining character datetimes with +#posixct type in wt_download_report. +aru.error$recording_date_time <- as.POSIXct(aru.error$recording_date_time) +pc.error$recording_date_time <- as.POSIXct(pc.error$recording_date_time) + +#PUT TOGETHER############## + +#1. Collapse lists---- +#Take out ARU projects with "None" method +aru.wt <- rbindlist(aru.list[], fill=TRUE) %>% + rbind(aru.error, fill=TRUE) %>% + left_join(projects.use) %>% + dplyr::filter(task_method!="None") + +pc.wt <- rbindlist(pc.list[], fill=TRUE) %>% + rbind(pc.error, fill=TRUE) %>% + left_join(projects.use) + +#2. Save date stamped data & project list---- +save(aru.wt, pc.wt, projects.use, error.log, file=paste0(root, "/Data/WildTrax/wildtrax_raw_", Sys.Date(), ".Rdata")) + +#2. Save date stamped data & project list---- +save(aru.wt, pc.wt, projects.use, error.log, file=file.path(root, "Data", "WildTrax", "wildtrax_raw_2023-11-21.Rdata")) diff --git a/0_data/v2_scripts/birds/src/02.FilterEBirdData.R b/0_data/v2_scripts/birds/src/02.FilterEBirdData.R new file mode 100644 index 0000000..b4eb354 --- /dev/null +++ b/0_data/v2_scripts/birds/src/02.FilterEBirdData.R @@ -0,0 +1,45 @@ +# --- +# title: ABMI models - filter eBird data +# author: Elly Knight +# created: May 6, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This script wrangles raw eBird datasets for combination with wildtrax data. + +#raw eBird data is downloaded from the eBird interface at https://ebird.org/data/download/ebd prior to wrangling with the "auk" package and will require a request for access. Use the custom download tool to download only the datasets for Canada and the US instead of the global dataset. Note you will also need the global sampling file to use the auk package for zero filling. + +#raw eBird data omits Great Grey Owl & Northern Hawk Owl as sensitive species (https://support.ebird.org/en/support/solutions/articles/48000803210?b_id=1928&_gl=1*xq054u*_ga*ODczMTUyMjcuMTY2OTE0MDI4Ng..*_ga_QR4NVXZ8BM*MTY2OTE0MDI4NS4xLjEuMTY2OTE0MDM3OC4zNS4wLjA.&_ga=2.147122167.150058226.1669140286-87315227.1669140286) and should not be used for modelling these two species. + +#wrangling eBird data with the auk package requires installation of AWK on windows computers. Please see #https://cornelllabofornithology.github.io/auk/articles/auk.html. + +#eBird data has not been zerofilled because there was no species filtering done and we are assuming that all stationary counts have at least 1 bird observed. + +#PREAMBLE############################ + +#1. Load packages---- + +library(tidyverse) #basic data wrangling +library(auk) #eBird wrangling + +#2. Set root path for data on google drive---- + +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#FILTER DATA############### + +#1. Set ebd path---- +auk_set_ebd_path(file.path(root, "Data/ebd/ebd_CA-AB_smp_relJan-2026"), overwrite=TRUE) + +#2. Define filters---- +filters <- auk_ebd(file='ebd_CA-AB_smp_relJan-2026.txt') %>% + auk_protocol("Stationary") %>% + auk_duration(c(0, 10)) %>% + auk_complete() + +#3. Filter data---- +#select columns to keep +filtered <- auk_filter(filters, file=file.path(root, "Data/ebd/ebd_data_filtered.txt"), overwrite=TRUE, + keep = c("group identifier", "sampling_event_identifier", "scientific name", "common_name", "observation_count", "latitude", "longitude", "locality_type", "observation_date", "time_observations_started", "observer_id", "duration_minutes")) + diff --git a/0_data/v2_scripts/birds/src/03.Harmonize.R b/0_data/v2_scripts/birds/src/03.Harmonize.R new file mode 100644 index 0000000..0fcafa9 --- /dev/null +++ b/0_data/v2_scripts/birds/src/03.Harmonize.R @@ -0,0 +1,560 @@ +# --- +# title: ABMI models - harmonize data +# author: Elly Knight +# created: May 6, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This script harmonizes data from wildtrax and ebird and formats for subsequent modelling steps. + +#Riverforks data is stored in the ABMI Oracle database and should be downloaded using dBeaver. Use the UNRESTRICTED_ACCESS acount to ensure full retrieval of species at risk records. Contact Joan (qfang@ualberta.ca) for access information. + +#The location csv output of this script should be sent to Eric and/or Brandon for GIS covariate extraction. The output Eric provides will be used as input in the next script. + +#FUTURE VERSIONS: Riverforks data will be available in wildtrax and will not require extraction from the ABMI Oracle database. + +#PREAMBLE############################ + +#1. Load packages---- + +library(tidyverse) #basic data wrangling +library(wildrtrax) #to download data from wildtrax +library(auk) #to handle eBird data +library(data.table) #for binding lists into dataframes +library(lubridate) #date wrangling +library(downloader) #download zipped provincial boundary shp +library(sf) #shapefile wrangling +library(terra) #raster wrangling +library(hms) + +#Source temp fixes for wildrtrax. +source('temp_functions/wt_replace_tmtt_fixed.R') +source('temp_functions/wt_tidy_species_fixed.R') +source('temp_functions/wt_make_wide_fixed.R') + +#2. Set root path for data on google drive---- + +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Login to WildTrax---- +config <- "src/00.WTlogin.R" +source(config) + +#4. Authenticate---- +wt_auth() + +#5. Pointer to most recent RData file: +most_recent_file <- file.path(root, "Data", "WildTrax", "wildtrax_raw_2026-03-10.Rdata") + +#HARMONIZE############################### + +#1. Get list of bird species---- +birdcodes <- wt_get_species() |> + rename(common = species_common_name) |> + dplyr::select(common, species_code) |> + mutate(common = case_when(common == "Bald eagle" ~ "Bald Eagle", + common == "Northern Pygmy-owl" ~ "Northern Pygmy-Owl", + common == "Black-crowned Night Heron" ~ "Black-crowned Night-Heron", + !is.na(common) ~ common)) + +################################################### +# Manual step. Update the list of birds observed in the projects. +# Specifically, there are often species splits, creating duplicates of +# the same species with multiple codes. Then replace the birds-vYYYY.csv file. +# I went through and manually vetted the list, and added a preferred_synonym +# column for species with name changes. I also removed all species +# in birds-v2024 that had show=='o'. Those could be revisited in future and +# added back in if their situation changes. +################################################### +spp <- read.csv(file.path(root, "Data", "lookups", "birds-v2026.csv")) +spp <- spp[order(spp$common),] +spp <- left_join(spp, birdcodes) + +#Subset species with aliases due to name changes. +aliases <- spp[nchar(spp$preferred_synonym) == 4, ] + +#Filter spp to remove species with aliases. +spp <- spp[nchar(spp$preferred_synonym) != 4, ] + +rm(birdcodes) #birdcodes not used hereafter. In fact, now not needed at all. + +#2. Set desired columns---- +colnms <- c("source", "organization", "project_id", "sensor", "task_method", "location", "buffer", "latitude", "longitude", "date_time", "duration", "distance") + +#3. Load WildTrax data and fix a few species codes----- +load(most_recent_file) + +#Where a species_code exists in the data, replace with preferred_synonym. +for(i in 1:nrow(aliases)) { + aru.wt$species_code[aru.wt$species_code == aliases$species_code[i]] <- aliases$preferred_synonym[i] + pc.wt$species_code[pc.wt$species_code == aliases$species_code[i]] <- aliases$preferred_synonym[i] +} + +#Set options for lubridate, to enable checking of date parsing. +options(lubridate.verbose = TRUE) + +#4. Wrangle WT ARU data---- +#fix a few names to match the GIS +#remove detections > 180s for hybrid method and fix duration +use.aru <- aru.wt |> + dplyr::filter(!(task_method=="1SPM Audio/Visual hybrid" & as.numeric(detection_time) > 180)) |> + wt_tidy_species_fixed_aru(remove=c("mammal", "amphibian", "abiotic", "insect", "human", "unknown")) |> + mutate(abundance = ifelse(species_code == 'NONE', 0, abundance)) |> + mutate(abundance = ifelse(abundance == 'CI 1', 1, abundance)) |> + mutate(abundance = ifelse(abundance == 'CI 2', 1, abundance)) |> + mutate(abundance = ifelse(abundance == 'CI 3', 1, abundance)) |> + mutate(abundance = ifelse(abundance == 'N/A', 1, abundance)) |> + wt_replace_tmtt_fixed() |> + wt_make_wide_fixed() |> + mutate(source="WildTrax", + sensor="ARU", + distance=Inf, + date_time = ymd_hms(recording_date_time, tz="America/Edmonton", truncated=3), + #duration = round(as.numeric(str_sub(task_duration, -100, -2))), + duration = (round(task_duration / 60) * 60), + task_method = ifelse(is.na(task_method), 'Unknown', task_method), + duration = ifelse(task_method=="1SPM Audio/Visual hybrid", 180, duration), + location_buffer_m = ifelse(is.na(location_buffer_m), 0, location_buffer_m)) |> + mutate(tod = as_hms(date_time)) |> + rename(buffer = location_buffer_m) |> + filter(duration > 0, !(duration %in% c(240, 360, 420, 480))) #Remove a few weird durations. + +#Richard: further rounding to the nearest minute, to remove some weird task_durations. +table(use.aru$task_duration) +table(use.aru$duration, useNA = 'always') + + +#5. Wrangle WT PC data---- +#remove counts with unknown duration and distance +use.pc <- pc.wt |> + dplyr::filter(survey_duration_method!="UNKNOWN", + survey_distance_method!="UNKNOWN") |> + wt_tidy_species_fixed_pc(remove=c("mammal", "amphibian", "abiotic", "insect", "human", "unknown")) |> + wt_make_wide_fixed() |> + mutate(source="WildTrax", + sensor="PC", + task_method="PC", + date_time = ymd_hms(survey_date, tz="America/Edmonton", truncated=3)) |> + rowwise() |> + mutate(durationMethod = ifelse(str_sub(survey_duration_method, -1, -1)=="+", + str_sub(survey_duration_method, -100, -2), + survey_duration_method), + chardur = str_locate_all(durationMethod, "-"), + chardurmax = max(chardur), + duration = as.numeric(str_sub(durationMethod, chardurmax+1, -4))*60, + chardis = str_locate_all(survey_distance_method, "-"), + chardismax = max(chardis), + distance1 = str_sub(survey_distance_method, chardismax+1, -2), + distance = ifelse(distance1 %in% c("AR", "IN"), Inf, as.numeric(distance1))) |> + ungroup() |> + rename(buffer = location_buffer_m) + +table(use.pc$survey_duration_method, useNA = 'always') +table(use.pc$duration, useNA = 'always') + +#6. Wrangle Riverforks data---- + +#6a. Read it in----- +det.rf <- read.csv(file.path(root, "Data", "Riverforks", "RT_BIRD_COUNT_BL.csv"), header=TRUE) +loc.rf <- read.csv(file.path(root, "Data", "Riverforks", "A_RT_SITE_PHYCHAR_202301161554.csv"), header=TRUE) + +#6b. Put together---- +#concatenate site name with point count # (there are 9 per site) before joining +raw.rf <- det.rf |> + mutate(SITE = paste0(SITE, "-", TBB_POINT_COUNT), + YEAR = as.integer(YEAR)) |> + left_join(loc.rf |> + mutate(SITE = paste0(SITE, "-", TSFG_POINT_COUNT)) |> + dplyr::select(ROTATION, SITE, YEAR, SITE_LATITUDE, SITE_LONGITUDE) |> + unique()) + +#6c. Wrangle---- +#remove visits with no time data +#fix some names to match the gis +#fix some dates to match the gis +use.rf <- raw.rf |> + rename(location=SITE, latitude = SITE_LATITUDE, longitude = SITE_LONGITUDE, observer = ANALYST, common = COMMON_NAME) |> + mutate(source = "riverforks", + organization="ABMI", + project_id=9998, + sensor="ARU", + task_method = "1SPM", + buffer = 5500, + duration = 3*60, + distance = Inf, + abundance = 1, + date_time = dmy_hm(paste0(ADATE, " ", TBB_START_TIME), tz="America/Edmonton")) |> + dplyr::filter(!is.na(date_time)) |> + mutate(date_time = case_when(str_sub(location, 1, 4)=="1525" ~ dmy_hm(paste0(str_sub(ADATE, -100, -3), "07", " ", TBB_START_TIME)), + !is.na(date_time) ~ date_time)) |> + left_join(spp |> + dplyr::select(species_code, common)) |> + dplyr::select(all_of(colnms), species_code, abundance) |> + pivot_wider(names_from=species_code, values_from=abundance, values_fn=sum, values_fill=0) + +#7. Wrangle ebird data---- +#Note this assumes observations with "X" individuals are 1s +#Filter out hotspots +#Replace common name with alpha code + +#7a. Read it in---- +raw.ebd <- read_ebd(file.path(root, "Data", "ebd", "ebd_data_filtered.txt")) + +#7b. Wrangle---- +use.ebd <- raw.ebd |> + dplyr::filter(locality_type!="H") |> + mutate(source = "eBird", + organization = "eBird", + project_id=99999, + sensor="PC", + task_method="PC", + buffer=0, + date_time = ymd_hms(paste0(observation_date, time_observations_started), tz="America/Edmonton"), + distance = Inf, + abundance = as.numeric(ifelse(observation_count=="X", 1, observation_count)), + duration = duration_minutes*60) |> + rename(observer = observer_id, + location = checklist_id, + common = common_name) |> + left_join(spp |> + dplyr::select(species_code, common)) |> + dplyr::select(all_of(colnms), species_code, abundance) |> + pivot_wider(names_from=species_code, values_from=abundance, values_fn=sum, values_fill=0) + +#PUT TOGETHER############################ + +#1. Put everything together---- +use <- data.table::rbindlist(list(use.aru, use.pc, use.rf, use.ebd), fill=TRUE) |> + dplyr::select(all_of(c(colnms, spp$species_code))) |> + dplyr::filter(!is.na(latitude)) |> + mutate(across(c(ALFL:YRWA), \(x) replace_na(0))) + +#2. Clip by provincial boundaries & filter to AB---- + +#Download provincial boundaries shapefile - only need to do this one +# temp <- tempfile() +# download("https://www12.statcan.gc.ca/census-recensement/2021/geo/sip-pis/boundary-limites/files-fichiers/lpr_000b21a_e.zip", temp) +# unzip(zipfile=temp, exdir=file.path(root, "Data", "gis")) +# unlink(temp) + +#2a. Get boundaries---- +shp <- read_sf(file.path(root, "Data", "gis", "lpr_000b21a_e.shp")) |> + dplyr::filter(PRNAME=="Alberta") + +#2b. Filter points in Alberta---- +use.ab <- use |> + dplyr::filter(!is.na(longitude)) |> + st_as_sf(coords=c("longitude", "latitude"), crs=4326, remove = FALSE) |> + st_transform(crs=st_crs(shp)) |> + st_filter(st_geometry(shp)) |> + st_drop_geometry() |> + dplyr::select(colnames(use)) |> + rbind(use |> + dplyr::filter(is.na(longitude))) + +#3. Remove duplicate surveys---- + +#Flag column for surveys to remove. +use.ab$remove_dup <- FALSE +#Round lat and lon to 4 digits (11 meters at the equator, about 6 meters wide in AB). +use.ab$latr <- round(use.ab$latitude,4) +use.ab$lonr <- round(use.ab$longitude,4) +#Column for unique lat/lon/date/time. +use.ab$point_in_time <- paste(use.ab$latr, use.ab$lonr, use.ab$date_time, sep = '_') +#Flag column for secret locations. +use.ab$secret <- FALSE + +#Identify projects with at least one buffer > 0, and use that to flag secret locations. +buffered_projects <- aggregate(buffer ~ project_id, data = use.ab, FUN = max) +buffered_projects <- buffered_projects[buffered_projects$buffer > 0,] + +#use buffered projects to set secret == TRUE +use.ab$secret[use.ab$project_id %in% buffered_projects$project_id] <- TRUE + +#Identify duplicates surveys (same location and date/time). +duplicates <- table(use.ab$point_in_time) +duplicates <- duplicates[duplicates > 1] + +set.seed(1234) +for(i in 1:length(duplicates)) { + sub <- use.ab[use.ab$point_in_time == names(duplicates)[i],] + + # #If different surveys have different location names, flag all as secret locations. + # if(length(unique(sub$location)) == nrow(sub)) { + # sub$secret <- TRUE + # } + + #If two rows, one with ARU and PC, select ARU. + if(nrow(sub) == 2 & sum(sub$sensor == 'ARU') == 1 & + sum(sub$sensor == 'PC') == 1) { + sub$remove_dup[sub$sensor == 'PC'] <- TRUE + } + + #If the duplicates are from multiple sources, remove eBird. + if(length(unique(sub$source)) > 1 & 'eBird' %in% sub$source) { + sub$remove_dup[sub$source == 'eBird'] <- TRUE + } + + #If the duplicates have the same location name, select randomly among the + #longest surveys. + if(length(unique(sub$location)) == 1) { + longest <- which(sub$duration == max(sub$duration)) + selected <- sample(longest, 1) + sub$remove_dup <- TRUE + sub$remove_dup[selected] <- FALSE + } + + #If the above procedure has not accounted for any duplicates, a message will be printed. + if(sum(!sub$remove_dup) != 1 & !all(sub$secret)) { + #if(sum(sub$remove_dup) == 0) { + message(i,' Projects: ', paste(unique(sub$project_id), collapse = ' '), ' nrow: ', nrow(sub), + ' locations: ', paste(unique(sub$location), collapse = ' ')) + } + + # #Otherwise select longest survey. + # sub <- sub[which.max(sub$duration),] + # + # if(nrow()) + +} + +use.dup <- use.ab |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + group_by(date_time, latr, lonr) |> #Looking for same date_time, latr, lonr. + summarize(n = n()) |> + ungroup() + +#3a. Investigate---- +#Take out buffered locations +use.dup <- use.ab |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + group_by(date_time, latr, lonr) |> #Looking for same date_time, latr, lonr. + summarize(n = n()) |> + ungroup() |> + dplyr::filter(n > 1) |> + left_join(use.ab |> + dplyr::select(all_of(colnms)) |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)), + multiple="all") +#no eBird duplicates +#some point count data entry errors, but really only 2 sources of duplicates: +#1. JOSM points that have human & ARU data & eBird data +#2. Duplicate processing of recordings + +#3b. Identify JOSM points with human & ARU data---- +#Keep the ARU ones because frankly they're probably better data +use.josm <- use.dup |> + left_join(projects.use) |> + dplyr::filter(project %in% c("JOSM ECCC Cause and Effect Monitoring for Landbirds 2013", + "Oil Sands Monitoring CWS Prairie Region 2012", + "Oil Sands Monitoring CWS Prairie Region 2013", + "Oilsands Monitoring CWS Prairie Region 2014")) + +use.josm.remove <- use.josm |> + dplyr::filter(sensor=="PC") + +#3c. Identify recordings that have been processed twice---- +#Use recording with longer duration processing, random if processing is equal +use.duprec <- use.dup |> + dplyr::filter(sensor=="ARU") |> + left_join(use.ab |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + dplyr::select(all_of(colnms)), + multiple="all") |> + group_by(date_time, latitude, longitude, location) |> + summarize(n=n(), + maxdur = max(duration), + mindur = min(duration)) |> + left_join(use.ab, + multiple="all") + +use.mindur.remove <- use.duprec |> + dplyr::filter(mindur!=maxdur, + duration==mindur) + +set.seed(1234) +use.eqdur.remove <- use.duprec |> + dplyr::filter(mindur==maxdur) |> + group_by(date_time, latitude, longitude, location) |> + sample_n(1) |> + ungroup() |> + left_join(use.ab, + multiple="all") + +#3d. Look at remaining duplicates---- +use.dup2 <- use.ab |> + dplyr::filter(!is.na(longitude)) |> + anti_join(use.josm.remove) |> + anti_join(use.mindur.remove) |> + anti_join(use.eqdur.remove) |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + group_by(date_time, latr, lonr) |> + summarize(n = n()) |> + ungroup() |> + dplyr::filter(n > 1) |> + left_join(use.ab |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)), + multiple="all") + +#3e. Take out the ebird duplicates---- +use.ebird.remove <- use.dup2 |> + dplyr::filter(source=="eBird") + +#3f. Look at duplicates again---- +use.dup3 <- use.ab |> + dplyr::filter(!is.na(longitude)) |> + anti_join(use.josm.remove) |> + anti_join(use.mindur.remove) |> + anti_join(use.eqdur.remove) |> + anti_join(use.ebird.remove) |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + group_by(date_time, latr, lonr) |> + summarize(n = n()) |> + ungroup() |> + dplyr::filter(n > 1) |> + left_join(use.ab |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)), + multiple="all") |> + arrange(latr, lonr, date_time) |> + left_join(projects.use) + +set.seed(1234) +use.dup3.keep <- use.dup3 |> + group_by(latr, lonr, date_time, n) |> + sample_n(1) |> + ungroup() + +use.dup3.remove <- use.dup3 |> + anti_join(use.dup3.keep) + +#3g. Check again---- +use.dup4 <- use.ab |> + dplyr::filter(!is.na(longitude)) |> + anti_join(use.josm.remove) |> + anti_join(use.mindur.remove) |> + anti_join(use.eqdur.remove) |> + anti_join(use.ebird.remove) |> + anti_join(use.dup3.remove) |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)) |> + group_by(date_time, latr, lonr) |> + summarize(n = n()) |> + ungroup() |> + dplyr::filter(n > 1) |> + left_join(use.ab |> + dplyr::select(all_of(colnms)) |> + mutate(latr = round(latitude, 4), + lonr = round(longitude, 4)), + multiple="all") + +#3h. Filter out duplicates from dataset---- +#remove surveys before 1993 (first year with substantial data) +#remove ABMI surveys that can't resolve with GIS data +#create unique ID +#Fix location naming errors + +fix <- read.csv(file.path(root, "Data", "gis", "birds_mismatches_lookup.csv")) |> + dplyr::filter(locationfix!="") + +use <- use.ab |> + anti_join(use.josm.remove) |> + anti_join(use.mindur.remove) |> + anti_join(use.eqdur.remove) |> + anti_join(use.ebird.remove) |> + anti_join(use.dup3.remove) |> + mutate(year = year(date_time)) |> + dplyr::filter(year >= 1993) |> + dplyr::filter(!(location=="701-1" & year==2004)) |> + mutate(gisid = paste0(location, "_", project_id, "_", year)) |> + left_join(fix) |> + mutate(location = ifelse(!is.na(locationfix), locationfix, location)) + +#IDENTIFY LOCATIONS FOR COVARIATE EXTRACTION#### + +#1. Identify projects with buffered locations---- +#Any project with buffer of 55000 +secret1 <- use |> + dplyr::filter(organization=="ABMI", buffer==5500) |> + select(organization, project_id) |> + unique() |> + left_join(projects.use |> + dplyr::select(project, project_id)) + +#projects that have the same lat lon for more than one location +secret2 <- use |> + dplyr::filter(organization=="ABMI") |> + dplyr::select(organization, project_id, location, latitude, longitude) |> + unique() |> + group_by(organization, project_id, latitude, longitude) |> + summarize(n=n()) |> + ungroup() |> + dplyr::filter(n > 1) |> + anti_join(secret1) |> + dplyr::select(organization, project_id) |> + unique() |> + left_join(projects.use |> + dplyr::select(project, project_id)) + +secret <- rbind(secret1, secret2) |> + mutate(topsecret = 1, + project = ifelse(is.na(project), "ABMI-Riverforks", project)) + +#2. Filter to just unique combinations of year & location---- +location <- use |> + dplyr::select(gisid, source, organization, sensor, project_id, buffer, location, latitude, longitude, year) |> + left_join(projects.use |> + dplyr::select(project, project_id)) |> + mutate(project = case_when(project_id==9998 ~ "ABMI-Riverforks", + project_id==99999 ~ "eBird", + !is.na(project) ~ project)) |> + unique() |> + left_join(secret) |> + mutate(topsecret = ifelse(is.na(topsecret), 0, topsecret)) + +#3. Check against GIS inventory---- +gis <- read.csv(file.path(root, "Data", "gis", "OffGridCamARU_Analysis_camaru_20231208.csv")) + +missing <- read.csv(file.path(root, "Data", "gis", "birds_mismatches_lookup.csv")) |> + dplyr::filter(locationfix=="") + +gis.location <- location |> + dplyr::filter(topsecret==1) |> + left_join(gis |> + rename(location = Site_ID, + year = survey_year) |> + mutate(gis=1, + location = case_when(str_sub(location, 1, 5)=="OG-EI" ~ Site, + !is.na(location) ~ location)), + multiple="all") |> + mutate(gis = ifelse(is.na(gis), 0, 1)) + +gis.na <- dplyr::filter(gis.location, gis==0) |> + arrange(project, location) |> + dplyr::select(project, location, year) |> + left_join(missing) + +write.csv(gis.na, (file.path(root, "Data", "gis", "birds_gis_missing.csv")), row.names = FALSE) + +#4. Take out the mismatches for now---- +location <- location |> + anti_join(gis.na |> + dplyr::select(project, location, year)) + +use <- use |> + anti_join(gis.na |> + dplyr::select(project, location, year)) + +#5. Save---- +write.csv(location, file.path(root, "Data", "gis", "birds_ab_locations.csv"), row.names = FALSE) + +#SAVE!############################# +save(location, use, file=file.path(root, "Data", "Harmonized.Rdata")) \ No newline at end of file diff --git a/0_data/v2_scripts/birds/src/04.WrangleData.R b/0_data/v2_scripts/birds/src/04.WrangleData.R new file mode 100644 index 0000000..a3272c1 --- /dev/null +++ b/0_data/v2_scripts/birds/src/04.WrangleData.R @@ -0,0 +1,437 @@ +# --- +# title: ABMI models - wrangle data +# author: Elly Knight +# created: May 10, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This script wrangles the gis extraction output into the covariates used in the modelling workflow and calculates qpad offsets. + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling +library(mefa4) #Solymos data wrangling +library(lubridate) #date wrangling +library(wildrtrax) #offset calculation +library(sf) #coordinate reprojection +library(QPAD) #for offsets + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Load harmonized set---- +load(file.path(root, "Data", "Harmonized.Rdata")) + +#5. Load gis data extractions---- + +#climate data +load(file.path(root, "Data", "gis", "bird-point-climate_2024.Rdata")) + +#point data - load this one before the next one so you get the correct version of d.wide.150 and d.wide.564 +load(file.path(root, "Data", "gis", "birds-point-sites_1993-2023.Rdata")) + +#buffer data +load(file.path(root, "Data", "gis", "birds-point-sites-simplified_1993-2023.Rdata")) + +#tidy up things we don't need +rm(d.long.150, d.long.564) + +#6. Load missing uid lookup table---- +missingid <- read.csv(file.path(root, "Data", "lookups", "MissingID_lookup.csv")) |> + dplyr::select(UID, gisid) + +#7. Fix the ids---- +climate.id <- climate.data |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) + +d.long.pts.id <- d.long.pts |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) + +backfill.id <- data.frame(d.wide.150$veg.current) |> + rownames_to_column(var = "UID") |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) + +#REMOVE SURVEYS WITH MISSING DATA######### + +#1. Get unique IDs that are present in all datasets---- +ids <- location |> + dplyr::select(gisid) |> + dplyr::filter(gisid %in% climate.id$gisid, + gisid %in% d.long.pts.id$gisid, + gisid %in% backfill.id$gisid) + +#2. Filter survey object---- +#standardize time zone +#remove surveys with "NONE" transcription method +#remove missing lat/lons +#remove missing climate variables +#remove missing date/time +#remove missing duration or distance method +#remove data out of year range +#remove data out of assumptions for QPAD range +#remove surveys without covariate extraction + +complete <- use |> + dplyr::select(-locationfix, -missingcomments) |> #TAKE THIS OUT ONCE NAMES FIXED + dplyr::filter(gisid %in% ids$gisid, + task_method!="None", + !is.na(latitude), + !is.na(longitude), + !is.na(date_time), + !is.na(duration), + !is.na(distance), + year(date_time) >= 1993, + year(date_time) <= 2024, + yday(date_time) >= 125, + yday(date_time) <= 200, + hour(date_time) >= 3, + hour(date_time) <= 12) |> + arrange(gisid, date_time) |> + mutate(surveyid = row_number()) + +#CALCULATE OFFSETS#### + +#1. Load QPAD estimates---- +load_BAM_QPAD(3) + +#2. Make species list---- +#Remove species without enough data +spmin <- 20 + +spp.use <- complete |> + dplyr::select(ALFL:YRWA) |> + mutate_all(~ifelse(.>0, 1, 0)) |> + pivot_longer(ALFL:YRWA, names_to="species", values_to="detection") |> + dplyr::filter(detection > 0) |> + group_by(species) |> + summarize(detections = n()) |> + ungroup() |> + dplyr::filter(detections >= spmin) + +bird <- complete |> + dplyr::select(gisid, all_of(spp.use$species)) + +#Add GRAJ manually +spp <- sort(c(intersect(getBAMspecieslist(), colnames(bird)), "GRAJ")) + +#3. WildTRax login---- +source("00.WTlogin.R") +wt_auth() + +#4. Wrangle data---- +complete.x <- complete |> + dplyr::select(surveyid, organization, project_id, location, longitude, latitude, date_time, duration, distance, task_method) |> + rename(recording_date_time = date_time, + task_duration = duration, + task_distance = distance) + +#5. Make offsets---- +off <- wt_qpad_offsets(complete.x, species=spp, version=3, together=FALSE) + +#6. Put together---- +offset.calc <- data.frame(surveyid = complete.x$surveyid) |> + cbind(data.frame(off)) |> + arrange(surveyid) |> + rename(CAJA = GRAJ) + +#7. Get remaining species---- +spp.mean <- colnames(bird |> dplyr::select(-gisid)) |> + setdiff(c(spp, "CAJA")) + +#8. Calculate mean offset for them---- +offset.mean <- rowMeans(offset.calc[,-1]) +offset.df <- data.frame(replicate(offset.mean, n=length(spp.mean))) +colnames(offset.df) <- spp.mean + +#9. Put together---- +offset.spp <- cbind(offset.calc |> + dplyr::select(-surveyid), + offset.df) +offsets <- cbind(offset.calc |> + dplyr::select(surveyid), + offset.spp[, order(colnames(offset.spp))]) + +# DERIVE PREDICTORS#### + +#1. Get lookup tables---- +#These tables dictate how the different landcover types from the gis extraction should be handled in the script. They should be reviewed and updated each time the model is run. + +#Veg +tv <- read.csv(file.path(root, "Data", "lookups", "lookup-veg-hf-age-birds-v2024.csv")) +row.names(tv) <- tv$ID + +#Soil +ts <- read.csv(file.path(root, "Data", "lookups", "lookup-soil-hf-birds-v2024.csv")) +row.names(ts) <- ts$ID + +#2. Initial wrangling---- +#We manipulate a couple variables and add some column values from the point-level gis extraction and climate extraction +covs1 <- complete |> + dplyr::select(surveyid, gisid, source:distance) |> + mutate(year = year(date_time) - min(year(date_time))+1) |> + left_join(d.long.pts.id |> + dplyr::select(gisid, NRNAME, NSRNAME), + multiple = "all") |> + left_join(climate.id |> + dplyr::select(gisid, paspen, MAP, TD, CMD, FFP, EMT)) |> + unique() + +#3. Scale and format GIS data---- +#We divide by the area of each buffer size to scale from 0 to 1 +#We join to survey data frame to link covariates (extracted at the year * location level) to surveys, which can be multiple in one year +vc1 <- data.frame(d.wide.150$veg.current) |> + mutate_all(~./70680) |> + rownames_to_column(var = "UID") |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) |> + inner_join(covs1 |> dplyr::select(gisid, surveyid), multiple="all") |> + remove_rownames() |> + column_to_rownames(var = "surveyid") |> + dplyr::select(-gisid, -UID) + +vc2 <- data.frame(d.wide.564$veg.current) |> + mutate_all(~./999291) |> + rownames_to_column(var = "UID") |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) |> + inner_join(covs1 |> dplyr::select(gisid, surveyid), multiple="all") |> + remove_rownames() |> + column_to_rownames(var = "surveyid") |> + dplyr::select(-gisid, -UID) + +sc1 <- data.frame(d.wide.150$soil.current) |> + mutate_all(~./70680) |> + rownames_to_column(var = "UID") |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) |> + inner_join(covs1 |> dplyr::select(gisid, surveyid), multiple="all") |> + remove_rownames() |> + column_to_rownames(var = "surveyid") |> + dplyr::select(-gisid, -UID) + +sr1 <- data.frame(d.wide.150$soil.reference) |> + mutate_all(~./70680) |> + rownames_to_column(var = "UID") |> + left_join(missingid, + multiple= "all") |> + mutate(gisid = ifelse(is.na(gisid), UID, gisid)) |> + inner_join(covs1 |> dplyr::select(gisid, surveyid), multiple="all") |> + remove_rownames() |> + column_to_rownames(var = "surveyid") |> + dplyr::select(-gisid, -UID) + +#4. Calculate water proportions---- +covs1$pWater <- rowSums(vc1[,tv[colnames(vc1), "is_water"]]) +covs1$pWater_KM <- rowSums(vc2[,tv[colnames(vc2), "is_water"]]) +covs1$pWater2_KM <- covs1$pWater_KM^2 + +#5. Dominant landcover type, weight, & indicator variable---- +#This section identifies the landcover type that comprises the largest proportion of the 150 m radius buffer and the proportion of that cover type, and then calculates a weighting factor for use in the glm + +#We calculate proportion without some classes because: +# - it is not a stratum we are interested in (water, snow/ice is 0 density), +# - its is too small of a feature to make up a full 7-ha buffer. +#We therefore lose a few surveys here that are entirely water or bare or mostly linear feature + +covs2 <- vc1 |> + rownames_to_column("surveyid") |> + pivot_longer(DeciduousR:CCPine4, names_to="vegage", values_to="proportion") |> + left_join(tv |> + rename(vegage=ID, vegc = UseInAnalysisNoAge) |> + dplyr::select(vegage, vegc)) |> + dplyr::filter(!vegage %in% c("Water","HWater", "SnowIce", "Bare", "EnSeismic", "HardLin", "TrSoftLin", "EnSoftLin", "Well"), + proportion > 0) |> + group_by(surveyid, vegc) |> + summarize(vegv = sum(proportion)) |> + group_by(surveyid) |> + dplyr::filter(vegv==max(vegv)) |> + ungroup() |> + mutate(vegw = pmax(0, pmin(1, 2*vegv-0.5)), + surveyid = as.numeric(surveyid), + isMix = ifelse(vegc=="Mixedwood", 1L, 0L), + isWSpruce = ifelse(vegc=="Spruce", 1L, 0L), + isPine = ifelse(vegc=="Pine", 1L, 0L), + isBogFen = ifelse(vegc %in% c("TreedBog", "TreedFen"), 1L, 0L), + isUpCon = ifelse(vegc %in% c("Spruce", "Pine"), 1L, 0L), + isCon = ifelse(vegc %in% c("TreedBog", "TreedFen", "Spruce", "Pine"), 1L, 0L)) |> + left_join(covs1) + +#6. Weighted Age---- +#This section identifies the proportion of each polygon of the 150m radius of each age class and then calculates a weighted age factor by multipling those proportions by a weighting factor, summing them, and dividing by the total proportion. +#We do this only forested landcover types + +# weighting values: exclude unknown (0) and non-forest (blank) +AgeMin <- data.frame(wt = c(0,10,20,40,60,80,100,120,140,160)/200, + age = c("R", "1", "2", "3", "4", "5", "6", "7", "8", "9")) + +covs3 <- vc1 |> + rownames_to_column("surveyid") |> + pivot_longer(DeciduousR:CCPine4, names_to="vegage", values_to="proportion") |> + left_join(tv |> + rename(vegage=ID, vegc = UseInAnalysisNoAge, age=AGE) |> + dplyr::select(vegage, vegc, age)) |> + dplyr::filter(vegc %in% c("Spruce","Decid","Mixedwood","Pine","TreedBog", "TreedFen"), + proportion > 0) |> + group_by(surveyid, age) |> + summarize(proportion = sum(proportion)) |> + left_join(AgeMin) |> + group_by(surveyid) |> + summarize(wtAge = sum(proportion*wt)/sum(proportion)) |> + ungroup() |> + mutate(surveyid = as.numeric(surveyid)) |> + right_join(covs2) |> + mutate(wtAge = ifelse(is.na(wtAge), 0, wtAge), + wtAge2 = wtAge^2, + wtAge05 = sqrt(wtAge)) + +#7. Forestry convergence---- +#In this section we determine which surveys are predemoninantly harvest within the 150m buffer, and create a variable that accounts for differences in forestry convergence of those areas relative to a natural burn. These trajectories are expert-defined and differ between deciduous and coniferous stands. + +#Dave Huggard's recovery trajectories---- +age <- c(0, 1:20*4)/200 +conif <- 1-c(0, 1.3, 4.7, 10, 17.3, 26, 35.5, 45.3, 54.6, 63.1, 70.7, 77.3, + 82.7, 87, 90.1, 92.3, 94, 95.3, 96.7, 98.2, 100)/100 +decid <- 1-c(0, 6.5, 15.1, 25.2, 36.1, 47.2, 57.6, 66.7, 74.3, 80.4, 85, + 88.3, 90.5, 92, 93, 94, 95.1, 96.4, 97.6, 98.8, 100)/100 + +covs4 <- vc1 |> + rownames_to_column("surveyid") |> + pivot_longer(DeciduousR:CCPine4, names_to="vegage", values_to="proportion") |> + left_join(tv |> + rename(vegage=ID) |> + mutate(vegccc = ifelse(is_harvest, paste0("CC", UseInAnalysisNoAge), UseInAnalysisNoAge)) |> + dplyr::select(vegage, vegccc)) |> + dplyr::filter(!vegage %in% c("Water","HWater", "SnowIce", "Bare", "EnSeismic", "HardLin", "TrSoftLin", "EnSoftLin", "Well"), + proportion > 0) |> + group_by(surveyid, vegccc) |> + summarize(vegccv = sum(proportion)) |> + group_by(surveyid) |> + dplyr::filter(vegccv==max(vegccv)) |> + ungroup() |> + mutate(isCC = ifelse(str_sub(vegccc, 1, 2)=="CC", 1L, 0L), + surveyid = as.numeric(surveyid)) |> + left_join(covs3) |> + mutate(fcc2 = case_when(isCC & isCon ~ approxfun(age, conif)(wtAge), + isCC & !isCon ~ approxfun(age, decid)(wtAge)), + fcc2 = ifelse(is.na(fcc2), 0, fcc2)) + +#Visualize +ggplot(covs4 |> dplyr::filter(isCC==TRUE)) + + geom_line(aes(x=wtAge, y=fcc2, colour=factor(isCon))) + +#8. Dominant soil type---- +#In this section, we find the dominant soil type within the 150 m buffer, as per veg type, except that we use the dominant soil type from the backfill layer (reference) when HFor is the dominant class. +#We also calculate weights, as per the veg categories + +#Calculate reference values +srsum <- sr1 |> + rownames_to_column("surveyid") |> + pivot_longer(ClaySub:Water, names_to="soilrc", values_to="proportion") |> + dplyr::filter(!soilrc %in% c("SoilWater", "SoilUnknown", "HWater"), + proportion > 0) |> + group_by(surveyid, soilrc) |> + summarize(soilrv = sum(proportion)) |> + group_by(surveyid) |> + dplyr::filter(soilrv == max(soilrv)) |> + ungroup() + +covs5 <- sc1 |> + rownames_to_column("surveyid") |> + pivot_longer(ClaySub:Wellsites, names_to="soilc", values_to="proportion") |> + dplyr::filter(!soilc %in% c("Water","HWater", "SnowIce", "Bare", "EnSeismic", "HardLin", "TrSoftLin", "EnSoftLin", "Well"), + proportion > 0) |> + group_by(surveyid, soilc) |> + summarize(soilv = sum(proportion)) |> + group_by(surveyid) |> + dplyr::filter(soilv == max(soilv)) |> + ungroup() |> + left_join(srsum) |> + mutate(soilc = ifelse(soilc=="HFor", soilrc, soilc), + soilv = ifelse(soilc=="HFor", soilrv, soilv), + soilw = pmax(0, pmin(1, 2*soilv-0.5)), + surveyid = as.numeric(surveyid)) |> + inner_join(covs4) + + +#9. Add nuisance variables, modifier variables, and tidy---- +#Surveys that are BBS or surveys with > 0.4 proportion "is_road" +#Fix factor levels for vegc and soilc and method +#Add proportions for the linear features & well sites +#Make hybrid surveys 1SPM + +covs6 <- covs5 |> + mutate(road = case_when(project_id %in% c(1384, 1385) ~ 1, + pWater > 0.4 ~ 1, + !is.na(pWater) ~ 0), + method = case_when(source=="eBird" ~ "eBird", + task_method=="1SPM Audio/Visual hybrid" ~ "1SPM", + !is.na(task_method) ~ task_method)) |> + left_join(vc1 |> + rownames_to_column("surveyid") |> + mutate(surveyid = as.numeric(surveyid)) |> + dplyr::select(surveyid, EnSoftLin, HardLin, TrSoftLin, EnSeismic, Wellsites)) |> + mutate(mSoft = EnSeismic + EnSoftLin + TrSoftLin, + vegc = relevel(as.factor(vegc), "Decid"), + soilc = relevel(as.factor(soilc), "Loamy"), + method = relevel(as.factor(method), "PC")) |> + rename(mWell = Wellsites, + mEnSft = EnSoftLin, + mTrSft = TrSoftLin, + mSeism = EnSeismic) + +#10. Identify north and south regions----- +#We convert lat lon to EPSG 3400 for 10TM UTM +covs7 <- covs6 |> + st_as_sf(coords=c("longitude", "latitude"), crs=4326, remove=FALSE) |> + st_transform(crs=3400) |> + st_coordinates() |> + cbind(covs6) |> + mutate(useNorth = case_when(pWater > 0.5 ~ FALSE, + vegw==0 ~ FALSE, + NRNAME=="Grassland" ~ FALSE, + !is.na(surveyid) ~ TRUE), + useSouth = case_when(NRNAME %in% c("Grassland", "Parkland") ~ TRUE, + NSRNAME=="Dry Mixedwood" ~ TRUE, + latitude > 56.7 ~ FALSE, + soilw==0 ~ FALSE, + pWater > 0.5 ~ FALSE, + soilc=="SoilUnknown" ~ FALSE, + !is.na(surveyid) ~ FALSE)) |> + dplyr::filter(!(useNorth==FALSE & useSouth==FALSE)) + +#Visualize +ggplot(covs7) + + geom_point(aes(x=X, y=Y, colour=useNorth)) + +ggplot(covs7) + + geom_point(aes(x=X, y=Y, colour=useSouth)) + +#PACKAGE#### + +#1. Get final covariates---- +covs <- covs7 |> + dplyr::select(organization, project_id, surveyid, gisid, useNorth, useSouth, X, Y, year, date_time, vegc, soilc, vegw, soilw, wtAge, wtAge2, wtAge05, isCon, isUpCon, isBogFen, isMix, isPine, isWSpruce, fcc2, road, mWell, mSoft, mEnSft, mTrSft, mSeism, method, pWater_KM, pWater2_KM, paspen, MAP, TD, CMD, FFP, EMT) |> + rename(Easting = X, Northing = Y) + +bird <- complete |> + dplyr::select(surveyid, gisid, all_of(colnames(offsets[,-1]))) |> + dplyr::filter(surveyid %in% covs$surveyid) + +off <- offsets |> + dplyr::filter(surveyid %in% covs$surveyid) + +save(covs, bird, off, file=file.path(root, "Data", "Wrangled.Rdata")) diff --git a/0_data/v2_scripts/birds/src/05.StratifyData.R b/0_data/v2_scripts/birds/src/05.StratifyData.R new file mode 100644 index 0000000..9bfe787 --- /dev/null +++ b/0_data/v2_scripts/birds/src/05.StratifyData.R @@ -0,0 +1,199 @@ +# --- +# title: ABMI models - stratify data +# author: Elly Knight +# created: May 10, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This code picks one survey per location per block of region and time interval for each bootstrap, checks that the list of species to model have sufficient data, and filters counts to the 99.9% quantile to remove outliers + +#This code uses several lookups to compile the list of birds that are actually modelled. + +#FUTURE VERSION: count outlier removal may make more sense in a previous step. +#FUTURE VERSION: Bird list lookups are a relic of previous modeling versions and could probably be combined for parsimony. +#FUTURE VERSION: The list of species modelled could probably be expanded based on exploration of sample sizes and model assumptions. + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Load wrangled data set---- +load(file.path(root, "Data", "Wrangled.Rdata")) + +#BLOCKING UNITS##### + +#1. Make bins---- + +#number of spatial bins is same as other taxa, has been updated to UTM +#temporal bins are determined by quantiles +tbins <- quantile(covs$year, probs=seq(0, 1, by=0.2)) + +bins <- covs |> + mutate(blockx = cut(Easting, c(180000, 407000, 634000, 861000)), + blocky = cut(Northing, c(5420000, 5730000, 6040000, 6350000, 6660000)), + blockt = cut(year, tbins), + blockxy = interaction(blockx, blocky, sep="::"), + block = interaction(blockxy, blockt, sep="::")) + +ftable(bins$blockt, bins$blockx, bins$blocky) + +#2. Add location id---- +#round UTM to nearest 20 m +tolerance <- 20 + +loc <- bins |> + mutate(Xr = round(Easting/tolerance)*tolerance, + Yr = round(Northing/tolerance)*tolerance) |> + group_by(Xr, Yr) |> + mutate(locationid = cur_group_id()) |> + ungroup() + +#3. Get unique locations---- +covsu <- loc |> + dplyr::select(locationid, Xr, Yr) |> + unique() + +#4. Add quantiles for witholding data---- +set.seed(1234) +covsu$q <- sample.int(100, nrow(covsu), replace=TRUE) + +#5. Join back to all surveys---- +covsbins <- loc |> + left_join(covsu) |> + arrange(surveyid) + +#MAKE BOOTSTRAPS########## + +#1. Set parameters---- +#Minimum sample size +NMIN <- 20 + +#Number of bootstraps +B <- 100 + +#2. Set up loop---- +boot <- covsbins |> + dplyr::filter(q > 10) |> + dplyr::select(block, locationid) |> + unique() |> + dplyr::select(-block, -locationid) |> + data.frame() + +for(i in 1:B){ + + #3. Set seed---- + set.seed(i) + + #4. Get random sample of one location per block---- + boot.i <- covsbins |> + dplyr::filter(q > 10) |> + group_by(block, locationid) %>% + mutate(rowid = row_number(), + use = sample(1:max(rowid), 1)) %>% + ungroup() |> + dplyr::filter(rowid==use) + + #5. Bind to boot object---- + boot[,i] <- boot.i$surveyid + + cat("Finished", i, "of", B, "\n") + +} + +#6. Name columns--- +colnames(boot) <- c(1:B) + +#SPECIES LIST#### + +#1. Make to do list---- +loop <- expand.grid(boot = 1:B, + region = c("north", "south")) + +#2. Set up loop---- +count.list <- list() +for(i in 1:nrow(loop)){ + + #3. Filter survey data to region and bootstrap---- + if(loop$region[i]=="north"){ + survey.i <- covs[covs$surveyid %in% boot[,loop$boot[i]],] |> + dplyr::filter(useNorth==TRUE) + } + + if(loop$region[i]=="south"){ + survey.i <- covs[covs$surveyid %in% boot[,loop$boot[i]],] |> + dplyr::filter(useSouth==TRUE) + } + + #4. Filter bird data and count detections---- + count.list[[i]] <- bird[bird$surveyid %in% survey.i$surveyid,] |> + dplyr::select(-surveyid, -gisid) |> + pivot_longer(ALFL:YRWA, names_to="species", values_to="count") |> + dplyr::filter(count > 0) |> + group_by(species) |> + summarize(detections = n()) |> + ungroup() |> + mutate(region = loop$region[i], + boot = loop$boot[i]) + +} + +#5. Summarize across bootstraps---- +#Remove birds for regions with a mean # of detections less than 20 +nmin <- 20 + +#Get the bird wish list (list of species to run, same as previous years) +birdlist <- read.csv(file.path(root, "Data", "lookups", "birds-v2024.csv")) |> + left_join(read.csv(file.path(root, "Data", "lookups", "birdlist.csv")) |> + rename(common = species, + species = code)) |> + mutate(north = ifelse(show %in% c("c", "n"), TRUE, FALSE), + south = ifelse(show %in% c("c", "s"), TRUE, FALSE)) |> + dplyr::select(species, north, south) |> + pivot_longer(north:south, names_to="region", values_to="model") |> + dplyr::filter(model==TRUE) |> + dplyr::select(-model) |> + left_join(do.call(rbind, count.list) |> + group_by(region, species) |> + summarize(det.mean = round(mean(detections)), + det.min = min(detections)) |> + ungroup()) |> + dplyr::filter(det.mean >= nmin) + +#6. Filter counts to 99.9% quantile---- +bird.q <- bird +for(i in 1:nrow(birdlist)){ + + #Get just the presence points + bird.i <- bird[,birdlist$species[i]][bird[,birdlist$species[i]]>0] + + #Get the quantile + q.i <- ceiling(quantile(bird.i, 0.995)) + + #Replace + bird.q[,birdlist$species[i]] <- ifelse(bird[,birdlist$species[i]] > q.i, + q.i, bird[,birdlist$species[i]]) + +} + +#Rename and tidy +bird <- bird.q |> + dplyr::select(c("surveyid", all_of(unique(birdlist$species)))) +rm(bird.q) + +#PACKAGE###### + +#1. Add train/test to covs object & repackage---- +covs <- covsbins |> + mutate(use = ifelse(q <= 10, "test", "train")) |> + dplyr::select(-blockx, -blocky, -blockt, -blockxy, -Xr, -Yr, -q) + +#2. Save---- +save(covs, bird, off, boot, birdlist, file=file.path(root, "Data", "Stratified.Rdata")) diff --git a/0_data/v2_scripts/birds/src/06.ModelClimate.R b/0_data/v2_scripts/birds/src/06.ModelClimate.R new file mode 100644 index 0000000..85d3354 --- /dev/null +++ b/0_data/v2_scripts/birds/src/06.ModelClimate.R @@ -0,0 +1,229 @@ +# --- +# title: ABMI models - run climate models +# author: Elly Knight +# created: June 5, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This script runs the first stage of the modelling process, which is the climate models that are run with all data for the entire province. + +#This script is written to be run on the alliance canada cluster in parallel. Messages are therefore printed in the output for each step in the script to help with debugging. Use the Climate.sh object to run the script on the cluster. The cedar cluster is recommended. + +#There are two objects at the beginning of the script that can be set to TRUE if running tests. One controls whether you are running on a subset of model iterations (i.e., testing), and one controls whether you are running on your local machine or alliance canada. Ideally you would: +#1. set test to true and cc to false (test on local) +#2. set cc to true (test on alliance canada) +#3. set test to false (run full model set on alliance canada) + +#The script is set to inventory the models already run and remove them from the to-do list ("loop" object) every time the script is run. This means you can submit it as a [relatively] small job on alliance canada instead of requesting enough resources for the entire list of models (which is a lot). Just make sure you keep the "results" folder with all the output in it until you are finished running everything, because this is what is being used to inventory the models already run. + +#The steps for running on alliance canada (for this and other scripts are): +#1. Transfer this script and your data object between local computer and alliance canada's servers using Globus Connect. +#2. Create any folders you need for saving output into (as per your script). You'll want to work in the scratch space, given the volume of output we will produce. +#3. Log in to alliance canada in the terminal with the ssh function. +#4. Figure out which modules you need to run your R packages (if making any changes) and load them. +#5. Load an instance of R in the test node and install the packages you need. Close it. +#6. Use the nano function to create a shell script that tells the slurm the resources you need, the modules you need, and the script to run. NOTE: You have to do this via the terminal or with a Linux machine. The slurm can't read the encoding if you create it on a windows machine and transfer it over via Globus. +#7. Use the cd function to navigate to the write working directory within copute canada's file servers (i.e., where you put your files with globus connect) +#8. Run your script with sbatch and the name of your sh file! +#9. Use squeue -u and your username to check on the status of your job. +#10. Rerun the script as many times as you need to work through all the required models (see note above). + +#see medium.com/the-nature-of-food/how-to-run-your-r-script-with-compute-canada-c325c0ab2973 for the most straightforward tutorial I found for alliance canada + +#FUTURE VERSION: Try using climate variables that are smoothed via a large focal moving window (e.g., 20 km) to smooth the response and prediction surfaces + +#PREAMBLE############################ + +#1. Load packages---- +print("* Loading packages on master *") +library(tidyverse) #basic data wrangling +library(AICcmodavg) # For model selection +library(MuMIn) #Model averaging +library(parallel) #parallel computing + +#2. Determine if testing and on local or cluster---- +test <- FALSE +cc <- FALSE + +#3. Set nodes for local vs cluster---- +if(cc){ nodes <- 48} +if(!cc | test){ nodes <- 4} + +#4. Create and register clusters---- +print("* Creating clusters *") +cl <- makePSOCKcluster(nodes, type="PSOCK") + +#5. Set root path---- +print("* Setting root file path *") +if(cc){root <- "/scratch/ecknight/ABModels"} +if(!cc){root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels"} + +tmpcl <- clusterExport(cl, c("root")) + +#6. Load packages on clusters---- +print("* Loading packages on workers *") +tmpcl <- clusterEvalQ(cl, library(tidyverse)) +tmpcl <- clusterEvalQ(cl, library(AICcmodavg)) +tmpcl <- clusterEvalQ(cl, library(MuMIn)) + +#7. Load data package---- +print("* Loading data on master *") + +load(file.path(root, "Data", "Stratified.Rdata")) + +#8. Load model script---- +if(cc){source("00.ClimateModels.R")} +if(!cc){source("src/00.ClimateModels.R")} + +#9. Number of climate models---- +n <- length(modelsclimate) + +#10. Link functions---- +inv.link <- function (eta) {pmin(pmax(exp(eta), .Machine$double.eps), .Machine$double.xmax)} +link <- poisson()$linkfun + +#11. Load data objects---- +print("* Loading data on workers *") + +tmpcl <- clusterExport(cl, c("bird", "off", "covs", "boot", "birdlist", "modelsclimate", "n", "inv.link", "link")) + +#WRITE FUNCTION########## + +model_climate <- function(i){ + + #1. Loop settings---- + boot.i <- loop$bootstrap[i] + species.i <- as.character(loop$species[i]) + + #2. Get the data---- + covs.i <- covs[covs$surveyid %in% boot[,boot.i],] + bird.i <- bird[bird$surveyid %in% boot[,boot.i], species.i] + off.i <- off[off$surveyid %in% boot[,boot.i], species.i] + + dat.i <- data.frame(count = bird.i, offset = off.i) |> + cbind(covs.i) + + #3. Make model list--- + climate.list <- list() + + #4. Run null model---- + climate.list[[1]] <- try(glm(count ~ 1 + offset(offset), + data = dat.i, + family = "poisson", + y=FALSE, + model=FALSE)) + + if(!inherits(climate.list[[1]], "try-error")){ + + #5. Run the other climate models---- + for(j in 1:n){climate.list[[j + 1]] <- try(update(climate.list[[1]], formula=modelsclimate[[j]]))} + + #6. Add XY---- + for(j in 1:n){climate.list[[j + n + 1]] <- try(update(climate.list[[j + 1]], . ~ . + Easting + Northing + Easting:Northing))} + + for(j in 1:n){climate.list[[j + 2*n + 1]] <- try(update(climate.list[[j + n + 1]], . ~ . + I(Easting^2) + I(Northing^2)))} + + #Take out any try-errors + climate.list <- climate.list[sapply(climate.list, function(x) !inherits(x, "try-error"))] + + #7. Model averaging---- + averagemodel <- model.avg(climate.list , rank = "AICc") + + #8. Get predictions---- + averageprediction <- inv.link(predict(averagemodel, type="link", full=TRUE)) + + #9. Get coefficients---- + averagecoefficients <- data.frame(coef = summary(averagemodel)$coefmat.full[, c("Estimate", "Std. Error")]) |> + rename(coef = coef.Estimate, + se = coef.Std..Error) + + #Make a species folder in predictions + if(!(file.exists(file.path(root, "Results", "ClimateModels", "Predictions", species.i)))){ + dir.create(file.path(root, "Results", "ClimateModels", "Predictions", species.i)) + } + + #Save the prediction + write.csv(averageprediction, file = file.path(root, "Results", "ClimateModels", "Predictions", species.i, paste0("ClimateModelPrediction_", species.i, "_", boot.i, ".csv")), row.names = FALSE) + + #Make a species folder in coefficients + if(!(file.exists(file.path(root, "Results", "ClimateModels", "Coefficients", species.i)))){ + dir.create(file.path(root, "Results", "ClimateModels", "Coefficients", species.i)) + } + + #Save the coefficients + write.csv(averagecoefficients, file = file.path(root, "Results", "ClimateModels", "Coefficients", species.i, paste0("ClimateModelCoefficients_", species.i, "_", boot.i, ".csv")), row.names = TRUE) + } + + #Save any try-errors + if(inherits(climate.list[[1]], "try-error")){ + + error <- data.frame(class = class(climate.list[[1]]), + error = climate.list[[1]][[1]], + species = species.i, + boot = boot.i) + + write.csv(error, file = file.path(root, "Results", "ClimateModels", "Try-errors", paste0("ClimateModelErrors_", species.i, "_", boot.i, ".csv")), row.names = FALSE) + + } + + #11. Clean up---- + rm(climate.list, averagemodel, averageprediction, averagecoefficients, dat.i) + +} + +#RUN MODELS############### + +#1. Set species list---- +spp <- unique(birdlist$species) + +#2. Set bootstrap list---- +b <- c(1:100) + +#3. Make todo list---- +todo <- expand.grid(species = spp, bootstrap = b) |> + arrange(species) + +#4. Check against models already run---- +done <- data.frame(file = list.files(file.path(root, "Results", "ClimateModels", "Predictions"), pattern="*.csv", recursive = TRUE)) |> + separate(file, into=c("f1", "f2", "species", "bootstrap", "f3")) |> + dplyr::select(species, bootstrap) |> + mutate(bootstrap = as.numeric(bootstrap)) |> + inner_join(data.frame(file = list.files(file.path(root, "Results", "ClimateModels", "Coefficients"), pattern="*.csv", recursive=TRUE)) |> + separate(file, into=c("f4", "f5", "species", "bootstrap", "f6")) |> + dplyr::select(species, bootstrap) |> + mutate(bootstrap = as.numeric(bootstrap))) + +#5. Check against try-error models---- +error <- data.frame(file = list.files(file.path(root, "Results", "ClimateModels", "Try-errors"), pattern="*.csv")) |> + separate(file, into=c("f1", "species", "bootstrap", "f2")) |> + dplyr::select(species, bootstrap) |> + mutate(bootstrap = as.numeric(bootstrap)) + +#6. Make modelling list---- +loop <- anti_join(todo, done) |> + anti_join(error) + +if(nrow(loop) > 0){ + + #For testing + if(test) {loop <- loop[1:nodes,]} + + print("* Loading model loop on workers *") + tmpcl <- clusterExport(cl, c("loop")) + + #7. Run model function in parallel---- + print("* Fitting models *") + mods <- parLapply(cl, + X=1:nrow(loop), + fun=model_climate) + +} + +#CONCLUDE#### + +#1. Close clusters---- +print("* Shutting down clusters *") +stopCluster(cl) + +if(cc){ q() } diff --git a/0_data/v2_scripts/birds/src/07.ModelLandcover.R b/0_data/v2_scripts/birds/src/07.ModelLandcover.R new file mode 100644 index 0000000..56575bc --- /dev/null +++ b/0_data/v2_scripts/birds/src/07.ModelLandcover.R @@ -0,0 +1,244 @@ +# --- +# title: ABMI models - run landcover models +# author: Elly Knight +# created: June 6, 2024 +# --- + +#NOTES################################ + +#PURPOSE: This script runs the second stage of the modelling process, which is the landcover models that are run for the north region and the soil models that are run forh the south region. + +#This script uses the same function to run both north and south models, using a lookup table built from list of climate models and the birdlist to determine which model to run. This script will therefore only run for species for which the climate predictions are available as output from the previous step because it requires them for input. + +#This script is also written to be run on alliance canada following the steps in `06.ModelClimate.R` + +#PREAMBLE############################ + +#1. Load packages---- +print("* Loading packages on master *") +library(tidyverse) #basic data wrangling +library(parallel) #parallel computing + +#2. Determine if testing and on local or cluster---- +test <- FALSE +cc <- FALSE + +#3. Set nodes for local vs cluster---- +if(cc){ nodes <- 48} +if(!cc | test){ nodes <- 8} + +#4. Create and register clusters---- +print("* Creating clusters *") +cl <- makePSOCKcluster(nodes, type="PSOCK") + +#5. Set root path---- +print("* Setting root file path *") +if(cc){root <- "/scratch/ecknight/ABModels"} +if(!cc){root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels"} + +tmpcl <- clusterExport(cl, c("root")) + +#6. Load packages on clusters---- +print("* Loading packages on workers *") +tmpcl <- clusterEvalQ(cl, library(tidyverse)) +tmpcl <- clusterEvalQ(cl, library(AICcmodavg)) +tmpcl <- clusterEvalQ(cl, library(MuMIn)) + +#7. Load data package---- +print("* Loading data on master *") + +load(file.path(root, "Data", "Stratified.Rdata")) + +#8. Load model script---- +if(cc){source("00.NorthModels.R") + source("00.SouthModels.R")} +if(!cc){source("src/00.NorthModels.R") + source("src/00.SouthModels.R")} + +#9. Load data objects---- +print("* Loading data on workers *") + +tmpcl <- clusterExport(cl, c("bird", "off", "covs", "boot", "birdlist", "modelsnorth", "modelssouth")) + +#WRITE FUNCTION########## + +model_landcover <- function(i){ + + #2. Loop settings---- + boot.i <- loop$bootstrap[i] + species.i <- as.character(loop$species[i]) + region.i <- loop$region[i] + + #3. Get the data---- + covs.i <- covs[covs$surveyid %in% boot[,boot.i],] + bird.i <- bird[bird$surveyid %in% boot[,boot.i], species.i] + off.i <- off[off$surveyid %in% boot[,boot.i], species.i] + + #4. Load the climate model predictions---- + climate.i <- read.csv(loop$path[i]) + + #5. Put together---- + dat.i <- data.frame(count = bird.i, offset = off.i, climate = climate.i$x) |> + cbind(covs.i) + + #6. Subset the data and rename the weights---- + if(region.i=="north"){use.i <- dplyr::filter(dat.i, useNorth==TRUE) |> + rename(weight = vegw)} + if(region.i=="south") {use.i <- dplyr::filter(dat.i, useSouth==TRUE) |> + rename(weight = soilw)} + + #7. Rename the model script--- + if(region.i=="north"){models <- modelsnorth} + if(region.i=="south"){models <- modelssouth} + + #8. Make model output list--- + lc.list <- list() + + #9. Run null model---- + lc.list[[1]] <- glm(count ~ climate + offset(offset), + data = use.i, + family = "poisson", + weights = use.i$weight) + + #10. Set up model stage loop---- + for(j in 1:length(models)){ + + #11. Get models---- + mods.j <- models[j][[1]] + + #12. Set up model loop---- + full.list <- list() + for(k in 1:length(mods.j)){ + + full.list[[k]] <- try(update(lc.list[[j]], formula=mods.j[[k]])) + + } + + #13. Remove try errors---- + full.list <- full.list[!sapply(full.list, inherits, "try-error")] + + if(length(full.list) > 0){ + + #13. Get the BIC table---- + bictable <- AICcmodavg::bictab(cand.set = full.list, sort = F) + + #14. Pick best model---- + bestmodeltable <- bictable |> + dplyr::filter(K > 1, Delta_BIC <=2) |> + dplyr::filter(K == min(K)) + + #15. Save that model for the next stage---- + lc.list[[j+1]] <- full.list[[as.numeric(str_sub(bestmodeltable$Modnames[1], 4, 5))]] + + } + + } + + #16. Get the final model---- + bestmodel <- lc.list[[length(lc.list)]] + + #17. Save it---- + if(region.i=="north"){ + + #Make a species folder in models + if(!(file.exists(file.path(root, "Results", "LandcoverModels", "Models", "north", species.i)))){ + dir.create(file.path(root, "Results", "LandcoverModels", "Models", "north", species.i)) + } + + #Save the model + save(bestmodel, file = file.path(root, "Results", "LandcoverModels", "Models", "north", species.i, paste0("NorthModel_", species.i, "_", boot.i, ".Rdata"))) + + } + + if(region.i=="south"){ + + #Make a species folder in models + if(!(file.exists(file.path(root, "Results", "LandcoverModels", "Models", "south", species.i)))){ + dir.create(file.path(root, "Results", "LandcoverModels", "Models", "south", species.i)) + } + + #Save the model + save(bestmodel, file = file.path(root, "Results", "LandcoverModels", "Models", "south", species.i, paste0("SouthModel_", species.i, "_", boot.i, ".Rdata"))) + + } + + #18. Save the coefficients---- + coef <- data.frame(name = names(bestmodel$coefficients), + coef = summary(bestmodel)$coefficients[, "Estimate"], + se = summary(bestmodel)$coefficients[, "Std. Error"]) + + if(region.i=="north"){ + + #Make a species folder + if(!(file.exists(file.path(root, "Results", "LandcoverModels", "Coefficients", "north", species.i)))){ + dir.create(file.path(root, "Results", "LandcoverModels", "Coefficients", "north", species.i)) + } + + #Save the coefficients + write.csv(coef, file = file.path(root, "Results", "LandcoverModels", "Coefficients", "north", species.i, paste0("NorthModel_", species.i, "_", boot.i, ".csv")), row.names = FALSE) } + + if(region.i=="south"){ + + #Make a species folder in models + if(!(file.exists(file.path(root, "Results", "LandcoverModels", "Coefficients", "south", species.i)))){ + dir.create(file.path(root, "Results", "LandcoverModels", "Coefficients", "south", species.i)) + } + + write.csv(coef, file = file.path(root, "Results", "LandcoverModels", "Coefficients", "south", species.i, paste0("SouthModel_", species.i, "_", boot.i, ".csv")), row.names = FALSE) } + + #19. Tidy up---- + rm(lc.list, bestmodel, bictable, bestmodeltable) + +} + +#RUN MODELS############### + +#1. Get list of climate models---- +climate <- data.frame(path = list.files(file.path(root, "Results", "ClimateModels", "Predictions"), full.names = TRUE, pattern="*.csv", recursive=TRUE), + file = list.files(file.path(root, "Results", "ClimateModels", "Predictions"), pattern="*.csv", recursive=TRUE)) |> + separate(file, into=c("spf", "model", "species", "bootstrap", "filetype")) |> + dplyr::select(-model, -filetype, -spf) + +#2. Make list---- +todo <- birdlist |> + dplyr::select(species, region) |> + inner_join(climate, multiple="all") + +#3. Check against models already run---- +done <- data.frame(file = list.files(file.path(root, "Results", "LandCoverModels", "Models"), pattern="*.Rdata", recursive = TRUE)) |> + separate(file, into=c("region", "f1", "f2", "species", "bootstrap", "f3")) |> + dplyr::select(region, species, bootstrap) |> + inner_join(data.frame(file = list.files(file.path(root, "Results", "LandCoverModels", "Coefficients"), pattern="*.csv", recursive = TRUE)) |> + separate(file, into=c("region", "f4", "f5", "species", "bootstrap", "f6")) |> + dplyr::select(region, species, bootstrap)) + +#4. Make to do list---- +loop <- anti_join(todo, done) + +if(nrow(loop) > 0){ + + #For testing + if(test) {loop <- loop[1:nodes,]} + + start <- Sys.time() + + print("* Loading model loop on workers *") + tmpcl <- clusterExport(cl, c("loop")) + + #5. Run model function in parallel---- + print("* Fitting models *") + mods <- parLapply(cl, + X=1:nrow(loop), + fun=model_landcover) + + end <- Sys.time() + +} + +#CONCLUDE#### + +#1. Close clusters---- +print("* Shutting down clusters *") +stopCluster(cl) + +if(cc){ q() } diff --git a/0_data/v2_scripts/birds/src/08.PackageCoefficients.R b/0_data/v2_scripts/birds/src/08.PackageCoefficients.R new file mode 100644 index 0000000..72e7c06 --- /dev/null +++ b/0_data/v2_scripts/birds/src/08.PackageCoefficients.R @@ -0,0 +1,771 @@ +# --- +# title: ABMI models - package model coefficients +# author: Elly Knight +# created: June 17, 2024 +# --- + +#NOTES################################ + +#The translation of the model coefficients to the coefficients that are standardized across taxa relies on a lookup table. The proportions of the age coefficients in the raw models that contribute to the age stages in the standardized coefficients are area under the curve. + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling +library(purrr) #functional programming +library(vegan) #for picking median bootstrap +library(pROC) #AUC + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Get the list of models run---- +mods <- data.frame(path = list.files(file.path(root, "Results", "LandcoverModels", "Coefficients"), full.names = TRUE, recursive = TRUE, pattern="*.csv"), + file = list.files(file.path(root, "Results", "LandcoverModels", "Coefficients"), recursive = TRUE, pattern="*.csv")) |> + separate(file, into=c("region", "f1", "f2", "species", "bootstrap")) |> + mutate(bootstrap = as.numeric(bootstrap)) |> + dplyr::select(-f1, -f2) + +#5. Load model scripts---- +source("src/00.NorthModels.R") +source("src/00.SouthModels.R") + +#6. Load data---- +load(file.path(root, "Data", "Stratified.Rdata")) + +#7. Function to fix interaction term names---- +#make formula term names sorted and predictable, i.e. always A:B instead of B:A +fix_names <- function(x, sep=":") { + unlist(lapply(x, function(z) { + paste(sort(strsplit(z, sep)[[1]]), collapse=sep) + })) +} + +#8. Function to get model terms----- +#Formula from Peter's approach +get_terms <- function(mods, type=c("formula", "list"), intercept=TRUE) { + type <- match.arg(type) + x <- unlist(lapply(unlist(mods), function(z) as.character(z)[3])) + # x <- unname(substr(x, 5, nchar(x))) + x <- gsub(". + ", "", x, fixed=TRUE) + x <- unlist(strsplit(x, "+", fixed=TRUE)) + x <- unlist(strsplit(x, "*", fixed=TRUE)) + if (type == "list") + x <- unlist(strsplit(x, ":", fixed=TRUE)) + x <- sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", x, perl=TRUE) + x <- unique(x) + if (type == "formula") { + x <- paste("~", paste(x, collapse=" + ", sep="")) + if (!intercept) + x <- paste(x, "- 1") + x <- as.formula(x) + } + x +} + +#9. Load veg age lookup---- +load(file.path(root, "Data", "lookups", "Xn-veg-v2024.Rdata")) +colnames(age) <- fix_names(colnames(age)) + +#CLIMATE MODEL COEFFICIENTS########## + +#1. Get list of climate models---- +climate <- data.frame(path = list.files(file.path(root, "Results", "ClimateModels", "Coefficients"), full.names = TRUE, pattern="*.csv", recursive = TRUE), + file = list.files(file.path(root, "Results", "ClimateModels", "Coefficients"), pattern="*.csv", recursive = TRUE)) |> + separate(file, into=c("f1", "model", "species", "bootstrap", "filetype")) |> + dplyr::select(-model, -filetype, -f1) |> + mutate(bootstrap = as.numeric(bootstrap)) |> + inner_join(mods |> + dplyr::select(species, bootstrap) |> + unique()) + +#2. Get list of species---- +spp <- unique(climate$species) + +#3. Get max # of bootstraps---- +bmax <- max(climate$bootstrap) + +#4. Set the column names---- +coefnames <- c("(Intercept)", "MAP", "FFP", "TD", "CMD", "Easting", "Northing", "I(Easting^2)", "I(Northing^2)", "Easting:Northing") +coefrename <- c("Intercept", "MAP", "FFP", "TD", "CMD", "Easting", "Northing", "Easting2", "Northing2", "EastingNorthing") + +#5. Set up loop----- +for(i in 1:length(spp)){ + + #6. List of models for that species---- + climate.i <- dplyr::filter(climate, species==spp[i], + bootstrap %in% c(1:bmax)) + + #7. Read them in---- + #sort and fix names + coef.list <- list() + se.list <- list() + for(j in 1:nrow(climate.i)){ + coef.list[[j]] <- read.csv(climate.i$path[j]) |> + dplyr::select(-se) |> + pivot_wider(names_from="X", values_from = "coef") |> + dplyr::select(all_of(coefnames)) + colnames(coef.list[[j]]) <- coefrename + + se.list[[j]] <- read.csv(climate.i$path[j]) |> + dplyr::select(-coef) |> + pivot_wider(names_from="X", values_from = "se") |> + dplyr::select(all_of(coefnames)) + colnames(se.list[[j]]) <- coefrename + } + + #8. Make the array if first species---- + if(i==1){ + marginal <- array(0, c(length(spp), length(coefrename), bmax)) + dimnames(marginal) <- list(spp, coefrename, paste0("b", c(1:bmax))) + + marginal_se <- array(0, c(length(spp), length(coefrename), bmax)) + dimnames(marginal_se) <- list(spp, coefrename, paste0("b", c(1:bmax))) + } + + #9. Add species to array---- + marginal[spp[i],,] <- as.matrix(t(do.call(rbind, coef.list))) + marginal_se[spp[i],,] <- as.matrix(t(do.call(rbind, se.list))) + + cat("Finished species", i, "of", length(spp), "\n") + +} + +#LANDCOVER MODEL COEFFICIENTS - NORTH############# + +#1. Get the list of north models---- +north <- mods |> + dplyr::filter(region=="north") + +#2. Get list of species---- +spp <- unique(north$species) + +#3. Get the full list of potential continuous covariates---- +#don't need the categorical ones because they're in every model +names.north <- do.call(rbind, unlist(modelsnorth)) |> + data.frame() |> + separate(X3, into=c("X3", "X4", "X5", "X6", "X7", "X8", "X9", "X10", "X11", "X12", "X13", "X14", "X15", "X16", "X17", "X18", "X19", "X20", "X21", "X22", "X23"), sep = " +") |> + dplyr::select(-X1, -X2, -X3) |> + pivot_longer(cols=X4:X23, names_to="position", values_to="name") |> + dplyr::filter(!is.na(name), name!="+") |> + dplyr::select(-position) |> + unique() |> + mutate(name = fix_names(name)) |> + dplyr::filter(!name %in% c("method", "vegc")) + +#4. Get the full north data---- +covs.n <- dplyr::filter(covs, useNorth==TRUE) + +#5. Get the model matrix---- +Xn <- model.matrix(get_terms(modelsnorth), covs.n) +colnames(Xn) <- fix_names(c("Intercept", colnames(Xn)[-1])) + +#6. Set up loop---- +for(i in 1:length(spp)){ + + #7. List of models for that species---- + north.i <- dplyr::filter(north, species==spp[i]) + + coef.list <- list() + se.list <- list() + for(j in 1:nrow(north.i)){ + + #8. Get the raw coefficients----- + #Add zeros for any covariates that weren't in the best model + coef.j <- read.csv(north.i$path[j]) |> + mutate(name = fix_names(name), + name = ifelse(name=="(Intercept)", "Intercept", name)) |> + full_join(data.frame(name = names.north$name)) |> + mutate(coef = ifelse(is.na(coef), 0, coef), + se = ifelse(is.na(se), 0, se)) |> + suppressMessages() + + raw.j <- coef.j$coef + names(raw.j) <- coef.j$name + + raw_se.j <- coef.j$se + names(raw_se.j) <- coef.j$name + + #9. Translate to standardized & transformed coefficients for the veg coefficients---- + mu <- drop(age %*% raw.j[colnames(age)]) + lam.j <- exp(drop(age %*% raw.j[colnames(age)])) + + mu_se <- drop(age %*% raw_se.j[colnames(age)]) + lam_se.j <- exp(drop(age %*% raw_se.j[colnames(age)])) + + #10. Adjust the linear feature coefficients for competing models---- + #replace others with msoft if it is non-zero + #because mSoft is competed with the others in the model set + hf.j <- coef.j |> + dplyr::select(-se) |> + dplyr::filter(name %in% c("mWell", "mSoft", "mEnSft", "mTrSft", "mSeism")) |> + mutate(coef = exp(coef)) |> + pivot_wider(names_from=name, values_from=coef) |> + mutate(mEnSft = ifelse(mSoft!=0 & mEnSft==0, mSoft, mEnSft), + mTrSft = ifelse(mSoft!=0 & mTrSft==0, mSoft, mTrSft), + mSeism = ifelse(mSoft!=0 & mSeism==0, mSoft, mSeism)) |> + pivot_longer(mWell:mSeism, names_to="name", values_to="coef") |> + data.frame() + + hf_se.j <- coef.j |> + dplyr::select(-coef) |> + dplyr::filter(name %in% c("mWell", "mSoft", "mEnSft", "mTrSft", "mSeism")) |> + mutate(se = exp(se)) |> + pivot_wider(names_from=name, values_from=se) |> + mutate(mEnSft = ifelse(mSoft!=0 & mEnSft==0, mSoft, mEnSft), + mTrSft = ifelse(mSoft!=0 & mTrSft==0, mSoft, mTrSft), + mSeism = ifelse(mSoft!=0 & mSeism==0, mSoft, mSeism)) |> + pivot_longer(mWell:mSeism, names_to="name", values_to="se") |> + data.frame() + + #11. Adjust the linear feature and well coefficients---- + + #Human-modified landcover types that we don't want interfering with adjustment + hfc <- c("Crop", "Industrial", "Mine", "RoughP", "Rural", "TameP", "Urban") + + #Dataframe of variables to adjust + vars <- data.frame(var = c("mWell", "mEnSft", "mTrSft", "mSeism")) + + for(k in 1:nrow(vars)){ + + #Make a mock dataframe for the variable + zero.k <- data.frame(var = 0) + colnames(zero.k) <- vars$var[k] + + #Get the rows of interest from the model matrix + #> 0 proportion of variable, no human-modified landover type, no harvest + rows.k <- covs.n |> + mutate(rowid = row_number()) |> + anti_join(zero.k) |> + dplyr::filter(!vegc %in% hfc & + fcc2==0) |> + suppressMessages() + + Xn.k <- Xn[rows.k$rowid, colnames(age)] + + #Make predictions from those rows using the raw coefficient + lam.k <- exp(Xn.k %*% raw.j[colnames(Xn.k)]) + + #Multiply transformed coefficients by those predictions and take the mean + vars$est[k] <- mean(lam.k * hf.j[hf.j$name==vars$var[k],]$coef) + + #Add some extra tracking information + vars$n[k] <- nrow(rows.k) + vars$original[k] <- exp(raw.j[vars$var[k]]) + + } + + #12. Cap open habitat values---- + #for coef only, not se + + #Get maximum lambda for open habitat types + lam.open <- max(lam.j[c(names(lam.j)[endsWith(names(lam.j), "R")], + "GrassHerb", "Shrub", "GraminoidFen", "Marsh")]) + + #Get maximum lambda for open human footprint types + lam.hf <- max(lam.j[c("Industrial", "Rural", "Urban")]) + + #Overall cap value + lam.max <- max(lam.open, lam.hf) + + #Cap the linear features---- + linear <- vars |> + rowwise() |> + mutate(capped = min(est, lam.max)) |> + ungroup() |> + mutate(cap_open = lam.open, + cap_hf = lam.hf, + cap_total = lam.max, + species = spp[i], + boot = j, + name = c("Wellsites", "EnSoftLin", "TrSoftLin", "EnSeismic")) + + linear.j <- linear$capped + names(linear.j) <- linear$name + + linear_se.j <- hf_se.j[hf_se.j$name %in% linear$var, "se"] + names(linear_se.j) <- linear$name + + #13. Put together---- + lam.out <- c(Climate = exp(raw.j["climate"]), + lam.j[names(lam.j)!="Mine"], + linear.j, + HardLin = 0, + Water = 0, + Bare = 0, + SnowIce = 0, + Mine = 0, + MineV = unname(lam.j["Mine"])) + names(lam.out) <- gsub("Spruce", "WhiteSpruce", names(lam.out)) + names(lam.out) <- gsub("Decid", "Deciduous", names(lam.out)) + names(lam.out) <- gsub("Climate.climate", "Climate", names(lam.out)) + names(lam.out) <- gsub("TreedBog", "BlackSpruce", names(lam.out)) + + se.out <- c(Climate = exp(raw_se.j["climate"]), + lam_se.j[names(lam_se.j)!="Mine"], + linear_se.j, + HardLin = 0, + Water = 0, + Bare = 0, + SnowIce = 0, + Mine = 0, + MineV = unname(lam_se.j["Mine"])) + names(se.out) <- gsub("Spruce", "WhiteSpruce", names(se.out)) + names(se.out) <- gsub("Decid", "Deciduous", names(se.out)) + names(se.out) <- gsub("Climate.climate", "Climate", names(se.out)) + names(se.out) <- gsub("TreedBog", "BlackSpruce", names(se.out)) + + #14. Transform back and cap values---- + lam.final <- log(lam.out) + lam.final[lam.final > 10^4] <- 10^4 + lam.final[lam.final < -10^4] <- -10^4 + + coef.list[[j]] <- lam.final + + se.final <- log(se.out) + se.final[is.infinite(se.final)] <- 0 + + se.list[[j]] <- se.final + + } + + #15. Make the array if first species---- + if(i==1){ + joint.n <- array(0, c(length(spp), length(coef.list[[j]]), nrow(north.i))) + dimnames(joint.n) <- list(spp, names(coef.list[[j]]), paste0("b", c(1:nrow(north.i)))) + + joint_se.n <- array(0, c(length(spp), length(se.list[[j]]), nrow(north.i))) + dimnames(joint_se.n) <- list(spp, names(se.list[[j]]), paste0("b", c(1:nrow(north.i)))) + } + + #16. Add species to array---- + joint.n[spp[i],,] <- as.matrix(do.call(cbind, coef.list)) + joint_se.n[spp[i],,] <- as.matrix(do.call(cbind, se.list)) + + cat("Finished species", i, "of", length(spp), "\n") + +} + +#17. Truncate NESP climate coef because it blows up the relative abundance prediction---- +joint.n["NESP","Climate",] <- joint.n["NESP","Climate",]*0.1 + +#LANDCOVER MODEL COEFFICIENTS - SOUTH############# + +#1. Get the list of north models---- +south <- mods |> + dplyr::filter(region=="south") + +#2. Get list of species---- +spp <- unique(south$species) + +#3. Get the full list of potential continuous covariates---- +#don't need the categorical ones because they're in every model +names.south <- do.call(rbind, unlist(modelssouth)) |> + data.frame() |> + separate(X3, into=c("X3", "X4", "X5", "X6", "X7", "X8", "X9"), sep = " +") |> + dplyr::select(-X1, -X2, -X3) |> + pivot_longer(cols=X4:X9, names_to="position", values_to="name") |> + dplyr::filter(!is.na(name), name!="+") |> + dplyr::select(-position) |> + unique() |> + mutate(name = fix_names(name)) |> + dplyr::filter(!name %in% c("method", "soilc")) + +#4. Get the full south data---- +covs.s <- dplyr::filter(covs, useSouth==TRUE, !is.na(soilc)) + +#5. Get the model matrix---- +#use formula from north section above +Xs <- model.matrix(get_terms(modelssouth), covs.s) +colnames(Xs) <- fix_names(c("Intercept", colnames(Xs)[-1])) + +#6. Set up loop---- +for(i in 1:length(spp)){ + + #7. List of models for that species---- + south.i <- dplyr::filter(south, species==spp[i]) + + coef.list <- list() + se.list <- list() + for(j in 1:nrow(south.i)){ + + #9. Get the raw coefficients----- + #Add zeros for any covariates that weren't in the best model + coef.j <- read.csv(south.i$path[j]) |> + mutate(name = fix_names(name), + name = ifelse(name=="(Intercept)", "Intercept", name)) |> + full_join(data.frame(name = names.south$name)) |> + mutate(coef = ifelse(is.na(coef), 0, coef), + se = ifelse(is.na(se), 0, se)) |> + suppressMessages() + + raw.j <- coef.j$coef + names(raw.j) <- coef.j$name + + raw_se.j <- coef.j$se + names(raw_se.j) <- coef.j$name + + #10. Transform the soil estimates and handle intercept---- + names.soil <- c("soilcBlowout", "soilcClaySub", "soilcCrop", + "soilcIndustrial", "soilcMine", "soilcOther", "soilcRapidDrain", + "soilcRoughP", "soilcRural", "soilcSandyLoam", "soilcSoilUnknown", + "soilcTameP", "soilcThinBreak", "soilcUrban", "soilcWater", "soilcWellsites") + + lam.soil <- exp(c(raw.j[1], raw.j[1] + raw.j[names.soil])) + names(lam.soil) <- levels(covs.s$soilc) + + lam_se.soil <- exp(c(raw_se.j[1], raw_se.j[1] + raw_se.j[names.soil])) + names(lam_se.soil) <- levels(covs.s$soilc) + + #11. Adjust the linear feature and well coefficients---- + + #Human-modified landcover types that we don't want interfering with adjustment + hfc <- c("Crop", "Industrial", "Mine", "RoughP", "Rural", "TameP", "Urban") + + #Dataframe of variables to adjust + vars <- data.frame(var = c("mWell", "mSoft")) + + for(k in 1:nrow(vars)){ + + #Make a mock dataframe for the variable + zero.k <- data.frame(var = 0) + colnames(zero.k) <- vars$var[k] + + #Get the rows of interest from the model matrix + #> 0 proportion of variable, no human-modified landover type, no harvest + rows.k <- covs.s |> + mutate(rowid = row_number()) |> + anti_join(zero.k) |> + dplyr::filter(!vegc %in% hfc) |> + suppressMessages() + + Xs.k <- Xs[rows.k$rowid,] + + #Make predictions from those rows using the raw coefficient + lam.k <- exp(Xs.k %*% raw.j[colnames(Xs)]) + + #Multiply transformed coefficient by those predictions and take the mean + vars$est[k] <- mean(lam.k * exp(raw.j[vars$var[k]])) + + #Add some extra tracking information + vars$n[k] <- nrow(rows.k) + vars$original[k] <- exp(raw.j[vars$var[k]]) + + } + + #12. Cap open habitat values---- + #Get maximum lambda for open habitat types + lam.open <- max(lam.soil[c("Loamy", "Blowout", "ClaySub", "RapidDrain", "SandyLoam", "ThinBreak", "Other")]) + + #Get maximum lambda for open human footprint types + lam.hf <- max(lam.soil[c("Industrial", "Rural", "Urban")]) + + #Overall cap value + lam.max <- max(lam.open, lam.hf) + + #Cap the linear features---- + linear <- vars |> + rowwise() |> + mutate(capped = min(est, lam.max)) |> + ungroup() |> + mutate(cap_open = lam.open, + cap_hf = lam.hf, + cap_total = lam.max, + species = spp[i], + boot = j, + name = c("Wellsites", "EnSoft")) + + linear.j <- linear$capped + names(linear.j) <- linear$name + + #13. Put together---- + lam.out <- c(Climate = exp(raw.j["climate"]), + lam.soil[!names(lam.soil) %in% c("Mine", "Water", "Wellsites")], + pAspen = exp(unname(raw.j["paspen"])), + Wellsites = linear$capped[1], + EnSeismic = linear$capped[2], + EnSoftLin = linear$capped[2], + TrSoftLin = linear$capped[2], + HardLin = 0, + Water = 0, + Mine = 0, + MineV = unname(lam.soil["Mine"])) + names(lam.out) <- gsub("Climate.climate", "Climate", names(lam.out)) + + se.out <- c(Climate = exp(raw_se.j["climate"]), + lam_se.soil[!names(lam_se.soil) %in% c("Mine", "Water", "Wellsites")], + Wellsites = exp(raw_se.j["mWell"]), + EnSeismic = exp(raw_se.j["mSoft"]), + EnSoftLin = exp(raw_se.j["mSoft"]), + TrSoftLin = exp(raw_se.j["mSoft"]), + HardLin = 0, + Water = 0, + Mine = 0, + MineV = unname(lam_se.soil["Mine"])) + names(se.out) <- gsub("Climate.climate", "Climate", names(se.out)) + + #14. Transform back and cap values---- + lam.final <- log(lam.out) + lam.final[lam.final > 10^4] <- 10^4 + lam.final[lam.final < -10^4] <- -10^4 + + coef.list[[j]] <- t(lam.final) + + se.final <- log(se.out) + se.final[is.infinite(se.final)] <- 0 + + se.list[[j]] <- t(se.final) + + } + + #15. Make the array if first species---- + if(i==1){ + joint.s <- array(0, c(length(spp), length(coef.list[[j]]), nrow(south.i))) + dimnames(joint.s) <- list(spp, names(lam.final), paste0("b", c(1:nrow(south.i)))) + + joint_se.s <- array(0, c(length(spp), length(se.list[[j]]), nrow(south.i))) + dimnames(joint_se.s) <- list(spp, names(se.final), paste0("b", c(1:nrow(south.i)))) + } + + #16. Add species to array---- + joint.s[spp[i],,] <- as.matrix(do.call(cbind, coef.list)) + joint_se.s[spp[i],,] <- as.matrix(do.call(cbind, se.list)) + + cat("Finished species", i, "of", length(spp), "\n") + +} + +#17. Truncate NESP climate coef because it blows up the relative abundance prediction---- +joint.n["NESP","Climate",] <- joint.n["NESP","Climate",]*0.1 + +#MEDIAN BOOTSTRAP SELECTION######## + +#1. List of species*region---- +regions <- mods |> + dplyr::select(species, region) |> + unique() + +todo <- regions |> + dplyr::select(species) |> + unique() + +#2. Set up loop---- +boots <- data.frame() +for(i in 1:nrow(todo)){ + + #3. Settings---- + spp.i <- todo$species[i] + regions.i <- regions |> + dplyr::filter(species==spp.i) + region.i <- ifelse(nrow(regions.i)==2, "both", unique(regions.i$region)) + + #4. Get the right matrix---- + if("north" %in% regions.i$region){ + north.i <- t(as.matrix(joint.n[spp.i,,])) + } + if("south" %in% regions.i$region){ + south.i <- t(as.matrix(joint.s[spp.i,,])) + } + + if(region.i=="both"){coefs.i <- cbind(north.i, south.i)} + if(region.i=="north"){coefs.i <- north.i} + if(region.i=="south"){coefs.i <- south.i} + + #5. Run an NMDS---- + set.seed(i) + nmds.i <- metaMDS(coefs.i, k=2, distance="euclidean", trace=0) + + #6. Get the site scores---- + scores.i <- scores(nmds.i, display="sites") + + #7. Calculate centroid---- + centroid.i <- colMeans(scores.i) + + #8. Get distances to centroid---- + dist.i <- data.frame(scores.i) |> + mutate(distance = sqrt((NMDS1-centroid.i[1])^2 + (NMDS2-centroid.i[2])^2)) |> + rownames_to_column() |> + rename(bootstrap = rowname) |> + mutate(bootstrap = as.numeric(str_sub(bootstrap, 2, 3))) + + #9. Get closest bootstrap---- + min.i <- dist.i |> + dplyr::filter(distance==min(distance)) + + boots <- rbind(boots, + min.i |> + mutate(species = spp.i, + region = region.i)) + + cat("Finished nmds", i, "of", nrow(todo), "\n") + + +} + +#MODEL EVALUATION######### + +#1. Peter's AUC functions---- +simple_roc <- function(labels, scores){ + Labels <- labels[order(scores, decreasing=TRUE)] + data.frame( + TPR=cumsum(Labels)/sum(Labels), + FPR=cumsum(!Labels)/sum(!Labels), + Labels=Labels) +} + +simple_auc <- function(ROC) { + ROC$inv_spec <- 1-ROC$FPR + dx <- diff(ROC$inv_spec) + sum(dx * ROC$TPR[-1]) / sum(dx) +} + +#2. Get list of median models---- +loop <- data.frame(path = list.files(file.path(root, "Results", "LandcoverModels", "Models"), full.names = TRUE, pattern="*.Rdata", recursive = TRUE), + file = list.files(file.path(root, "Results", "LandcoverModels", "Models"), pattern="*.Rdata", recursive = TRUE)) |> + separate(file, into=c("region", "sp1", "region2", "species", "bootstrap", "filetype")) |> + mutate(bootstrap = as.numeric(bootstrap)) |> + dplyr::select(-filetype, -region2, -sp1) |> + inner_join(rbind(boots |> + dplyr::filter(region %in% c("north", "south")), + boots |> + dplyr::filter(region=="both") |> + mutate(region="north"), + boots |> + dplyr::filter(region=="both") |> + mutate(region="south")), + by=c("species", "region", "bootstrap")) + +#3. Set up loop---- +loop$AUC_binary <- NA +loop$AUC_poisson <- NA +for(i in 1:nrow(loop)){ + + #4. Load the model---- + load.i <-try(load(loop$path[i])) + if(inherits(load.i, "try-error")){ next } + + #5. Make predictions on training data---- + pred.i <- predict(bestmodel, type="response") + + #6. AUC for binary response---- + bestmodel$binary <- ifelse(bestmodel$y > 1, 1, bestmodel$y) + roc.i <- try(roc(response=bestmodel$binary, predictor=pred.i, quiet=TRUE)) + if(inherits(roc.i, "try-error")){loop$AUC_binary[i] <- NA} else {loop$AUC_binary[i] <- auc(roc.i)} + + #7. AUC for count response---- + roc.p <- simple_roc(labels=bestmodel$y, scores=pred.i) + loop$AUC_poisson[i] <- simple_auc(roc.p) + + cat("Finished model ", i, "of", nrow(loop), "\n") + + +} + +#8. Tidy---- +auc.out <- loop +rm(loop) + +#PACKAGING########## + +#1. Change array names from code to common name---- + +#Get lookup table +birdnames <- read.csv(file.path(root, "Data", "lookups", "birdlist.csv")) + +#Match +birdnames.m <- birdnames |> + arrange(code) |> + dplyr::filter(code %in% dimnames(marginal)[[1]]) + +birdnames.n <- birdnames |> + arrange(code) |> + dplyr::filter(code %in% dimnames(joint.n)[[1]]) + +birdnames.s <- birdnames |> + arrange(code) |> + dplyr::filter(code %in% dimnames(joint.s)[[1]]) + +#Replace +dimnames(marginal) <- list(birdnames.m$sppid, dimnames(marginal)[[2]], dimnames(marginal)[[3]]) + +dimnames(marginal_se) <- list(birdnames.m$sppid, dimnames(marginal_se)[[2]], dimnames(marginal)[[3]]) + +dimnames(joint.n) <- list(birdnames.n$sppid, dimnames(joint.n)[[2]], dimnames(marginal)[[3]]) + +dimnames(joint_se.n) <- list(birdnames.n$sppid, dimnames(joint_se.n)[[2]], dimnames(marginal)[[3]]) + +dimnames(joint.s) <- list(birdnames.s$sppid, dimnames(joint.s)[[2]], dimnames(marginal)[[3]]) + +dimnames(joint_se.s) <- list(birdnames.s$sppid, dimnames(joint_se.s)[[2]], dimnames(marginal)[[3]]) + +#2. Bird look up table----- + +#Get the show details +birds2024 <- read.csv(file.path(root, "Data", "lookups", "birds-v2024.csv")) |> + rename(species = common) |> + dplyr::select(species, show) + +#Get the occurrence totals +occurrence <- bird |> + pivot_longer(ALFL:YRWA, names_to="code", values_to="count") |> + dplyr::filter(count > 0) |> + group_by(code) |> + summarize(Occurrences = n()) |> + ungroup() + +#Get the AUC values +auc <- auc.out |> + rename(code = species) |> + group_by(code, region) |> + summarize(AUC = mean(AUC_poisson)) |> + ungroup() |> + pivot_wider(names_from="region", values_from=c("AUC")) + +#Wrangle the median bootstrap +bootuse <- boots |> + dplyr::select(species, bootstrap) |> + rename(code = species) + +#set species to remove +spp.remove <- c("VEER", "LEYE") + +#set different plot truncation quantile species +q990 <- c("NOFL", "BTNW", "BLPW", "CEDW", "CMWA", "COGR", "EAPH", "HOSP", "PUFI", "SOSP", "WBNU", "YHBL", "YRWA") +q999 <- c("BLBW", "MOCH", "WCSP") + +#Make the table +birdtable <- birdnames |> + dplyr::filter(sppid %in% dimnames(joint.n)[[1]] | sppid %in% dimnames(joint.s)[[1]]) |> + left_join(birds2024) |> + left_join(occurrence) |> + left_join(auc) |> + left_join(bootuse) |> + mutate(ModelNorth = ifelse(show %in% c("c", "n"), TRUE, FALSE), + ModelSouth = ifelse(show %in% c("c", "s"), TRUE, FALSE), + LinkHabitat = "log", + LinkSpclim = "log", + Group = "birds", + Nonnative = FALSE, + Use = ifelse(code %in% spp.remove, FALSE, TRUE), + PlotQuantile = case_when(code %in% q990 ~ 0.990, + code %in% q999 ~ 0.999, + !is.na(code) & Use==TRUE ~ 0.995)) |> + rename(SpeciesID = sppid, + ScientificName = scinam, + CommonName = species, + Comments = code) |> + rename(AUCNorth = north, AUCSouth = south, Bootstrap = bootstrap) |> + dplyr::select(SpeciesID, ScientificName, CommonName, ModelNorth, ModelSouth, Occurrences, Nonnative, LinkHabitat, LinkSpclim, AUCNorth, AUCSouth, Bootstrap, Comments, Group, Use, PlotQuantile) + +#3. Put together---- +birds <- list( + north = list(marginal = marginal, marginal_se = marginal_se, joint = joint.n, joint_se = joint_se.n), + south = list(marginal = marginal, marginal_se = marginal_se, joint = joint.s, joint_se = joint_se.s), + species = birdtable +) + +#4. Save---- +save(birds, file=file.path(root, "Results", "Birds2024.RData")) diff --git a/0_data/v2_scripts/birds/src/09.Predict.R b/0_data/v2_scripts/birds/src/09.Predict.R new file mode 100644 index 0000000..104cc20 --- /dev/null +++ b/0_data/v2_scripts/birds/src/09.Predict.R @@ -0,0 +1,247 @@ +# --- +# title: ABMI models - make model predictions +# author: Elly Knight +# created: Sept 25, 2024 +# --- + +#NOTES################################ + +#Adapted from Brandon Allen's prediction script. + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling +library(Matrix) #sparse matrices +library(abind) #binding arrays +library(sf) #shapefiles +library(gridExtra) #plotting + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Load the coefficients---- +load(file.path(root, "Results", "Birds2024.RData")) + +#5. Define link functions---- +inv.link <- function (eta) {pmin(pmax(exp(eta), .Machine$double.eps), .Machine$double.xmax)} +link <- poisson()$linkfun + +#6. Load the kgrid & backfill---- +load(file.path(root, "Data", "gis", "kgrid_2.2.Rdata")) +load(file.path(root, "Data", "gis", "backfillV7_w2w_2021HFI.Rdata")) + +#7. Load BA's functions---- +source("src/00.Functions.R") + +#8. Load lookups---- +veg.lookup <- read.csv(file.path(root, "Data", "lookups", "lookup-veg-hf-age-v2020.csv")) +soil.lookup <- read.csv(file.path(root, "Data", "lookups", "lookup-soil-hf-v2020.csv")) + +#WRANGLING########## + +#1. Add intercept to climate kgrid---- +kgrid$Intercept <- 1 + +#2. Add easting and northing derived columns +kgrid$Easting2 <- kgrid$Easting^2 +kgrid$Northing2 <- kgrid$Northing^2 +kgrid$EastingNorthing <- kgrid$Easting*kgrid$Northing + +#2. Standardize veg & soil kgrid, convert to proportions, and add climate vars---- + +#Current veg +veg.cur.raw <- landscape_hf_summary(data.in = as.data.frame(as.matrix(d.wide$veg.current)), + landscape.lookup = veg.lookup, + class.in = "ID", class.out = "UseInAnalysis_Simplified") + +veg.cur <- data.frame(veg.cur.raw/rowSums(veg.cur.raw)) |> + mutate(LinkID = row.names(veg.cur.raw)) |> + left_join(kgrid, by= "LinkID") +row.names(veg.cur) <- veg.cur$LinkID + +#Current soil +soil.cur.raw <- landscape_hf_summary(data.in = as.data.frame(as.matrix(d.wide$soil.current)), + landscape.lookup = soil.lookup, + class.in = "ID", class.out = "UseInAnalysis_Simplified") + +soil.cur <- data.frame(soil.cur.raw/rowSums(soil.cur.raw)) |> + mutate(LinkID = row.names(soil.cur.raw)) |> + left_join(kgrid, by="LinkID") +row.names(soil.cur) <- soil.cur$LinkID + +#3. Simplify bird coefficients for kgrid predictions---- +#Take mean of the treed fen coeffs in north +#Take mean of urban & industrial for both +#Take mean of mine and minev for both + +#Get the offending coeffs +treedfen.all <- birds$north$joint[,c("TreedFenR", "TreedFen1", "TreedFen2", "TreedFen3", "TreedFen4", "TreedFen5", "TreedFen6", "TreedFen7", "TreedFen8"),] +urbind.n.all <- birds$north$joint[,c("Urban", "Industrial"),] +urbind.s.all <- birds$south$joint[,c("Urban", "Industrial"),] + +#Take the means for the north +means.n <- array(0, c(dim(birds$north$joint)[1], 2, dim(birds$north$joint)[3])) +for(i in 1:dim(treedfen.all)[3]){ + means.n[,1,i] <- rowMeans(treedfen.all[,,i]) + means.n[,2,i] <- rowMeans(urbind.n.all[,,i]) +} + +#Take the means for the south +means.s <- array(0, c(dim(birds$south$joint)[1], 1, dim(birds$south$joint)[3])) +for(i in 1:dim(urbind.s.all)[3]){ + means.s[,1,i] <- rowMeans(urbind.s.all[,,i]) +} + +#Rename +dimnames(means.n) <- list(dimnames(birds$north$joint)[[1]], c("TreedFen", "UrbInd"), dimnames(birds$north$joint)[[3]]) + +dimnames(means.s) <- list(dimnames(birds$south$joint)[[1]], c("UrbInd"), dimnames(birds$south$joint)[[3]]) + +#Remove the unwanted +removed.n <- birds$north$joint[,!dimnames(birds$north$joint)[[2]] %in% c("TreedFenR", "TreedFen1", "TreedFen2", "TreedFen3", "TreedFen4", "TreedFen5", "TreedFen6", "TreedFen7", "TreedFen8", "Urban", "Industrial", "MineV"),] + +removed.s <- birds$south$joint[,!dimnames(birds$south$joint)[[2]] %in% c("Urban", "Industrial", "MineV"),] + +#Put back together +northjoint <- abind(removed.n, means.n, along = 2) +southjoint <- abind(removed.s, means.s, along = 2) + +#4. Some renaming---- +dimnames(northjoint)[[2]] <- gsub("GrassHerb", "Grass", dimnames(northjoint)[[2]]) +dimnames(southjoint)[[2]] <- gsub("GrassHerb", "Grass", dimnames(southjoint)[[2]]) + +#MAKE PREDICTIONS########## + +#1. List of spp---- +#use the median Bootstrap from the birdlist object +spp <- birds$species |> + dplyr::filter(!(ModelNorth==FALSE & ModelSouth==FALSE)) |> + mutate(label=paste0(Comments, "_", Bootstrap)) + +#2. Set up loop---- +predictions <- list() +for(i in 1:nrow(spp)){ + + #3. Determine if the spp is north, south, or both---- + mod.i <- case_when(spp$ModelNorth[i]==TRUE & spp$ModelSouth[i]==TRUE ~ "both", + spp$ModelNorth[i]==TRUE & spp$ModelSouth[i]==FALSE ~ "north", + spp$ModelNorth[i]==FALSE & spp$ModelSouth[i]==TRUE ~ "south") + + #4. Get the coefficients---- + if(mod.i %in% c("both", "north")){ + climate.i <- birds$north$marginal[spp$SpeciesID[i],,spp$Bootstrap[i]] + } + + if(mod.i=="south"){ + climate.i <- birds$south$marginal[spp$SpeciesID[i],,spp$Bootstrap[i]] + } + + #5. Make predictions---- + + #Get the climate variables + use.climate <- kgrid |> + dplyr::select(names(climate.i)) |> + as.matrix() + rownames(use.climate) <- kgrid$LinkID + + #make the climate predictions + raw.climate <- matrix(inv.link(drop(use.climate %*% climate.i)), + ncol=1, + dimnames = list(rownames(use.climate), "Climate")) + + q99 <- quantile(raw.climate, 0.99) + pred.climate <- ifelse(raw.climate > q99, q99, raw.climate) + + #get the veg coefficients and make veg predictions + if(mod.i %in% c("both", "north")){ + + #Get the coefficients + vegclim.i <- northjoint[spp$SpeciesID[i],,spp$Bootstrap[i]] + veg.i <- vegclim.i[names(vegclim.i)!="Climate"] + + #Get the kgrid veg data, but take out climate + use.veg <- veg.cur |> + dplyr::select(names(veg.i)) |> + as.matrix() + + #predict the joint climate contribution + joint.climate.veg <- matrix(pred.climate * vegclim.i["Climate"], + ncol = ncol(use.veg), nrow = nrow(use.veg)) + + #Create climate adjusted veg covariates + veg.coef <- t(t(joint.climate.veg) + veg.i) + colnames(veg.coef) <- names(veg.i) + + #prediction + veg.cur$Veg <- rowSums(use.veg * inv.link(veg.coef)) + + if(mod.i=="north"){soil.cur$Soil <- 0} + + } + + #get the soil coefficients and make soil predictions + if(mod.i %in% c("both", "south")){ + + # #Get the coefficients + soilclim.i <- southjoint[spp$SpeciesID[i],,spp$Bootstrap[i]] + soil.i <- soilclim.i[!names(soilclim.i) %in% c("Climate", "pAspen")] + + #Get the kgrid soil data + use.soil <- soil.cur |> + dplyr::select(names(soil.i)) |> + as.matrix() + + #get the paspen + paspen.pred <- kgrid$pAspen + + #predict the joint climate contribution + joint.climate.soil <- matrix(pred.climate * soilclim.i["Climate"], + ncol = ncol(use.soil), nrow = nrow(use.soil)) + + #predict the joint paspen contribution + joint.paspen.soil <- matrix(paspen.pred * soilclim.i["pAspen"], + ncol = ncol(use.soil), nrow = nrow(use.soil)) + + #put together + joint.soil <- joint.climate.soil + joint.paspen.soil + + #Create climate adjusted soil covariates + soil.coef <- t(t(joint.soil) + soil.i) + + #prediction + soil.cur$Soil <- rowSums(use.soil * inv.link(soil.coef)) + + if(mod.i=="south"){veg.cur$Veg <- 0} + + } + + #6. Combine & store---- + q <- spp$PlotQuantile[i] + predictions[[i]] <- try(data.frame(Climate = pred.climate, + Veg = veg.cur$Veg, + Soil = soil.cur$Soil, + wN = veg.cur$wN, + wS = veg.cur$wS, + LinkID = veg.cur$LinkID) |> + mutate(Veg = ifelse(is.infinite(Veg), median(Veg), Veg), + Soil = ifelse(is.infinite(Soil), median(Soil), Soil)) |> + mutate(Provincial = Veg*wN + Soil*wS, + Soil = ifelse(wS==0, 0, Soil), + Veg = ifelse(wN==0, 0, Veg), + species = spp$Comments[i], + speciesname = spp$SpeciesID[i], + Bootstrap = spp$Bootstrap[i]) |> + mutate(Provincial = ifelse(Provincial > quantile(Provincial, q), quantile(Provincial, q), Provincial))) + + cat("Finished", spp$Comments[i], "predictions :", i, "of", nrow(spp), "\n") + +} + +names(predictions) <- spp$Comments + +#7. Save---- +save(predictions, file=file.path(root, "Results", "Predictions2024.RData")) diff --git a/0_data/v2_scripts/birds/src/10.Visualize.R b/0_data/v2_scripts/birds/src/10.Visualize.R new file mode 100644 index 0000000..f9880cf --- /dev/null +++ b/0_data/v2_scripts/birds/src/10.Visualize.R @@ -0,0 +1,236 @@ +# --- +# title: ABMI models - plot predictions +# author: Elly Knight +# created: Sept 25, 2024 +# --- + +#NOTES################################ + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling +library(Matrix) #sparse matrices +library(terra) #rasters +library(sf) #polygons +library(gridExtra) #plotting +library(ebirdst) #ebird predictions +library(auk) #ebird codes + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Load the new coefficients---- +new <- new.env() +load(file.path(root, "Results", "Birds2024.RData"), envir=new) + +#5. Load the old coefficients---- +old <- new.env() +load(file.path(root, "Results", "Archive", "2023", "Birds2023.RData"), envir=old) + +#6. Load the data---- +load(file.path(root, "Data", "Stratified.Rdata")) + +#7. Load the kgrids---- +load(file.path(root, "Data", "gis", "kgrid_2.2.Rdata")) + +#4. Get the new predictions & kgrid---- +load(file.path(root, "Results", "Predictions2024.RData")) + +#KGRID PREDICTIONS####### + +#1. Get the eBird codes---- +codes <- get_ebird_taxonomy() + +#2. Species list---- +spp <- inner_join(new$birds$species |> + dplyr::filter(ModelNorth==TRUE | ModelSouth==TRUE) |> + dplyr::select(Comments), + old$birds$species |> + dplyr::filter(ModelNorth==TRUE | ModelSouth==TRUE) |> + dplyr::select(Comments, ScientificName)) |> + rename(species = Comments) |> + mutate(scientific_name = ScientificName, + ScientificName = str_replace_all(ScientificName, " ", "-"), + scientific_name = case_when(scientific_name=="Ammodramus bairdii" ~ "Centronyx bairdii", + scientific_name=="Picoides pubescens" ~ "Dryobates pubescens", + scientific_name=="Picoides villosus" ~ "Dryobates villosus", + scientific_name=="Ammodramus nelsoni" ~ "Ammospiza nelsoni", + scientific_name=="Oreothlypis celata" ~ "Leiothlypis celata", + scientific_name=="Carpodacus purpureus" ~ "Haemorhous purpureus", + scientific_name=="Regulus calendula" ~ "Corthylio calendula", + scientific_name=="Oreothlypis peregrina" ~ "Leiothlypis peregrina", + !is.na(scientific_name) ~ scientific_name)) |> + left_join(codes) + +#3. Get the eBird predictions---- +#only need to do this once +# for(i in 1:nrow(spp)){ +# +# ebirdst_download_status(species = spp$species_code[i], +# download_abundance = TRUE, +# download_ranges = FALSE, +# force=TRUE, +# pattern = "abundance_seasonal_mean_3km") +# } + +#4. Get an alberta border for cropping---- +ab <- read_sf(file.path(root, "Data", "gis", "lpr_000b21a_e.shp")) |> + dplyr::filter(PRNAME=="Alberta") |> + st_transform(crs(load_raster(spp$species_code[1], product="abundance", period="seasonal", resolution="3km"))) |> + vect() + +#6. Set up species loop---- +out <- data.frame() +for(i in 1:nrow(spp)){ + + #7. Load the old raster---- + pred.old <- try(rast(file.path(root, "PreviousModelRasters", paste0(spp$ScientificName[i], ".tif")))$Current) + + #8. Get the new rasters---- + pred.i <- predictions[[spp[i,]$species]] + + if(class(pred.i)=="try-error"){next} + + #9. Get the landcover prediction---- + pred.new <- pred.i |> + left_join(kgrid, by="LinkID") |> + dplyr::select(X, Y, Provincial) |> + raster::rasterFromXYZ(crs=3400) |> + rast() + + #10. Get the climate prediction---- + clim <- pred.i |> + left_join(kgrid, by="LinkID") |> + dplyr::select(X, Y, Climate) |> + raster::rasterFromXYZ(crs=3400) |> + rast() + + #11. Load eBird and crop---- + if(class(pred.old)!="try-error"){ + pred.ebd.raw <-load_raster(spp$species_code[i], period="seasonal", resolution="3km", product="abundance") + if("breeding" %in% names(pred.ebd.raw)){ + pred.ebd <- pred.ebd.raw[["breeding"]] |> + crop(ab, mask=TRUE) |> + project(crs(pred.old)) |> + resample(pred.old, method="bilinear") + } + if("resident" %in% names(pred.ebd.raw)){ + pred.ebd <- pred.ebd.raw[["resident"]] |> + crop(ab, mask=TRUE) |> + project(crs(pred.old)) |> + resample(pred.old, method="bilinear") + } + } + + #12. Stack them---- + if(class(pred.old)!="try-error"){ + pred <- c(pred.old, pred.new, clim, pred.ebd) + names(pred) <- c("old", "new", "climate", "ebird") + } else { + pred <- c(pred.new, clim) + names(pred) <- c("new", "climate") + } + + #14. Pearson correlation---- + cor <- layerCor(pred, "cor") + + #15. Difference in population size---- + pop <- global(pred, fun="sum", na.rm=TRUE) + + #16. Wrangle---- + if(class(pred.old)!="try-error"){ + out <- data.frame(species = spp$species[i], + cor_oldnew = cor$correlation["old", "new"], + cor_oldebd = cor$correlation["old", "ebird"], + cor_newebd = cor$correlation["new", "ebird"], + pop.old = pop["old",], + pop.new = pop["new",]) |> + rbind(out) + } else { + out <- data.frame(species = spp$species[i], + cor_oldnew = NA, + cor_oldebd = NA, + cor_newebd = NA, + pop.old = NA, + pop.new = pop["new",]) |> + rbind(out) + } + + #17. Get a bootstrap of data points to plot---- + pts <- bird |> + dplyr::filter(surveyid %in% boot$'1') |> + dplyr::select(surveyid, spp$species[i]) |> + left_join(covs |> + dplyr::select(surveyid, Easting, Northing)) + colnames(pts) <- c("surveyid", "count", "Easting", "Northing") + + #17. Plot---- + pred.plotdf <- as.data.frame(pred, xy=TRUE) |> + pivot_longer(-c(x, y), names_to="layer", values_to="value") + + if(class(pred.old)!="try-error"){ + old.plot <- ggplot(pred.plotdf |> dplyr::filter(layer=="old")) + + geom_raster(aes(x=x, y=y, fill=value)) + + scale_fill_viridis_c() + + theme(legend.position = "bottom", + axis.title = element_blank(), + axis.text = element_blank()) + + ggtitle("Old prediction") + + ebd.plot <- ggplot(pred.plotdf |> dplyr::filter(layer=="ebird")) + + geom_raster(aes(x=x, y=y, fill=value)) + + scale_fill_viridis_c() + + theme(legend.position = "bottom", + axis.title = element_blank(), + axis.text = element_blank()) + + ggtitle("eBird prediction") + + } + + new.plot <- ggplot(pred.plotdf |> dplyr::filter(layer=="new")) + + geom_raster(aes(x=x, y=y, fill=value)) + + scale_fill_viridis_c() + + theme(legend.position = "bottom", + axis.title = element_blank(), + axis.text = element_blank()) + + ggtitle("New prediction - packaged") + + clim.plot <- ggplot(pred.plotdf |> dplyr::filter(layer=="climate")) + + geom_raster(aes(x=x, y=y, fill=value)) + + scale_fill_viridis_c() + + theme(legend.position = "bottom", + axis.title = element_blank(), + axis.text = element_blank()) + + ggtitle("Climate prediction - packaged") + + pts.plot <- ggplot(pred.plotdf |> dplyr::filter(layer=="ebird")) + + geom_raster(aes(x=x, y=y), fill="white") + + geom_point(data=dplyr::filter(pts, count > 0), + aes(x=Easting, y=Northing, colour=count)) + + scale_colour_viridis_c() + + theme(legend.position = "bottom", + axis.title = element_blank(), + axis.text = element_blank()) + + ggtitle("Detections") + + if(class(pred.old)!="try-error"){ + ggsave(grid.arrange(clim.plot, new.plot, old.plot, ebd.plot, pts.plot, + ncol=5, nrow=1, top=spp$species[i]), + filename = file.path(root, "Results", "Plots", paste0(spp$species[i], ".jpeg")), + width = 14, height = 6, device="jpeg") + } else { + ggsave(grid.arrange(clim.plot, new.plot, pts.plot, + ncol=3, nrow=1, top=spp$species[i]), + filename = file.path(root, "Results", "Plots", paste0(spp$species[i], ".jpeg")), + width = 9, height = 6, device="jpeg") + } + + cat("Finished", spp$species[i], "predictions :", i, "of", nrow(spp), "\n") + +} + +write.csv(out, file.path(root, "Results", "ModelComparison.csv"), row.names = FALSE) diff --git a/0_data/v2_scripts/birds/src/11.Compare.R b/0_data/v2_scripts/birds/src/11.Compare.R new file mode 100644 index 0000000..73eb3c2 --- /dev/null +++ b/0_data/v2_scripts/birds/src/11.Compare.R @@ -0,0 +1,109 @@ +# --- +# title: ABMI models - compare versions +# author: Elly Knight +# created: Sept 25, 2024 +# --- + +#NOTES################################ + +#PREAMBLE############################ + +#1. Load packages---- +library(tidyverse) #basic data wrangling +library(Matrix) #sparse matrices + +#2. Set root path for data on google drive---- +root <- "G:/Shared drives/ABMI_RHedley/Projects/BirdModels" + +#3. Restrict scientific notation---- +options(scipen = 99999) + +#4. Load the new coefficients---- +new <- new.env() +load(file.path(root, "Results", "Birds2024.RData"), envir=new) + +#5. Load the old coefficients---- +old <- new.env() +load(file.path(root, "Results", "Archive", "2023", "Birds2023.RData"), envir=old) + +#6. Output from visualization script---- +out <- read.csv(file.path(root, "Results", "ModelComparison.csv")) + +#MODEL EVALUATION#### + +#1. Wrangle---- +auc <- old$birds$species |> + dplyr::select(Comments, AUCNorth, AUCSouth) |> + mutate(version = "old") |> + rbind(new$birds$species |> + dplyr::select(Comments, AUCNorth, AUCSouth) |> + mutate(version = "new")) |> + dplyr::filter(!(is.na(AUCNorth) & is.na(AUCSouth))) |> + mutate(model = case_when(is.na(AUCNorth) ~ "south", + is.na(AUCSouth) ~ "north", + !is.na(AUCNorth) & !is.na(AUCSouth) ~ "both")) |> + pivot_longer(cols = AUCNorth:AUCSouth, names_to="Region", values_to="AUC", names_prefix = "AUC") |> + pivot_wider(names_from=version, values_from=AUC) |> + dplyr::filter(!is.na(old) & !is.na(new)) + +#2. Plot against each other---- +ggplot(auc) + + geom_text(aes(x=old, y=new, label=Comments, colour = model)) + + geom_abline(aes(intercept=0, slope=1), linetype="dashed") + + facet_wrap(~Region) + +#3. Plot totals---- +ggplot(pivot_longer(auc, old:new, names_to="version", values_to="AUC")) + + geom_violin(aes(x=version, y=AUC)) + +ggplot(pivot_longer(auc, old:new, names_to="version", values_to="AUC")) + + geom_violin(aes(x=version, y=AUC, fill=model)) + +#POPULATION SIZE########### + +#1. Define species with unreasonable population sizes in old version ---- +remove <- c("MAGO", "LASP", "SAVS", "CCLO", "BANS", "LBCU", "BRBL") + +#2. Correlation---- +ggplot(out |> dplyr::filter(!species %in% remove)) + + geom_text(aes(x=pop.old, y=pop.new, label=species, colour=cor_oldnew)) + + geom_abline(aes(intercept=0, slope=1), linetype="dashed") + + scale_colour_viridis_c() + +#3. Correlation log scale---- +ggplot(out |> dplyr::filter(!species %in% remove)) + + geom_text(aes(x=log(pop.old), y=log(pop.new), label=species, colour=cor_oldnew)) + + geom_abline(aes(intercept=0, slope=1), linetype="dashed") + + scale_colour_viridis_c() + +#4. Histograms---- +ggplot(out |> dplyr::filter(!species %in% remove)) + + geom_histogram(aes(x=pop.old)) + +ggplot(out |> dplyr::filter(!species %in% remove)) + + geom_histogram(aes(x=pop.new)) + +#5. Boxplot---- +ggplot(out |> pivot_longer(pop.old:pop.new, names_to="version", values_to="males") |> + dplyr::filter(!species %in% remove)) + + geom_boxplot(aes(x=version, y=log(males))) + +#SPATIAL CORRELATION########### + +#1. Put together with AUC---- +out_auc <- auc |> + rename(species = Comments) |> + inner_join(out) |> + mutate(auc_diff = new - old) + +#2. Old vs new vs AUC ---- +ggplot(out_auc) + + geom_text(aes(x=cor_oldnew, y=auc_diff, label=species)) + +#3. EBird correlation ---- +ggplot(out_auc) + + geom_text(aes(x=cor_oldebd, y=cor_newebd, label=species)) + + geom_abline(aes(intercept=0, slope=1), linetype="dashed") + +ggplot(out_auc |> pivot_longer(cor_oldebd:cor_newebd, names_to="version", values_to="corr")) + + geom_boxplot(aes(x=version, y=corr)) diff --git a/0_data/v2_scripts/birds/temp_functions/wt_make_wide_fixed.R b/0_data/v2_scripts/birds/temp_functions/wt_make_wide_fixed.R new file mode 100644 index 0000000..fafdec1 --- /dev/null +++ b/0_data/v2_scripts/birds/temp_functions/wt_make_wide_fixed.R @@ -0,0 +1,72 @@ + +#Version taken from Elly's Feb 2 PR, which was subsequently over-written. + + +#' Convert to a wide survey by species dataframe +#' +#' @description This function converts a long-formatted report into a wide survey by species dataframe of abundance values. +#' +#' @param data WildTrax main report or tag report from the `wt_download_report()` function. +#' @param sound Character; vocalization type(s) to retain ("all", "Song", "Call", "Non-vocal"). Can be used to remove certain types of detections. Defaults to "all" (i.e., no filtering). +#' +#' @import dplyr +#' @importFrom tidyr pivot_wider +#' @export +#' +#' @examples +#' \dontrun{ +#' dat.tidy <- wt_tidy_species(dat) +#' dat.tmtt <- wt_replace_tmtt(dat.tidy) +#' dat.wide <- wt_make_wide(dat.tmtt, sound="all") +#' } +#' @return A dataframe identical to input with observations of the specified groups removed. + +wt_make_wide_fixed <- function(data, sound="all"){ + + #Steps for ARU data + if(!"survey_url" %in% colnames(data)){ + + #Filter to first detection per individual + summed <- data |> + group_by(organization, project_id, location, recording_date_time, task_method, task_is_complete, observer_id, species_code, species_common_name, individual_order) |> + mutate(first = min(detection_time)) |> + ungroup() |> + filter((species_code != "NONE" & detection_time == first) | species_code == "NONE") + + #Remove undesired sound types + if(!"all" %in% sound){ + sound <- gsub("\\b(\\w)", "\\U\\1", tolower(sound), perl = TRUE) + summed <- filter(summed, vocalization %in% sound) + } + + #Make it wide + wide <- summed |> + mutate(abundance = case_when(is.na(abundance) & species_code == "NONE" ~ "0", grepl("^C", abundance) ~ NA_character_, TRUE ~ as.character(abundance)) |> as.numeric()) |> + pivot_wider(id_cols = organization:task_method, + names_from = "species_code", + values_from = "abundance", + values_fn = sum, + values_fill = 0, + names_sort = TRUE) + + } + + #Steps for point count data + if("survey_url" %in% colnames(data)){ + + #Make it wide and return field names to point count format + wide <- data |> + rename(abundance = individual_count) |> + mutate(abundance = case_when(is.na(abundance) & species_code == "NONE" ~ "0", grepl("^C", abundance) ~ NA_character_, TRUE ~ as.character(abundance)) |> as.numeric()) |> + pivot_wider(id_cols = organization:survey_duration_method, + names_from = "species_code", + values_from = "abundance", + values_fn = sum, + values_fill = 0, + names_sort = TRUE) + + } + + return(wide) + +} \ No newline at end of file diff --git a/0_data/v2_scripts/birds/temp_functions/wt_replace_tmtt_fixed.R b/0_data/v2_scripts/birds/temp_functions/wt_replace_tmtt_fixed.R new file mode 100644 index 0000000..5ccc31e --- /dev/null +++ b/0_data/v2_scripts/birds/temp_functions/wt_replace_tmtt_fixed.R @@ -0,0 +1,73 @@ + + +#' Replace 'TMTT' abundance with model-predicted values +#' +#' @description This function uses a lookup table of model-predicted values to replace 'TMTT' entries in listener-processed ARU data from WildTrax. The model-predicted values were produced using estimated abundances for 'TMTT' entries in mixed effects model with a Poisson distribution and random effects for species and observer. +#' +#' @param data Dataframe of WildTrax observations, for example the summary report. +#' @param calc Character; method to convert model predictions to integer ("round", "ceiling", or "floor"). See `?round()` for details. +#' +#' @import dplyr +#' @export +#' +#' @examples +#' \dontrun{ +#' dat.tmtt <- wt_replace_tmtt(dat, calc="round") +#' } +#' @return A dataframe identical to input with 'TMTT' entries in the abundance column replaced by integer values. + +wt_replace_tmtt_fixed <- function(data, calc="round"){ + + if(!"recording_date_time" %in% colnames(data)){ + stop("The `wt_replace_tmtt` function only works on data from the ARU sensor") + } + + check_none <- data |> + select(species_code) |> + distinct() |> + pull() + + if (length(check_none) == 1 && check_none == 'NONE') { + stop('There are no species in this project') + } + + .tmtt <- readRDS(system.file("extdata", "tmtt_predictions.rds", package="wildrtrax")) + + dat.tmtt <- mutate(data, id = row_number()) + + # only TMTT rows for replacement + dat.tmt <- dat.tmtt |> filter(abundance %in% c("TMTT", "TNPE")) + + if(nrow(dat.tmt) > 0){ + dat.tmt <- dat.tmt |> + mutate(species_code_temp = species_code) |> + mutate( + species_code = ifelse(species_code %in% .tmtt$species_code, species_code, "species"), + observer_id = as.integer(ifelse(observer_id %in% .tmtt$observer_id, observer_id, 0)) + ) |> + inner_join(.tmtt |> select(species_code, observer_id, pred), + by = c("species_code", "observer_id")) |> + mutate( + abundance = case_when( + calc == "round" ~ round(pred), + calc == "ceiling" ~ ceiling(pred), + calc == "floor" ~ floor(pred), + TRUE ~ NA_real_ + ) + ) |> + mutate(species_code = species_code_temp) |> + select(-pred, -species_code_temp) + } + + # replace TMTT rows with predictions + + dat.tmtt <- dat.tmtt |> + mutate(abundance = case_when(abundance %in% c("TMTT", "TNPE") ~ NA, TRUE ~ abundance)) |> + mutate(abundance = as.numeric(abundance)) |> + rows_update(dat.tmt, by = c("id")) |> + select(-id) + + return(dat.tmtt) +} + + diff --git a/0_data/v2_scripts/birds/temp_functions/wt_tidy_species_fixed.R b/0_data/v2_scripts/birds/temp_functions/wt_tidy_species_fixed.R new file mode 100644 index 0000000..215fd39 --- /dev/null +++ b/0_data/v2_scripts/birds/temp_functions/wt_tidy_species_fixed.R @@ -0,0 +1,210 @@ + +#' Filter species from a report +#' +#' @description This function filters the species provided in WildTrax reports to only the groups of interest. The groups available for filtering are mammal, bird, amphibian, abiotic, insect, and unknown. Zero-filling functionality is available to ensure all surveys are retained in the dataset if no observations of the group of interest are available. +#' +#' @param data WildTrax main report or tag report from the `wt_download_report()` function. +#' @param remove Character; groups to filter from the report ("mammal", "bird", "amphibian", "abiotic", "insect", "human", "unknown"). Defaults to retaining bird group only. +#' @param zerofill Logical; indicates if zerofilling should be completed. If TRUE, unique surveys with no observations after filtering are added to the dataset with "NONE" as the value for species_code and/or species_common_name. If FALSE, only surveys with observations of the retained groups are returned. Default is TRUE. +#' +#' @import dplyr +#' @export +#' +#' @examples +#' \dontrun{ +#' dat.tidy <- wt_tidy_species(dat, remove=c("mammal", "unknown"), zerofill = T) +#' } +#' @return A dataframe identical to input with observations of the specified groups removed. + +wt_tidy_species_fixed_aru <- function(data, + remove = "", + zerofill = TRUE) { + + if (is.null(remove)) { + stop('Not removing any species') + } + + if (any(!(remove %in% c("mammal", "bird", "amphibian", "abiotic", "insect", "human", "unknown")))) { + stop("Select remove options from bird, mammal, amphibian, abiotic, insect, human or unknown.") + } + + if('bird' %in% remove){ + message('Note: By removing birds, you will not be able to use wt_qpad_offsets since QPAD offsets are only available for birds.') + } + + #Convert to the sql database labels for species class + remove <- case_when(remove=="mammal" ~ "MAMMALIA", + remove=="amphibian" ~ "AMPHIBIA", + remove=="abiotic" ~ "ABIOTIC", + remove=="insect" ~ "INSECTA", + remove=="bird" ~ "AVES", + remove=="human" ~ "HUMAN ACTIVITY", + remove=="unknown" ~ "unknown", + remove=="" ~ remove) + + .species <- wt_get_species() + + #Get the species codes for what you want to filter out + species.remove <- .species |> + filter(species_class %in% remove) + + #Add the unknowns if requested + if("unknown" %in% remove){ + species.remove <- .species %>% + filter(substr(species_common_name, 1, 12) == "Unidentified") %>% + rbind(species.remove) + } + + #Remove those codes from the data + filtered <- data |> + filter(!(species_code %in% species.remove$species_code)) + + #if you don't need nones, remove other NONEs & return the filtered object + if(zerofill==FALSE){ + + filtered.sp <- filter(filtered, species_code!="NONE") + + return(filtered.sp) + } + + #if you do need nones, add them + if(zerofill==TRUE){ + + #first identify the unique visits (task_id) ensure locations are included for proper join + visit <- data |> + select(organization, project_id, location, latitude, longitude, location_id, recording_date_time, task_id, task_duration) |> + distinct() + + #see if there are any that have been removed + none <- suppressMessages(anti_join(visit, filtered)) |> + mutate(species_code = "NONE", + species_common_name = "NONE", + species_scientific_name = NA) #Replaced with NA to align with other NONE tags. + + #add to the filtered data + filtered.none <- suppressMessages(full_join(filtered, none)) |> + arrange(organization, project_id, location, recording_date_time) + + #return the filtered object with nones added + return(filtered.none) + + } + +} + + +#' Filter species from a report +#' +#' @description This function filters the species provided in WildTrax reports to only the groups of interest. The groups available for filtering are mammal, bird, amphibian, abiotic, insect, and unknown. Zero-filling functionality is available to ensure all surveys are retained in the dataset if no observations of the group of interest are available. +#' +#' @param data WildTrax main report or tag report from the `wt_download_report()` function. +#' @param remove Character; groups to filter from the report ("mammal", "bird", "amphibian", "abiotic", "insect", "human", "unknown"). Defaults to retaining bird group only. +#' @param zerofill Logical; indicates if zerofilling should be completed. If TRUE, unique surveys with no observations after filtering are added to the dataset with "NONE" as the value for species_code and/or species_common_name. If FALSE, only surveys with observations of the retained groups are returned. Default is TRUE. +#' +#' @import dplyr +#' @export +#' +#' @examples +#' \dontrun{ +#' dat.tidy <- wt_tidy_species(dat, remove=c("mammal", "unknown"), zerofill = T) +#' } +#' @return A dataframe identical to input with observations of the specified groups removed. + +wt_tidy_species_fixed_pc <- function(data, + remove = "", + zerofill = TRUE) { + + if (is.null(remove)) { + stop('Not removing any species') + } + + if (any(!(remove %in% c("mammal", "bird", "amphibian", "abiotic", "insect", "human", "unknown")))) { + stop("Select remove options from bird, mammal, amphibian, abiotic, insect, human or unknown.") + } + + #Rename survey_id to task_id, survey_date to recording_date_time, + #and add empty task_duration + data <- data |> + select(-recording_date_time) |> + rename(task_id=survey_id, + recording_date_time=survey_date) + #If task_duration does not exist, add placeholder with NA. + #This is needed because task_duration was added to list of columns below. + if(!'task_duration' %in% colnames(data)) {data$task_duration <- NA} + + if('bird' %in% remove){ + message('Note: By removing birds, you will not be able to use wt_qpad_offsets since QPAD offsets are only available for birds.') + } + + #Convert to the sql database labels for species class + remove <- case_when(remove=="mammal" ~ "MAMMALIA", + remove=="amphibian" ~ "AMPHIBIA", + remove=="abiotic" ~ "ABIOTIC", + remove=="insect" ~ "INSECTA", + remove=="bird" ~ "AVES", + remove=="human" ~ "HUMAN ACTIVITY", + remove=="unknown" ~ "unknown", + remove=="" ~ remove) + + .species <- wt_get_species() + + #Get the species codes for what you want to filter out + species.remove <- .species |> + filter(species_class %in% remove) + + #Add the unknowns if requested + if("unknown" %in% remove){ + species.remove <- .species %>% + filter(substr(species_common_name, 1, 12) == "Unidentified") %>% + rbind(species.remove) + } + + #Remove those codes from the data + filtered <- data |> + filter(!(species_code %in% species.remove$species_code)) + + #if you don't need nones, remove other NONEs & return the filtered object + if(zerofill==FALSE){ + + filtered.sp <- filter(filtered, species_code!="NONE") + + #Translate point count field names back + filtered.sp <- filtered.sp |> + rename(survey_id=task_id, + survey_date = recording_date_time) + + return(filtered.sp) + } + + #if you do need nones, add them + if(zerofill==TRUE){ + + #first identify the unique visits (task_id) ensure locations are included for proper join + visit <- data |> + select(organization, project_id, location, latitude, longitude, location_id, recording_date_time, task_id, survey_duration_method) |> + distinct() + + #see if there are any that have been removed + none <- suppressMessages(anti_join(visit, filtered)) |> + mutate(species_code = "NONE", + species_common_name = "NONE", + species_scientific_name = NA) #Replaced with NA to align with other NONE tags. + + #add to the filtered data + filtered.none <- suppressMessages(full_join(filtered, none)) |> + arrange(organization, project_id, location, recording_date_time) + + #Translate point count field names back + filtered.none <- filtered.none |> + rename(survey_id=task_id, + survey_date = recording_date_time) + + #return the filtered object with nones added + return(filtered.none) + + } +} + + + + diff --git a/1_code/_setup/01_harmonize_model_ready_v2.R b/1_code/_setup/01_harmonize_model_ready_v2.R index 65b9ed3..d345851 100644 --- a/1_code/_setup/01_harmonize_model_ready_v2.R +++ b/1_code/_setup/01_harmonize_model_ready_v2.R @@ -22,6 +22,21 @@ # - lichen.csv survey_unit_id + species columns # - mite.csv survey_unit_id + species columns # - mammal.csv survey_unit_id + species columns +# in 0_data/test_dataset/covariates/, per plant-group taxon: +# - _climate.csv survey_unit_id + climate covariates +# - _veg.csv survey_unit_id + north veg and HF +# - _soil.csv survey_unit_id + south soil and HF +# and for mammals, per region: +# - mammal_north_climate.csv, mammal_north_veg.csv +# - mammal_south_climate.csv, mammal_south_soil.csv +# 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 # notes: # Source files use two incompatible survey designs, so # they are harmonized into one shared convention rather than @@ -29,6 +44,46 @@ # 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. +# +# The response tables above carry detections only. The +# covariate and lookup tables carry everything else the v2 +# hierarchical models regress against, so the modelling code in +# 1_code/modules/plants/ can run from 0_data/test_dataset/ +# alone rather than reaching back to the snapshot. +# +# Covariates are written per taxon rather than once, because +# the four files do not agree. Bryophyte, lichen and vascular +# plant share identical veg and soil values on shared survey +# units, but mite does not: its veg and soil blocks differ on +# nearly every column while its climate block matches exactly. +# That points at a different spatial support or HF vintage in +# the mite source, so the four are kept separate rather than +# reconciled here. +# +# Mammal covariates come from the same two SpTable files as +# the mammal response, because those files are themselves the +# output of the v2 scripts in 0_data/v2_scripts/mammals/. Their +# embedded pred_matrix objects were checked against +# prediction-matrix_north.csv and Prediction matrix for ABMI +# South coefficients 2020.csv on the ABMI Mammals drive and are +# identical, so no separate lookup is needed for them. +# +# Mammals are written per region rather than per taxon. North +# and south are separate models on overlapping deployments - +# 512 location_project values appear in both files - so their +# covariates cannot be stacked into one table the way the +# response is. +# +# Set SDM_V2_LOOKUP to the v2 project folder holding +# veg-prediction-matrix-CC_2024.csv and +# soil-prediction-matrix_2024.csv. Without it the prediction +# matrices fall back to the snapshot's veg.pm and soil.pm, and +# the vegetation models cannot be fitted - see section 1.5. +# +# Future improvement - the plant-group files are read twice, +# once for the response and once for the covariates. That is +# simpler to follow than threading one environment through both +# readers, and this script runs once per snapshot. # --- # 1. Setup ---- @@ -55,6 +110,11 @@ snapshot_dir <- Sys.getenv( # gitignored along with the rest of 0_data/. output_dir <- file.path(project_root, "0_data/test_dataset") +# Covariates and lookups are split into their own folders so the +# response tables stay the obvious contents of test_dataset/. +covariate_dir <- file.path(output_dir, "covariates") +lookup_dir <- file.path(output_dir, "lookup") + ## 1.3 Name the source files ---- # Plant-group files share one schema, mammal files another. # @@ -155,7 +215,123 @@ plant_site_cols <- c( "Protocol" ) -## 1.5 Name the WildTrax species lookup ---- +# Of those, the fields sites.csv already carries. They are +# dropped from the climate covariate table so each value has one +# home, and the model-data loader joins them back from sites.csv +# under their v2 names. +plant_site_cols_in_sites <- c( + "Lat", + "Long", + "Elevation", + "NR", + "NSR", + "LufName", + "Easting", + "Northing" +) + +# And the ones that are products of other stored columns. They +# are not written: the model-data loader recomputes them with the +# same expressions 01a_data-standardization.R used. +# +# Storing them would be worse than redundant. A CSV holds about +# 15 significant digits, so Northing lands within ~2e-9 of the +# source value; squaring it lifts that to ~0.05 in absolute +# terms. Written and read back independently, Northing2 would no +# longer be exactly Northing * Northing, and a model fitting both +# would see an inconsistent pair. Deriving keeps them consistent +# with whatever precision the stored columns carry. +plant_site_cols_derived <- c( + "Easting2", + "Northing2", + "EastingNorthing", + "MAPPET", + "MAT2", + "CMDMAT", + "MWMT2" +) + +## 1.5 Name the mammal column blocks ---- +# The mammal files are one frame, `d`, holding design fields, +# species-season columns and covariates. The species span is +# given by the file's own first_sp_col/last_sp_col indices, and +# the rest is split by naming the two non-habitat blocks; what +# is left over is habitat. That is the same split-by-elimination +# the plant-group reader uses, and section 6.6 checks that the +# three blocks account for every column. + +# 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 climate predictions ---- +# The mammal habitat models take a climate offset rather than +# fitting climate themselves: 03_basic-models.R reads this file +# for both regions. It is produced by a separate climate +# pipeline, so it is copied in rather than derived here. +mammal_climate_pred_file <- Sys.getenv( + "SDM_MAMMAL_CLIMATE_PRED", + unset = paste0( + "G:/Shared drives/ABMI Mammals/Results/Habitat Modeling/", + "2024/Climate/Predictions/", + "All Species Climate Predictions.csv" + ) +) + +## 1.7 Name the v2 prediction-matrix lookups ---- +# The v2 modelling scripts do not use the veg.pm and soil.pm +# objects carried in the snapshot. They read these two CSVs from +# the v2 project instead, and the two are not the same: veg.pm is +# missing the aggregate habitat columns - Peatland, Mineral, +# Upland and CCR1234 - that four of the twelve vegetation models +# are predicted onto. +# +# So the CSVs are preferred when SDM_V2_LOOKUP points at them, +# and the snapshot objects are the fallback. Section 7.4 says +# which was used, because a fallback run cannot fit the +# vegetation models. +v2_lookup_dir <- Sys.getenv("SDM_V2_LOOKUP", unset = NA_character_) + +v2_lookup_files <- c( + veg_prediction_matrix = "veg-prediction-matrix-CC_2024.csv", + soil_prediction_matrix = "soil-prediction-matrix_2024.csv" +) + +## 1.8 Name the WildTrax species lookup ---- # The naming authority for mammal species. wt_species_file <- Sys.getenv( "SDM_WT_SPECIES", @@ -165,7 +341,7 @@ wt_species_file <- Sys.getenv( ) ) -## 1.6 Check the inputs are reachable ---- +## 1.9 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)), @@ -409,7 +585,9 @@ normalize_mammal_column <- function(x, native_sp, label) { #' @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") @@ -530,7 +708,144 @@ 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 +#' +#' Companion to `read_plant_taxon()`, which takes the response. +#' This takes what the v2 hierarchical models regress against: +#' the climate block, the north vegetation and HF block, the +#' south soil and HF block, the two habitat prediction matrices, +#' and the lists naming which species each model set is fitted +#' for. +#' +#' The habitat blocks are found by difference rather than by +#' position. `climate.data` is identity + species + climate, so +#' whatever `veg.data` holds that `climate.data` does not is the +#' vegetation block, and likewise for soil. That reproduces the +#' positional spans the v2 scripts hard-code - `[403:489]` for +#' bryophytes, `[448:534]`, `[328:414]` and `[1408:1494]` for the +#' other three - without depending on column order staying put. +#' +#' @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: Take each habitat block by difference from + # climate.data, which leaves the covariates behind and drops + # the identity, species and climate columns both frames share. + 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: The v2 coefficient template is the first 87 columns + # of this block, taken positionally. A snapshot that reordered + # or shortened it would silently rename every vegetation + # coefficient, so the width is checked rather than assumed. + 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 describe the same survey units + # in the same order, or the tables cannot be recombined on + # survey_unit_id downstream. + 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: Record which species each model set is fitted for. + # These are subsets of the response columns, and the v2 scripts + # read them straight out of the .Rdata, so they have to travel + # with the dataset or the work queue cannot be rebuilt. + modelled <- union(env$veg.species.list, env$soil.species.list) + + # The two lists are separately ordered, and the v2 scripts walk + # each in its own order. A single stacked table would lose that, + # so each species carries its position in whichever lists hold + # it, and the loader sorts on those rather than on the row + # order of this file. + 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_mammal_region() ---- #' Read One Mammal Snapshot File #' @@ -633,6 +948,90 @@ read_mammal_region <- function(path, region, native_sp) { stringsAsFactors = FALSE ) + # Step 5: Split the covariates off the same frame. The species + # span is already known, and the two non-habitat blocks are + # named in section 1.5, so habitat is what is left. The unit + # ids are reused rather than rebuilt: make_unique_ids() numbers + # duplicate deployments, and a second call would have to + # reproduce that numbering exactly. + take_block <- function(wanted) { + present <- intersect(wanted, names(d)) + + data.frame( + survey_unit_id = unit_id, + d[, present, drop = FALSE], + check.names = FALSE, + stringsAsFactors = FALSE + ) + } + + climate <- take_block(mammal_climate_cols) + + habitat_cols <- setdiff( + names(d), + c(mammal_site_cols, mammal_climate_cols, species_cols) + ) + habitat <- take_block(habitat_cols) + + # The four blocks must partition `d` exactly. They are built by + # difference, so an overlap or a gap would quietly move a + # column into the wrong table. + 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, + ": the design, climate, species and habitat blocks cover ", + accounted, + " of ", + ncol(d), + " columns.", + call. = FALSE + ) + } + + # Step 6: Record the work queue. Mammals model each season + # separately and at two occurrence thresholds - sp_table_* are + # the species with at least 20 detections, which get the full + # habitat model, and sp_table_*_ua those with at least 3, which + # get the use-availability model. One row per species-season, + # with its position in each list it belongs to. + 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 + ) + ) + + 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 + ) + } + )) + message( " mammal ", region, @@ -640,10 +1039,21 @@ read_mammal_region <- function(path, region, native_sp) { nrow(species), " units x ", length(species_cols), - " species-season columns" + " species-season columns; ", + ncol(climate) - 1, + " climate, ", + ncol(habitat) - 1, + " habitat covariates" ) - return(list(species = species, sites = sites)) + return(list( + species = species, + sites = sites, + climate = climate, + habitat = habitat, + pred_matrix = as.data.frame(env$pred_matrix), + species_lists = species_lists + )) } # 3. Read the sources ---- @@ -662,7 +1072,24 @@ plant_parts <- lapply( ) names(plant_parts) <- names(plant_files) -## 3.2 Read the mammal files ---- +## 3.2 Read the plant-group covariates and lookups ---- +# A second pass over the same four files. The response and the +# covariates are kept in separate readers because they answer +# separate questions, and this script runs once per snapshot. +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 ---- # The WildTrax strings are loaded once and passed to both # regions, so each resolves its names against the same authority. message("Reading mammal files ...") @@ -849,6 +1276,129 @@ for (taxon in names(species_tables)) { } } +## 6.3 Covariates must cover the response, unit for unit ---- +# A survey unit with a detection but no covariates would be +# dropped silently at model time, so the two are required to +# describe exactly the same set. +for (taxon in names(covariate_parts)) { + response_ids <- species_tables[[taxon]]$survey_unit_id + + for (block in c("climate", "veg", "soil")) { + block_ids <- covariate_parts[[taxon]][[block]]$survey_unit_id + + if (!setequal(response_ids, block_ids)) { + stop( + taxon, + ": the ", + block, + " 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.4 Modelled species must exist as response columns ---- +# veg.species.list and soil.species.list are the work queue. A +# name that is not a column would fail per bootstrap inside a +# tryCatch, so it is caught here instead. +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 ---- +# They are written once rather than per taxon, which is only +# sound while all four files 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 ---- +# The habitat block is what is left once the design, climate and +# species columns are named, so a new unnamed column would land +# in it silently. The reader has already checked that the blocks +# partition the frame; this checks that nothing non-numeric +# arrived, which is the shape a stray design field would have. +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 + ) + } +} + # 7. Write the CSVs ---- # One file per taxon plus the site table, all sharing the # survey_unit_id key. @@ -880,6 +1430,267 @@ message( ncol(sites), " cols" ) + +## 7.3 Write the plant-group covariate tables ---- +# Three per taxon, each keyed on survey_unit_id like the response +# tables, so a model-data frame is rebuilt by joining rather than +# by trusting column positions. +dir.create(covariate_dir, recursive = TRUE, showWarnings = FALSE) + +for (taxon in names(covariate_parts)) { + for (block in c("climate", "veg", "soil")) { + path <- file.path( + covariate_dir, + paste0(taxon, "_", block, ".csv") + ) + fwrite(covariate_parts[[taxon]][[block]], path, na = "") + + message( + "Wrote covariates/", + basename(path), + ": ", + nrow(covariate_parts[[taxon]][[block]]), + " rows x ", + ncol(covariate_parts[[taxon]][[block]]), + " cols" + ) + } +} + +## 7.4 Write the shared lookups ---- +# Section 6.5 has already confirmed the two prediction matrices +# are the same in all four files, so they are written once. +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 +) + +# Take the v2 CSVs when they are reachable. They are what the v2 +# scripts read, and the snapshot objects are missing columns the +# vegetation models need. +for (matrix_name in names(prediction_matrices)) { + if (is.na(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" + ) +} + +# The four aggregate columns the vegetation models predict onto. +# Their absence is what separates the snapshot's veg.pm from the +# CSV the v2 scripts read, so it is reported here rather than +# found later by check_prediction_terms(). +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 covariate tables ---- +# Per region, not per taxon. North and south are separate models +# on overlapping deployments, so their covariates cannot be +# stacked the way the response is. The habitat block is named +# veg in the north and soil in the south, matching the plant +# convention and the model each one feeds. +mammal_habitat_names <- c(north = "veg", south = "soil") + +for (region in names(mammal_parts)) { + blocks <- list( + climate = mammal_parts[[region]]$climate, + habitat = mammal_parts[[region]]$habitat + ) + + names(blocks)[2] <- mammal_habitat_names[[region]] + + for (block in names(blocks)) { + path <- file.path( + covariate_dir, + paste0("mammal_", region, "_", block, ".csv") + ) + fwrite(blocks[[block]], path, na = "") + + message( + "Wrote covariates/", + basename(path), + ": ", + nrow(blocks[[block]]), + " rows x ", + ncol(blocks[[block]]), + " cols" + ) + } +} + +## 7.6 Write the mammal lookups ---- +# The prediction matrices are per region and were checked against +# the CSVs on the ABMI Mammals drive, so they are taken from the +# snapshot rather than copied in. +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" + ) +} + +# Mammals get their own species table rather than rows in +# modelled_species.csv: their work queue is season by occurrence +# threshold, which the plant north/south schema has no room for. +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" +) + +# The climate offset the mammal habitat models take. It is +# produced by a separate climate pipeline, so it is copied in +# with survey_unit_id added, keyed the way the rest of the +# dataset is. A deployment with no climate prediction keeps the +# NA the v2 join would have produced. +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 + ) +} + 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 index 414536a..dde933b 100644 --- a/1_code/_setup/02_validate_test_dataset.R +++ b/1_code/_setup/02_validate_test_dataset.R @@ -11,6 +11,14 @@ # - lichen.csv # - mite.csv # - mammal.csv +# - covariates/_{climate,veg,soil}.csv +# - covariates/mammal__{climate,veg|soil}.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 # from 0_data/data_snapshots/model_ready_v2/ on ABMI-DATA2: # - the four plant-group .Rdata files # - the two mammal SpTable .RData files @@ -20,7 +28,14 @@ # Two passes over the harmonized dataset. Section 2 describes # it: sizes, coverage, value ranges, and whether the two-file # layout joins the way it is meant to. Section 3 traces every -# written value back to the snapshot it came from. +# written value back to the snapshot it came from: responses in +# 3.3 and 3.4, plant-group covariates in 3.5, and mammal +# covariates and lookups in 3.6. +# +# Covariate values are compared on relative difference, not +# absolute. A CSV carries about 15 significant digits, so UTMY +# at 6.6e6 comes back about 6e-9 away from the source; that is +# a round-trip artefact, not a harmonization error. # # Run after 01_harmonize_model_ready_v2.R, and again whenever # the snapshot or that script changes. @@ -253,6 +268,16 @@ plant_files <- c( mite = "mite-model-data.Rdata" ) +# The mammal climate offset, produced outside this repository. +mammal_climate_pred_file <- Sys.getenv( + "SDM_MAMMAL_CLIMATE_PRED", + unset = paste0( + "G:/Shared drives/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 ", @@ -515,7 +540,507 @@ for (rg in names(mammal_files)) { ) } -## 3.5 Verdict ---- +## 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 +#' +#' The absolute counterpart, compare_blocks(), is right for the +#' response, whose values are small integers. Covariates span +#' UTM coordinates at 1e6 and cover proportions at 1e-4, so a +#' single absolute tolerance cannot serve both. +#' +#' @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 +) + +for (taxon in names(plant_files)) { + src <- read_source(plant_files[[taxon]]) + clim <- src$climate.data + rownames(clim) <- clim$SiteYearQu + + blocks <- list( + climate = clim, + veg = src$veg.data, + soil = src$soil.data + ) + + for (block in names(blocks)) { + csv_path <- file.path( + data_dir, "covariates", paste0(taxon, "_", block, ".csv") + ) + + if (!file.exists(csv_path)) { + note(taxon, paste(block, "covariates written"), FALSE, + "file not found") + next + } + + csv <- as.data.frame(fread(csv_path, na.strings = "")) + source_frame <- blocks[[block]] + + # Every written column must exist in the source, and the + # survey units must line up before values are compared. + cols <- setdiff(names(csv), "survey_unit_id") + absent <- setdiff(cols, names(source_frame)) + + note( + taxon, + paste(block, "columns exist in source"), + length(absent) == 0, + if (length(absent) > 0) { + paste(utils::head(absent, 5), collapse = ", ") + } else { + paste(length(cols), "columns") + } + ) + + if (length(absent) > 0) { + next + } + + row_order <- match( + csv$survey_unit_id, as.character(source_frame$SiteYearQu) + ) + + note( + taxon, + paste(block, "keys resolve in source"), + !anyNA(row_order), + paste(nrow(csv), "rows") + ) + + if (anyNA(row_order)) { + next + } + + numeric_cols <- cols[ + vapply(source_frame[, cols], is.numeric, logical(1)) + ] + + cmp <- compare_blocks_rel( + csv[, numeric_cols], + source_frame[row_order, numeric_cols] + ) + + note( + taxon, + paste(block, "numeric values match source"), + isTRUE(cmp$n == 0), + sprintf("max rel diff %.2e", cmp$max_diff) + ) + + # Non-numeric columns must round-trip exactly. + other_cols <- setdiff(cols, numeric_cols) + mismatched <- other_cols[ + !vapply( + other_cols, + function(one) { + identical( + as.character(csv[[one]]), + as.character(source_frame[row_order, one]) + ) + }, + logical(1) + ) + ] + + note( + taxon, + paste(block, "non-numeric values match"), + length(mismatched) == 0, + if (length(mismatched) > 0) { + paste(mismatched, collapse = ", ") + } else { + paste(length(other_cols), "columns") + } + ) + } + + # The seven derived terms are not stored. Confirm each rebuilds + # from the stored columns to the value the snapshot holds. + clim_csv <- as.data.frame(fread( + file.path( + data_dir, "covariates", paste0(taxon, "_climate.csv") + ), + na.strings = "" + )) + + sites_csv <- as.data.frame(fread( + file.path(data_dir, "sites.csv"), na.strings = "" + )) + + 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") + ) +} + +# The prediction matrices are written once for all four taxa, so +# they are 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 ---- +# Mammal covariates come from the same two SpTable files as the +# mammal response, and are written per region because north and +# south are separate models on overlapping deployments. + +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) + + for (block in c("climate", mammal_habitat_name[[region]])) { + csv_path <- file.path( + data_dir, "covariates", + paste0("mammal_", region, "_", block, ".csv") + ) + + if (!file.exists(csv_path)) { + note(label, paste(block, "covariates written"), FALSE, + "file not found") + next + } + + csv <- as.data.frame(fread(csv_path, na.strings = "")) + cols <- setdiff(names(csv), "survey_unit_id") + absent <- setdiff(cols, names(d)) + + note( + label, + paste(block, "columns exist in source"), + length(absent) == 0, + if (length(absent) > 0) { + paste(utils::head(absent, 5), collapse = ", ") + } else { + paste(length(cols), "columns") + } + ) + + if (length(absent) > 0) { + next + } + + # The reader writes rows in source order, so the two frames + # line up without a join. Anything else means the ids were + # rebuilt rather than reused. + note( + label, + paste(block, "row count matches source"), + nrow(csv) == nrow(d), + paste(nrow(csv), "rows") + ) + + if (nrow(csv) != nrow(d)) { + next + } + + numeric_cols <- cols[ + vapply(d[, cols, drop = FALSE], is.numeric, logical(1)) + ] + + cmp <- compare_blocks_rel( + csv[, numeric_cols], d[, numeric_cols] + ) + + note( + label, + paste(block, "numeric values match source"), + isTRUE(cmp$n == 0), + sprintf("max rel diff %.2e", cmp$max_diff) + ) + + other_cols <- setdiff(cols, numeric_cols) + mismatched <- other_cols[ + !vapply( + other_cols, + function(one) { + identical( + as.character(csv[[one]]), as.character(d[[one]]) + ) + }, + logical(1) + ) + ] + + note( + label, + paste(block, "non-numeric values match"), + length(mismatched) == 0, + if (length(mismatched) > 0) { + paste(mismatched, collapse = ", ") + } else { + paste(length(other_cols), "columns") + } + ) + } + + # 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.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) 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 index 3418500..929dfe9 100644 --- a/1_code/experiments/exp_000_parity_v2/01_collect_results.R +++ b/1_code/experiments/exp_000_parity_v2/01_collect_results.R @@ -3,21 +3,23 @@ # author: Brendan Casey # created: 2026-09-05 # inputs: -# in 2_pipeline/exp_000_parity_v2//3_output/: +# in pipeline_dir//: # - models/-species-models.Rdata # - validation/-models-validation.Rdata # outputs: -# in 3_output/exp_000_parity_v2/tables/: +# in out_dir/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 +# - Placeholder. Reads the model output each taxon left in +# pipeline_dir and writes flat summaries to out_dir. +# - Raw model objects stay in pipeline_dir 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. +# - Expects exp_id, pipeline_dir and out_dir from run.R. Both +# paths are taken from there rather than rebuilt here, so a +# run pointed at a scratch disk is still read correctly. # --- # 1. Setup ---- @@ -25,17 +27,16 @@ ## 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( +# A taxon appears here only once its stages have run into this +# pipeline_dir, in this pass or an earlier one. +run_taxa <- list.dirs( pipeline_dir, full.names = FALSE, recursive = FALSE ) -staged_taxa <- setdiff(staged_taxa, "logs") +run_taxa <- setdiff(run_taxa, "logs") # 2. Collect model coefficients ---- # TODO: load each -species-models.Rdata, reduce the @@ -48,10 +49,10 @@ staged_taxa <- setdiff(staged_taxa, "logs") # 4. Report what was found ---- cat( - "01_collect_results.R is a placeholder. Taxa staged in ", + "01_collect_results.R is a placeholder. Taxa found in ", pipeline_dir, ": ", - if (length(staged_taxa) > 0) { - paste(staged_taxa, collapse = ", ") + if (length(run_taxa) > 0) { + paste(run_taxa, collapse = ", ") } else { "none" }, diff --git a/1_code/experiments/exp_000_parity_v2/README.md b/1_code/experiments/exp_000_parity_v2/README.md index aa48ade..2a2cc59 100644 --- a/1_code/experiments/exp_000_parity_v2/README.md +++ b/1_code/experiments/exp_000_parity_v2/README.md @@ -1,6 +1,6 @@ # exp_000_parity_v2 -![Status](https://img.shields.io/badge/Status-Scaffolded-yellow) +![Status](https://img.shields.io/badge/Status-Partially%20running-yellow) ![Languages](https://img.shields.io/badge/Languages-R-blue) The validation gate. Runs the v2.0 models through this repository's @@ -9,8 +9,8 @@ v2.0 outputs. ## Question -Does running the unmodified v2 scripts through this repository's -harness and modules reproduce the v2.0 results? +Does running the rewritten v2 modelling code, on the harmonized test +dataset, through this repository's pipeline 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 @@ -20,9 +20,9 @@ plumbing, not in the method being tested. | Element | Value | | --- | --- | -| Taxa | Set per run in `run.R` (`mites <- TRUE`, and so on) | +| Taxa | Set per run in `run.R` section 1.4 (`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 | +| Bootstraps | `boot_iter` in `run.R`; must stay at the v2 value of `1:100` for parity | | Reference | The published v2.0 output — source still to be agreed | | Target | Not yet defined; to be agreed per taxon | @@ -30,21 +30,30 @@ plumbing, not in the method being tested. | File | Purpose | | --- | --- | -| `run.R` | Entry point. Taxon flags, staging, module calls | +| `run.R` | Entry point. Paths, taxon flags, stage flags, run length | | `utils/species_lists.R` | The species vector for each taxon | -| `01_collect_results.R` | Raw v2 output → flat summary tables | +| `01_collect_results.R` | Model output → flat summary tables | | `02_compare_to_v2.R` | The parity comparison itself | | `03_build_report.R` | Tables and figures → `report.md` | ## 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. +1. Build the test dataset first, if it is not already there — see + [Setup](../../../README.md#setup) in the repository README. A run needs + only `0_data/test_dataset/`, not the v2 project. +2. Edit `run.R`: + - **1.3** where the run reads and writes. The defaults follow the + repository conventions; point `pipeline_dir` at a scratch disk for a + long run. + - **1.4** the taxon flags. + - **1.5** the stage flags. `02` needs what `01` wrote and `03` needs what + `02` wrote, so a stage can be run alone only once the ones before it + have run into the same `pipeline_dir`. + - **1.6** the run length. Leave it at the v2 values for parity. +3. Name the species in `utils/species_lists.R`. `NULL` runs every modelled + species; a short vector is the smoke test, and is the right way to + shorten a trial run since `boot_iter` has to stay at `1:100`. +4. Run from the repository root: ```r source("1_code/experiments/exp_000_parity_v2/run.R") @@ -52,21 +61,37 @@ source("1_code/experiments/exp_000_parity_v2/run.R") ## Outputs -Intermediates, per taxon, in `2_pipeline/exp_000_parity_v2/`: +Intermediates, per taxon, in `pipeline_dir` +(`2_pipeline/exp_000_parity_v2/` by default): -- `/` — the staged run root, plus the raw v2 model and - validation output. Gitignored; too large to commit. -- `logs/` — one timestamped log per pipeline step. +- `/bootstrap/` — the per-species bootstrap site ids. +- `/models/` — the fitted climate, vegetation and soil + coefficients. Gitignored; 100 bootstraps by every species by three + model families is too large to commit. +- `/validation/` — the per-bootstrap fit measures. +- `logs/` — one timestamped log per stage. -Deliverables in `3_output/exp_000_parity_v2/`: +Deliverables in `out_dir` (`3_output/exp_000_parity_v2/` by default): - `tables/`, `figures/`, `report.md` — committed, so comparisons across experiments can be made from the repository alone. ## Status -Scaffolded. The taxon modules and staging run; `01`–`03` are -placeholders pending two decisions: +The climate and soil model sets run end to end. Three things are +outstanding: -- Where the v2.0 reference output comes from. -- What the minimum acceptable parity target is, per taxon. +- **The vegetation models cannot be fitted.** The prediction matrix in the + snapshot is missing four columns the v2 vegetation models are predicted + onto. See [Known gaps](../../../README.md#known-gaps) — it is one file + away from working, and `02_hierarchical_models.R` stops with the missing + columns named rather than failing partway through a run. +- **The v2.0 reference source** is undecided: a frozen snapshot under + `0_data/` or the external v2 project. +- **The parity target** is undefined, per taxon. + +`01`–`03` are placeholders pending the last two. + +Note that the v2 bootstrap draws without a fixed seed, so successive runs +of identical code differ. `boot_seed` in `run.R` fixes the stream when a +run needs to be repeatable; `NULL` reproduces v2. diff --git a/1_code/experiments/exp_000_parity_v2/run.R b/1_code/experiments/exp_000_parity_v2/run.R index 5298d77..d344c7a 100644 --- a/1_code/experiments/exp_000_parity_v2/run.R +++ b/1_code/experiments/exp_000_parity_v2/run.R @@ -4,34 +4,40 @@ # created: 2026-09-05 # inputs: # harness, in 1_code/harness/utils/: -# - v2_script_runner.R -# - stage_v2_inputs.R +# - step_runner.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 +# - 01_bootstrap_ids.R +# - 02_hierarchical_models.R +# - 03_model_validation.R +# data: +# - 0_data/test_dataset/ # outputs: -# in 2_pipeline/exp_000_parity_v2/: -# - / (staged inputs and raw v2 model output) +# in pipeline_dir (2_pipeline/exp_000_parity_v2/ by default): +# - /bootstrap/, /models/, /validation/ # - logs/ -# in 3_output/exp_000_parity_v2/: -# - tables/ -# - figures/ -# - report.md +# in out_dir (3_output/exp_000_parity_v2/ by default): +# - tables/, figures/, report.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. +# - Entry point for the experiment, and the only file that has +# to be edited to change what runs. Sections 1.2 to 1.6 are +# the whole configuration: where output goes, which taxa run, +# on which species, and at what run length. +# - The modelling scripts in 1_code/modules/plants/ take every +# path as an argument. Nothing is hard-coded to a project +# layout, so pipeline_dir and out_dir can point anywhere +# writable; the defaults follow this repository's +# conventions. +# - Reads 0_data/test_dataset/ only, which is the harmonized +# snapshot 1_code/_setup/ builds. The v2 project itself is +# not needed at run time, and 0_data/ is not written to. +# - Species vectors live in utils/species_lists.R. NULL models +# every species the snapshot declares as modelled. +# - The three stages are ordered: 02 reads what 01 wrote and 03 +# reads what 02 wrote, all from pipeline_dir. Re-running one +# stage means setting its flag alone, so long as the earlier +# stages have run at least once. # --- # 1. Setup ---- @@ -45,7 +51,7 @@ ## 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 +# 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" @@ -55,19 +61,27 @@ exp_code_dir <- file.path( project_root, "1_code/experiments", exp_id ) -log_path <- file.path(project_root, "2_pipeline", exp_id, "logs") +module_dir <- file.path(project_root, "1_code/modules/plants") +## 1.3 Choose where the run reads and writes ---- +# The three paths a run needs. Point them anywhere writable - a +# scratch disk for a long run, say - and nothing else has to +# change. The defaults follow this repository's conventions. +# +# data_dir is read only. It holds the frozen test dataset, and +# no stage writes to it. +data_dir <- file.path(project_root, "0_data/test_dataset") + +# pipeline_dir takes the intermediates: bootstrap ids, fitted +# models, validation objects, and the logs. These are large and +# gitignored. +pipeline_dir <- file.path(project_root, "2_pipeline", exp_id) + +# out_dir takes the committed deliverables: tables, figures and +# the report. 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" -)) +log_path <- file.path(pipeline_dir, "logs") ## 1.4 Set the taxa to run ---- # Set to TRUE to model that taxon. Toggling a flag re-runs one @@ -77,81 +91,140 @@ 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.5 Set the stages to run ---- +# The three modelling stages, in order. 02 needs what 01 wrote +# and 03 needs what 02 wrote, so a stage can be run alone only +# once the ones before it have run at least once into the same +# pipeline_dir. +run_bootstrap <- TRUE # 01_bootstrap_ids.R +run_models <- TRUE # 02_hierarchical_models.R +run_validation <- TRUE # 03_model_validation.R -## 1.6 Set the analysis flags ---- -# The steps that turn raw v2 output into committed deliverables. +# The steps that turn raw model output into 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. +## 1.6 Set the run length ---- +# v2 hard-coded 100 bootstraps and 14 cores. Both are parameters +# now, but parity means running at the v2 values, so leave these +# as they are for exp_000 and shorten a smoke test with the +# species vectors instead. +boot_iter <- 1:100 +n_clusters <- 14 + +# NULL leaves the bootstrap stream unseeded, as v2 did. Set an +# integer to make a run repeatable. +boot_seed <- NULL + +## 1.7 Load the species vectors ---- +# Defines bryophyte_species, lichen_species, mite_species and +# vascular_plant_species. NULL means every modelled species. +source(file.path(exp_code_dir, "utils/species_lists.R")) + +## 1.8 Load the step runner ---- +# Supplies run_step(), which times each stage and mirrors its +# output to a log. +source(file.path( + project_root, "1_code/harness/utils/step_runner.R" +)) + +# 2. Run the modelling stages ---- +# One block per taxon. Each sets the parameters the module +# scripts read - taxon, species and the output root - then runs +# the three stages in order. Nothing outside pipeline_dir is +# written. + +## 2.1 run_taxon() ---- + +#' Run the Three Modelling Stages for One Taxon +#' +#' Sets the configuration the module scripts read from the global +#' environment, then runs the stages whose flags are TRUE. The +#' scripts are sourced rather than called because they read their +#' parameters by name from there, which is also where their +#' parallel workers export from. +#' +#' @param taxon_name Character. Taxon slug, as used in the test +#' dataset file names. +#' @param taxon_species Character vector of species to model, or +#' NULL for every modelled species. +#' @param label Character. The taxon as it reads in a log line. +#' @return NULL, invisibly. +#' +#' @example +#' # Example usage of the function +#' # run_taxon("mite", mite_species, "mites") +run_taxon <- function(taxon_name, taxon_species, label) { + # Step 1: Publish the parameters the module scripts read. They + # are assigned to the global environment because that is where + # the scripts are sourced and where clusterExport() looks. + # + # run_dir is the module's own output root, kept distinct from + # out_dir so the intermediates and the deliverables cannot be + # written to the same place by accident. + taxon <<- taxon_name + species_subset <<- taxon_species + run_dir <<- file.path(pipeline_dir, taxon_name) + + # Step 2: Run each requested stage in order + stages <- list( + list( + flag = run_bootstrap, + label = paste0("01: Bootstrap ids (", label, ")"), + script = file.path(module_dir, "01_bootstrap_ids.R") + ), + list( + flag = run_models, + label = paste0("02: Hierarchical models (", label, ")"), + script = file.path(module_dir, "02_hierarchical_models.R") + ), + list( + flag = run_validation, + label = paste0("03: Model validation (", label, ")"), + script = file.path(module_dir, "03_model_validation.R") + ) + ) + + for (stage in stages) { + if (stage$flag) { + run_step( + label = stage$label, + script = stage$script, + log_dir = log_path + ) + } + } + + invisible(NULL) +} + +## 2.2 Run each requested taxon ---- 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" - )) + run_taxon("bryophyte", bryophyte_species, "bryophytes") } -## 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" - )) + run_taxon("lichen", lichen_species, "lichens") } -## 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" - )) + run_taxon("mite", mite_species, "mites") } -## 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 + run_taxon( + "vascular_plant", vascular_plant_species, "vascular plants" ) - 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. +# These read the model output left in pipeline_dir and write the +# committed deliverables to out_dir. They are placeholders until +# the parity targets are agreed. +dir.create(out_dir, recursive = TRUE, showWarnings = FALSE) ## 3.1 Collect model output ---- if (run_collect) { @@ -174,6 +247,7 @@ cat("\n========================================\n") cat("EXPERIMENT ", exp_id, " COMPLETE\n", sep = "") cat("Total run time: ", experiment_time, "\n", sep = "") cat("========================================\n") +cat("Intermediates are in ", pipeline_dir, "\n", sep = "") cat("Deliverables are in ", out_dir, "\n", sep = "") # 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 index 39e00b2..9ca6a2d 100644 --- a/1_code/experiments/exp_000_parity_v2/utils/species_lists.R +++ b/1_code/experiments/exp_000_parity_v2/utils/species_lists.R @@ -6,37 +6,44 @@ # 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. +# run.R and passed to the module scripts, which narrow the +# work queue to these names. +# - NULL models every species the snapshot declares as +# modelled, which is the parity setting: exp_000 has to cover +# what v2 covered. +# - A short vector is the smoke test. Species count and +# boot_iter are both adjustable now, but boot_iter has to +# stay at the v2 value for a parity run, so the species +# vector is what a trial run should shorten. +# - Names must match the species columns exactly. +# load_plant_model_data() stops and lists any name it cannot +# find, so a typo fails before modelling starts. +# - The names are those in lookup/modelled_species.csv, which +# is written from the snapshot's own veg.species.list and +# soil.species.list. To see the options for a taxon: +# +# modelled <- read.csv( +# "0_data/test_dataset/lookup/modelled_species.csv" +# ) +# head(modelled[modelled$taxon == "mite", ]) # --- # 1. Species vectors ---- ## 1.1 Bryophytes ---- -# NULL runs every bryophyte in the data. +# 134 modelled species: 133 north, 32 south. bryophyte_species <- NULL ## 1.2 Lichens ---- +# 191 modelled species: 175 north, 55 south. 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" -) +# 125 modelled species: 116 north, 34 south. +mite_species <- NULL ## 1.4 Vascular plants ---- +# 486 modelled species: 353 north, 269 south. vascular_plant_species <- NULL # 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/step_runner.R b/1_code/harness/utils/step_runner.R new file mode 100644 index 0000000..030faa2 --- /dev/null +++ b/1_code/harness/utils/step_runner.R @@ -0,0 +1,109 @@ +# --- +# title: Pipeline Step Runner +# author: Brendan Casey +# created: 2026-09-05 +# inputs: none +# outputs: none +# notes: +# - Taxon-agnostic helper for running one numbered module +# script, timing it, and mirroring its output to a log. +# Sourced by the experiments in 1_code/experiments/. +# - Was v2_script_runner.R, which also switched the working +# directory to a v2 project root and restored the caller's +# objects after each script's rm(list = ls()). The module +# scripts do neither now: they take their paths as arguments +# and clear nothing, so both are gone along with the input +# checks, which each script does for itself against the paths +# it was actually given. +# - Scripts are sourced into the global environment on purpose. +# They read their configuration from objects the experiment +# has already set there, and their clusterExport() calls read +# from .GlobalEnv. +# --- + +# 1. run_step() ---- + +#' Run One Pipeline Step +#' +#' Sources a script, reporting its label and the time it took. +#' Mirrors console output to a timestamped log file so an +#' unattended run leaves a record. +#' +#' The script is sourced into the global environment, so it sees +#' the configuration the caller set there - `taxon`, `out_dir` +#' and the rest - and its parallel workers can export from it. +#' +#' @param label Character. A descriptive label for the step, used +#' in the console output and in the log file name +#' (e.g. "02: Hierarchical models (mites)"). +#' @param script Character. Path to the script to run. +#' @param log_dir Character. Directory for log files, or NULL to +#' print to the console only. +#' @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 = "02: Hierarchical models (mites)", +#' script = "1_code/modules/plants/02_hierarchical_models.R", +#' log_dir = log_path +#' ) +#' +#' # Run without writing a log file +#' run_step( +#' label = "02: Hierarchical models (mites)", +#' script = "1_code/modules/plants/02_hierarchical_models.R", +#' log_dir = NULL +#' ) +run_step <- function(label, script, log_dir = NULL) { + # Step 1: Fail on a missing script before anything is logged + if (!file.exists(script)) { + stop("Script not found: ", script, call. = FALSE) + } + + # Step 2: Announce the step and record the start time + cat("\n--- Running ", label, " ---\n", sep = "") + start <- Sys.time() + + # Step 3: 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 4: Source into the global environment, which is where the + # module scripts read their configuration and where their + # clusterExport() calls look for objects + source(script) + + # Step 5: 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/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/modules/plants/01_bootstrap_ids.R b/1_code/modules/plants/01_bootstrap_ids.R new file mode 100644 index 0000000..5899935 --- /dev/null +++ b/1_code/modules/plants/01_bootstrap_ids.R @@ -0,0 +1,233 @@ +# --- +# title: Generate Bootstrap Site Ids (Plant Groups) +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# set by the calling experiment, or defaulted in 1.2: +# - taxon, data_dir, run_dir, species_subset, boot_iter, +# n_clusters +# in data_dir: +# - .csv, sites.csv, covariates/, lookup/ +# in this repository: +# - 1_code/modules/plants/load_model_data.R +# - 1_code/modules/plants/functions/bootstrapping_functions.R +# outputs: +# in run_dir: +# - bootstrap/-bootstrap-ids.Rdata (bootstrap.ids) +# notes: +# - Rewrite of the v2 script 01b_bootstrapping.R, which held +# the same four blocks one after another in a single file and +# wrote back over the model-data files. This one takes the +# taxon as a parameter and writes only the bootstrap ids, so +# nothing in 0_data/ is modified by a run. +# - Each species gets its own set of ids because the thinning +# depends on where that species was detected. Iteration 1 is +# the complete data set by construction, and 2 onward +# resample sites within spatial blocks with replacement. +# - The block grid is the v2 grid: longitude cut at -121, -116, +# -112 and -109, latitude at 48, 51, 54, 57 and 61, with the +# interaction relabelled a, b, c and so on. +# - The ids are SiteYearQu values, which is what the +# hierarchical models and the validation both index on. +# - Bootstrapping resamples, so a run is only reproducible if +# the seed is fixed. v2 set none. `boot_seed` defaults to +# NULL, which reproduces v2 exactly; set it to make a run +# repeatable. +# - The species selection is `species_subset`, not `species`. +# The v2 code loops with `for (species in species.list)`, +# which would otherwise overwrite the selection and leave the +# next stage running on one species. +# - Future improvement - ids are generated for every modelled +# species even when a later stage runs on a subset, because +# the v2 code reads them as boot.data[[species]] and ignores +# extras. Passing `species` here narrows both. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(foreach) # sequential %dopar% loop, as in v2 (version: 1.5.2) +library(parallel) # species-level parallelism (version: 4.5.0) + +## 1.2 Configure the run ---- +# Values a calling experiment has already set are kept, so this +# script runs either from 1_code/experiments/ or on its own. +if (!exists("project_root", inherits = FALSE)) { + project_root <- normalizePath(getwd(), winslash = "/") +} + +if (!exists("taxon", inherits = FALSE)) { + taxon <- "bryophyte" +} + +if (!exists("data_dir", inherits = FALSE)) { + data_dir <- file.path(project_root, "0_data/test_dataset") +} + +if (!exists("run_dir", inherits = FALSE)) { + run_dir <- file.path(project_root, "2_pipeline/plants") +} + +# NULL generates ids for every species the snapshot declares as +# modelled. +if (!exists("species_subset", inherits = FALSE)) { + species_subset <- NULL +} + +# The v2 defaults. 01b used 16 cores where 02 used 14. +if (!exists("boot_iter", inherits = FALSE)) { + boot_iter <- 1:100 +} + +if (!exists("n_clusters", inherits = FALSE)) { + n_clusters <- 16 +} + +# Minimum detections for a region's model to be considered +# viable, as in v2. +if (!exists("boot_threshold", inherits = FALSE)) { + boot_threshold <- 20 +} + +# NULL leaves the stream unseeded, which is what v2 did. +if (!exists("boot_seed", inherits = FALSE)) { + boot_seed <- NULL +} + +## 1.3 Load functions and data ---- +source(file.path( + project_root, "1_code/modules/plants/load_model_data.R" +)) +source(file.path( + project_root, + "1_code/modules/plants/functions/bootstrapping_functions.R" +)) + +model_data <- load_plant_model_data( + taxon = taxon, + data_dir = data_dir, + species = species_subset +) + +climate.data <- model_data$climate.data + +species.list <- unique(c( + model_data$veg.species.list, + model_data$soil.species.list +)) + +## 1.4 Create the output folder ---- +# save() does not create a missing folder. +dir.create( + file.path(run_dir, "bootstrap"), + recursive = TRUE, showWarnings = FALSE +) + +# 2. Define the bootstrap blocks ---- +# Sites are resampled within coarse latitude and longitude +# blocks, so a bootstrap sample keeps the geographic spread of +# the original data rather than drifting toward whichever region +# happens to be best surveyed. + +## 2.1 Cut the study area into blocks ---- +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 +) + +## 2.2 Relabel the blocks ---- +# bootstrap_data() selects a block with grep(), so the labels +# have to be free of the regex metacharacters that the interval +# notation above is full of. +reclass.site <- data.frame( + Orig = unique(site.block$Block), + Update = letters[1:length(unique(site.block$Block))] +) + +climate.data$Block <- reclass.site$Update[ + match(site.block$Block, reclass.site$Orig) +] + +rm(site.block, reclass.site) + +# 3. Generate the bootstrap ids ---- +# One set of ids per species, because the viability checks inside +# bootstrap_data() depend on where that species was detected. + +## 3.1 Define cores and objects for parallel processing ---- +if (!is.null(boot_seed)) { + set.seed(boot_seed) +} + +core.input <- makeCluster(n_clusters) + +if (!is.null(boot_seed)) { + clusterSetRNGStream(core.input, boot_seed) +} + +clusterExport( + core.input, + c("climate.data", "species.list", "boot_iter", "boot_threshold", + "bootstrap_data") +) + +cat( + "Bootstrapping ", taxon, ": ", length(species.list), + " species x ", length(boot_iter), " iterations on ", + n_clusters, " cores\n", + sep = "" +) + +## 3.2 Loop through each species ---- +bootstrap.list <- foreach(species = species.list) %dopar% + + parSapply( + core.input, + as.list(boot_iter), + FUN = function(boot) { + tryCatch( + bootstrap_data( + data = climate.data, + species = species, + threshold = boot_threshold, + boot = boot + ), + error = function(e) e + ) + } + ) + +names(bootstrap.list) <- species.list + +stopCluster(core.input) + +## 3.3 Simplify to one array per species ---- +bootstrap.ids <- list() + +for (one_species in species.list) { + bootstrap.ids[[one_species]] <- simplify2array( + bootstrap.list[[one_species]] + ) +} + +# 4. Save the results ---- +bootstrap_path <- file.path( + run_dir, "bootstrap", paste0(taxon, "-bootstrap-ids.Rdata") +) + +save(bootstrap.ids, file = bootstrap_path) + +cat("Wrote ", bootstrap_path, "\n", sep = "") + +# End of script ---- diff --git a/1_code/modules/plants/02_hierarchical_models.R b/1_code/modules/plants/02_hierarchical_models.R new file mode 100644 index 0000000..7892984 --- /dev/null +++ b/1_code/modules/plants/02_hierarchical_models.R @@ -0,0 +1,525 @@ +# --- +# title: Fit Bootstrapped Hierarchical Models (Plant Groups) +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# set by the calling experiment, or defaulted in 1.2: +# - taxon, data_dir, run_dir, species_subset, boot_iter, +# n_clusters +# in data_dir: +# - .csv, sites.csv, covariates/, lookup/ +# in run_dir: +# - bootstrap/-bootstrap-ids.Rdata, from 01 +# in this repository: +# - 1_code/modules/plants/load_model_data.R +# - 1_code/modules/plants/functions/ +# hierarchical-model_functions.R +# outputs: +# in run_dir: +# - models/-species-models.Rdata +# (climate.coef, vegetation.coef, soil.coef) +# notes: +# - Rewrite of the v2 scripts 02a-02d, which were four +# near-identical files. They differed only in the taxon they +# loaded and in whether they fitted a Protocol term, so they +# are one script here, parameterized by `taxon`. The formula +# text in section 2 is the v2 text verbatim, and the Protocol +# term is inserted for the taxa whose v2 script carried it, +# which reproduces all 42 formulas of both variants exactly. +# - The v2 scripts read a -model-data.Rdata that 01a +# built against paths on the v2 project. This one reads the +# harmonized test dataset, so a run needs only this +# repository and 0_data/test_dataset/. +# - Output location is the caller's to choose. v2 hard-coded +# 3_output/models/; here run_dir comes from the experiment. +# - All three model sets are defined in section 2, before any +# of them is fitted. v2 defined each set immediately before +# fitting it, which meant a model naming a habitat type its +# prediction matrix had no column for failed only after the +# climate models had already run. +# - The species selection is `species_subset`, not `species`. +# The v2 code loops with `for (species in species.list)`, +# which would otherwise overwrite the selection and leave the +# next stage running on one species. +# - boot_iter and n_clusters were hard-coded in v2 as 1:100 and +# 14. They are parameters here, but they default to the v2 +# values, so a parity run sets neither. +# - The v2 code took its vegetation coefficient names +# positionally, as colnames(veg.data)[403:489] and three +# other per-taxon spans. load_model_data.R names them +# instead; see its header for why. +# - foreach() runs with no backend registered, exactly as in +# v2, so the outer %dopar% is sequential and the parallelism +# is the inner parSapply over bootstraps. Left as it is: +# registering a backend would change the run, not just its +# speed. +# - Future improvement - the three model sets differ only in +# their data, formulas and fitting function, so sections 3 to +# 5 could share one helper rather than repeating the cluster +# setup. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(foreach) # sequential %dopar% loop, as in v2 (version: 1.5.2) +library(parallel) # bootstrap-level parallelism (version: 4.5.0) + +## 1.2 Configure the run ---- +# Values a calling experiment has already set are kept, so this +# script runs either from 1_code/experiments/ or on its own. +if (!exists("project_root", inherits = FALSE)) { + project_root <- normalizePath(getwd(), winslash = "/") +} + +if (!exists("taxon", inherits = FALSE)) { + taxon <- "bryophyte" +} + +if (!exists("data_dir", inherits = FALSE)) { + data_dir <- file.path(project_root, "0_data/test_dataset") +} + +if (!exists("run_dir", inherits = FALSE)) { + run_dir <- file.path(project_root, "2_pipeline/plants") +} + +# NULL models every species the snapshot declares as modelled. +if (!exists("species_subset", inherits = FALSE)) { + species_subset <- NULL +} + +# The v2 defaults. Lower them for a smoke test. +if (!exists("boot_iter", inherits = FALSE)) { + boot_iter <- 1:100 +} + +if (!exists("n_clusters", inherits = FALSE)) { + n_clusters <- 14 +} + +## 1.3 Load functions and data ---- +source(file.path( + project_root, "1_code/modules/plants/load_model_data.R" +)) +source(file.path( + project_root, + "1_code/modules/plants/functions/hierarchical-model_functions.R" +)) + +model_data <- load_plant_model_data( + taxon = taxon, + data_dir = data_dir, + species = species_subset +) + +climate.data <- model_data$climate.data +veg.data <- model_data$veg.data +soil.data <- model_data$soil.data + +veg.species.list <- model_data$veg.species.list +soil.species.list <- model_data$soil.species.list +species.list <- unique(c(veg.species.list, soil.species.list)) + +## 1.4 Load the bootstrap ids ---- +# Written by 01_bootstrap_ids.R into the same run_dir. +bootstrap_path <- file.path( + run_dir, "bootstrap", paste0(taxon, "-bootstrap-ids.Rdata") +) + +if (!file.exists(bootstrap_path)) { + stop( + "No bootstrap ids at ", + bootstrap_path, + "\nRun 1_code/modules/plants/01_bootstrap_ids.R first.", + call. = FALSE + ) +} + +load(bootstrap_path) + +## 1.5 Set the Protocol term for this taxon ---- +# v2 fitted Protocol for bryophytes and lichens, and not for +# mites or vascular plants. plant_taxa() is the record of which. +use_protocol <- taxon_uses_protocol(taxon) + +# In v2 the two Protocol scripts were their non-Protocol +# counterparts with the term inserted directly after Climate, and +# nowhere else. Applying that rule to the formula text in section +# 2 reproduces both variants exactly. +# +# The environment is set to the global environment, matching v2, +# where every formula was built at the top level. +build_models <- function(model_text, protocol = use_protocol) { + lapply( + model_text, + function(one) { + if (protocol) { + one <- sub( + "pcount ~ Climate", + "pcount ~ Climate + Protocol", + one, + fixed = TRUE + ) + } + + as.formula(one, env = globalenv()) + } + ) +} + +# Prefix for the coefficient templates, for the same reason. +coef_prefix <- if (use_protocol) { + c("Intercept", "Climate", "Protocol") +} else { + c("Intercept", "Climate") +} + +## 1.6 Create the output folder ---- +# save() does not create a missing folder, so a run would +# otherwise fail after the modelling rather than before it. +dir.create( + file.path(run_dir, "models"), + recursive = TRUE, showWarnings = FALSE +) + +cat( + "Fitting ", taxon, ": ", length(species.list), " species x ", + length(boot_iter), " bootstraps on ", n_clusters, " cores\n", + sep = "" +) + +# 2. Define the model sets ---- +# Everything the three fitting sections need, built before any of +# them runs, so a mismatch between a model and its prediction +# matrix is found in seconds rather than after the climate models +# have been fitted. + +## 2.1 Define climate models ---- +# The climate formulas carry no Protocol term in either v2 +# variant, so they are built without one. +climate.model.text <- c( + "pcount ~ 1", + "pcount ~ PET", + "pcount ~ CMD", + "pcount ~ MAT", + "pcount ~ FFP", + "pcount ~ MAP + FFP", + "pcount ~ MAP + FFP + CMD", + "pcount ~ MAP + PET + CMD + MAPPET", + "pcount ~ MAT + MAP + CMD + CMDMAT", + "pcount ~ MAT + MAP", + "pcount ~ MWMT + TD", + "pcount ~ CMD + PET", + "pcount ~ MAT + MAT2 + MWMT + MWMT2", + "pcount ~ TD + FFP + MAT" +) + +climate.models <- build_models( + climate.model.text, protocol = FALSE +) + +bioclim.model.text <- c( + ".~.+ bio9 + bio15" +) + +bioclim.models <- build_models( + bioclim.model.text, protocol = FALSE +) + +## 2.2 Define spatial models ---- +space.model.text <- c( + ".~.+ Easting + Northing", + ".~.+ Easting + Northing + EastingNorthing", + ".~.+ Easting + Northing + Easting2 + Northing2 + EastingNorthing" +) + +space.models <- build_models(space.model.text, protocol = FALSE) + +## 2.3 Define the prediction matrices ---- +# Both are needed for the checks below, so unlike v2 they are +# held under separate names rather than one reused +# prediction.matrix. +veg.prediction.matrix <- model_data$veg.pm +rownames(veg.prediction.matrix) <- veg.prediction.matrix$VegType +veg.prediction.matrix <- veg.prediction.matrix[, -1] + +soil.prediction.matrix <- model_data$soil.pm +rownames(soil.prediction.matrix) <- soil.prediction.matrix$VegType +soil.prediction.matrix <- soil.prediction.matrix[, -1] + +## 2.4 Define vegetation models ---- +vegetation.model.text <- c( + "pcount ~ 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", + "pcount ~ 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", + "pcount ~ 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", + "pcount ~ 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", + "pcount ~ Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Bog + Fen + Swamp + Marsh + GrassShrub + CCWhiteSprucePineR + CCWhiteSprucePine1 + CCWhiteSprucePine234 + CCDecidMixedR + CCDecidMixed1 + CCDecidMixed234 + HardLin + SoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + "pcount ~ Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Peatland + Mineral + GrassShrub + CCWhiteSprucePineR1234 + CCDecidMixedR1234 + HardLin + SoftLin + UrbIndWellsites + Crop + Pasture", + "pcount ~ Climate + WhiteSpruce + Pine + Deciduous + Mixedwood + Lowland + GrassShrub + CCWhiteSprucePineR1234 + CCDecidMixedR1234 + SoftLin + Alien", + "pcount ~ Climate + Upland + BlackSpruce + TreedFen + TreedSwamp + GraminoidFen + ShrubbyFen + ShrubbyBog + ShrubbySwamp + Marsh + Grass + Shrub + CCR1234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + "pcount ~ Climate + Upland + Bog + Fen + Swamp + Marsh + Grass + Shrub + CCR1234 + HardLin + EnSeismic + EnSoftLin + TrSoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + "pcount ~ Climate + Upland + Peatland + Swamp + Marsh + GrassShrub + CCR1234 + HardLin + SoftLin + UrbInd + Wellsites + Crop + RoughP + TameP", + "pcount ~ Climate + Upland + Peatland + Mineral + GrassShrub + CCR1234 + HardLin + SoftLin + UrbIndWellsites + Crop + Pasture", + "pcount ~ Climate + Upland + Lowland + GrassShrub + CCR1234 + SoftLin + Alien" +) + +vegetation.models <- build_models(vegetation.model.text) + +## 2.5 Define soil models ---- +soil.model.text <- c( + "pcount ~ Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + "pcount ~ Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbInd+ Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin", + "pcount ~ Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + "pcount ~ Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbIndWellsites + Cult + SoftLin + HardLin", + "pcount ~ Climate + Productive + Nonproductive + Other + Alien + SoftLin", + "pcount ~ Climate + Blowout + ClaySub + Loamy + RapidDrain + SandyLoam + ThinBreak + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + "pcount ~ Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbInd + Wellsites + Crop + TameP + RoughP + EnSoftLin + EnSeismic + TrSoftLin + HardLin + paspen", + "pcount ~ Climate + Blowout + ClaySub + Loamy +RapidDrain + SandyLoam + ThinBreak + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + "pcount ~ Climate + Blowout + ClaySubThin + Loamy + SandyRapid + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbIndWellsites + Crop + Pasture + SoftLin + HardLin + paspen", + "pcount ~ Climate + Productive + Nonproductive + Other + UrbIndWellsites + Cult + SoftLin + HardLin + paspen", + "pcount ~ Climate + Productive + Nonproductive + Other + Alien + SoftLin + paspen" +) + +soil.models <- build_models(soil.model.text) + +## 2.6 Check the models against the prediction matrices ---- +# Every habitat term is predicted onto a column of its prediction +# matrix after fitting, so a term with no column cannot be +# predicted. In v2 that surfaced as `object '' not found` +# raised inside every bootstrap of every species. +pm_source_note <- paste0( + "\nThe matrices in ", data_dir, "/lookup/ are written from ", + "the\nsnapshot's veg.pm and soil.pm. The v2 scripts instead ", + "read\nveg-prediction-matrix-CC_2024.csv and\n", + "soil-prediction-matrix_2024.csv from the v2 project, which\n", + "carry the aggregate habitat columns the snapshot copies do\n", + "not. Set SDM_V2_LOOKUP to the folder holding those two files\n", + "and re-run 1_code/_setup/01_harmonize_model_ready_v2.R." +) + +check_prediction_terms( + vegetation.models, veg.prediction.matrix, "vegetation", + pm_source_note +) + +check_prediction_terms( + soil.models, soil.prediction.matrix, "soil", pm_source_note +) + +## 2.7 Define the coefficient templates ---- +# The vegetation template is the 87 habitat types, named by +# load_model_data.R rather than taken positionally. +veg.coef.names <- c(coef_prefix, model_data$veg_coef_names) +veg.coef.template <- rep(NA, length(veg.coef.names)) +names(veg.coef.template) <- veg.coef.names + +soil.coef.names <- c( + "paspen", + "Loamy", + "SandyLoam", + "ClaySub", + "RapidDrain", + "Blowout", + "ThinBreak", + "Other", + "EnSeismic", + "EnSoftLin", + "TrSoftLin", + "HardLin", + "UrbInd", + "Wellsites", + "Crop", + "TameP", + "RoughP" +) + +soil.coef.template.names <- c(coef_prefix, soil.coef.names) +soil.coef.template <- rep( + NA, length(soil.coef.template.names) +) +names(soil.coef.template) <- soil.coef.template.names + +# 3. Fit the climate models ---- +# Run over every bootstrap iteration on the spatially thinned +# data. The fitted climate coefficients feed both habitat model +# sets, so this section runs first. + +## 3.1 Define cores and objects for parallel processing ---- +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") +) +clusterEvalQ(core.input, { + + # Load relevant libraries + library(AICcmodavg) # Model averaging + library(arm) # Allows for the use of bayesglm function + library(binom) # For exact binomial confidence intervals + library(mapproj) # For projected maps + library(mgcv) # For binomial GAM + library(MuMIn) + library(pROC) + library(RcmdrMisc) + +}) + +## 3.2 Loop through each species ---- +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) + +# 4. Fit the vegetation models ---- +# The north model set, fitted for veg.species.list. + +## 4.1 Define cores and objects for parallel processing ---- +# use_protocol is read inside the worker closure, so it has to be +# exported. v2 passed a literal TRUE or FALSE and did not. +core.input <- makeCluster(n_clusters) +clusterExport( + core.input, + c("veg.data", "species.list", "bootstrap.ids", + "vegetation.models", "veg.prediction.matrix", "climate.coef", + "boot_iter", "veg.coef.template", "use_protocol", + "vegetation_models") +) +clusterEvalQ(core.input, { + + # Load relevant libraries + library(AICcmodavg) # Model averaging + library(arm) # Allows for the use of bayesglm function + library(binom) # For exact binomial confidence intervals + library(mapproj) # For projected maps + library(mgcv) # For binomial GAM + library(MuMIn) + library(pROC) + library(RcmdrMisc) + +}) + +## 4.2 Loop through each species ---- +vegetation.coef <- foreach(species = veg.species.list) %dopar% + + t(parSapply( + core.input, + as.list(boot_iter), + FUN = function(boot) { + tryCatch( + vegetation_models( + species = species, + data = veg.data, + boot.data = bootstrap.ids, + habitat.models = vegetation.models, + prediction.matrix = veg.prediction.matrix, + climate.coef = climate.coef, + coef.template = veg.coef.template, + weight.method = "IVW", + coef.adjust = TRUE, + protocol.flag = use_protocol, + boot = boot + ), + error = function(e) e + ) + } + )) + +names(vegetation.coef) <- veg.species.list + +stopCluster(core.input) + +# 5. Fit the soil models ---- +# The south model set, fitted for soil.species.list. A species +# can be common enough to model in one region and not the other, +# so the two lists differ. + +## 5.1 Define cores and objects for parallel processing ---- +core.input <- makeCluster(n_clusters) +clusterExport( + core.input, + c("soil.data", "species.list", "bootstrap.ids", "soil.models", + "soil.prediction.matrix", "climate.coef", "boot_iter", + "soil.coef.template", "use_protocol", "soil_models") +) +clusterEvalQ(core.input, { + + # Load relevant libraries + library(AICcmodavg) # Model averaging + library(arm) # Allows for the use of bayesglm function + library(binom) # For exact binomial confidence intervals + library(mapproj) # For projected maps + library(mgcv) # For binomial GAM + library(MuMIn) + library(pROC) + library(RcmdrMisc) + +}) + +## 5.2 Loop through each species ---- +soil.coef <- foreach(species = soil.species.list) %dopar% + + t(parSapply( + core.input, + as.list(boot_iter), + FUN = function(boot) { + tryCatch( + soil_models( + species = species, + data = soil.data, + boot.data = bootstrap.ids, + habitat.models = soil.models, + prediction.matrix = soil.prediction.matrix, + climate.coef = climate.coef, + coef.template = soil.coef.template, + weight.method = "IVW", + coef.adjust = TRUE, + protocol.flag = use_protocol, + boot = boot + ), + error = function(e) e + ) + } + )) + +names(soil.coef) <- soil.species.list + +stopCluster(core.input) + +# 6. Save the results from all three model sets ---- +models_path <- file.path( + run_dir, "models", paste0(taxon, "-species-models.Rdata") +) + +save(climate.coef, soil.coef, vegetation.coef, file = models_path) + +cat("Wrote ", models_path, "\n", sep = "") + +# End of script ---- diff --git a/1_code/modules/plants/03_model_validation.R b/1_code/modules/plants/03_model_validation.R new file mode 100644 index 0000000..e5eff25 --- /dev/null +++ b/1_code/modules/plants/03_model_validation.R @@ -0,0 +1,285 @@ +# --- +# title: Validate Bootstrapped Models (Plant Groups) +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# set by the calling experiment, or defaulted in 1.2: +# - taxon, data_dir, run_dir, species_subset, boot_iter, +# n_clusters +# in data_dir: +# - .csv, sites.csv, covariates/, lookup/ +# in run_dir: +# - bootstrap/-bootstrap-ids.Rdata, from 01 +# - models/-species-models.Rdata, from 02 +# in this repository: +# - 1_code/modules/plants/load_model_data.R +# - 1_code/modules/plants/functions/ +# model-validation_functions.R +# outputs: +# in run_dir: +# - validation/-models-validation.Rdata +# (vegetation.fit, soil.fit) +# notes: +# - Rewrite of the v2 scripts 03a-03d, which were four +# near-identical files differing only in the taxon they +# loaded and in protocol.flag. They are one script here, +# parameterized by `taxon`, with the flag read from +# plant_taxa() so it cannot drift from what 02 fitted. +# - The species queue comes from the fitted model object rather +# than from the data, exactly as v2 did, so validation covers +# what was actually fitted even when 02 ran on a subset. +# - NA coefficients are set to qlogis(0.001) before scoring and +# the standard error columns are dropped, which is v2's +# handling of a bootstrap that failed to converge: an +# unestimated coefficient is scored as near-zero probability +# rather than dropping the iteration. +# - v2's 03a header names its output byrophyte-...Rdata while +# the code writes bryophyte-...Rdata. The name is built from +# `taxon` here, so the two cannot disagree. +# - The species selection is `species_subset`, not `species`. +# The v2 code loops with `for (species in species.list)`, +# which would otherwise overwrite the selection and leave the +# next stage running on one species. +# - Future improvement - the two model sets differ only in +# their data, coefficients and landcover.type, so they could +# share one helper rather than repeating the cluster setup. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(foreach) # sequential %dopar% loop, as in v2 (version: 1.5.2) +library(parallel) # bootstrap-level parallelism (version: 4.5.0) + +## 1.2 Configure the run ---- +# Values a calling experiment has already set are kept, so this +# script runs either from 1_code/experiments/ or on its own. +if (!exists("project_root", inherits = FALSE)) { + project_root <- normalizePath(getwd(), winslash = "/") +} + +if (!exists("taxon", inherits = FALSE)) { + taxon <- "bryophyte" +} + +if (!exists("data_dir", inherits = FALSE)) { + data_dir <- file.path(project_root, "0_data/test_dataset") +} + +if (!exists("run_dir", inherits = FALSE)) { + run_dir <- file.path(project_root, "2_pipeline/plants") +} + +if (!exists("species_subset", inherits = FALSE)) { + species_subset <- NULL +} + +# The v2 defaults. +if (!exists("boot_iter", inherits = FALSE)) { + boot_iter <- 1:100 +} + +if (!exists("n_clusters", inherits = FALSE)) { + n_clusters <- 14 +} + +## 1.3 Load functions and data ---- +source(file.path( + project_root, "1_code/modules/plants/load_model_data.R" +)) +source(file.path( + project_root, + "1_code/modules/plants/functions/model-validation_functions.R" +)) + +model_data <- load_plant_model_data( + taxon = taxon, + data_dir = data_dir, + species = species_subset +) + +veg.data <- model_data$veg.data +soil.data <- model_data$soil.data + +use_protocol <- taxon_uses_protocol(taxon) + +## 1.4 Load the bootstrap ids and the fitted models ---- +bootstrap_path <- file.path( + run_dir, "bootstrap", paste0(taxon, "-bootstrap-ids.Rdata") +) + +models_path <- file.path( + run_dir, "models", paste0(taxon, "-species-models.Rdata") +) + +missing_inputs <- c(bootstrap_path, models_path) +missing_inputs <- missing_inputs[!file.exists(missing_inputs)] + +if (length(missing_inputs) > 0) { + stop( + "Validation inputs not found:\n ", + paste(missing_inputs, collapse = "\n "), + "\nRun 01_bootstrap_ids.R and 02_hierarchical_models.R first.", + call. = FALSE + ) +} + +load(bootstrap_path) +load(models_path) + +## 1.5 Take the species queue from the fitted models ---- +# Not from the data. 02 may have run on a subset, and only what +# it fitted can be scored. +species.list <- names(climate.coef) +veg.species.list <- names(vegetation.coef) +soil.species.list <- names(soil.coef) + +dir.create( + file.path(run_dir, "validation"), + recursive = TRUE, showWarnings = FALSE +) + +cat( + "Validating ", taxon, ": ", length(veg.species.list), + " vegetation and ", length(soil.species.list), + " soil species x ", length(boot_iter), " bootstraps\n", + sep = "" +) + +## 1.6 Prepare coefficients for model fit evaluation ---- +# A bootstrap that failed to estimate a coefficient leaves NA. +# v2 scores those as qlogis(0.001), a near-zero probability, +# rather than dropping the iteration, and drops the standard +# error columns, which are not used in scoring. +for (one_species in veg.species.list) { + + climate.coef[[one_species]][ + is.na(climate.coef[[one_species]]) + ] <- qlogis(0.001) + + vegetation.coef[[one_species]][ + is.na(vegetation.coef[[one_species]]) + ] <- qlogis(0.001) + vegetation.coef[[one_species]] <- vegetation.coef[[one_species]][ + , -grep(".SE", colnames(vegetation.coef[[one_species]])) + ] + +} + +for (one_species in soil.species.list) { + + climate.coef[[one_species]][ + is.na(climate.coef[[one_species]]) + ] <- qlogis(0.001) + + soil.coef[[one_species]][ + is.na(soil.coef[[one_species]]) + ] <- qlogis(0.001) + soil.coef[[one_species]] <- soil.coef[[one_species]][ + , -grep(".SE", colnames(soil.coef[[one_species]])) + ] + +} + +# 2. Vegetation model fit ---- +# Scores the north model set per species per bootstrap, on AUC +# and the related measures model_validation() returns. + +## 2.1 Define cores and objects for parallel processing ---- +core.input <- makeCluster(n_clusters) +clusterExport( + core.input, + c("veg.data", "veg.species.list", "bootstrap.ids", + "vegetation.coef", "climate.coef", "boot_iter", + "use_protocol", "model_validation") +) +clusterEvalQ(core.input, { + + # Load relevant libraries + library(pROC) + +}) + +## 2.2 Loop through each species ---- +vegetation.fit <- foreach(species = veg.species.list) %dopar% + + t(parSapply( + core.input, + as.list(boot_iter), + FUN = function(boot) { + tryCatch( + model_validation( + species = species, + data = veg.data, + boot.data = bootstrap.ids, + climate.coef = climate.coef, + landcover.coef = vegetation.coef, + landcover.type = "Vegetation", + protocol.flag = use_protocol, + boot = boot + ), + error = function(e) e + ) + } + )) + +names(vegetation.fit) <- veg.species.list + +stopCluster(core.input) + +# 3. Soil model fit ---- +# The same scoring for the south model set. + +## 3.1 Define cores and objects for parallel processing ---- +core.input <- makeCluster(n_clusters) +clusterExport( + core.input, + c("soil.data", "soil.species.list", "bootstrap.ids", + "soil.coef", "climate.coef", "boot_iter", "use_protocol", + "model_validation") +) +clusterEvalQ(core.input, { + + # Load relevant libraries + library(pROC) + +}) + +## 3.2 Loop through each species ---- +soil.fit <- foreach(species = soil.species.list) %dopar% + + t(parSapply( + core.input, + as.list(boot_iter), + FUN = function(boot) { + tryCatch( + model_validation( + species = species, + data = soil.data, + boot.data = bootstrap.ids, + climate.coef = climate.coef, + landcover.coef = soil.coef, + landcover.type = "Soil", + protocol.flag = use_protocol, + boot = boot + ), + error = function(e) e + ) + } + )) + +names(soil.fit) <- soil.species.list + +stopCluster(core.input) + +# 4. Save the results ---- +validation_path <- file.path( + run_dir, "validation", + paste0(taxon, "-models-validation.Rdata") +) + +save(vegetation.fit, soil.fit, file = validation_path) + +cat("Wrote ", validation_path, "\n", sep = "") + +# End of script ---- diff --git a/1_code/modules/plants/functions/bootstrapping_functions.R b/1_code/modules/plants/functions/bootstrapping_functions.R new file mode 100644 index 0000000..fd87be9 --- /dev/null +++ b/1_code/modules/plants/functions/bootstrapping_functions.R @@ -0,0 +1,130 @@ +# --- +# title: Bootstrapping functions +# author: Brandon Allen +# created: 2025-02-11 +# notes: Define functions that are used generating the bootstrap site list +# --- + +#' [Bootstrap data] +#' +#' [Creates a vector of site codes after thinning the recording data and performing a spatially explicate bootstrap sample.] +#' +#' @param [data] [Cleaned species and landcover data.] +#' @param [species] [Species code.] +#' @param [threshold] [Number of unique sites required to be considered sufficient for modeling.] +#' @param [boot] [Bootstrap iteration.] +#' @return [Creates a vector of site codes.] +#' + +bootstrap_data <- function(data, species, threshold = 20, boot) { + + # + # 1.0 Data standardization + # + + # Since we are treating each recording individually, we fix visit to 1 as we no longer need to apply this weight. + data["nQuadrant"] <- 1 + data$visit <- 1 + + # Create new column which is the observed count data (used for weighting in the age relationships), one for the converted probabilities + data["Count"] <- as.integer(ifelse(data[, species] > 0, 1, 0)) + data["pcount"] <- as.integer(ifelse(data[, species] > 0, 1, 0) / data$nQuadrant) + + # + # 2.0 Bootstrap + # If the boot index is 1, use the complete data set, + # otherwise perform subsampling with replacement based on block ID. + # + + # Check if there are at least 20 detections in each modeling region. + veg.detect <- sum(data$pcount[data$NR != "Grassland"]) + soil.detect <- sum(data$pcount[data$NR %in% c("Grassland", "Parkland")]) + + if (boot != 1) { + + unique.blocks <- unique(data$Block) + veg.site <- 0 + soil.site <- 0 + + # If both models are viable originally + if(veg.detect >= threshold & soil.detect >= threshold) { + + while (veg.site < threshold | soil.site < threshold) { + + data.in <- NULL + + for (sample_block in 1:length(unique.blocks)) { + + data.block <- data[grep(unique.blocks[sample_block], data$Block), ] + data.block <- data.block[sample(1:nrow(data.block), + nrow(data.block), replace=TRUE), ] + data.in <- rbind(data.in, data.block) + + } + + veg.site <- sum(ifelse(data.in[, "Count"] > 0, 1, 0)) + soil.site <- sum(ifelse(data.in[, "Count"] > 0, 1, 0)) + + } + + } + + # If only veg model is viable + if(veg.detect >= threshold & soil.detect < threshold) { + + while (veg.site < threshold) { + + data.in <- NULL + + for (sample_block in 1:length(unique.blocks)) { + + data.block <- data[grep(unique.blocks[sample_block], data$Block), ] + data.block <- data.block[sample(1:nrow(data.block), + nrow(data.block), replace=TRUE), ] + data.in <- rbind(data.in, data.block) + + } + + veg.site <- sum(ifelse(data.in[, "Count"] > 0, 1, 0)) + + } + + } + + # If only soil model is viable + if(veg.detect < threshold & soil.detect >= threshold) { + + while (soil.site < threshold) { + + data.in <- NULL + + for (sample_block in 1:length(unique.blocks)) { + + data.block <- data[grep(unique.blocks[sample_block], data$Block), ] + data.block <- data.block[sample(1:nrow(data.block), + nrow(data.block), replace=TRUE), ] + data.in <- rbind(data.in, data.block) + + } + + soil.site <- sum(ifelse(data.in[, "Count"] > 0, 1, 0)) + + } + + } + + + + } else { + + data.in <- data + + } + + # Return the unique IDs for the bootstrap iteration + boot.id <- data.frame(Boot = data.in$SiteYearQu) + colnames(boot.id)[1] <- paste0("Boot_", boot) + + return(boot.id) + +} diff --git a/1_code/modules/plants/functions/hierarchical-model_functions.R b/1_code/modules/plants/functions/hierarchical-model_functions.R new file mode 100644 index 0000000..b38632b --- /dev/null +++ b/1_code/modules/plants/functions/hierarchical-model_functions.R @@ -0,0 +1,981 @@ +# --- +# title: Species hierarchical model functions +# author: Brandon Allen +# created: 2025-02-11 +# notes: Define functions that are used for performing the hierarchical modeling process. +# --- + +#' [Climate-space models] +#' +#' [Climate and spatial models that uses the spatially thinned data.] +#' +#' @param [species] [Focal species of interest.] +#' @param [data] [Cleaned species, climate, and landcover data.] +#' @param [boot.data] [List of site codes to be included for each species and bootstrap iteration.] +#' @param [climate.models] [List of climate model formulas to be assessed.] +#' @param [bioclim.models] [List of bioclim model formulas to be assessed.] +#' @param [space.models] [List of spatial model formulas to be assessed.] +#' @param [boot] [Defines bootstrap iteration.] +#' @return [Outputs vector of model coefficients defined in climate.models, bioclim.models, and space.models.] +#' + +climate_models <- function(species, data, boot.data, climate.models, bioclim.models, space.models, boot) { + + # + # 1.0 Data standardization + # + + # Since we are treating each recording individually, we fix visit to 1 as we no longer need to apply this weight. + data["nQuadrant"] <- 1 + data$visit <- 1 + + # Create new column which is the observed count data (used for weighting in the age relationships), one for the converted probabilities + data["Count"] <- as.integer(ifelse(data[, species] > 0, 1, 0)) + data["pcount"] <- as.integer(ifelse(data[, species] > 0, 1, 0) / data$nQuadrant) + data["TotalNoOfQU"] <- rep (1, nrow(data)) #Just add 1 + data["wt"] <- rep (1, nrow(data)) #Just add 1 + wt1<-data$TotalNoOfQU*data$wt # Kept for legacy purposes + + # 2.0 Bootstrap Selection + boot.data <- boot.data[[species]] + site.id <- boot.data[, paste0("Boot_", boot)] + data <- data[site.id, ] + + # + # 3.0 Climate Models + # + + space.climate.store <- list(NULL) + + for (model in 1:length(climate.models)) { + + space.climate.store[[model]] <- try(bayesglm(climate.models[[model]], + family = "binomial", + data = data, + maxit = 250)) + + } + + # Need to make sure all climate models get an update for these two variables + if(!is.null(bioclim.models)) { + + for (model.bioclim in 1:length(bioclim.models)) { + + # Calculate the length of the current model object and add to it + model.list.length <- length(climate.models) + + for (model.clim in 1:length(climate.models)) { + + # Define modifier for storing + space.climate.store[[model.clim + model.list.length]] <- try(update(space.climate.store[[model.clim]], bioclim.models[[model.bioclim]])) + + } + + } + + } + + # + # 4.0 Spatial Models + # + + if(!is.null(space.models)) { + + # Only add spatial updates for models without MAT, TD, PET (keep 1,3,5,6,7,17,19,20,21) + model.update.id <- c(1, 3, 5, 6, 7, 15, 17, 19, 20, 21) + + for (model.clim in model.update.id) { + + # Calculate the length of the current model object and add to it + model.list.length <- length(space.climate.store) + + for (model.space in 1:length(space.models)) { + + # Define modifier for storing + space.climate.store[[model.space + model.list.length]] <- try(update(space.climate.store[[model.clim]], space.models[[model.space]])) + + } + + } + + } + + # + # 5.0 Create ensemble and store + # + + modavg.sc <- model.avg(space.climate.store , rank = "AICc") + aicWtd.sc <- modavg.sc$coefficients["full", ] + + # Formatting to align variable names and keep intercept first + intercept.only <- aicWtd.sc[1] + names(intercept.only) <- "Intercept" + aicWtd.sc <- aicWtd.sc[-1] + aicWtd.sc <- aicWtd.sc[order(names(aicWtd.sc))] + aicWtd.sc <- c(intercept.only, aicWtd.sc) + + return(aicWtd.sc) + +} + +#' [Vegetation models] +#' +#' [Vegetation models that uses the spatially thinned data.] +#' +#' @param [species] [Focal species of interest.] +#' @param [data] [Cleaned species, climate, and landcover data.] +#' @param [boot.data] [List of site codes to be included for each species and bootstrap iteration.] +#' @param [habitat.models] [List of habitat model formulas to be assessed.] +#' @param [prediction.matrix] [Prediction matrix used for converting model coefficients to standardized habitat classes.] +#' @param [climate.coef] [List of climate coefficients calculated from the detection_models function.] +#' @param [weight.method] [Method used for weighting model coefficients. Inverse variance weighted is the only available method currently.] +#' @param [coef.template] [Vector template used to define valid model coefficients] +#' @param [protocol.flag] [Flag that determines if we need to account for differences in sample protocols] +#' @param [coef.adjust] [Flag used to determine if poorly sampled human footprint coefficients are adjusted based on similar feature types.] +#' @param [boot] [Defines bootstrap iteration.] +#' @return [Outputs vector of model coefficients defined in habitat.models.] +#' + +vegetation_models <- function(species, data, boot.data, habitat.models, prediction.matrix, + climate.coef, weight.method = "IVW", coef.template, + protocol.flag, coef.adjust = TRUE, boot) { + + # + # 1.0 Data standardization + # + + # Since we are treating each recording individually, we fix visit to 1 as we no longer need to apply this weight. + data["nQuadrant"] <- 1 + data$visit <- 1 + + # Create new column which is the observed count data (used for weighting in the age relationships), one for the converted probabilities + data["Count"] <- as.integer(ifelse(data[, species] > 0, 1, 0)) + data["pcount"] <- as.integer(ifelse(data[, species] > 0, 1, 0) / data$nQuadrant) + + # 1.1 Bootstrap Selection + boot.data <- boot.data[[species]] + site.id <- boot.data[, paste0("Boot_", boot)] + data <- data[site.id, ] + + # 1.2 Regional filter + data <- data[!(data$NR %in% c("Grassland")), ] + + # If the number of detections for the species is less than 20, skip + if(sum(data$Count) < 20) { + + coef.results <- coef.template + coef.se.results <- coef.results + names(coef.se.results) <- paste0(names(coef.se.results), ".SE") + coef.results <- c(coef.results, coef.se.results) + return(coef.results) + + } + + # 1.3 Define the templates for coefficients + coef.results <- coef.template + coef.se.results <- coef.template + + # + # 3.0 Climate Predictions + # + + # Using the matching climate model, create the prediction that will be used + # Add the intercept and extract climate coefficients + data$Intercept <- 1 + climate.dect.coef <- climate.coef[[species]][boot, ] + climate.veg <- as.matrix(data[, names(climate.dect.coef)]) + + # Predict space/climate component (Probability scale) + data$Climate <- plogis(drop(climate.veg %*% climate.dect.coef)) + + # + # 4.0 Vegetation Model + # + + # Loop through the models + landscape.store <- list(NULL) + + for (model in 1:length(habitat.models)) { + + landscape.store[[model]] <- try(bayesglm(habitat.models[[model]], family = "binomial", + data = data, + maxit = 250)) + + } + + # + # 5.0 Store the coefficients + # + + nModels <- length(habitat.models) + p1 <- p1.se <- array(0, c(length(habitat.models), nrow(prediction.matrix))) # Predictions for each model for each soil and HF type type. These are the main coefficients + colnames(p1) <- colnames(p1.se) <- rownames(prediction.matrix) + p.site1 <- p.site1.se <- array(0, c(nModels, nrow(data))) # Predictions for each model and each site. These are used as the offsets in the next stage + + # If there is a protocol coefficient, add it to the list, otherwise only store the climate coefficient + if(protocol.flag == TRUE) { + + p1.climate <- p1.climate.se <- array(0, c(length(habitat.models), 3)) + colnames(p1.climate) <- colnames(p1.climate.se) <- c("Intercept", "Climate", "Protocol") + + } else { + + p1.climate <- p1.climate.se <- array(0, c(length(habitat.models), 2)) + colnames(p1.climate) <- colnames(p1.climate.se) <- c("Intercept", "Climate") + + } + + for (i in 1:nModels) { + + if (class(landscape.store[[i]])[1] != "try-error") { # Prediction is 0 if model failed, but this is not used because AIC wt would equal 0 + + if(protocol.flag == TRUE) { + + plot.data <- data.frame(prediction.matrix, + Climate = 0, + Protocol = as.factor("New")) + + } else { + + plot.data <- data.frame(prediction.matrix, + Climate = 0) + + } + + p <- predict(landscape.store[[i]], newdata = plot.data, se.fit = TRUE) # For each type. Predictions made at 0% Aspen. All predictions made with new protocol. Aspen effect added later, and plotted as separate points + p1[i,] <- p$fit + p1.se[i,] <- p$se.fit + + model.fit <- predict(landscape.store[[i]], se.fit = TRUE) + p.site1[i,] <- model.fit$fit # For each site (using the original d.sp data frame) + p.site1.se[i,] <- model.fit$se.fit # For each site SE + + # Extract the climate and intercept coefficients + # We weight them separately, but then add them together to create the final coefficient + + # Coef storage (Extracts only the number of coefficients equal to object) + p <- summary(landscape.store[[i]])$coefficients[1:ncol(p1.climate),1] # For each type. + names(p)[1] <- "Intercept" + p1.climate[i, ] <- p + + # Standard error storage + p <- summary(landscape.store[[i]])$coefficients[1:ncol(p1.climate),2] # For each type. + names(p)[1] <- "Intercept" + p1.climate.se[i, ] <- p + + } + + } + + # + # 6.0 Weight the models + # + + if (weight.method == "IVW") { + + # + # Landcover + # + + tTypeMean <- tTypeVar <- NULL # Logit-scaled IVW for each veg type + + mod.converged <- NULL + for (i in 1:nModels) {mod.converged[i] <- landscape.store[[i]]$converged} + + # If there SE is 0 for a coefficient, fix it to a small value to avoid INF + p1.se[p1.se == 0] <- 0.0001 + + for (i in 1:nrow(prediction.matrix)) { + + # Note for me, the SE should be the mean not the sum. Otherwise the SE will converge to 0 + tTypeMean[i] <- sum(p1[mod.converged ,i] / p1.se[mod.converged ,i]^2) / sum(1/p1.se[mod.converged ,i]^2)# IVW mean of nModels for each veg type, on transformed scale + # Double check this tTypeVar[i]<- 1/mean(1/p1.se[mod.converged ,i]^2 ) # IVW variance of mean... + tTypeVar[i]<- 1/sum(1/p1.se[mod.converged ,i]^2 ) # IVW variance of mean... + + } + + # Weight the site level predictions + data$prediction <- colSums(p.site1/ p.site1.se^2) / colSums(1/p.site1.se^2) # Add logit-scaled model average prediction to data frame + + # Add names + names(tTypeMean) <- names(tTypeVar) <- rownames(prediction.matrix) + + # Put coefficients in Coef matrix (and SE's) + coef.results[na.omit(match(names(tTypeMean), names(coef.results)))] <- tTypeMean[names(coef.results)[na.omit(match(names(tTypeMean), names(coef.results)))]] # On logit scale + coef.se.results[na.omit(match(names(tTypeVar), names(coef.se.results)))] <- sqrt(tTypeVar[names(coef.se.results)[na.omit(match(names(tTypeVar), names(coef.se.results)))]]) # On logit scale + + # + # Climate + # + + tClimateMean <- tClimateVar <- NULL # Logit-scaled IVW for each climate + + mod.converged <- NULL + for (i in 1:nModels) {mod.converged[i] <- landscape.store[[i]]$converged} + + # If there SE is 0 for a coefficient, fix it to a small value to avoid INF + p1.climate.se[p1.climate.se == 0] <- 0.0001 + + for (i in 1:ncol(p1.climate)) { + + # Note for me, the SE should be the mean not the sum. Otherwise the SE will converge to 0 + tClimateMean[i] <- sum(p1.climate[mod.converged ,i] / p1.climate.se[mod.converged ,i]^2) / sum(1/p1.climate.se[mod.converged ,i]^2)# IVW mean of nModels for each veg type, on transformed scale + # Double check this tTypeVar[i]<- 1/mean(1/p1.se[mod.converged ,i]^2 ) # IVW variance of mean... + tClimateVar[i]<- 1/sum(1/p1.climate.se[mod.converged ,i]^2 ) # IVW variance of mean... + + } + + + # Add the intercept coefficient to the table + coef.results["Intercept"] <- tClimateMean[1] # On logit scale + coef.se.results["Intercept"] <- tClimateVar[1] # On logit scale + + # Add the climate coefficient to the table + coef.results["Climate"] <- tClimateMean[2] # On logit scale + coef.se.results["Climate"] <- tClimateVar[2] # On logit scale + + # Store protocol coefficient if modeled + if (protocol.flag == TRUE) { + + coef.results["Protocol"] <- tClimateMean[3] # On logit scale + coef.se.results["Protocol"] <- tClimateVar[3] # On logit scale + + } + + + } + + # # Currently only implement the IWV + # if (weight.method == "AIC") { + # + # # AIC calculation (I'm using AIC here, because this is primarily for prediction, rather than finding a minimial best model) + # aic.ta <- rep(999999999, (nModels)) + # + # for (i in 1:(nModels)) { + # + # if (!is.null(landscape.store[[i]]) & class(landscape.store[[i]])[1] != "try-error") { # last part is to not used non-converged models, unless none converged + # aic.ta[i] <- AICc(landscape.store[[i]]) + # } + # + # } + # + # aic.delta <- aic.ta - min(aic.ta) + # aic.exp <- exp(-1 / 2 * aic.delta) + # aic.wt.ta <- aic.exp / sum(aic.exp) + # + # tTypeMean <- tTypeVar <- NULL # Logit-scaled model averages for each veg type + # + # aic.wt.ta.adj <- ifelse(aic.wt.ta < 0.01, 0, aic.wt.ta) # Use adjusted weight to avoid poor fitting models with extreme values for certain types (usually numerically equivalent to 0's or 1's) + # aic.wt.ta.adj <- aic.wt.ta.adj / sum(aic.wt.ta.adj) + # + # # Add the site level prediction based on the ensemble + # # Convert to probabilities for the age estimation + # data$prediction <- colSums(p.site1 * aic.wt.ta.adj) + # + # for (i in 1:nrow(prediction.matrix)) { + # + # tTypeMean[i] <- sum(aic.wt.ta.adj * p1[, i]) # Mean of nModels for each veg type, on transformed scale + # #tTypeVar[i] <- sum(aic.wt.ta.adj * sqrt(p1.se[, i]^2 + (rep(tTypeMean[i], nModels) - p1[, i])^2))^2 # AIC-weighted variance of mean... + # + # } + # + # names(tTypeMean) <- rownames(prediction.matrix) # Rename the final intercept coefficient to productive + # + # # Put coefficients in Coef matrix (and SE's) + # coef.results[na.omit(match(names(tTypeMean), names(coef.results)))] <- tTypeMean[names(coef.results)[na.omit(match(names(tTypeMean), names(coef.results)))]] # On logit scale + # coef.se.results[na.omit(match(names(tTypeVar), names(coef.se.results)))] <- sqrt(tTypeVar[names(coef.se.results)[na.omit(match(names(tTypeVar), names(coef.se.results)))]]) # On logit scale + # + # + # } + + # + # 7.0 Create the forest age relationships + # + + # 7.1 Set up separate dataframes for sites containing a minimum amount of each broad stand type + stand.data <- list(WhiteSpruce = NULL, Pine = NULL, + Deciduous = NULL, Mixedwood = NULL, + BlackSpruce = NULL) + + cutoff.pc.for.age <- 0.1 # Set the cut-off for the minimum proportion of a stand type for a site to be included in the age analysis for a stand type + pSoftLin <- c(0.049, 0.0893, 0.434, 0.396) # Values based on overlap of softlin and the stand types in the 1km summary file. Lowland spruce includes other wetlands. Updated proportions 2020-11-17 + pSoftLin <- pSoftLin / sum(pSoftLin) # Make sure they sum to zero + aic.age <- array(NA, c(1, 4)) + stand.name <- c("WhiteSpruce", "Pine", "Deciduous", "Mixedwood", "BlackSpruce") + + for (i in 0:8) { # Add sites with each age class of the stand type to a separate data frames for each stand type + + i1 <- ifelse(i == 0, "R", i) # For variable name + i2 <- ifelse(i == 0, 0.5, i) # For twenty-year age + + for (stand.id in 1:length(stand.name)) { + + temp.name <- paste(stand.name[stand.id], i1, sep = "") # Col name + if (sum(data[ ,temp.name] > cutoff.pc.for.age) > 0) { + + stand.data[[stand.name[stand.id]]] <- rbind(stand.data[[stand.name[stand.id]]], + data.frame(pCount = data[data[, temp.name] > cutoff.pc.for.age, "Count"] / data$nQuadrant[data[, temp.name] > cutoff.pc.for.age], + age = i2, + wt1 = data[data[, temp.name] > cutoff.pc.for.age, temp.name]*data$visit[data[, temp.name] > cutoff.pc.for.age]*data$nQuadrant[data[, temp.name] > cutoff.pc.for.age], + p = data$prediction[data[, temp.name] > cutoff.pc.for.age])) # Weight is the proportion of the site of that age class and stand type, multiplied by the original weight (which accounts for revisited sites) and the number of binomial trials + + } + + } + + } + + rm(stand.name) + + # For upland forests, add grass sites as age 1, but with half the normal weight + d.grass <- data[data[, "Grass"] > cutoff.pc.for.age, ] # Select sites with grass (to make lines below less unruly) + pWhiteSpruce <- d.grass$WhiteSpruce / (d.grass$WhiteSpruce + d.grass$Pine + d.grass$Deciduous + d.grass$Mixedwood + d.grass$BlackSpruce + 0.01) + pPine <- d.grass$Pine / (d.grass$WhiteSpruce + d.grass$Pine + d.grass$Deciduous + d.grass$Mixedwood + d.grass$BlackSpruce + 0.01) + pDeciduous <- d.grass$Deciduous / (d.grass$WhiteSpruce + d.grass$Pine + d.grass$Deciduous + d.grass$Mixedwood + d.grass$BlackSpruce + 0.01) + pMixedwood <- d.grass$WhiteSpruce / (d.grass$WhiteSpruce + d.grass$Pine + d.grass$Deciduous + d.grass$Mixedwood + d.grass$BlackSpruce + 0.01) + + # If there are no sites to add, don't bind + if(sum(pWhiteSpruce) != 0) {stand.data$WhiteSpruce <- rbind(stand.data$WhiteSpruce, data.frame(pCount = d.grass[pWhiteSpruce > 0, "Count"] / d.grass$nQuadrant[pWhiteSpruce > 0], age = 0.5, wt1 = d.grass[pWhiteSpruce > 0, "Grass"]/2*d.grass$visit[pWhiteSpruce > 0]*d.grass$nQuadrant[pWhiteSpruce > 0]*pWhiteSpruce[pWhiteSpruce > 0], p = d.grass$prediction[pWhiteSpruce > 0]))} + if(sum(pPine) != 0) {stand.data$Pine <- rbind(stand.data$Pine, data.frame(pCount = d.grass[pPine > 0, "Count"] / d.grass$nQuadrant[pPine>0], age = 0.5, wt1 = d.grass[pPine>0,"Grass"]/2*d.grass$visit[pPine>0]*d.grass$nQuadrant[pPine>0]*pPine[pPine>0], p = d.grass$prediction[pPine>0]))} + if(sum(pDeciduous) != 0) {stand.data$Deciduous <- rbind(stand.data$Deciduous, data.frame(pCount = d.grass[pDeciduous > 0, "Count"] / d.grass$nQuadrant[pDeciduous > 0], age = 0.5, wt1 = d.grass[pDeciduous > 0, "Grass"] / 2*d.grass$visit[pDeciduous > 0]*d.grass$nQuadrant[pDeciduous > 0]*pDeciduous[pDeciduous > 0], p = d.grass$prediction[pDeciduous > 0]))} + if(sum(pMixedwood) != 0) {stand.data$Mixedwood <- rbind(stand.data$Mixedwood, data.frame(pCount = d.grass[pMixedwood > 0, "Count"] / d.grass$nQuadrant[pMixedwood > 0], age = 0.5, wt1 = d.grass[pMixedwood > 0, "Grass"] / 2*d.grass$visit[pMixedwood > 0]*d.grass$nQuadrant[pMixedwood > 0]*pMixedwood[pMixedwood > 0], p = d.grass$prediction[pMixedwood > 0]))} + + # And same for sites with shrubs + d.shrub <- data[data[, "Shrub"] > cutoff.pc.for.age,] # Select sites with shrubs (to make lines below less unruly) + pWhiteSpruce <- d.shrub$WhiteSpruce / (d.shrub$WhiteSpruce + d.shrub$Pine + d.shrub$Deciduous + d.shrub$Mixedwood + d.shrub$BlackSpruce + 0.01) + pPine <- d.shrub$Pine / (d.shrub$WhiteSpruce + d.shrub$Pine + d.shrub$Deciduous + d.shrub$Mixedwood + d.shrub$BlackSpruce + 0.01) + pDeciduous <- d.shrub$Deciduous / (d.shrub$WhiteSpruce + d.shrub$Pine + d.shrub$Deciduous + d.shrub$Mixedwood + d.shrub$BlackSpruce + 0.01) + pMixedwood <- d.shrub$WhiteSpruce / (d.shrub$WhiteSpruce + d.shrub$Pine + d.shrub$Deciduous + d.shrub$Mixedwood + d.shrub$BlackSpruce + 0.01) + + if(sum(pWhiteSpruce) != 0) {stand.data$WhiteSpruce <- rbind(stand.data$WhiteSpruce, data.frame(pCount = d.shrub[pWhiteSpruce > 0 , "Count"] / d.shrub$nQuadrant[pWhiteSpruce > 0], age = 1, wt1 = d.shrub[pWhiteSpruce > 0, "Shrub"] / 2*d.shrub$visit[pWhiteSpruce > 0]*d.shrub$nQuadrant[pWhiteSpruce > 0]*pWhiteSpruce[pWhiteSpruce > 0], p = d.shrub$prediction[pWhiteSpruce > 0]))} + if(sum(pPine) != 0) {stand.data$Pine <- rbind(stand.data$Pine, data.frame(pCount = d.shrub[pPine > 0, "Count"] / d.shrub$nQuadrant[pPine > 0], age = 1, wt1 = d.shrub[pPine > 0, "Shrub"] / 2*d.shrub$visit[pPine > 0]*d.shrub$nQuadrant[pPine > 0]*pPine[pPine > 0], p = d.shrub$prediction[pPine > 0]))} + if(sum(pDeciduous) != 0) {stand.data$Deciduous <- rbind(stand.data$Deciduous, data.frame(pCount = d.shrub[pDeciduous > 0, "Count"] / d.shrub$nQuadrant[pDeciduous > 0], age = 1, wt1 = d.shrub[pDeciduous > 0, "Shrub"] / 2*d.shrub$visit[pDeciduous > 0]*d.shrub$nQuadrant[pDeciduous > 0]*pDeciduous[pDeciduous > 0], p = d.shrub$prediction[pDeciduous > 0]))} + if(sum(pMixedwood) != 0) {stand.data$Mixedwood <- rbind(stand.data$Mixedwood, data.frame(pCount = d.shrub[pMixedwood > 0, "Count"] / d.shrub$nQuadrant[pMixedwood > 0], age = 1, wt1 = d.shrub[pMixedwood > 0, "Shrub"] / 2*d.shrub$visit[pMixedwood > 0]*d.shrub$nQuadrant[pMixedwood > 0]*pMixedwood[pMixedwood > 0], p = d.shrub$prediction[pMixedwood > 0]))} + + # Combined data frames for models using more than one stand type + stand.data$Conifpine <- rbind(cbind(stand.data$WhiteSpruce, Sp = "WhiteSpruce"), cbind(stand.data$Pine, Sp = "Pine")) + stand.data$Decidmixed <- rbind(cbind(stand.data$Deciduous, Sp = "Decid"), cbind(stand.data$Mixedwood, Sp = "Mixed")) + stand.data$All <- rbind(cbind(stand.data$WhiteSpruce, Sp = "WhiteSpruce"), cbind(stand.data$Pine, Sp = "Pine"), cbind(stand.data$Deciduous, Sp = "Decid"), cbind(stand.data$Mixedwood, Sp = "Mixed"), cbind(stand.data$BlackSpruce, Sp = "BlackSpruce")) + + # 6.2 Then fit models of age functions + ndet <- 8 + m.age <- list(NULL) # Age models for each of the 5 stand types plus 3 combinations + if (sum(sign(stand.data$WhiteSpruce$pCount)) > ndet) { + m.age[[1]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$WhiteSpruce, family = "binomial", weights = wt1) # Fit spline through age data for that stand type if enough records + } else { + m.age[[1]] <- gam(pCount~1 + offset(p), data = stand.data$WhiteSpruce, family = "binomial", weights = wt1) # Fit constant only if too few records in that stand type + } + if (sum(sign(stand.data$Pine$pCount)) > ndet) { + m.age[[2]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$Pine, family = "binomial", weights = wt1) + } else { + m.age[[2]] <- gam(pCount~1 + offset(p), data = stand.data$Pine, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$Deciduous$pCount)) > ndet) { + m.age[[3]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$Deciduous, family = "binomial", weights = wt1) + } else { + m.age[[3]] <- gam(pCount~1 + offset(p), data = stand.data$Deciduous, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$Mixedwood$pCount)) > ndet) { + m.age[[4]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$Mixedwood, family = "binomial", weights = wt1) + } else { + m.age[[4]] <- gam(pCount~1 + offset(p), data = stand.data$Mixedwood, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$BlackSpruce$pCount)) > ndet) { + m.age[[5]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$BlackSpruce, family = "binomial", weights = wt1) + } else { + m.age[[5]] <- gam(pCount~1 + offset(p), data = stand.data$BlackSpruce, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$Conifpine$pCount)) > ndet) { + m.age[[6]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$Conifpine, family = "binomial", weights = wt1) + } else { + m.age[[6]] <- gam(pCount~1 + offset(p), data = stand.data$Conifpine, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$Decidmixed$pCount)) > ndet) { + m.age[[7]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$Decidmixed, family = "binomial", weights = wt1) + } else { + m.age[[7]] <- gam(pCount~1 + offset(p), data = stand.data$Decidmixed, family = "binomial", weights = wt1) + } + if (sum(sign(stand.data$All$pCount)) > ndet) { + m.age[[8]] <- gam(pCount~s(sqrt(age),k = 3,m = 2) + offset(p), data = stand.data$All, family = "binomial", weights = wt1) + } else { + m.age[[8]] <- gam(pCount~1 + offset(p), data = stand.data$All, family = "binomial", weights = wt1) + } + + # Added an intercept only model. Prevents the simple model 8 from producing curves + # when we effectively have no age relationships. Even if we have enough data to attempt a curve. + m.age[[9]] <- gam(pCount~1 + offset(p), data = stand.data$All, family = "binomial", weights = wt1) + + # AIC for options - each separate, pairwise combinations, combine all + aic.age[1,1] <- AIC(m.age[[1]]) + AIC(m.age[[2]]) + AIC(m.age[[3]]) + AIC(m.age[[4]]) + AIC(m.age[[5]])-4 # Minus 4 for the 4 extra variances + aic.age[1,2] <- AIC(m.age[[5]]) + AIC(m.age[[6]]) + AIC(m.age[[7]])-2 + aic.age[1,3] <- AIC(m.age[[8]]) + aic.age[1,4] <- AIC(m.age[[9]]) + + # 7.3. Predict coefficients (and logit-scale SE) for each age class for each stand type + if (which.min(aic.age[1, ]) == 1) { + + p3 <- predict(m.age[[1]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["WhiteSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[2]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Pine"]), se.fit = T) + coef.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[3]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Deciduous"]), se.fit = T) + coef.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[4]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Mixedwood"]), se.fit = T) + coef.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[5]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["BlackSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$se.fit # SE still on the logit scale + + } + + if (which.min(aic.age[1, ]) == 2) { + + p3 <- predict(m.age[[6]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["WhiteSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[6]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Pine"]), se.fit = T) + coef.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[7]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Deciduous"]), se.fit = T) + coef.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[7]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Mixedwood"]), se.fit = T) + coef.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[5]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["BlackSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$se.fit # SE still on the logit scale + + } + + if (which.min(aic.age[1, ]) == 3) { + + p3 <- predict(m.age[[8]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["WhiteSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[8]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Pine"]), se.fit = T) + coef.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[8]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Deciduous"]), se.fit = T) + coef.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[8]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Mixedwood"]), se.fit = T) + coef.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[8]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["BlackSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$se.fit # SE still on the logit scale + + } + + + if (which.min(aic.age[1, ]) == 4) { + + p3 <- predict(m.age[[9]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["WhiteSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "WhiteSpruceR"):which(names(coef.results) == "WhiteSpruce8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[9]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Pine"]), se.fit = T) + coef.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "PineR"):which(names(coef.results) == "Pine8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[9]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Deciduous"]), se.fit = T) + coef.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "DeciduousR"):which(names(coef.results) == "Deciduous8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[9]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["Mixedwood"]), se.fit = T) + coef.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "MixedwoodR"):which(names(coef.results) == "Mixedwood8")] <- p3$se.fit # SE still on the logit scale + + p3 <- predict(m.age[[9]], newdata = data.frame(age = c(0.5,1:8), p = tTypeMean["BlackSpruce"]), se.fit = T) + coef.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$fit # Coefficient on logit scale + coef.se.results[which(names(coef.results) == "BlackSpruceR"):which(names(coef.results) == "BlackSpruce8")] <- p3$se.fit # SE still on the logit scale + + } + + # Will need to think of something else + # # 7.4 Adjust SE for estimates that are numerically equivalent to 0 - use exact binomial CI + # i4 <- which(is.na(coef.results) | coef.results < 0.0001) + # coef.results[i4] <- 0.0001 + # ntrials <- (colSums(data[, match(names(coef.results), names(data), nomatch = 0)])*2) + 1 # *2 because many rare types (which have the 0's are estimated from groups of types), + 1 to avoid failure for old cutblocks, + # for (i5 in i4) coef.se.results[i5] <- (qlogis(binom.confint(0, ntrials[i5], conf.level = 0.9)[5,6]) - qlogis(0.0001)) / 1.65 # That conf/level gives 1SE. Value is on logit scale, assuming estimate of 0.0001. This is set up so that when 90% CI's are ploted below, they will return the exact 90% binom confints + + # 7.5 Converge CC to natural trajectory + # Weighting is done on the probabilities + # Smooth CC trajectories into natural ones + coef.results["CCWhiteSpruce2"] <- qlogis(plogis(coef.results["WhiteSpruce2"])*0.50 + plogis(coef.results["CCWhiteSpruce2"])*(1-0.50)) # WhiteSpruce CC 20-40yr is 50% of way to 20-40yr natural forest - see document on convergence rates + coef.results["CCWhiteSpruce3"] <- qlogis(plogis(coef.results["WhiteSpruce3"])*0.849 + plogis(coef.results["CCWhiteSpruce3"])*(1-0.849)) # WhiteSpruce CC 40-60yr is 84.9% of way to 40-60yr natural forest + coef.results["CCWhiteSpruce4"] <- qlogis(plogis(coef.results["WhiteSpruce4"])*0.96 + plogis(coef.results["CCWhiteSpruce4"])*(1-0.96)) # WhiteSpruce CC 60-80yr is 96% of way to 60-80yr natural forest + coef.results["CCPine2"] <- qlogis(plogis(coef.results["Pine2"])*0.50 + plogis(coef.results["CCPine2"])*(1-0.50)) # Pine CC 20-40 is 50% of way to 20-40yr natural forest - see document on convergence rates + coef.results["CCPine3"] <- qlogis(plogis(coef.results["Pine3"])*0.849 + plogis(coef.results["CCPine3"])*(1-0.849)) # Pine CC 40-60 is 84.9% of way to 40-60yr natural forest + coef.results["CCPine4"] <- qlogis(plogis(coef.results["Pine4"])*0.96 + plogis(coef.results["CCPine4"])*(1-0.96)) # Pine CC 60-80 is 96% of way to 60-80yr natural forest + coef.results["CCDeciduous2"] <- qlogis(plogis(coef.results["Deciduous2"])*0.705 + plogis(coef.results["CCDeciduous2"])*(1-0.705)) # Decid CC 20-40yr is 70.5% of way to 20-40yr natural forest - see document on convergence rates + coef.results["CCDeciduous3"] <- qlogis(plogis(coef.results["Deciduous3"])*0.912 + plogis(coef.results["CCDeciduous3"])*(1-0.912)) # Decid CC 40-60yr is 91.2% of way to 40-60yr natural forest + coef.results["CCDeciduous4"] <- qlogis(plogis(coef.results["Deciduous4"])*0.97 + plogis(coef.results["CCDeciduous4"])*(1-0.97)) # Decid CC 60-80yr is 97% of way to 60-80yr natural forest + coef.results["CCMixedwood2"] <- qlogis(plogis(coef.results["Mixedwood2"])*0.705 + plogis(coef.results["CCMixedwood2"])*(1-0.705)) # Mixedwood CC 20-40yr is 70.5% of way to 20-40yr natural forest - see document on convergence rates + coef.results["CCMixedwood3"] <- qlogis(plogis(coef.results["Mixedwood3"])*0.912 + plogis(coef.results["CCMixedwood3"])*(1-0.912)) # Mixedwood CC 40-60yr is 91.2% of way to 40-60yr natural forest + coef.results["CCMixedwood4"] <- qlogis(plogis(coef.results["Mixedwood4"])*0.97 + plogis(coef.results["CCMixedwood4"])*(1-0.97)) # Mixedwood CC 60-80yr is 97% of way to 60-80yr natural forest + + # And same for SE's + coef.se.results["CCWhiteSpruce2"] <- coef.se.results["WhiteSpruce2"]*0.50 + coef.se.results["CCWhiteSpruce2"]*(1-0.50) + coef.se.results["CCWhiteSpruce3"] <- coef.se.results["WhiteSpruce3"]*0.849 + coef.se.results["CCWhiteSpruce3"]*(1-0.849) + coef.se.results["CCWhiteSpruce4"] <- coef.se.results["WhiteSpruce4"]*0.96 + coef.se.results["CCWhiteSpruce4"]*(1-0.96) + coef.se.results["CCPine2"] <- coef.se.results["Pine2"]*0.50 + coef.se.results["CCPine2"]*(1-0.50) + coef.se.results["CCPine3"] <- coef.se.results["Pine3"]*0.849 + coef.se.results["CCPine3"]*(1-0.849) + coef.se.results["CCPine4"] <- coef.se.results["Pine4"]*0.96 + coef.se.results["CCPine4"]*(1-0.96) + coef.se.results["CCDeciduous2"] <- coef.se.results["Deciduous2"]*0.705 + coef.se.results["CCDeciduous2"]*(1-0.705) + coef.se.results["CCDeciduous3"] <- coef.se.results["Deciduous3"]*0.912 + coef.se.results["CCDeciduous3"]*(1-0.912) + coef.se.results["CCDeciduous4"] <- coef.se.results["Deciduous4"]*0.97 + coef.se.results["CCDeciduous4"]*(1-0.97) + coef.se.results["CCMixedwood2"] <- coef.se.results["Mixedwood2"]*0.705 + coef.se.results["CCMixedwood2"]*(1-0.705) + coef.se.results["CCMixedwood3"] <- coef.se.results["Mixedwood3"]*0.912 + coef.se.results["CCMixedwood3"]*(1-0.912) + coef.se.results["CCMixedwood4"] <- coef.se.results["Mixedwood4"]*0.97 + coef.se.results["CCMixedwood4"]*(1-0.97) + + # + # 8.0 Adjust coefficients that are often estimated poorly. + # + + if (coef.adjust == TRUE) { # If true, adjust coefficients, otherwise leave as is. Can help to determine how much the adjustment is needed + + coef.results["HardLin"] <- (coef.results["HardLin"] / coef.se.results["HardLin"]^2 + coef.results["UrbInd"]/coef.se.results["UrbInd"]^2) / (1 / coef.se.results["HardLin"]^2 + 1 / coef.se.results["UrbInd"]^2) # Inverse-variance weighted, done on logit scale + coef.se.results["HardLin"] <- sqrt(1 / (1 / coef.se.results["HardLin"]^2 + 1 / coef.se.results["UrbInd"]^2)) + + young <- (pSoftLin[1]*coef.results["CCWhiteSpruceR"] + pSoftLin[2]*coef.results["CCPineR"] + pSoftLin[3]*coef.results["CCDeciduousR"] + pSoftLin[4]*coef.results["BlackSpruce1"]) / sum(pSoftLin) + young.se <- sqrt( ( pSoftLin[1]*coef.se.results["CCWhiteSpruceR"]^2 + pSoftLin[2]*coef.se.results["CCPineR"]^2 + pSoftLin[3]*coef.se.results["CCDeciduousR"]^2 + pSoftLin[4]*coef.se.results["BlackSpruce1"]^2 ) / sum(pSoftLin) ) # Weighted se (on logit scale) - does not include component of variance among types, because fixed weighting + + # Adjust for the three soft linear type coefficients (EnSoftLin, EnSeismic, TrSoftLin) + coef.results["EnSoftLin"] <- (coef.results["EnSoftLin"]/coef.se.results["EnSoftLin"]^2 + young / young.se^2) / (1 / coef.se.results["EnSoftLin"]^2 + 1 / young.se^2) # Inverse-variance weighted + coef.se.results["EnSoftLin"] <- sqrt(1 / (1 / coef.se.results["EnSoftLin"]^2 + 1 / young.se^2)) + + coef.results["EnSeismic"] <- (coef.results["EnSeismic"]/coef.se.results["EnSeismic"]^2 + young / young.se^2) / (1 / coef.se.results["EnSeismic"]^2 + 1 / young.se^2) # Inverse-variance weighted + coef.se.results["EnSeismic"] <- sqrt(1 / (1 / coef.se.results["EnSeismic"]^2 + 1 / young.se^2)) + + coef.results["TrSoftLin"] <- (coef.results["TrSoftLin"]/coef.se.results["TrSoftLin"]^2 + young / young.se^2) / (1 / coef.se.results["TrSoftLin"]^2 + 1 / young.se^2) # Inverse-variance weighted + coef.se.results["TrSoftLin"] <- sqrt(1 / (1 / coef.se.results["TrSoftLin"]^2 + 1 / young.se^2)) + + rm(young, young.se) + + } + + # Store the coefficients as a single object + names(coef.se.results) <- paste0(names(coef.se.results), ".SE") + coef.results <- c(coef.results, coef.se.results) + return(coef.results) + + +} + +#' [Soil models] +#' +#' [soil models that uses the spatially thinned data.] +#' +#' @param [species] [Focal species of interest.] +#' @param [data] [Cleaned species, climate, and landcover data.] +#' @param [boot.data] [List of site codes to be included for each species and bootstrap iteration.] +#' @param [habitat.models] [List of habitat model formulas to be assessed.] +#' @param [prediction.matrix] [Prediction matrix used for converting model coefficients to standardized habitat classes.] +#' @param [climate.coef] [List of climate coefficients calculated from the detection_models function.] +#' @param [weight.method] [Method used for weighting model coefficients. Inverse variance weighted is the only available method currently.] +#' @param [coef.template] [Vector template used to define valid model coefficients] +#' @param [protocol.flag] [Flag that determines if we need to account for differences in sample protocols] +#' @param [coef.adjust] [Flag used to determine if poorly sampled human footprint coefficients are adjusted based on similar feature types.] +#' @param [boot] [Defines bootstrap iteration.] +#' @return [Outputs vector of model coefficients defined in habitat.models.] +#' + +soil_models <- function(species, data, boot.data, habitat.models, prediction.matrix, + climate.coef, weight.method = "IVW", coef.template, + protocol.flag, coef.adjust = TRUE, boot) { + + # + # 1.0 Data standardization + # + + # Since we are treating each recording individually, we fix visit to 1 as we no longer need to apply this weight. + data["nQuadrant"] <- 1 + data$visit <- 1 + + # Create new column which is the observed count data (used for weighting in the age relationships), one for the converted probabilities + data["Count"] <- as.integer(ifelse(data[, species] > 0, 1, 0)) + data["pcount"] <- as.integer(ifelse(data[, species] > 0, 1, 0) / data$nQuadrant) + + # 1.1 Bootstrap Selection + boot.data <- boot.data[[species]] + site.id <- boot.data[, paste0("Boot_", boot)] + data <- data[site.id, ] + + # 1.2 Regional filter + data <- data[data$NR %in% c("Grassland", "Parkland"), ] + + # If the number of detections for the species is less than 20, return empty matrix + if(sum(data$Count) < 20) { + + coef.results <- coef.template + coef.se.results <- coef.results + names(coef.se.results) <- paste0(names(coef.se.results), ".SE") + coef.results <- c(coef.results, coef.se.results) + return(coef.results) + + } + + # 1.3 Define the templates for coefficients + coef.results <- coef.template + coef.se.results <- coef.template + + # + # 3.0 Climate Predictions + # + + # Using the matching climate model, create the prediction that will be used + # Add the intercept and extract climate coefficients + data$Intercept <- 1 + climate.dect.coef <- climate.coef[[species]][boot, ] + climate.veg <- as.matrix(data[, names(climate.dect.coef)]) + + # Predict space/climate component (Probability scale) + data$Climate <- plogis(drop(climate.veg %*% climate.dect.coef)) + + # + # 4.0 Soil Model + # + + # Loop through the models + landscape.store <- list(NULL) + + for (model in 1:length(habitat.models)) { + + landscape.store[[model]] <- try(bayesglm(habitat.models[[model]], family = "binomial", + data = data, + maxit = 250)) + + } + + # + # 4.0 Store the coefficients + # + + # South model needs to account for the addition of the probability of aspen coefficient, otherwise the processes is similar. + nModels <- length(habitat.models) + p1 <- p1.se <- array(0, c(length(habitat.models), nrow(prediction.matrix))) # Predictions for each model for each soil and HF type type. These are the main coefficients + colnames(p1) <- colnames(p1.se) <- rownames(prediction.matrix) + p.site1 <- p.site1.se <- array(0, c(nModels, nrow(data))) # Predictions for each model and each site. These are used as the offsets in the next stage + + # If there is a protocol coefficient, add it to the list, otherwise only store the climate coefficient + if(protocol.flag == TRUE) { + + p1.climate <- p1.climate.se <- array(0, c(length(habitat.models), 3)) + colnames(p1.climate) <- colnames(p1.climate.se) <- c("Intercept", "Climate", "Protocol") + + } else { + + p1.climate <- p1.climate.se <- array(0, c(length(habitat.models), 2)) + colnames(p1.climate) <- colnames(p1.climate.se) <- c("Intercept", "Climate") + + } + + p1.aspen <- p1.se.aspen <- rep(0, nModels) # Predictions for each model for aspen coefficient + + for (i in 1:nModels) { + + if (class(landscape.store[[i]])[1] != "try-error") { # Prediction is 0 if model failed, but this is not used because AIC wt would equal 0 + + if(protocol.flag == TRUE) { + + plot.data <- data.frame(prediction.matrix, + Climate = 0, + paspen = 0, + Protocol = as.factor("New")) + + } else { + + plot.data <- data.frame(prediction.matrix, + paspen = 0, + Climate = 0) + + } + + p <- predict(landscape.store[[i]], newdata = plot.data, se.fit = TRUE) # For each type. Predictions made at 0% Aspen. All predictions made with new protocol. Aspen effect added later, and plotted as separate points + p1[i,] <- p$fit + p1.se[i,] <- p$se.fit + + model.fit <- predict(landscape.store[[i]], se.fit = TRUE) + p.site1[i,] <- model.fit$fit # For each site (using the original d.sp data frame) + p.site1.se[i,] <- model.fit$se.fit # For each site SE + + # Extract the climate and intercept coefficients + # We weight them separately, but then add them together to create the final coefficient + + # Coef storage + p <- summary(landscape.store[[i]])$coefficients[1:ncol(p1.climate),1] # For each type. Predictions made at 0% Aspen. All predictions made with new protocol. Aspen effect added later, and plotted as separate points + names(p)[1] <- "Intercept" + p1.climate[i, ] <- p + + # Standard error storage + p <- summary(landscape.store[[i]])$coefficients[1:ncol(p1.climate),2] # For each type. Predictions made at 0% Aspen. All predictions made with new protocol. Aspen effect added later, and plotted as separate points + names(p)[1] <- "Intercept" + p1.climate.se[i, ] <- p + + # If pasen is present, store the coefficient + if ("paspen" %in% names(coef(landscape.store[[i]]))) { + p1.aspen[i] <- coefficients(summary(landscape.store[[i]]))["paspen","Estimate"] + p1.se.aspen[i] <- coefficients(summary(landscape.store[[i]]))["paspen","Std. Error"] + } + + } + + } + + # + # 5.0 Weight the models + # + + if (weight.method == "IVW") { + + # + # Landcover + # + + tTypeMean <- tTypeVar <- NULL # Logit-scaled IVW for each veg type + + mod.converged <- NULL + for (i in 1:nModels) {mod.converged[i] <- landscape.store[[i]]$converged} + + for (i in 1:nrow(prediction.matrix)) { + + tTypeMean[i] <- sum(p1[mod.converged ,i] / p1.se[mod.converged ,i]^2) / sum(1/p1.se[mod.converged ,i]^2)# IVW mean of nModels for each veg type, on transformed scale + tTypeVar[i]<- 1/sum(1/p1.se[mod.converged ,i]^2 ) # IVW variance of mean... + + } + + # Add names + names(tTypeMean) <- names(tTypeVar) <- rownames(prediction.matrix) + + # If paspen coefficients / SE is 0, remove + p1.aspen <- p1.aspen[p1.aspen > 0] + p1.se.aspen <- p1.se.aspen[p1.se.aspen > 0] + + tTypeMean["paspen"] <- sum(p1.aspen / p1.se.aspen^2) / sum(1 / p1.se.aspen^2) + tTypeVar["paspen"] <- 1/sum(1/p1.se.aspen^2 ) # IVWvariance of mean... + + # Put coefficients in Coef matrix (and SE's) + coef.results[na.omit(match(names(tTypeMean), names(coef.results)))] <- tTypeMean[names(coef.results)[na.omit(match(names(tTypeMean), names(coef.results)))]] # On logit scale + coef.se.results[na.omit(match(names(tTypeVar), names(coef.se.results)))] <- sqrt(tTypeVar[names(coef.se.results)[na.omit(match(names(tTypeVar), names(coef.se.results)))]]) # On logit scale + + + # + # Climate + # + + tClimateMean <- tClimateVar <- NULL # Logit-scaled IVW for each climate + + mod.converged <- NULL + for (i in 1:nModels) {mod.converged[i] <- landscape.store[[i]]$converged} + + # If there SE is 0 for a coefficient, fix it to a small value to avoid INF + p1.climate.se[p1.climate.se == 0] <- 0.0001 + + for (i in 1:ncol(p1.climate)) { + + # Note for me, the SE should be the mean not the sum. Otherwise the SE will converge to 0 + tClimateMean[i] <- sum(p1.climate[mod.converged ,i] / p1.climate.se[mod.converged ,i]^2) / sum(1/p1.climate.se[mod.converged ,i]^2)# IVW mean of nModels for each veg type, on transformed scale + # Double check this tTypeVar[i]<- 1/mean(1/p1.se[mod.converged ,i]^2 ) # IVW variance of mean... + tClimateVar[i]<- 1/sum(1/p1.climate.se[mod.converged ,i]^2 ) # IVW variance of mean... + + } + + # Add the intercept coefficient to the table + coef.results["Intercept"] <- tClimateMean[1] # On logit scale + coef.se.results["Intercept"] <- tClimateVar[1] # On logit scale + + # Add the climate coefficient to the table + coef.results["Climate"] <- tClimateMean[2] # On logit scale + coef.se.results["Climate"] <- tClimateVar[2] # On logit scale + + # Store protocol coefficient if modeled + if (protocol.flag == TRUE) { + + coef.results["Protocol"] <- tClimateMean[3] # On logit scale + coef.se.results["Protocol"] <- tClimateVar[3] # On logit scale + + } + + } + + # Don't currently use this method of weighting + # if (weight.method == "AIC") { + # + # + # # AIC calculation (I'm using AIC here, because this is primarily for prediction, rather than finding a minimial best model) + # aic.ta <- rep(999999999, (nModels)) + # + # for (i in 1:(nModels)) { + # + # if (!is.null(landscape.store[[i]]) & class(landscape.store[[i]])[1] != "try-error") { # last part is to not used non-converged models, unless none converged + # aic.ta[i] <- AICc(landscape.store[[i]]) + # } + # + # } + # + # aic.delta <- aic.ta - min(aic.ta) + # aic.exp <- exp(-1 / 2 * aic.delta) + # aic.wt.ta <- aic.exp / sum(aic.exp) + # + # tTypeMean <- tTypeVar <- NULL # Logit-scaled model averages for each veg type + # + # aic.wt.ta.adj <- ifelse(aic.wt.ta < 0.01, 0, aic.wt.ta) # Use adjusted weight to avoid poor fitting models with extreme values for certain types (usually numerically equivalent to 0's or 1's) + # aic.wt.ta.adj <- aic.wt.ta.adj / sum(aic.wt.ta.adj) + # + # for (i in 1:ncol(p1)) { + # + # tTypeMean[i] <- sum(aic.wt.ta.adj * p1[, i]) + # tTypeVar[i] <- sum(aic.wt.ta.adj * p1.se[, i]) + # + # } + # + # # Add names + # names(tTypeMean) <- names(tTypeVar) <- rownames(prediction.matrix) + # + # # Adjust the paspen variable as it isn't in all of the models + # mod.converged[p1[, "paspen"] == 0] <- FALSE + # tTypeMean["paspen"] <- sum(p1[mod.converged ,"paspen"] / p1.se[mod.converged ,"paspen"]^2) / sum(1/p1.se[mod.converged ,"paspen"]^2)# IVW mean of nModels for each veg type, on transformed scale + # tTypeVar["paspen"] <- 1/sum(1/p1.se[mod.converged ,"paspen"]^2 ) # IVW variance of mean... + # + # # Put coefficients in Coef matrix (and SE's) + # coef.results[na.omit(match(names(tTypeMean), names(coef.results)))] <- tTypeMean[names(coef.results)[na.omit(match(names(tTypeMean), names(coef.results)))]] # On logit scale + # coef.se.results[na.omit(match(names(tTypeVar), names(coef.se.results)))] <- sqrt(tTypeVar[names(coef.se.results)[na.omit(match(names(tTypeVar), names(coef.se.results)))]]) # On logit scale + # + # + # } + + # + # 7.0 Adjust coefficients that are often estimated poorly. + # + + if (coef.adjust == TRUE) { # If true, adjust coefficients, otherwise leave as is. Can help to determine how much the adjustment is needed + + coef.results["HardLin"] <- (coef.results["HardLin"] / coef.se.results["HardLin"]^2 + coef.results["UrbInd"]/coef.se.results["UrbInd"]^2) / (1 / coef.se.results["HardLin"]^2 + 1 / coef.se.results["UrbInd"]^2) # Inverse-variance weighted, done on logit scale + coef.se.results["HardLin"] <- sqrt(1 / (1 / coef.se.results["HardLin"]^2 + 1 / coef.se.results["UrbInd"]^2)) + + } + + # Store the coefficients as a single object + names(coef.se.results) <- paste0(names(coef.se.results), ".SE") + coef.results <- c(coef.results, coef.se.results) + return(coef.results) + +} diff --git a/1_code/modules/plants/functions/model-validation_functions.R b/1_code/modules/plants/functions/model-validation_functions.R new file mode 100644 index 0000000..f4a31c1 --- /dev/null +++ b/1_code/modules/plants/functions/model-validation_functions.R @@ -0,0 +1,232 @@ +# --- +# title: Model validation functions +# author: Brandon Allen +# created: 2025-02-11 +# notes: Define functions that are used for model validation. +# --- + +#' [Model validation] +#' +#' [Calculation of AUC statistics based on the final hierachical model. Implements two prediction approaches and climate truncation.] +#' +#' @param [species] [Focal species of interest.] +#' @param [data] [Cleaned species, climate, and landcover data.] +#' @param [boot.data] [List of site codes to be included for each species and bootstrap iteration.] +#' @param [climate.coef] [List of space-climate coefficients calculated from the detection_models function.] +#' @param [landcover.coef] [List of landcover coefficients calculated from the detection_models function.] +#' @param [landcover.type] [Defines if the provided landcover coefficients are Vegetation or Soil models.] +#' @param [protocol.flag] [Flag that determines if we need to account for differences in sample protocols] +#' @param [boot] [Defines bootstrap iteration.] +#' @return [Outputs vector of model coefficients defined in climate.models and space.models.] +#' + +model_validation <- function(species, data, boot.data, + climate.coef, landcover.coef, + landcover.type, protocol.flag, boot) { + + # + # 1.0 Libraries + # + + require(pROC) + + # + # 2.0 Data standardization + # + + # Since we are treating each recording individually, we fix visit to 1 as we no longer need to apply this weight. + data["nQuadrant"] <- 1 + data$visit <- 1 + + # Create new column which is the observed count data (used for weighting in the age relationships), one for the converted probabilities + data["Count"] <- as.integer(ifelse(data[, species] > 0, 1, 0)) + data["pcount"] <- as.integer(ifelse(data[, species] > 0, 1, 0) / data$nQuadrant) + + # 3.0 Bootstrap Selection + boot.data <- boot.data[[species]] + site.id <- boot.data[, paste0("Boot_", boot)] + data <- data[data$SiteYearQu %in% site.id, ] + + # + # 4.0 Climate Predictions + # + + # Using the matching climate model, create the prediction that will be used + # Add the intercept and extract climate coefficients + data$Intercept <- 1 + climate.dect.coef <- climate.coef[[species]][boot, ] + climate.veg <- as.matrix(data[, names(climate.dect.coef)]) + + # Predict space/climate component (Probability scale) + climate.prediction <- plogis(drop(climate.veg %*% climate.dect.coef)) + climate.prediction.truncated <- ifelse(climate.prediction >= quantile(climate.prediction, 0.99), + quantile(climate.prediction, 0.99), + climate.prediction) + + # + # 5.0 Landcover Predictions and statistics + # + + if(landcover.type == "Vegetation") { + + # + # Evaluation using landcover + climate + # + + veg.dect.coef <- vegetation.coef[[species]][boot, ] + + # If protocol flag is present, subtract protocol coefficient from the values + # for "Old" surveys. This is done because the coefficients are based on the + # "New" protocol. + if(protocol.flag == TRUE) { + + # Align the vegetation information and coefficients + column.remove <- -(1:3) + veg.in <- as.matrix(data[, names(veg.dect.coef)[column.remove]]) + + # Predict without space climate component + data$Vegetation <- drop(veg.in %*% plogis(veg.dect.coef[column.remove])) + + # If protocol == "old" remove the protocol coefficient + data$Vegetation[data$Protocol == "Old"] <- data$Vegetation[data$Protocol == "Old"] - as.numeric(veg.dect.coef["Protocol"]) + + } else { + + # Align the vegetation information and coefficients + column.remove <- -(1:2) + veg.in <- as.matrix(data[, names(veg.dect.coef)[column.remove]]) + + # Predict without space climate component + data$Vegetation <- drop(veg.in %*% plogis(veg.dect.coef[column.remove])) + + } + + # Predict with space climate component + climate.component <- climate.prediction * veg.dect.coef["Climate"] + climate.component.truncated <- climate.prediction.truncated * veg.dect.coef["Climate"] + data$VegetationClim <- plogis(qlogis(drop(veg.in %*% plogis(veg.dect.coef[column.remove]))) + climate.component) + data$VegetationClimTrunc <- plogis(qlogis(drop(veg.in %*% plogis(veg.dect.coef[column.remove]))) + climate.component.truncated) + + # Statistics + # Climate uses the entire grid + climate.auc <- auc(data$pcount, climate.prediction) + climate.truncated.auc <- auc(data$pcount, climate.prediction.truncated) + + # Landcover only uses the section included in the model + data.region <- data[!(data$NR %in% c("Grassland")), ] + landcover.auc <- auc(data.region$pcount, data.region$Vegetation) + full.auc <- auc(data.region$pcount, data.region$VegetationClim) + full.truncated.auc <- auc(data.region$pcount, data.region$VegetationClimTrunc) + + # + # Evaluation using modified climate + landcover coefficients + # + + # Convert climate component to a climate matrix with same dimentions as the landcover + climate.component <- matrix(climate.component, nrow = nrow(veg.in), ncol = ncol(veg.in)) + climate.component.truncated <- matrix(climate.component.truncated, nrow = nrow(veg.in), ncol = ncol(veg.in)) + + # Isolate the landcover coefficients + veg.dect.coef <- veg.dect.coef[column.remove] + + # Joint landcover and climate prediction + veg.joint.coef <- t(t(climate.component) + veg.dect.coef) + veg.joint.truncated.coef <- t(t(climate.component.truncated) + veg.dect.coef) + + data$VegetationClimJoint <- rowSums(veg.in * plogis(veg.joint.coef)) + data$VegetationClimJointTrunc <- rowSums(veg.in * plogis(veg.joint.truncated.coef)) + + # Evaluation in the focal region + data.region <- data[!(data$NR %in% c("Grassland")), ] + full.joint.auc <- auc(data.region$pcount, data.region$VegetationClimJoint) + full.joint.truncated.auc <- auc(data.region$pcount, data.region$VegetationClimJointTrunc) + + } + + if(landcover.type == "Soil") { + + # + # Evaluation using landcover + climate + # + + soil.dect.coef <- soil.coef[[species]][boot, ] + + # If protocol flag is present, subtract protocol coefficient from the values + # for "Old" surveys. This is done because the coefficients are based on the + # "New" protocol. + if(protocol.flag == TRUE) { + + # Align the vegetation information and coefficients + column.remove <- -(1:4) + soil.in <- as.matrix(data[, names(soil.dect.coef)[column.remove]]) + + # Predict without space climate component + data$Soil <- drop(soil.in %*% plogis(soil.dect.coef[column.remove])) + + # If protocol == "old" remove the protocol coefficient + data$Soil[data$Protocol == "Old"] <- data$Soil[data$Protocol == "Old"] - as.numeric(soil.dect.coef["Protocol"]) + + } else { + + # Align the vegetation information and coefficients + column.remove <- -(1:3) + soil.in <- as.matrix(data[, names(soil.dect.coef)[column.remove]]) + + # Predict without space climate component + data$Soil <- drop(soil.in %*% plogis(soil.dect.coef[column.remove])) + + } + + # Predict the pAspen and climate components + paspen.component <- data$paspen * soil.dect.coef["paspen"] + climate.component <- climate.prediction * soil.dect.coef["Climate"] + climate.component.truncated <- climate.prediction.truncated * soil.dect.coef["Climate"] + + # Predict with space climate component + data$SoilClim <- plogis(qlogis(drop(soil.in %*% plogis(soil.dect.coef[column.remove]))) + paspen.component + climate.component) + data$SoilClimTrunc <- plogis(qlogis(drop(soil.in %*% plogis(soil.dect.coef[column.remove]))) + paspen.component + climate.component.truncated) + + # Statistics + # Climate uses the entire grid + climate.auc <- auc(data$pcount, climate.prediction) + climate.truncated.auc <- auc(data$pcount, climate.prediction.truncated) + + # Landcover only uses the section included in the model + data.region <- data[data$NR %in% c("Grassland", "Parkland"), ] + landcover.auc <- auc(data.region$pcount, data.region$Soil) + full.auc <- auc(data.region$pcount, data.region$SoilClim) + full.truncated.auc <- auc(data.region$pcount, data.region$SoilClimTrunc) + + # + # Evaluation using modified climate + landcover coefficients + # + + # Convert climate component to a climate matrix with same dimentions as the landcover + climate.component <- matrix((climate.component + paspen.component), nrow = nrow(soil.in), ncol = ncol(soil.in)) + climate.component.truncated <- matrix((climate.component.truncated + paspen.component), nrow = nrow(soil.in), ncol = ncol(soil.in)) + + # soil.dect.coef the landcover coefficients + soil.dect.coef <- soil.dect.coef[column.remove] + + # Joint landcover and climate prediction + soil.joint.coef <- t(t(climate.component) + soil.dect.coef) + soil.joint.truncated.coef <- t(t(climate.component.truncated) + soil.dect.coef) + + data$SoilClimJoint <- rowSums(soil.in * plogis(soil.joint.coef)) + data$SoilClimJointTrunc <- rowSums(soil.in * plogis(soil.joint.truncated.coef)) + + # Evaluation in the focal region + data.region <- data[data$NR %in% c("Grassland", "Parkland"), ] + full.joint.auc <- auc(data.region$pcount, data.region$SoilClimJoint) + full.joint.truncated.auc <- auc(data.region$pcount, data.region$SoilClimJointTrunc) + + } + + model.fit <- c(climate.auc, climate.truncated.auc, landcover.auc, + full.auc, full.truncated.auc, full.joint.auc, full.joint.truncated.auc) + names(model.fit) <- c("Climate", "Climate_Truncated", "Landcover", + "Full", "Full_Truncated", "Full_Joint", "Full_Joint_Truncated") + return(model.fit) + +} + diff --git a/1_code/modules/plants/load_model_data.R b/1_code/modules/plants/load_model_data.R new file mode 100644 index 0000000..e771a50 --- /dev/null +++ b/1_code/modules/plants/load_model_data.R @@ -0,0 +1,443 @@ +# --- +# title: Load Plant-Group Model Data from the Test Dataset +# author: Brendan Casey +# created: 2026-09-08 +# inputs: +# in 0_data/test_dataset/: +# - sites.csv +# - .csv +# - covariates/_climate.csv +# - covariates/_veg.csv +# - covariates/_soil.csv +# - lookup/veg_prediction_matrix.csv +# - lookup/soil_prediction_matrix.csv +# - lookup/modelled_species.csv +# outputs: none; returns objects in memory +# notes: +# - Rebuilds the three model frames the v2 plant scripts used to +# load from -model-data.Rdata, from the harmonized CSVs +# instead. The frames it returns are equivalent to the v2 +# objects of the same name, so the v2 function files in +# functions/ run against them unmodified. +# - The v2 code took its vegetation coefficient names +# positionally, as colnames(veg.data)[403:489] and three other +# per-taxon spans. Those spans are all the same 87 habitat +# types, and they are the first 87 columns of the vegetation +# covariate table, so veg_coef_names names them instead. That +# removes the one place where a reordered snapshot would have +# silently renamed every vegetation coefficient. +# - Protocol is carried only for bryophytes and lichens, because +# only those two v2 scripts fit it. plant_taxa() is the single +# record of which taxa do, and 02 and 03 read the flag from +# there rather than repeating it. +# - Both row-addressing styles the v2 functions use are +# supported: the hierarchical models index by rownames +# (data[site.id, ]) and the validation indexes by column +# (data$SiteYearQu %in% site.id), so SiteYearQu is kept as a +# column and as the rownames. +# - Future improvement - the same reader would serve mammals +# once their covariates are harmonized; nothing here is +# specific to the plant taxa except plant_taxa() and the site +# field mapping. +# --- + +# 1. Setup ---- + +## 1.1 Load packages ---- +library(data.table) # fast CSV reading (version: 1.16.4) + +# 2. plant_taxa() ---- + +#' Describe the Plant-Group Taxa +#' +#' The one record of which taxa exist and which of them fit a +#' Protocol term. In v2 that distinction was implicit in four +#' near-identical scripts: 02a and 02b carried `Protocol` in every +#' habitat formula and passed `protocol.flag = TRUE`, while 02c +#' and 02d carried neither. It is stated once here so the single +#' modelling script can reproduce both variants. +#' +#' @return A data frame with `taxon`, `use_protocol`, and +#' `label` (the taxon as it reads in a log line). +#' +#' @example # Example usage of the function +#' # plant_taxa() +#' # subset(plant_taxa(), taxon == "mite")$use_protocol +plant_taxa <- function() { + data.frame( + taxon = c("bryophyte", "lichen", "mite", "vascular_plant"), + use_protocol = c(TRUE, TRUE, FALSE, FALSE), + label = c("bryophytes", "lichens", "mites", "vascular plants"), + stringsAsFactors = FALSE + ) +} + +# 3. taxon_uses_protocol() ---- + +#' Look Up One Taxon's Protocol Flag +#' +#' @param taxon Character. One of the taxa in `plant_taxa()`. +#' @return Logical. TRUE when that taxon's v2 scripts fit a +#' Protocol term. +#' +#' @example # Example usage of the function +#' # taxon_uses_protocol("lichen") +taxon_uses_protocol <- function(taxon) { + taxa <- plant_taxa() + match_row <- match(taxon, taxa$taxon) + + if (is.na(match_row)) { + stop( + "Unknown taxon '", + taxon, + "'. Expected one of: ", + paste(taxa$taxon, collapse = ", "), + call. = FALSE + ) + } + + taxa$use_protocol[match_row] +} + +# 4. check_prediction_terms() ---- + +#' Check a Model Set Against Its Prediction Matrix +#' +#' Every habitat term a model fits is later predicted onto a row +#' of the prediction matrix, so a term the matrix has no column +#' for cannot be predicted. In v2 that surfaced only once fitting +#' reached the prediction step, as `object '' not found` +#' raised separately inside every bootstrap of every species. +#' Checking up front turns it into one readable failure. +#' +#' `Climate`, `Protocol` and `paspen` are excluded: they are +#' columns the model functions attach to the data themselves, and +#' the prediction matrix is not expected to carry them. +#' +#' @param models List of model formulas. +#' @param prediction_matrix Data frame. The prediction matrix the +#' fitted models are predicted onto, with `VegType` already +#' moved to the rownames. +#' @param what Character. Label for the model set, used in the +#' error message (e.g. "vegetation"). +#' @param source_note Character. Where the matrix came from, so +#' the message says what to fix. +#' @return NULL, invisibly. Stops when a term has no column. +#' +#' @example # Example usage of the function +#' # check_prediction_terms( +#' # vegetation.models, prediction.matrix, "vegetation" +#' # ) +check_prediction_terms <- function( + models, + prediction_matrix, + what, + source_note = "" +) { + # Step 1: Collect the habitat terms across the whole model set + attached_by_model_code <- c( + "pcount", "Climate", "Protocol", "paspen" + ) + + terms <- unique(unlist(lapply(models, all.vars))) + terms <- setdiff(terms, attached_by_model_code) + + # Step 2: Report every missing column at once + missing_terms <- setdiff(terms, colnames(prediction_matrix)) + + if (length(missing_terms) > 0) { + stop( + "The ", what, " prediction matrix has no column for ", + length(missing_terms), " term(s) the models fit:\n ", + paste(missing_terms, collapse = "\n "), + "\n", source_note, + call. = FALSE + ) + } + + invisible(NULL) +} + +# 5. load_plant_model_data() ---- + +#' Rebuild One Taxon's v2 Model Frames from the Test Dataset +#' +#' Joins the response, site and covariate tables into the three +#' frames the v2 plant scripts expect - `climate.data`, +#' `veg.data` and `soil.data` - and returns them alongside the +#' prediction matrices and species lists. +#' +#' `climate.data` is identity + response + climate covariates. +#' `veg.data` and `soil.data` are that frame plus their own +#' habitat block, which is how the v2 files were built: each +#' habitat frame is a superset of the climate frame, so a model +#' formula can name a species, a climate term and a habitat term +#' at once. +#' +#' @param taxon Character. One of the taxa in `plant_taxa()`. +#' @param data_dir Character. Path to 0_data/test_dataset. +#' @param species Character vector of species to model, or NULL +#' to keep every species the snapshot declares as modelled. +#' @return A list with `climate.data`, `veg.data`, `soil.data`, +#' `veg.pm`, `soil.pm`, `veg.species.list`, `soil.species.list` +#' and `veg_coef_names`. +#' +#' @example # Example usage of the function +#' # model_data <- load_plant_model_data( +#' # taxon = "bryophyte", +#' # data_dir = "0_data/test_dataset" +#' # ) +#' # dim(model_data$veg.data) +load_plant_model_data <- function( + taxon, + data_dir, + species = NULL +) { + taxon_uses_protocol(taxon) + + # Step 1: Confirm every file is present, so a missing covariate + # table fails here rather than as a cryptic formula error hours + # into a bootstrap run. + paths <- c( + sites = file.path(data_dir, "sites.csv"), + response = file.path(data_dir, paste0(taxon, ".csv")), + climate = file.path( + data_dir, "covariates", paste0(taxon, "_climate.csv") + ), + veg = file.path( + data_dir, "covariates", paste0(taxon, "_veg.csv") + ), + soil = file.path( + data_dir, "covariates", paste0(taxon, "_soil.csv") + ), + veg_pm = file.path( + data_dir, "lookup", "veg_prediction_matrix.csv" + ), + soil_pm = file.path( + data_dir, "lookup", "soil_prediction_matrix.csv" + ), + modelled = file.path( + data_dir, "lookup", "modelled_species.csv" + ) + ) + + missing_paths <- paths[!file.exists(paths)] + + if (length(missing_paths) > 0) { + stop( + "Test dataset files not found:\n ", + paste(missing_paths, collapse = "\n "), + "\nRun 1_code/_setup/01_harmonize_model_ready_v2.R first.", + call. = FALSE + ) + } + + read_table <- function(path) { + as.data.frame(fread(path, na.strings = "")) + } + + response <- read_table(paths[["response"]]) + climate_covariates <- read_table(paths[["climate"]]) + veg_covariates <- read_table(paths[["veg"]]) + soil_covariates <- read_table(paths[["soil"]]) + + # Step 2: Take the site fields back under their v2 names. The + # harmonizer factored them out of the covariate tables into + # sites.csv, so each value has one home; the v2 functions read + # them as NR, Lat and so on, and reference them by name. + site_fields <- c( + SiteYearQu = "survey_unit_id", + SiteYear = "site_year", + Site = "site", + Year = "year", + QUAD = "quadrant", + OnOffGrid = "on_off_grid", + Lat = "lat", + Long = "long", + Elevation = "elevation", + NR = "nr", + NSR = "nsr", + LufName = "luf", + Easting = "easting", + Northing = "northing" + ) + + sites <- read_table(paths[["sites"]])[, site_fields] + names(sites) <- names(site_fields) + + # Step 3: Put every table in the response table's row order, so + # the three frames stay aligned and reproduce the v2 ordering. + unit_ids <- as.character(response$survey_unit_id) + + align <- function(frame, what) { + row_order <- match(unit_ids, as.character(frame$survey_unit_id)) + + if (anyNA(row_order)) { + stop( + taxon, + ": ", + sum(is.na(row_order)), + " survey unit(s) in the response have no ", + what, + " row.", + call. = FALSE + ) + } + + frame[row_order, setdiff(names(frame), "survey_unit_id"), + drop = FALSE] + } + + site_rows <- sites[ + match(unit_ids, sites$SiteYearQu), , drop = FALSE + ] + + if (anyNA(site_rows$SiteYearQu)) { + stop( + taxon, + ": ", + sum(is.na(site_rows$SiteYearQu)), + " survey unit(s) in the response are absent from sites.csv.", + call. = FALSE + ) + } + + # Step 4: Assemble the climate frame - identity, response and + # climate covariates - then extend it with each habitat block. + species_columns <- response[ + , setdiff(names(response), "survey_unit_id"), drop = FALSE + ] + + climate.data <- cbind( + site_rows, + species_columns, + align(climate_covariates, "climate covariate") + ) + + # Step 4b: Recompute the terms that are products of other + # columns, using the same expressions + # 01a_data-standardization.R used. They are derived rather than + # stored so they stay exactly consistent with the columns they + # come from: a CSV carries about 15 significant digits, and a + # separately stored Northing2 would not equal Northing squared. + climate.data$Easting2 <- + climate.data$Easting * climate.data$Easting + climate.data$Northing2 <- + climate.data$Northing * climate.data$Northing + climate.data$EastingNorthing <- + climate.data$Northing * climate.data$Easting + climate.data$MAPPET <- climate.data$MAP * climate.data$PET + climate.data$MAT2 <- climate.data$MAT * climate.data$MAT + climate.data$CMDMAT <- climate.data$CMD * climate.data$MAT + climate.data$MWMT2 <- climate.data$MWMT * climate.data$MWMT + + veg_block <- align(veg_covariates, "vegetation covariate") + soil_block <- align(soil_covariates, "soil covariate") + + veg.data <- cbind(climate.data, veg_block) + soil.data <- cbind(climate.data, soil_block) + + # Step 5: Address rows both ways. The hierarchical models index + # by rownames and the validation matches on the SiteYearQu + # column, so the identifier has to be reachable as both. + for (frame_name in c("climate.data", "veg.data", "soil.data")) { + frame <- get(frame_name) + rownames(frame) <- frame$SiteYearQu + assign(frame_name, frame) + } + + # Step 6: Protocol is a factor in the v2 data, and the habitat + # formulas fit it as one. fread reads it as character, so it is + # converted back for the two taxa that carry it. + if (taxon_uses_protocol(taxon)) { + if (!"Protocol" %in% names(climate.data)) { + stop( + taxon, + " fits a Protocol term but no Protocol column was found ", + "in its climate covariates.", + call. = FALSE + ) + } + + climate.data$Protocol <- as.factor(climate.data$Protocol) + veg.data$Protocol <- as.factor(veg.data$Protocol) + soil.data$Protocol <- as.factor(soil.data$Protocol) + } + + # Step 7: Name the 87 habitat types the vegetation coefficient + # template is built from. They are the head of the vegetation + # block, which is the same set the v2 scripts reached by + # position; the rest of the block holds the aggregates the + # formulas call for, such as Peatland and CCDecidMixed234. + veg_coef_names <- names(veg_block)[1:87] + + # Step 8: Read the work queue, narrowed to `species` when the + # caller names one. The lists say which species each model set + # is fitted for, and they differ: a species can be common + # enough to model in the north and not in the south. + modelled <- read_table(paths[["modelled"]]) + modelled <- modelled[modelled$taxon == taxon, ] + + if (nrow(modelled) == 0) { + stop( + "No modelled species listed for ", + taxon, + " in lookup/modelled_species.csv.", + call. = FALSE + ) + } + + if (!is.null(species)) { + unknown <- setdiff(species, modelled$species) + + if (length(unknown) > 0) { + stop( + "Species not modelled for ", + taxon, + ":\n ", + paste(unknown, collapse = "\n "), + call. = FALSE + ) + } + + # Subsetting rather than reordering keeps the v2 queue order, + # so a narrowed run visits species in the same sequence. + modelled <- modelled[modelled$species %in% species, ] + } + + # Each list keeps its own v2 ordering, recorded per species by + # the harmonizer. The two differ, so neither can be recovered + # from the row order of modelled_species.csv alone. + veg_rows <- modelled[modelled$in_veg_models, ] + soil_rows <- modelled[modelled$in_soil_models, ] + + veg.species.list <- + veg_rows$species[order(veg_rows$veg_order)] + soil.species.list <- + soil_rows$species[order(soil_rows$soil_order)] + + message( + "Loaded ", + taxon, + ": ", + nrow(climate.data), + " survey units, ", + length(veg.species.list), + " vegetation and ", + length(soil.species.list), + " soil species" + ) + + return(list( + climate.data = climate.data, + veg.data = veg.data, + soil.data = soil.data, + veg.pm = read_table(paths[["veg_pm"]]), + soil.pm = read_table(paths[["soil_pm"]]), + veg.species.list = veg.species.list, + soil.species.list = soil.species.list, + veg_coef_names = veg_coef_names + )) +} + +# End of script ---- 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/_