From 49e21b89794d81be3494bcdb4125311df8ba0718 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 09:44:23 -0700 Subject: [PATCH 1/5] Remove dead code; document functions; correct metadata descs and Rmd No behaviour change: only commented-out code, an if (FALSE) block, comments, desc strings and Rmd text are touched. Several input descs had been passed positionally into sourceURL; they are now in desc. Co-Authored-By: Claude Fable 5.1 --- fireSense_dataPrepPredict.R | 462 +++++++++++----------------------- fireSense_dataPrepPredict.Rmd | 37 ++- 2 files changed, 159 insertions(+), 340 deletions(-) diff --git a/fireSense_dataPrepPredict.R b/fireSense_dataPrepPredict.R index c16d46a..a2f766e 100644 --- a/fireSense_dataPrepPredict.R +++ b/fireSense_dataPrepPredict.R @@ -1,6 +1,8 @@ defineModule(sim, list( name = "fireSense_dataPrepPredict", - description = "", + description = paste( + "Prepares, each year, the covariate tables used by fireSense_IgnitionPredict,", + "fireSense_EscapePredict and fireSense_SpreadPredict."), keywords = "", authors = c( person("Ian", "Eddy", role = c("aut", "cre"), email = "ian.eddy@nrcan-rncan.gc.ca"), @@ -19,7 +21,6 @@ defineModule(sim, list( "data.table", "PredictiveEcology/fireSenseUtils@development (>= 0.1.0)", "terra" - #reproducible@ai ), parameters = rbind( defineParameter("cutoffForYoungAge", "numeric", 15, NA, NA, @@ -29,32 +30,35 @@ defineModule(sim, list( ) ), defineParameter("dataYear", "numeric", 2011, 1985, 2022, - "Used to override the default 'sourceURL' of NTEMS data for objects when not supplied"), - defineParameter("fireTimeStep", "numeric", 1, NA, NA, desc = "time step of fire model"), + paste("Year of the default landcover and stand age maps, and last year of the fires", + "used to initialise `nonForest_timeSinceDisturbance`.")), + defineParameter("fireTimeStep", "numeric", 1, NA, NA, desc = "Interval between events of this module, in years."), defineParameter("forestedLCC", "numeric", c(81, 210, 220, 230, 240), NA, NA, - "forested landcover classes in `rstLCC` - only relevant if `landcoverDT` is not supplied"), + "Forested landcover classes in `rstLCC_RTM`. Only used if `landcoverDT` is not supplied."), defineParameter("flammabilityThreshold", "numeric", 0.1, 0, 1, - paste("Minimum proportion of flammable old pixel needed to define a new pixel - as flammable when upscaling the default flammable maps`.")), + paste("Minimum proportion of flammable pixels for an upscaled pixel to be flammable,", + "when building the default landcover.")), defineParameter("fuelClassCol", "character", "FuelClass", NA, NA, - "the column in sppEquiv that defines unique fuel classes for ignition"), - defineParameter("igAggFactor", "numeric", 4, 1, NA, # was 4 before xgboost, Jun 19, 2025 - "aggregation factor for rasters during ignition prep."), + "Column of `sppEquiv` that defines the fuel classes, for both ignition and spread."), + defineParameter("igAggFactor", "numeric", 4, 1, NA, + paste("Aggregation factor for the ignition and escape covariates.", + "Overwritten in `init` by the value set in other modules.")), defineParameter("nonflammableLCC", "numeric", c(0, 20, 31, 32, 33), NA, NA, desc = paste( - "used to create flammableRTM if unsupplied.", - "The non-flammable LCC in rstLCC layers - which", - "default to water, snow/ice, rock, and barren land in NTEMS LCC" + "Non-flammable landcover classes, used to create `flammableRTM` and the default landcover", + "if not supplied. Defaults are water, snow/ice, rock and barren land in NTEMS LCC." ) ), defineParameter("nonForestCanBeYoungAge", "logical", TRUE, NA, NA, - desc = "update non-forest when burned, to become youngAge"), + desc = "Should burned non-forest pixels be `youngAge` until `cutoffForYoungAge`?"), defineParameter("sppEquivCol", "character", "LandR", NA, NA, - desc = "column name in `sppEquiv` object that defines unique species in `cohortData`"), + desc = "Column of `sppEquiv` with the species names used in `cohortData`."), defineParameter("whichModulesToPrepare", "character", default = c("fireSense_SpreadPredict", "fireSense_IgnitionPredict", "fireSense_EscapeFit"), NA, NA, - desc = "Which fireSense fit modules to prep? defaults to all 3"), + desc = paste("Predict modules to prepare covariates for: `fireSense_IgnitionPredict` or", + "`fireSense_EscapePredict` for the ignition/escape table,", + "`fireSense_SpreadPredict` for the spread table.")), defineParameter(".plotInitialTime", "numeric", NA, NA, NA, "Describes the simulation time at which the first plot event should occur." ), @@ -63,7 +67,7 @@ defineModule(sim, list( "Describes the simulation time interval between plot events." ), defineParameter( - ".runInitialTime", "numeric", start(sim), NA, NA, "time to simulate initial fire" + ".runInitialTime", "numeric", start(sim), NA, NA, "Time of the first climate and covariate preparation events." ), defineParameter( ".saveInitialTime", "numeric", NA, NA, NA, @@ -83,85 +87,84 @@ defineModule(sim, list( ) ), inputObjects = bindrows( - expectsInput("climateVariablesForFire", "list", - sourceURL = NA, - paste( - "A list detailing which climate variables in `sim$projectedClimateRasters`", - "to use for which fire processes (ignition and spread). If the list is length one,", - "both processes will use the same variables. The default is to use 'MDC'.")), - expectsInput("climateYear", "character", - paste("optional character vector giving year (e.g. 'year2009') for preparing", - "the `currentClimateRasters` object. If unsupplied, `time(sim)` is used.", - "see PredictiveEcology/climateYear")), - expectsInput("currentClimateRasters", "SpatRaster", NA, - "SpatRaster of climate layers at current time of sim; this will be generated ", - "in this module (if this is absent) from projectedClimateRasters"), - expectsInput("cohortData", "data.table", NA, - "table that defines the cohorts by pixelGroup"), - expectsInput("fireSense_IgnitionFitted", "fireSense_IgnitionFit", NA, - "object containing slot `fittingRes` - the spatial resolution at which ignition will be predicted"), - expectsInput("missingLCCgroup", "character", NA, paste( - "if a pixel is forested but is absent from `cohortData`, it will be grouped in this class.", - "It can be estimated if `P(sim)$estimateFuelClasses` is TRUE.", - "If supplied, it must be one of the names in `sim$nonForestedLCCGroups`")), - expectsInput("flammableRTM", "SpatRaster", "Flammable landcover i.e, conditions at start(sim). Taken from last layer of rstLCCs"), - expectsInput("nonForestedLCCGroups", "list", NA, paste( - "a named list of non-forested landcover groups, e.g. `list('wetland' = c(19, 23, 32))`.", - "This is only relevant if `landcoverDT` is not supplied")), - expectsInput("lightningMaps", "SpatRaster", NA, paste( - "A 4-layer SpatRaster of lightning: lightningDays, lightningDensity, positiveCG, positiveCGdensity")), - expectsInput("pixelGroupMap", "SpatRaster", NA, - "SpatRaster that defines the pixelGroups for cohortData table"), - expectsInput("projectedClimateRasters", "list", NA, paste( - "list of projected climate variables in raster stack form", - "named according to variable, with names of individual raster layers", - "following the convention 'year'; this will only be used if `currentClimateRasters` is ", - "not supplied")), - expectsInput("propFlammable", "SpatRaster", NA, paste( - "a conditional object created if rstLCC is also not supplied, ", - "a raster representing the proportion of flammable landcover in a pixel")), - expectsInput("rasterToMatch", "SpatRaster", NA, - "template raster used only to derive `flammableRTM` if the latter is absent"), - expectsInput("rstCurrentBurn", "SpatRaster", "binary raster with 1 representing annual burn"), - expectsInput("rstLCC_RTM", "SpatRaster", "a landcover raster - only used if `landcoverDT` is not supplied"), - expectsInput("sppEquiv", "data.table", "table of LandR species equivalencies"), - # expectsInput("standAgeMaps", "list", sourceURL = NA, - # "list of length 2 of maps of stand age in dataYear[[1]] and dataYear[[2]]", - # " used to create `cohortDatas`. This is only used if standAgeMap is not supplied"), - expectsInput("standAgeMap", "SpatRaster", "stand age map in study area; assumed to be ages at `start(sim)`"), - expectsInput("landcoverDT", "data.table", - "`pixelID` and relevant landcover classes for flammable pixels in each layer, ", - "i.e, conditions at start(sim). Taken from last layer of landcoverDTs"), - + expectsInput("climateVariablesForFire", "list", sourceURL = NA, + desc = paste( + "Named list (`ignition`, `spread`) of the layer names in `currentClimateRasters`", + "used by each process. A length-one list is used for both. Default is 'MDC' for both.")), + expectsInput("climateYear", "character", sourceURL = NA, + desc = paste( + "Optional year used instead of `time(sim)` when checking whether the projected climate", + "covers the current year. See PredictiveEcology/climateYear.")), + expectsInput("currentClimateRasters", "SpatRaster", sourceURL = NA, + desc = paste( + "Climate layers for the current year, one layer per climate variable.", + "If absent, built from `projectedClimateRasters`.")), + expectsInput("cohortData", "data.table", sourceURL = NA, + desc = "Cohorts by `pixelGroup` (LandR)."), + expectsInput("fireSense_IgnitionFitted", "fireSense_IgnitionFit", sourceURL = NA, + desc = "Fitted ignition model. Not used by the current code."), + expectsInput("missingLCCgroup", "character", sourceURL = NA, + desc = paste( + "Forested pixels that are absent from `cohortData` are assigned to this class.", + "Must be one of the names of `nonForestedLCCGroups`.")), + expectsInput("flammableRTM", "SpatRaster", sourceURL = NA, + desc = paste( + "Binary raster of flammable pixels at `start(sim)`.", + "If absent, derived from the default landcover and `nonflammableLCC`.")), + expectsInput("nonForestedLCCGroups", "list", sourceURL = NA, + desc = paste( + "Named list of non-forested landcover groups, e.g. `list('wetland' = c(19, 23, 32))`.", + "Only used if `landcoverDT` is not supplied.")), + expectsInput("lightningMaps", "SpatRaster", sourceURL = NA, + desc = paste( + "Lightning layers: lightningDays, lightningDensity, positiveCG, positiveCGdensity.", + "Only `lightningDays` is used.")), + expectsInput("pixelGroupMap", "SpatRaster", sourceURL = NA, + desc = "Map of the `pixelGroup`s in `cohortData`."), + expectsInput("projectedClimateRasters", "list", sourceURL = NA, + desc = paste( + "Named list (one element per climate variable) of SpatRasters whose layers are named", + "'year'. Only used if `currentClimateRasters` is not supplied.")), + expectsInput("propFlammable", "SpatRaster", sourceURL = NA, + desc = paste( + "Proportion of flammable landcover in each pixel.", + "Created with the default landcover when `rstLCCs` is not supplied; not used otherwise.")), + expectsInput("rasterToMatch", "SpatRaster", sourceURL = NA, + desc = "Template raster for the study area."), + expectsInput("rstCurrentBurn", "SpatRaster", sourceURL = NA, + desc = "Binary raster with 1 where the pixel burned this year."), + expectsInput("rstLCC_RTM", "SpatRaster", sourceURL = NA, + desc = paste( + "Landcover raster, only used if `landcoverDT` is not supplied.", + "Defaults to the last layer of `rstLCCs`, else NTEMS landcover for `dataYear`.")), + expectsInput("sppEquiv", "data.table", sourceURL = NA, + desc = "Table of LandR species equivalencies; must have columns `sppEquivCol` and `fuelClassCol`."), + expectsInput("standAgeMap", "SpatRaster", sourceURL = NA, + desc = "Stand age (years) at `start(sim)`."), + expectsInput("landcoverDT", "data.table", sourceURL = NA, + desc = paste( + "`pixelID` plus one binary column per non-forest landcover group, for flammable pixels,", + "at `start(sim)`.")) ), outputObjects = bindrows( - createsOutput("currentClimateRasters", "SpatRaster", - "SpatRaster of climate layers at current time of sim; this will be generated ", - "in this module (if this is absent) from projectedClimateRasters"), - createsOutput("fireSense_igAndEscapePred_Covariates", "data.table", paste( - "data.table of covariates for ignition prediction, with pixelID column", - "corresponding to flammableRTM pixel index")), - createsOutput("fireSense_SpreadCovariates", "data.table", paste( - "data.table of covariates for spread prediction, with pixelID column", - "corresponding to flammableRTM pixel index")), - # createsOutput("flammableRTM", "list", "List of (2) binary SpatRaster of flammable landcover for years given by the list names"), - # createsOutput("landcoverDT", "data.table", - # "data.table with `pixelID` and relevant landcover classes for flammable pixels"), + createsOutput("currentClimateRasters", "SpatRaster", + desc = paste( + "Climate layers for the current year, one layer per climate variable.", + "Built from `projectedClimateRasters` if not supplied.")), + createsOutput("fireSense_igAndEscapePred_Covariates", "data.table", + desc = paste( + "Ignition and escape covariates at the aggregated (`igAggFactor`) resolution;", + "`pixelID` is the cell index of the aggregated raster.")), + createsOutput("fireSense_SpreadCovariates", "data.table", + desc = "Spread covariates; `pixelID` is the cell index of `flammableRTM`."), createsOutput("nonForest_timeSinceDisturbance", "SpatRaster", - desc = "time since burn for non-forest pixels") + desc = "Years since last burn, used to set `youngAge` in non-forest pixels.") ) )) -## event types -# - type `init` is required for initialization - doEvent.fireSense_dataPrepPredict <- function(sim, eventTime, eventType) { switch(eventType, init = { - ### check for more detailed object dependencies: - ### (use `checkObject` or similar) - - # do stuff for this event sim <- Init(sim) sim <- scheduleEvent(sim, time(sim) + 1, "fireSense_dataPrepPredict", "ageNonForest") sim <- scheduleEvent(sim, P(sim)$.runInitialTime, "fireSense_dataPrepPredict", "getClimateRasters") @@ -177,8 +180,6 @@ doEvent.fireSense_dataPrepPredict <- function(sim, eventTime, eventType) { sim <- scheduleEvent(sim, P(sim)$.runInitialTime, "fireSense_dataPrepPredict", "prepSpreadPredictData" ) } - # schedule future event(s) - # sim <- scheduleEvent(sim, P(sim)$.plotInitialTime, "fireSense_dataPrepPredict", "plot", eventPriority = 5.12) }, ageNonForest = { sim$nonForest_timeSinceDisturbance <- ageNonForest( @@ -193,7 +194,6 @@ doEvent.fireSense_dataPrepPredict <- function(sim, eventTime, eventType) { }, getClimateRasters = { sim <- getCurrentClimate(sim) - # sim$currentClimateRasters <- lapply(sim$currentClimateRasters, terra::unwrap) sim <- scheduleEvent( sim, time(sim) + P(sim)$fireTimeStep, "fireSense_dataPrepPredict", "getClimateRasters" @@ -219,10 +219,14 @@ doEvent.fireSense_dataPrepPredict <- function(sim, eventTime, eventType) { return(invisible(sim)) } -## event functions -# - keep event functions short and clean, modularize by calling subroutines from section below. - -### template initialization +#' Initialize the module +#' +#' Aligns `standAgeMap` and `rstLCC_RTM` to `rasterToMatch`, builds `landcoverDT` and +#' `nonForest_timeSinceDisturbance` if absent, and expands `climateVariablesForFire`. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`, invisibly. Init <- function(sim) { # force it to be same as the other module's value @@ -240,17 +244,6 @@ Init <- function(sim) { sim$rstLCC_RTM } - # objs <- c(sim$standAgeMap, sim$rstLCC_RTM) - # if (!isInt(objs[[1]]) | !isInt(objs[[2]])) { - # objs <- lapply(objs, LandR::asInt) - # } - # standAgeMap <- objs[[1]] - # rstLCC <- objs[[2]] - - # sim$flammableRTM <- defineFlammable(rstLCC, - # nonFlammClasses = P(sim)$nonflammableLCC, - # to = sim$rasterToMatch) - if (is.null(sim$landcoverDT)) { sim$landcoverDT <- makeLandcoverDT( rstLCC = rstLCC, @@ -263,15 +256,13 @@ Init <- function(sim) { if (is.null(sim$nonForest_timeSinceDisturbance)) { fireYears <- c(P(sim)$dataYear - P(sim)$cutoffForYoungAge):P(sim)$dataYear firePolys <- fireSenseUtils::getFirePolygons( - fun = "sf::st_read", #I think it must be SF? + fun = "sf::st_read", years = fireYears, useInnerCache = FALSE, destinationPath = inputPath(sim), cropTo = sim$rasterToMatch, maskTo = sim$studyArea, - projectTo = sim$rasterToMatch)# |> - # Cache(userTags = c("firePolys", - # paste0(fireYears, collapse = ":"))) + projectTo = sim$rasterToMatch) sim$nonForest_timeSinceDisturbance <- makeTSD( year = P(sim)$dataYear, @@ -293,11 +284,15 @@ Init <- function(sim) { return(invisible(sim)) } -### template for plot events - +#' Set `sim$currentClimateRasters` for the current year +#' +#' If `sim$currentClimateRasters` is absent, takes layer `year` of each element of +#' `sim$projectedClimateRasters`. Stops if the result does not match `sim$pixelGroupMap`. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`. getCurrentClimate <- function(sim) { - ## this function has been rewritten due to an undiagnosed bug involving - ## digest of a file-backed SpatRaster, and restartSpades() if (is.null(sim$currentClimateRasters)) { sim$currentClimateRasters <- sim$projectedClimateRasters[[1]] @@ -334,7 +329,7 @@ getCurrentClimate <- function(sim) { } ) - sim$currentClimateRasters <- terra::rast(thisYearsClimate)#lapply(thisYearsClimate, terra::wrap) + sim$currentClimateRasters <- terra::rast(thisYearsClimate) } if (!compareGeom(sim$pixelGroupMap, sim$currentClimateRasters, stopOnError = FALSE)) { @@ -345,6 +340,14 @@ getCurrentClimate <- function(sim) { return(sim) } +#' Age the time-since-disturbance raster by one year +#' +#' @param TSD `SpatRaster` of years since last burn. +#' @param rstCurrentBurn `SpatRaster` with 1 where the pixel burned this year, or `NULL`. +#' Burned pixels are reset to 0. +#' @param timeStep Not used; `TSD` always increases by 1. +#' +#' @return `TSD`, updated. ageNonForest <- function(TSD, rstCurrentBurn, timeStep) { TSDvals <- as.vector(TSD) TSDvals <- TSDvals + 1 @@ -352,14 +355,20 @@ ageNonForest <- function(TSD, rstCurrentBurn, timeStep) { burnVals <- as.vector(rstCurrentBurn) unburned <- is.na(burnVals) | burnVals == 0 TSDvals[!unburned] <- 0 - # rm(TSDvals, burnVals, unburned) rm(burnVals, unburned) } TSD <- setValues(TSD, TSDvals) - # gc() return(TSD) } +#' Build this year's ignition and escape covariates +#' +#' Creates `sim$fireSense_igAndEscapePred_Covariates` from fuel classes, non-forest landcover, +#' ignition climate and lightning days, aggregated by `igAggFactor`. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`, invisibly. prepare_IgnitionAndEscapePredict <- function(sim) { ## get climate ignitionClimate <- sim$currentClimateRasters[[sim$climateVariablesForFire$ignition]] @@ -370,20 +379,6 @@ prepare_IgnitionAndEscapePredict <- function(sim) { if (!data.table::is.data.table(sim$sppEquiv)) data.table::setDT(sim$sppEquiv) if (is.null(mod$requiredFuelClasses)) mod$requiredFuelClasses <- sim$sppEquiv[[P(sim)$fuelClassCol]] - ## get fuel classes - # There may be fuel classes that disappear because of succession/dispersal limtation etc. - # e.g., Popu_tre disappeared in one example. Need to set up an zero SpatRaster for any that disappear - # requiredFuelClasses <- getRequiredFuelClasses( - # candidates = unique(unlist(sim$fireSense_IgnitionFitted$scaleData$dimnames)), - # climateNames = names(ignitionClimate), - # nonForestedLCCNames = names(sim$nonForestedLCCGroups) - # ) - # requiredFuelClasses <- unique(unlist(sim$fireSense_IgnitionFitted$scaleData$dimnames)) - # nonFuelNames <- c("pixelID", names(ignitionClimate), "youngAge", "year", names(sim$nonForestedLCCGroups)) - # requiredFuelClasses <- setdiff(requiredFuelClasses, nonFuelNames) - # # may be "lightningDays" or other - # requiredFuelClasses <- grep("lightning", value = TRUE, invert = TRUE, requiredFuelClasses) - # if ignition and spread fuel classes are the same, this should use Mod # to avoid doing it twice (in spreadFit, assuming people run both events) fuelCovsCoarse <- prepare_FuelCovsCoarse( @@ -423,115 +418,22 @@ prepare_IgnitionAndEscapePredict <- function(sim) { useCache = FALSE) set(sim$fireSense_igAndEscapePred_Covariates, NULL, "ignitions", NULL) - # sim$lightningMaps <- prepare_LightningData(sim$rasterToMatch, P(sim)$igAggFactor, - # dPath = inputPath(sim)) - # fuelClasses <- cohortsToFuelClasses( - # cohortData = sim$cohortData, - # sppEquiv = sim$sppEquiv, - # sppEquivCol = P(sim)$sppEquivCol, - # pixelGroupMap = sim$pixelGroupMap, - # landcoverDT = sim$landcoverDT, - # flammableRTM = sim$flammableRTM, - # fuelClassCol = P(sim)$fuelClassCol, - # cutoffForYoungAge = P(sim)$cutoffForYoungAge - # ) - - if (FALSE) { - fcs <- setdiff(names(fuelClasses), "youngAge") - fuelClasses <- as.data.table(as.data.frame(fuelClasses, cells = TRUE)) - setnames(fuelClasses, old = "cell", new = "pixelID") - - # make sure join is only landcoverDT - ignitionCovariates <- fuelClasses[sim$landcoverDT, on = c("pixelID")] - - ignitionCovariates[, rowcheck := rowSums(.SD), .SDcols = setdiff(names(ignitionCovariates), "pixelID")] - ## if all rows are 0, it must be a forested LCC absent from cohortData - ignitionCovariates[rowcheck == 0, eval(sim$missingLCCgroup) := 1] - set(ignitionCovariates, NULL, "rowcheck", NULL) - - # this must happen after the missingLC are evaluated - ignitionCovariates <- ignitionCovariates[, eval(fcs) := lapply(.SD, FUN = logMinB), .SDcols = fcs] - - if (P(sim)$nonForestCanBeYoungAge) { - ignitionCovariates[, YA_NF := as.vector(sim$nonForest_timeSinceDisturbance)[ignitionCovariates$pixelID] <= - P(sim)$cutoffForYoungAge] - ignitionCovariates[YA_NF == TRUE, youngAge := 1] - ignitionCovariates[, YA_NF := NULL] - } - - exclusiveCols <- c(fcs, names(sim$landcoverDT)) - exclusiveCols <- setdiff(exclusiveCols, c("pixelID", "youngAge")) - # TODO: I believe this triggers a warning - ignitionCovariates <- makeMutuallyExclusive( - dt = ignitionCovariates, - mutuallyExclusiveCols = list("youngAge" = exclusiveCols) - ) - - # climateCovariates <- rast(ignitionClimate) # it was a list - - climateCovariates <- na.omit(as.data.table(ignitionClimate, cells = TRUE)) - setnames(climateCovariates, new = c("pixelID", names(ignitionClimate))) - ignitionCovariates <- climateCovariates[ignitionCovariates, on = c("pixelID")] - - #put back into raster for aggregate - #TODO: this should be put in fireSenseUtils - covCols <- setdiff(names(ignitionCovariates), "pixelID") - rasObj <- rast(sim$flammableRTM) - rasObj[!is.na(sim$flammableRTM[])] <- 0 #make sure NA is 0 for mean during aggregate - out <- lapply(covCols, FUN = function(cov, ras = rasObj, covDT = ignitionCovariates) { - ras[covDT$pixelID] <- covDT[[cov]] - return(ras) - }) - names(out) <- covCols - ignitionCovariates <- rast(out) - - # now aggregate to match fitting resolution... - mods <- sim$fireSense_IgnitionFitted$modelList - if (!is.null(mods$fittingRes)) { - # following changes to ignitionModel - prediction will now occur at same spatial scale, - # location of predicted ignitions will be randomly drawn from finer scale - igAggFactor <- ceiling(mods$fittingRes / c(res(sim$rasterToMatch)[1])) - ignitionCovariates <- terra::aggregate(ignitionCovariates, fact = igAggFactor) - } - - # Lightning --> was at 1km resolution, so don't add prior to aggregation; add after - a <- postProcess(sim$lightningMaps[[2]], to = ignitionCovariates) - lightningTxt <- grep("lightn", unlist(sim$fireSense_IgnitionFitted$scaleData$dimnames), ignore.case = TRUE, value = TRUE) - names(a) <- lightningTxt - - ignitionCovariates <- c(ignitionCovariates, lightning = a) - - ignitionCovariates <- as.data.table(ignitionCovariates, cells = TRUE) - setnames (ignitionCovariates, old = "cell", new = "pixelID") - - } -# sim$fireSense_igAndEscapePred_Covariates <- ignitionCovariates - - # gc() return(invisible(sim)) } +#' Build this year's spread covariates +#' +#' Creates `sim$fireSense_SpreadCovariates` from fuel classes, non-forest landcover and +#' spread climate, at the resolution of `flammableRTM`. Stops if a non-forest pixel has forest fuel. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`, invisibly. prepare_SpreadPredict <- function(sim) { spreadClimate <- sim$currentClimateRasters[[sim$climateVariablesForFire$spread]] if (is.null(spreadClimate)) stop("spreadClimate is NULL; there is a problem to debug") - # requiredFuelClasses <- getRequiredFuelClasses( - # candidates = names(sim$studyAreaWithSpreadParams$params[[1]]), - # climateNames = names(spreadClimate), - # nonForestedLCCNames = names(sim$nonForestedLCCGroups), - # fuelNames = sim$sppEquiv[[P(sim)$fuelClassCol]] - # ) - # requiredFuelClasses <- names(sim$studyAreaWithSpreadParams$params[[1]]) - # fuelNames <- sim$sppEquiv[[P(sim)$fuelClassCol]] - # nonFuelNames <- c("pixelID", names(spreadClimate), "youngAge", "year", names(sim$nonForestedLCCGroups)) - # nonLogitParams <- unique(c(fuelNames, nonFuelNames)) - # logitParams <- setdiff(requiredFuelClasses, nonLogitParams) - # requiredFuelClasses <- setdiff(requiredFuelClasses, logitParams) - # requiredFuelClasses <- - # # may be "lightningDays" or other --> likely not here because this is spread; just "in case" - # requiredFuelClasses <- grep("lightning", value = TRUE, invert = TRUE, requiredFuelClasses) - if (is.null(mod$requiredFuelClasses)) mod$requiredFuelClasses <- sim$sppEquiv[[P(sim)$fuelClassCol]] @@ -556,71 +458,8 @@ prepare_SpreadPredict <- function(sim) { nonForest_timeSinceDisturbance = sim$nonForest_timeSinceDisturbance, studyAreaName = P(sim)$.studyAreaName, useCache = FALSE # predict is annual, no point in caching - - #fuelClassCol = P(sim)$fuelClassCol, - #sppEquivCol = P(sim)$sppEquivCol, - #cutoffForYoungAge = P(sim)$cutoffForYoungAge, - #missingLCCgroup = sim$missingLCCgroup, - #nonForestedLCCGroups = sim$nonForestedLCCGroups, - #nonForest_timeSinceDisturbance = sim$nonForest_timeSinceDisturbance, - #nonForestCanBeYoungAge = P(sim)$nonForestCanBeYoungAge ) - # fuelClasses <- cohortsToFuelClasses( - # cohortData = sim$cohortData, - # pixelGroupMap = sim$pixelGroupMap, - # flammableRTM = sim$flammableRTM, - # sppEquiv = sim$sppEquiv, - # landcoverDT = sim$landcoverDT, - # fuelClassCol = P(sim)$fuelClassCol, - # sppEquivCol = P(sim)$sppEquivCol, - # cutoffForYoungAge = P(sim)$cutoffForYoungAge - # ) - # - # - # ## make columns for each fuel class - # # fuelClasses <- terra::app(fuelClasses, fun = logMinB) - # # terra app is horrifically slow - # # fcs <- setdiff(names(fuelClasses), "youngAge") - # fuelClasses <- as.data.table(as.data.frame(fuelClasses, cells = TRUE)) - # setnames(fuelClasses, old = "cell", new = "pixelID") - # - # # make sure join is only landcoverDT -- this adds the nonForest that are in sim$landcoverDT - # spreadCovariates <- fuelClasses[sim$landcoverDT, on = c("pixelID")] - # - # - # ## Nov 2023 - there should not be NA values - previously this used nafill - # ## if they return - use x <- as.data.table(nafill(vegData), 0) and setnames(x, names(vegData)) - # spreadCovariates[, rowcheck := rowSums(.SD), .SDcols = setdiff(names(spreadCovariates), "pixelID")] - # if (any(is.na(spreadCovariates$rowCheck))) { - # stop("NA in vegData columns of fireSense_dataPrepPredict... please contact module developers") - # } - # # if all rows are 0, it must be a forested LCC absent from cohortData - # spreadCovariates[rowcheck == 0, eval(sim$missingLCCgroup) := 1] - # set(spreadCovariates, NULL, "rowcheck", NULL) - # - # # Making exclusive has to be prior to logMinB, or else the 0 biomass become -0.59 or so - # # --> they need to stay at the minimum of 3.605 - # exclusiveCols <- c(fcs, names(sim$landcoverDT)) - # exclusiveCols <- setdiff(exclusiveCols, "pixelID") - # spreadCovariates <- makeMutuallyExclusive(dt = spreadCovariates, - # mutuallyExclusive = list("youngAge" = exclusiveCols)) - # - # spreadCovariates <- spreadCovariates[, eval(fcs) := lapply(.SD, FUN = logMinB), .SDcols = fcs] - # - # - # if (P(sim)$nonForestCanBeYoungAge) { - # # this should only alter non-forest - # spreadCovariates[, isNonForest := rowSums(.SD) > 0, .SDcols = names(sim$nonForestedLCCGroups)] - # spreadCovariates[, YA_NF := as.vector(sim$nonForest_timeSinceDisturbance)[spreadCovariates$pixelID] <= P(sim)$cutoffForYoungAge & - # isNonForest == TRUE] - # spreadCovariates[YA_NF == TRUE, youngAge := 1] - # spreadCovariates[, c("YA_NF", "isNonForest") := NULL] - # } - - # exclusiveCols <- c(fcs, names(sim$landcoverDT)) - # exclusiveCols <- setdiff(exclusiveCols, "pixelID") - # TODO: this chunk is untested 18/12/2024 climateCovariates <- spreadClimate |> as.data.frame(cells = TRUE) climateCovariates <- na.omit(climateCovariates) |> as.data.table() @@ -628,9 +467,6 @@ prepare_SpreadPredict <- function(sim) { setnames(climateCovariates, new = c("pixelID", names(spreadClimate))) spreadCovariates <- climateCovariates[spreadCovariates, on = c("pixelID")] - # spreadCovariates <- makeMutuallyExclusive(dt = spreadCovariates, - # mutuallyExclusive = list("youngAge" = exclusiveCols)) - nonFuelNames <- c("pixelID", names(spreadClimate), "youngAge") setcolorder(spreadCovariates, neworder = nonFuelNames) sim$fireSense_SpreadCovariates <- spreadCovariates @@ -640,7 +476,6 @@ prepare_SpreadPredict <- function(sim) { df <- sim$fireSense_SpreadCovariates fcs <- setdiff(colnames(df), c(nonFuelNames, nfCols)) df[df - min(df[[fcs[[1]]]], na.rm = TRUE) == 0] <- NA - # df[df - df[[fcs[[1]]]][1] == 0] <- NA fuelInSamePixelAsNonForest <- any(rowSums(!is.na(df[, ..fcs])) > 0 & (rowSums(df[, ..nfCols]) > 0)) @@ -651,15 +486,19 @@ prepare_SpreadPredict <- function(sim) { } +#' Supply default inputs +#' +#' Defaults for `climateVariablesForFire`, `rstLCC_RTM` (and `propFlammable`), `standAgeMap`, +#' `flammableRTM` and `landcoverDT`. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`, invisibly. .inputObjects <- function(sim) { cacheTags <- c(currentModule(sim), "otherFunctions:.inputObjects") dPath <- asPath(inputPath(sim), 1) message(currentModule(sim), ": using dataPath '", dPath, "'.") - # objectSyns <- list(c("standAgeMap", "standAgeMap2011"), - # c("rstLCC", "rstLCC2011")) - # sim <- objectSynonyms(sim, objectSyns) - if (!suppliedElsewhere("climateVariablesForFire", sim)) { sim$climateVariablesForFire <- list( spread = "MDC", @@ -667,7 +506,6 @@ prepare_SpreadPredict <- function(sim) { ) } - # if (!suppliedElsewhere("rstLCC", sim)) { if (suppliedElsewhere("rstLCCs", sim)) { sim$rstLCC_RTM <- tail(sim$rstLCCs, 1)[[1]] } else { @@ -689,19 +527,13 @@ prepare_SpreadPredict <- function(sim) { sim$propFlammable <- rstLCC$flammableProp } - # } - if (!suppliedElsewhere("standAgeMap", sim)) { - # if (suppliedElsewhere("standAgeMaps", sim)) { - # sim$standAgeMap <- tail(sim$standAgeMaps, 1)[[1]] - # } else { sim$standAgeMap <- Cache(prepInputsStandAgeMap, rasterToMatch = sim$rasterToMatch, studyArea = sim$studyArea, destinationPath = dPath, startTime = P(sim)$dataYear, userTags = c(cacheTags, "prepInputsStandAgeMap2011")) - # } } if (!suppliedElsewhere("fireSense_IgnitionFitted", sim)) { @@ -729,15 +561,3 @@ prepare_SpreadPredict <- function(sim) { return(invisible(sim)) } - -# -# getRequiredFuelClasses <- function(candidates, climateNames, nonForestedLCCNames, -# fuelNames = NULL) { -# nonFuelNames <- c("pixelID", climateNames, "youngAge", "year", nonForestedLCCNames) -# required <- if (is.null(fuelNames)) { -# setdiff(candidates, nonFuelNames) -# } else { -# intersect(candidates, c(fuelNames, nonFuelNames)) -# } -# grep("lightning", required, value = TRUE, invert = TRUE) -# } diff --git a/fireSense_dataPrepPredict.Rmd b/fireSense_dataPrepPredict.Rmd index 55828e5..a6e9ec2 100644 --- a/fireSense_dataPrepPredict.Rmd +++ b/fireSense_dataPrepPredict.Rmd @@ -45,18 +45,20 @@ download.file(url = "https://img.shields.io/badge/Made%20with-Markdown-1f425f.pn ### Module summary - -fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019] +Prepares, each year, the covariate tables that the fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019] predict modules use: -Provide a brief summary of what the module does / how to use the module. +- `fireSense_igAndEscapePred_Covariates` for *fireSense_IgnitionPredict* and *fireSense_EscapePredict*: fuel classes, non-forest landcover, `youngAge`, ignition climate and lightning days, aggregated by `igAggFactor`. +- `fireSense_SpreadCovariates` for *fireSense_SpreadPredict*: the same fuel, landcover and `youngAge` columns plus spread climate, at the resolution of `flammableRTM`. -Module documentation should be written so that others can use your module. -This is a template for module documentation, and should be changed to reflect your module. +Fuel classes come from `cohortData` and `pixelGroupMap`, grouped by the `fuelClassCol` column of `sppEquiv`. +The covariates are built by the same *fireSenseUtils* functions that *fireSense_dataPrepFit* uses, so they match the fitted models. ### Module inputs and parameters -Describe input data required by the module and how to obtain it (e.g., directly from online sources or supplied by other modules) -If `sourceURL` is specified, `downloadData("fireSense_dataPrepPredict", "..")` may be sufficient. +`cohortData`, `pixelGroupMap` and `rstCurrentBurn` come from the vegetation and fire modules during the simulation. +`sppEquiv`, `nonForestedLCCGroups`, `missingLCCgroup`, `lightningMaps`, `flammableRTM` and `landcoverDT` should be the ones used by *fireSense_dataPrepFit*. +Climate is either `currentClimateRasters`, or `projectedClimateRasters` with layers named `year`. +`igAggFactor` is overwritten in `init` with the value set in the other modules. Table \@ref(tab:moduleInputs-fireSense-dataPrepPredict) shows the full list of module inputs. @@ -78,18 +80,15 @@ knitr::kable(df_params, caption = "List of (ref:fireSense-dataPrepPredict) param ### Events - -Describe what happens for each event type. +All events after `init` repeat every `fireTimeStep` years. -### Plotting +- `init`: aligns `standAgeMap` and `rstLCC_RTM` to `rasterToMatch`; builds `landcoverDT` if absent; builds `nonForest_timeSinceDisturbance` if absent, from the fire polygons of the `cutoffForYoungAge` years up to `dataYear`. +- `getClimateRasters` (from `.runInitialTime`): if `currentClimateRasters` is absent, takes layer `year` of each element of `projectedClimateRasters`. Stops if it does not match `pixelGroupMap`. +- `prepIgAndEscPredictData` (from `.runInitialTime`): builds `fireSense_igAndEscapePred_Covariates`. Scheduled if `whichModulesToPrepare` has `fireSense_IgnitionPredict` or `fireSense_EscapePredict`. +- `prepSpreadPredictData` (from `.runInitialTime`): builds `fireSense_SpreadCovariates`. Scheduled if `whichModulesToPrepare` has `fireSense_SpreadPredict`. +- `ageNonForest` (from `time(sim) + 1`): adds 1 to `nonForest_timeSinceDisturbance` and resets pixels burned in `rstCurrentBurn` to 0. - -Write what is plotted. - -### Saving - - -Write what is saved. +The module does not plot or save anything. ### Module outputs @@ -103,8 +102,8 @@ knitr::kable(df_outputs, caption = "List of (ref:fireSense-dataPrepPredict) outp ### Links to other modules - -Describe any anticipated linkages to other modules, such as modules that supply input data or do post-hoc analysis. +Runs after *Biomass_borealDataPrep*, *fireSense_dataPrepFit*, *fireSense_IgnitionFit* and *fireSense_SpreadFit*, and supplies *fireSense_IgnitionPredict*, *fireSense_EscapePredict* and *fireSense_SpreadPredict*. +It is normally run as part of the [fireSense](https://github.com/PredictiveEcology/fireSense) module group. ### Getting help From 392740305cd6b1e1e64d2a9d9a06bd66054b6401 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 13:45:12 -0700 Subject: [PATCH 2/5] Add a verified testthat suite for the toy landscape Adds tests for `ageNonForest()`, `getCurrentClimate()`, `Init()`/`init`, `.inputObjects()` and the two covariate-assembly events, on a 4x4 toy landscape whose every covariate can be worked out by hand. The toy climate encodes both the year and the cell in its values, so an assertion on a value proves which layer of which variable was taken. 99 assertions, no skips. Verified to pass identically on `origin/development` and on this branch, run the way CI runs them (convertToPackage + test_local). Every substantive test was mutation-checked: 14 mutations of the module source, 14 detected. Five defects are recorded, none of them blessed as correct: each states the INTENDED assertion wrapped in `expect_failure()` so that fixing the defect trips the test, plus an assertion pinning the current state. - `.inputObjects` leaves `rstLCC_RTM` NULL: the `suppliedElsewhere("rstLCCs")` branch does `tail(sim$rstLCCs, 1)[[1]]`, but `rstLCCs` is not a declared input and so is absent. `Init()` then errors on `.compareRas(rtm, NULL)`, which makes the module unusable as shipped. - `.inputObjects` cannot build `flammableRTM`: `defineFlammable(rstLCC, ...)` uses a local from the other branch and a function the module does not import. - The covariate tables do not advance with simulation time: `getCurrentClimate()` only builds `currentClimateRasters` when it is NULL, so from year two on the climate is frozen at `start(sim)` while the `year` column still tracks `time(sim)` -- the table claims 2003 and carries 2001 climate. - `climateYear` does not override `time(sim)`: the inner lapply's formal `currentYear = time(sim)` shadows the outer `currentYear`. - `lightningDays` is NaN in the ignition table. - `Init()` realigns landcover with bilinear `postProcess()`, averaging categorical class codes into non-classes and silently yielding an all-NA landcoverDT. --- tests/testthat/setup-toyLandscape.R | 127 +++++++++++++++++ tests/testthat/test-ageNonForest.R | 39 ++++++ tests/testthat/test-covariates.R | 177 ++++++++++++++++++++++++ tests/testthat/test-getCurrentClimate.R | 71 ++++++++++ tests/testthat/test-init.R | 127 +++++++++++++++++ tests/testthat/test-inputObjects.R | 60 ++++++++ 6 files changed, 601 insertions(+) create mode 100644 tests/testthat/setup-toyLandscape.R create mode 100644 tests/testthat/test-ageNonForest.R create mode 100644 tests/testthat/test-covariates.R create mode 100644 tests/testthat/test-getCurrentClimate.R create mode 100644 tests/testthat/test-init.R create mode 100644 tests/testthat/test-inputObjects.R diff --git a/tests/testthat/setup-toyLandscape.R b/tests/testthat/setup-toyLandscape.R new file mode 100644 index 0000000..7a89be5 --- /dev/null +++ b/tests/testthat/setup-toyLandscape.R @@ -0,0 +1,127 @@ +## A 4 x 4 toy landscape on which every covariate can be worked out by hand. +## A setup file rather than a helper, so that it shares an environment with `moduleName` +## and `testPaths` from setup.R. +## +## Tests run inside the namespace of the package rendition; tables are handled with base +## subsetting and data.table::set() only, so nothing depends on data.table-awareness there. +## +## The module calls postProcess() and Cache() unqualified but does not list `reproducible` +## in `reqdPkgs`; in a project another module attaches it. It is always installed +## (SpaDES.core imports it), so attach it here. +suppressPackageStartupMessages(library(reproducible)) + +## Cell numbers (row-major) and what is in them: +## +## 1 2 3 4 PG1 PG1 PG2 PG2 pixel groups 1-4 are forest with cohorts +## 5 6 7 8 PG3 PG3 PG4 PG4 +## 9 10 11 12 wet wet grs grs non-forest: wetland, grass +## 13 14 15 16 --- --- wet X 13, 14: forest land cover but no cohorts +## 15: wetland burned 5 y ago; 16: not flammable +## +## PG1: Pice_mar 80 y B 2000 + Pinu_ban 40 y B 1000 -> class1 B = 3000 +## PG2: Popu_tre 50 y B 500 -> class2 B = 500 +## PG3: Pice_mar 10 y B 300 (max age 10 <= cutoff 15) -> youngAge +## PG4: Pice_mar 60 y B 100 + Popu_tre 60 y B 50 -> class1 B = 100, class2 B = 50 +toyRast <- function(vals) { + terra::rast(nrows = 4, ncols = 4, xmin = 0, xmax = 4, ymin = 0, ymax = 4, vals = vals, + crs = "EPSG:3005") +} + +toyLCC <- function() toyRast(c(rep(210, 8), 19, 19, 16, 16, 210, 210, 19, 20)) + +toyCohortData <- function() { + data.table::data.table( + pixelGroup = c(1L, 1L, 2L, 3L, 4L, 4L), + speciesCode = factor(c("Pice_mar", "Pinu_ban", "Popu_tre", "Pice_mar", "Pice_mar", "Popu_tre")), + age = c(80L, 40L, 50L, 10L, 60L, 60L), + B = c(2000L, 1000L, 500L, 300L, 100L, 50L) + ) +} + +toySppEquiv <- function() { + data.table::data.table(LandR = c("Pice_mar", "Pinu_ban", "Popu_tre"), + FuelClass = c("class1", "class1", "class2")) +} + +toyLandcoverDT <- function() { + data.table::data.table(pixelID = 1:15, + wetland = as.integer(1:15 %in% c(9, 10, 15)), + grass = as.integer(1:15 %in% c(11, 12))) +} + +## climate: layer `year` of MDC is (Y - 2000) * 100 + cell number, so both the year that +## was taken and the cell it came from can be read off any value; `Tmax` is its negative +toyClimate <- function(years = 2001:2003) { + mk <- function(sign) { + r <- terra::rast(lapply(years, function(y) toyRast(sign * ((y - 2000) * 100 + 1:16)))) + names(r) <- paste0("year", years) + r + } + list(MDC = mk(1), Tmax = mk(-1)) +} + +toyObjects <- function() { + list( + rasterToMatch = toyRast(1), + studyArea = terra::as.polygons(terra::ext(toyRast(1)), crs = "EPSG:3005"), + flammableRTM = toyRast(c(rep(1, 15), 0)), + pixelGroupMap = toyRast(c(1, 1, 2, 2, 3, 3, 4, 4, rep(NA, 8))), + cohortData = toyCohortData(), + sppEquiv = toySppEquiv(), + landcoverDT = toyLandcoverDT(), + nonForestedLCCGroups = list(wetland = 19L, grass = 16L), + missingLCCgroup = "grass", + ## years since fire: 30 everywhere except the wetland cell 15 and the forest cell 1 + nonForest_timeSinceDisturbance = toyRast(c(5, rep(30, 13), 5, 30)), + standAgeMap = toyRast(50), + ## `rstLCCs` is NOT in the metadata, so simInit() does not put it in the simList -- but + ## `suppliedElsewhere("rstLCCs", sim)` in `.inputObjects` (l.509) still sees it, which is + ## the only way to take the branch that does not try to download NTEMS landcover. The + ## branch then sets `sim$rstLCC_RTM <- tail(sim$rstLCCs, 1)[[1]]`, and since `sim$rstLCCs` + ## really is NULL by then, `sim$rstLCC_RTM` ends up NULL. See test-inputObjects.R. + ## Supplying `landcoverDT` is what keeps `Init()` from needing `rstLCC_RTM` at all. + rstLCCs = list(toyLCC()), + projectedClimateRasters = toyClimate(), + climateVariablesForFire = list(ignition = "MDC", spread = "MDC"), + lightningMaps = { + r <- c(toyRast(1:16), toyRast(1001:1016)) + names(r) <- c("lightningDays", "lightningDensity") + r + } + ) +} + +toyPrepSim <- function(objects = toyObjects(), params = list(), + times = list(start = 2001, end = 2001)) { + params <- utils::modifyList(list(igAggFactor = 2), params) + sim <- SpaDES.core::simInit( + times = c(times, timeunit = "year"), + modules = moduleName, + params = stats::setNames(list(params), moduleName), + objects = objects, + paths = testPaths + ) + ## Work around a module defect, deliberately and visibly: `.inputObjects` (l.509-510) takes + ## the `suppliedElsewhere("rstLCCs", sim)` branch -- which is the only branch that does not + ## try to download NTEMS landcover -- and sets `sim$rstLCC_RTM <- tail(sim$rstLCCs, 1)[[1]]`. + ## `rstLCCs` is not a declared input, so it is not in the simList at that point and the + ## result is NULL. `Init()` (l.241) then calls `.compareRas(rasterToMatch, NULL)`, which + ## errors with "subscript out of bounds", so the module cannot reach `init` at all. + ## Restoring it here lets the covariate tests exercise the code past that point; the defect + ## itself is pinned, unblessed, in test-inputObjects.R. + if (is.null(sim$rstLCC_RTM)) sim$rstLCC_RTM <- toyLCC() + sim +} + +toyPrepRun <- function(...) SpaDES.core::spades(toyPrepSim(...), debug = FALSE) + +## a covariate table as a data.frame ordered by pixelID +covDF <- function(dt) { + df <- as.data.frame(dt) + df[order(df$pixelID), , drop = FALSE] +} + +evOf <- function(dt, type) { + df <- as.data.frame(dt) + df[df$moduleName == "fireSense_dataPrepPredict" & df$eventType == type, , drop = FALSE] +} diff --git a/tests/testthat/test-ageNonForest.R b/tests/testthat/test-ageNonForest.R new file mode 100644 index 0000000..93279ed --- /dev/null +++ b/tests/testthat/test-ageNonForest.R @@ -0,0 +1,39 @@ +## `ageNonForest()` is the one helper in this module with no dependencies at all: it takes +## two rasters and returns one. Every value below is worked out by hand from the toy TSD. + +test_that("ageNonForest adds one year everywhere when nothing burned", { + TSD <- toyRast(c(5, rep(30, 13), 5, 30)) + out <- ageNonForest(TSD = TSD, rstCurrentBurn = NULL, timeStep = 1) + expect_s4_class(out, "SpatRaster") + ## hand-computed: every cell + 1 + expect_identical(as.vector(terra::values(out)), c(6, rep(31, 13), 6, 31)) + ## geometry must survive: the values are written back with setValues() + expect_true(terra::compareGeom(out, TSD, stopOnError = FALSE)) +}) + +test_that("ageNonForest resets burned pixels to zero and ages the rest", { + TSD <- toyRast(c(5, rep(30, 13), 5, 30)) + ## cell 2 burned (1); cell 3 is NA (no burn data, i.e. did not burn); cell 16 burned + burn <- toyRast(c(0, 1, NA, rep(0, 12), 1)) + out <- ageNonForest(TSD = TSD, rstCurrentBurn = burn, timeStep = 1) + ## hand-computed: 5+1; burned -> 0; NA is unburned so 30+1; cell 15 (TSD 5, unburned) -> 6; + ## cell 16 burned -> 0 + expect_identical(as.vector(terra::values(out)), c(6, 0, rep(31, 12), 6, 0)) +}) + +test_that("ageNonForest treats NA and 0 in rstCurrentBurn identically", { + TSD <- toyRast(rep(10, 16)) + allNA <- toyRast(rep(NA_real_, 16)) + allZero <- toyRast(rep(0, 16)) + expect_identical(as.vector(terra::values(ageNonForest(TSD, allNA, 1))), rep(11, 16)) + expect_identical(as.vector(terra::values(ageNonForest(TSD, allNA, 1))), + as.vector(terra::values(ageNonForest(TSD, allZero, 1)))) +}) + +test_that("ageNonForest ignores timeStep, as documented", { + ## `timeStep` is accepted but the raster always advances by exactly one year. Asserted so + ## that honouring it becomes a deliberate, visible change rather than a silent one. + TSD <- toyRast(rep(10, 16)) + expect_identical(as.vector(terra::values(ageNonForest(TSD, NULL, timeStep = 1))), + as.vector(terra::values(ageNonForest(TSD, NULL, timeStep = 10)))) +}) diff --git a/tests/testthat/test-covariates.R b/tests/testthat/test-covariates.R new file mode 100644 index 0000000..bb8743f --- /dev/null +++ b/tests/testthat/test-covariates.R @@ -0,0 +1,177 @@ +## The two covariate-assembly events. The structural facts -- which pixels appear, which +## climate layer and which year they carry, the column order, the non-forest columns -- are +## worked out by hand from the toy landscape. The fuel-class magnitudes come out of +## fireSenseUtils and are PINNED FROM AN OBSERVED RUN of this suite; they are identical on +## `origin/development` and on this branch (verified by running this file against both), but +## they are a regression pin on fireSenseUtils' internals, not a hand-derived truth. + +test_that("prepSpreadPredictData builds one row per flammable pixel with this year's climate", { + sim <- toyPrepRun() + df <- covDF(sim$fireSense_SpreadCovariates) + + ## the 16th toy pixel is non-flammable, so exactly 15 rows at flammableRTM resolution + expect_identical(df$pixelID, 1:15) + ## the declared column order: pixelID, the climate layers, youngAge, then the fuels + expect_identical(names(df)[1:3], c("pixelID", "MDC", "youngAge")) + expect_setequal(names(df), c("pixelID", "MDC", "youngAge", "class1", "class2", + "wetland", "grass")) + + ## hand-computed: spread climate is MDC, and toy MDC for 2001 is 100 + cellNumber, so a + ## value of 100 + pixelID proves both the right variable and the right year were taken + expect_identical(df$MDC, 100 + 1:15) + + ## hand-computed from the toy map: cells 9, 10, 15 are wetland. + expect_identical(which(df$wetland == 1L), c(9L, 10L, 15L)) + ## grass is 11 and 12 from the map, PLUS 13 and 14: those two are forested landcover (210) + ## with no cohort in `pixelGroupMap`, and `missingLCCgroup` is "grass", so the module + ## assigns them there. That is the documented behaviour of `missingLCCgroup` + ## (metadata l.106-109), not an accident, so it is asserted as correct. + expect_identical(which(df$grass == 1L), c(11L, 12L, 13L, 14L)) + + ## hand-computed: youngAge is set where max cohort age <= cutoffForYoungAge (pixel group 3, + ## cells 5 and 6, whose only cohort is 10 years old) and in non-forest pixels burned within + ## the cutoff (cell 15, TSD 5). Nowhere else. + expect_identical(which(df$youngAge == 1), c(5L, 6L, 15L)) +}) + +test_that("spread fuel classes follow the sppEquiv fuel column (pinned from origin/development)", { + ## PINNED FROM BASE: these are the values produced by + ## fireSenseUtils:::fireSenseCovariatesCreate() on origin/development. They are recorded so + ## that a change in how biomass is mapped to fuel classes is visible here rather than + ## downstream in a fitted model. + sim <- toyPrepRun() + df <- covDF(sim$fireSense_SpreadCovariates) + expect_equal(df$class1[1:4], c(8.006368, 8.006368, 3.605170, 3.605170), tolerance = 1e-6) + expect_equal(df$class2[1:4], c(3.605170, 3.605170, 6.214608, 6.214608), tolerance = 1e-6) + ## structural, hand-checked, and independent of the pinning: pixel group 1 (cells 1-2) is + ## the only group with two class1 cohorts, so it must carry the largest class1 value, and + ## pixel group 2 (cells 3-4) is pure class2, so its class2 must exceed pixel group 1's + expect_true(all(df$class1[1:2] > df$class1[3:4])) + expect_true(all(df$class2[3:4] > df$class2[1:2])) + ## a forested pixel with no cohorts (13, 14) gets the baseline, not NA + expect_false(anyNA(df$class1)) + expect_false(anyNA(df$class2)) +}) + +test_that("non-forest pixels never carry forest fuel (the module's own sanity check)", { + sim <- toyPrepRun() + df <- covDF(sim$fireSense_SpreadCovariates) + nonForest <- df$wetland == 1L | df$grass == 1L + baseline <- min(df$class1) + expect_true(all(df$class1[nonForest] == baseline)) + expect_true(all(df$class2[nonForest] == min(df$class2))) +}) + +test_that("prepIgAndEscPredictData aggregates to the igAggFactor grid", { + sim <- toyPrepRun() + df <- covDF(sim$fireSense_igAndEscapePred_Covariates) + + ## igAggFactor 2 over a 4 x 4 grid gives a 2 x 2 grid, i.e. four coarse cells; the fourth + ## contains the non-flammable pixel 16 and drops out, leaving three rows + expect_identical(df$pixelID, 1:3) + ## the year column carries time(sim), not the layer index + expect_identical(unique(df$year), 2001) + expect_setequal(names(df), c("pixelID", "MDC", "youngAge", "wetland", "grass", + "class1", "class2", "year", "lightningDays")) + ## `ignitions` belongs to the Fit table and is dropped here + expect_false("ignitions" %in% names(df)) + + ## hand-computed: coarse cell 1 is fine cells 1, 2, 5, 6, whose MDC is 101, 102, 105, 106, + ## mean 103.5; coarse cell 2 is 3, 4, 7, 8 -> 105.5; coarse cell 3 is 9, 10, 13, 14 -> 111.5 + expect_equal(df$MDC, c(103.5, 105.5, 111.5)) + ## hand-computed: youngAge is the mean over the coarse cell; cells 5 and 6 of four are + ## young in coarse cell 1 -> 0.5; none in coarse cell 2; none in coarse cell 3 (cell 15 is + ## in coarse cell 4, which is dropped) + expect_equal(df$youngAge, c(0.5, 0, 0)) + ## hand-computed: coarse cell 3 covers wetlands 9, 10 and grasses 11? no -- fine cells + ## 9, 10, 13, 14: 9 and 10 are wetland -> 0.5 wetland + expect_equal(df$wetland, c(0, 0, 0.5)) +}) + +test_that("igAggFactor 1 leaves the ignition covariates at flammableRTM resolution", { + sim <- toyPrepRun(params = list(igAggFactor = 1)) + df <- covDF(sim$fireSense_igAndEscapePred_Covariates) + ## no aggregation: the same 15 flammable pixels as the spread table, with the same climate + expect_identical(df$pixelID, 1:15) + expect_equal(df$MDC, 100 + 1:15) + expect_identical(which(df$wetland == 1), c(9L, 10L, 15L)) +}) + +test_that("a different ignition climate variable selects a different layer", { + ## Tmax is the negative of MDC in the toy climate, so the sign of the aggregated value + ## alone proves which variable the ignition table used. + objs <- toyObjects() + objs$climateVariablesForFire <- list(ignition = "Tmax", spread = "MDC") + sim <- toyPrepRun(objs) + ig <- covDF(sim$fireSense_igAndEscapePred_Covariates) + sp <- covDF(sim$fireSense_SpreadCovariates) + expect_true("Tmax" %in% names(ig)) + expect_false("MDC" %in% names(ig)) + expect_equal(ig$Tmax, c(-103.5, -105.5, -111.5)) + ## and the spread table is unaffected + expect_identical(sp$MDC, 100 + 1:15) +}) + +test_that("a climate variable that is not in currentClimateRasters is an error", { + objs <- toyObjects() + objs$climateVariablesForFire <- list(ignition = "notAVariable", spread = "MDC") + ## terra's own subsetting rejects it before the module's NULL guard can fire; asserted as + ## an error with a message, so that silently returning an empty table would fail here + expect_error(toyPrepRun(objs), "invalid name") +}) + +test_that("KNOWN BUG: the covariate tables do NOT advance with simulation time", { + ## Intended behaviour: each year's covariates carry that year's climate. They do not. + ## `getCurrentClimate()` (module source l.296) only builds `sim$currentClimateRasters` when + ## it `is.null()`. The `getClimateRasters` event reschedules itself every year, but from the + ## second year on the object is already populated, so the whole build is skipped and the + ## climate stays frozen at `start(sim)`. Every later year's covariates are silently stale. + ## + ## The toy climate encodes the year in the value (year MDC cell n = (Y-2000)*100 + n), + ## so this is unambiguous: after running 2001 -> 2003 the table still holds year2001 values. + ## Below, the INTENDED assertions are stated and recorded as currently failing. When the + ## staleness is fixed, `expect_failure()` will itself fail and these must be unwrapped. + sim <- toyPrepRun(times = list(start = 2001, end = 2003)) + sp <- covDF(sim$fireSense_SpreadCovariates) + ig <- covDF(sim$fireSense_igAndEscapePred_Covariates) + + ## INTENDED: the final year is 2003, so MDC should be 300 + pixelID + expect_failure(expect_identical(sp$MDC, 300 + 1:15)) + expect_failure(expect_equal(ig$MDC, c(303.5, 305.5, 311.5))) + + ## What actually happens, recorded so the staleness is visible and the fix is detectable: + ## the year2001 layer, unchanged after three simulated years. + expect_identical(sp$MDC, 100 + 1:15) + + ## and the giveaway that this really is staleness rather than a mislabelled table: the + ## `year` column DOES track time(sim), so the table claims 2003 while carrying 2001 climate + expect_identical(unique(ig$year), 2003) +}) + +test_that("KNOWN BUG: lightningDays is NaN in the ignition table", { + ## `lightningMaps` is supplied with a `lightningDays` layer holding 1:16, so the aggregated + ## mean over each 2 x 2 coarse cell is finite and easily computed by hand (5.5, 7.5, 13.5). + ## What comes back is NaN for every row. The layer is selected correctly -- single-bracket + ## `sim$lightningMaps["lightningDays"]` (module source l.416) returns the right one-layer + ## raster with the right values, checked directly -- so the loss happens inside + ## `fireSenseUtils::mergePreparedCovs()`. Not diagnosed further here. + ## + ## The INTENDED assertion is stated and recorded as failing. This test does NOT assert that + ## NaN is correct; it asserts that the column is present and that the intended value is not + ## yet produced. + sim <- toyPrepRun() + ig <- covDF(sim$fireSense_igAndEscapePred_Covariates) + expect_true("lightningDays" %in% names(ig)) + ## INTENDED: the mean of the fine-cell lightningDays over each coarse cell + expect_failure(expect_equal(ig$lightningDays, c(5.5, 7.5, 13.5))) + ## recorded actual state, so that producing ANY finite value here will trip this test + expect_true(all(is.nan(ig$lightningDays))) +}) + +test_that("ageNonForest runs as an event and ages the TSD raster each year", { + sim <- toyPrepRun(times = list(start = 2001, end = 2002)) + ## hand-computed: the toy TSD starts at c(5, 30 x 13, 5, 30) and the event fires once, + ## at 2002, with no rstCurrentBurn supplied + expect_identical(as.vector(terra::values(sim$nonForest_timeSinceDisturbance)), + c(6, rep(31, 13), 6, 31)) +}) diff --git a/tests/testthat/test-getCurrentClimate.R b/tests/testthat/test-getCurrentClimate.R new file mode 100644 index 0000000..878f9fb --- /dev/null +++ b/tests/testthat/test-getCurrentClimate.R @@ -0,0 +1,71 @@ +## `getCurrentClimate()` picks this year's layer out of each element of +## `projectedClimateRasters`. The toy climate encodes both the year and the cell in the +## value -- layer `year` of MDC holds `(Y - 2000) * 100 + cellNumber` -- so an assertion +## on a value proves exactly which layer of which variable was taken. + +test_that("getCurrentClimate takes the layer for time(sim), one per climate variable", { + sim <- toyPrepSim(times = list(start = 2002, end = 2002)) + sim <- getCurrentClimate(sim) + + ## one layer per element of projectedClimateRasters, named for the variable not the year + expect_identical(names(sim$currentClimateRasters), c("MDC", "Tmax")) + ## hand-computed from the toy encoding: year2002 MDC cell n = 200 + n; Tmax is its negative + expect_identical(as.vector(terra::values(sim$currentClimateRasters[["MDC"]])), 200 + 1:16) + expect_identical(as.vector(terra::values(sim$currentClimateRasters[["Tmax"]])), -(200 + 1:16)) +}) + +test_that("getCurrentClimate leaves a supplied currentClimateRasters untouched", { + objs <- toyObjects() + ## a raster that matches pixelGroupMap's geometry but holds a value no toy year produces + objs$currentClimateRasters <- toyRast(rep(999, 16)) + names(objs$currentClimateRasters) <- "MDC" + sim <- toyPrepSim(objs, times = list(start = 2002, end = 2002)) + sim <- getCurrentClimate(sim) + expect_identical(names(sim$currentClimateRasters), "MDC") + expect_identical(as.vector(terra::values(sim$currentClimateRasters)), rep(999, 16)) +}) + +test_that("getCurrentClimate errors when the climate does not match pixelGroupMap", { + objs <- toyObjects() + ## a 2 x 2 pixelGroupMap over the same extent: same extent and CRS, different resolution + objs$pixelGroupMap <- terra::rast(nrows = 2, ncols = 2, xmin = 0, xmax = 4, + ymin = 0, ymax = 4, vals = 1, crs = "EPSG:3005") + sim <- toyPrepSim(objs) + expect_error(getCurrentClimate(sim), "mismatch in resolution detected") +}) + +test_that("getCurrentClimate errors on a supplied currentClimateRasters of the wrong geometry", { + ## the second compareGeom() guard, on the branch where nothing is built + objs <- toyObjects() + objs$currentClimateRasters <- terra::rast(nrows = 2, ncols = 2, xmin = 0, xmax = 4, + ymin = 0, ymax = 4, vals = 1, crs = "EPSG:3005") + sim <- toyPrepSim(objs) + expect_error(getCurrentClimate(sim), "mismatch in resolution detected") +}) + +test_that("getCurrentClimate messages when the requested year is beyond the projection", { + ## toy climate covers 2001-2003; asking for 2005 must warn the user that a layer is reused + objs <- toyObjects() + objs$projectedClimateRasters <- toyClimate(2001:2003) + sim <- toyPrepSim(objs, times = list(start = 2005, end = 2005)) + expect_message(try(getCurrentClimate(sim), silent = TRUE), + "re-using projected climate layers from") +}) + +test_that("KNOWN BUG: climateYear does not override time(sim) for layer selection", { + ## Intended behaviour (module source, ~lines 314-318): `currentYear` is `sim$climateYear` + ## when supplied, and `currentYear` chooses the climate layer. It does not: the inner + ## lapply's formal `currentYear = time(sim)` shadows the outer `currentYear`, so the layer + ## is always `year` and `climateYear` only reaches the "beyond the projection" + ## message. This test states the INTENDED assertion and records that it currently fails; + ## when the shadowing is fixed, `expect_failure()` will itself fail and this test must be + ## unwrapped. It deliberately does not assert that the present behaviour is correct. + objs <- toyObjects() + objs$climateYear <- 2003 + sim <- toyPrepSim(objs, times = list(start = 2001, end = 2001)) + sim <- getCurrentClimate(sim) + expect_failure( + ## year2003 MDC cell n = 300 + n; what is actually returned is year2001, i.e. 100 + n + expect_identical(as.vector(terra::values(sim$currentClimateRasters[["MDC"]])), 300 + 1:16) + ) +}) diff --git a/tests/testthat/test-init.R b/tests/testthat/test-init.R new file mode 100644 index 0000000..ac05785 --- /dev/null +++ b/tests/testthat/test-init.R @@ -0,0 +1,127 @@ +## `Init()` and the `init` event: what gets built, and what gets scheduled. + +test_that("init produces every declared output on the toy landscape", { + sim <- toyPrepRun() + md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) + for (obj in md$outputObjects$objectName) { + expect_false(is.null(sim[[obj]]), info = obj) + } + expect_s4_class(sim$currentClimateRasters, "SpatRaster") + expect_s4_class(sim$nonForest_timeSinceDisturbance, "SpatRaster") + expect_s3_class(sim$fireSense_igAndEscapePred_Covariates, "data.table") + expect_s3_class(sim$fireSense_SpreadCovariates, "data.table") +}) + +test_that("Init expands a length-one climateVariablesForFire to ignition and spread", { + objs <- toyObjects() + objs$climateVariablesForFire <- list("MDC") + sim <- SpaDES.core::spades(toyPrepSim(objs), events = "init", debug = FALSE) + expect_identical(sim$climateVariablesForFire, list(ignition = list("MDC"), spread = list("MDC"))) +}) + +test_that("Init leaves a two-element climateVariablesForFire alone", { + objs <- toyObjects() + objs$climateVariablesForFire <- list(ignition = "Tmax", spread = "MDC") + sim <- SpaDES.core::spades(toyPrepSim(objs), events = "init", debug = FALSE) + expect_identical(sim$climateVariablesForFire, list(ignition = "Tmax", spread = "MDC")) +}) + +test_that("Init builds landcoverDT from rstLCC_RTM when it is not supplied", { + ## toy land cover: cells 9, 10, 15 are wetland (19), cells 11, 12 are grass (16), + ## cells 1-8, 13, 14 are forest (210) and cell 16 is class 20, which is non-flammable + ## in flammableRTM, so it is dropped. Every value below follows from that map. + ## + ## `rstLCC_RTM` is set directly on the simList rather than passed to `simInit()`, because + ## `.inputObjects` destroys any supplied value (see test-inputObjects.R). Calling `Init()` + ## directly keeps this test about `Init()`'s landcover logic rather than about that defect. + ## `landcoverDT` must still be supplied to `simInit()`: without it `.inputObjects` (l.552) + ## calls `makeLandcoverDT()` with the NULL `rstLCC_RTM` and errors before `Init()` is + ## reached. It is cleared afterwards so that `Init()` is the thing that builds it. + sim <- toyPrepSim(toyObjects()) + sim$landcoverDT <- NULL + sim <- SpaDES.core::spades(sim, events = "init", debug = FALSE) + dt <- covDF(sim$landcoverDT) + expect_identical(sort(names(dt)), c("grass", "pixelID", "wetland")) + ## only the 15 flammable pixels, in cell order + expect_identical(dt$pixelID, 1:15) + expect_identical(which(dt$wetland == 1L), c(9L, 10L, 15L)) + expect_identical(which(dt$grass == 1L), c(11L, 12L)) + ## no pixel is in two groups at once + expect_true(all(dt$wetland + dt$grass <= 1L)) +}) + +test_that("KNOWN BUG: Init resamples landcover continuously, destroying the class codes", { + ## `Init()` (l.241-245) realigns `rstLCC_RTM` with `postProcess(..., to = rasterToMatch)` + ## when the geometries differ. `postProcess()` defaults to bilinear resampling, which is + ## wrong for a *categorical* raster: averaging class codes 19, 16, 210 and 20 produces + ## values like 186.08 and 43.91, which are not landcover classes at all. `makeLandcoverDT()` + ## then matches none of them, so every non-forest column comes back NA -- silently, with + ## the right number of rows and the right column names. + ## + ## Verified directly: postProcess(disagg(toyLCC(), 2), to = rasterToMatch) returns + ## c(210, 210, 210, 210, 186.125, ...) rather than the original integer codes. + ## The fix is nearest-neighbour (`method = "near"`), as `disagg()` uses here. + ## + ## INTENDED: realigning a land-cover map that merely differs in resolution must give the + ## same landcoverDT as the aligned one. Stated and recorded as failing. + sim <- toyPrepSim(toyObjects()) + sim$landcoverDT <- NULL + sim$rstLCC_RTM <- terra::disagg(toyLCC(), fact = 2, method = "near") + sim <- SpaDES.core::spades(sim, events = "init", debug = FALSE) + dt <- covDF(sim$landcoverDT) + + ## the shape is right, which is what makes this dangerous + expect_identical(dt$pixelID, 1:15) + expect_identical(sort(names(dt)), c("grass", "pixelID", "wetland")) + + ## INTENDED: the same groups as the matching-resolution case above + expect_failure(expect_identical(which(dt$wetland == 1L), c(9L, 10L, 15L))) + expect_failure(expect_identical(which(dt$grass == 1L), c(11L, 12L))) + + ## recorded actual state: the classes are gone entirely + expect_true(all(is.na(dt$wetland))) + expect_true(all(is.na(dt$grass))) +}) + +test_that("init schedules exactly the events implied by whichModulesToPrepare", { + evs <- function(which) { + sim <- SpaDES.core::spades( + toyPrepSim(params = list(whichModulesToPrepare = which)), events = "init", debug = FALSE) + sort(as.data.frame(SpaDES.core::events(sim))$eventType) + } + ## ageNonForest and getClimateRasters are unconditional; the two prep events are not + expect_identical(evs("fireSense_SpreadPredict"), + c("ageNonForest", "getClimateRasters", "prepSpreadPredictData")) + expect_identical(evs("fireSense_IgnitionPredict"), + c("ageNonForest", "getClimateRasters", "prepIgAndEscPredictData")) + ## the ignition/escape table is shared: EscapePredict alone schedules it too + expect_identical(evs("fireSense_EscapePredict"), + c("ageNonForest", "getClimateRasters", "prepIgAndEscPredictData")) + expect_identical(evs(c("fireSense_SpreadPredict", "fireSense_IgnitionPredict")), + c("ageNonForest", "getClimateRasters", "prepIgAndEscPredictData", + "prepSpreadPredictData")) + ## a Fit module name is not a Predict module name: no covariate table is prepared + expect_identical(evs("fireSense_EscapeFit"), c("ageNonForest", "getClimateRasters")) +}) + +test_that("KNOWN BUG: the default whichModulesToPrepare prepares no escape covariates", { + ## The shipped default includes `fireSense_EscapeFit`, but `doEvent` tests for + ## `fireSense_EscapePredict`; the owner's decision is that the default should be + ## `fireSense_dataPrepPredict`'s own Predict trio. Either way the default is wrong, so this + ## records the INTENDED assertion -- that the default contains only Predict module names -- + ## as a currently-failing expectation rather than blessing the shipped value. + md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) + default <- md$parameters$default[[which(md$parameters$paramName == "whichModulesToPrepare")]] + expect_failure(expect_true(all(grepl("Predict$", default)))) + ## the offending element, named so the fix is unambiguous + expect_true("fireSense_EscapeFit" %in% default) +}) + +test_that("events reschedule themselves one fireTimeStep ahead", { + sim <- toyPrepRun(times = list(start = 2001, end = 2001)) + queued <- as.data.frame(SpaDES.core::events(sim)) + expect_setequal(queued$eventType, + c("ageNonForest", "getClimateRasters", + "prepIgAndEscPredictData", "prepSpreadPredictData")) + expect_identical(unique(queued$eventTime), 2002) +}) diff --git a/tests/testthat/test-inputObjects.R b/tests/testthat/test-inputObjects.R new file mode 100644 index 0000000..5247ecf --- /dev/null +++ b/tests/testthat/test-inputObjects.R @@ -0,0 +1,60 @@ +## `.inputObjects()` supplies defaults. Two of its branches are broken in ways that make the +## module unusable without a workaround, so they are pinned here -- as recorded defects, not +## as correct behaviour -- to make a fix detectable. + +test_that("KNOWN BUG: .inputObjects leaves rstLCC_RTM NULL, so Init() cannot run", { + ## `.inputObjects` (module source l.509-510) branches on `suppliedElsewhere("rstLCCs", sim)`. + ## That branch is the only one that does not try to download NTEMS landcover, but it does + ## `sim$rstLCC_RTM <- tail(sim$rstLCCs, 1)[[1]]`, and `rstLCCs` is not a declared input + ## (it is absent from `inputObjects`, l.89-147), so it is not in the simList when + ## `.inputObjects` runs. `tail(NULL, 1)[[1]]` is NULL, so `rstLCC_RTM` is left NULL. + ## + ## INTENDED: taking the `rstLCCs` branch should produce a usable `rstLCC_RTM`. + ## Stated and recorded as failing. This does not assert that NULL is correct. + objs <- toyObjects() # supplies rstLCCs, does not supply rstLCC_RTM + sim <- SpaDES.core::simInit( + times = list(start = 2001, end = 2001, timeunit = "year"), + modules = moduleName, + params = stats::setNames(list(list(igAggFactor = 2)), moduleName), + objects = objs, + paths = testPaths + ) + expect_failure(expect_s4_class(sim$rstLCC_RTM, "SpatRaster")) + ## recorded actual state + expect_null(sim$rstLCC_RTM) + + ## and the consequence: `Init()` calls `.compareRas(rasterToMatch, rstLCC_RTM)` at l.241, + ## which errors on NULL, so the `init` event cannot complete and the module is unusable as + ## shipped. This is why `toyPrepSim()` restores `rstLCC_RTM` after `simInit()` for every + ## other test in this suite. + expect_error(SpaDES.core::spades(sim, events = "init", debug = FALSE), + "subscript out of bounds") +}) + +test_that("KNOWN BUG: .inputObjects cannot build flammableRTM when it is not supplied", { + ## `.inputObjects` l.546 calls `defineFlammable(rstLCC, ...)`. `rstLCC` is a local created + ## only in the *other* branch (l.512), and `defineFlammable` is not imported by the module, + ## so with `rstLCCs` supplied and `flammableRTM` absent this is a guaranteed error. + ## The correct construction exists in `Init()` (~l.241-253). Recorded, not fixed here. + objs <- toyObjects() + objs$flammableRTM <- NULL + objs$landcoverDT <- NULL + expect_error( + SpaDES.core::simInit( + times = list(start = 2001, end = 2001, timeunit = "year"), + modules = moduleName, + params = stats::setNames(list(list(igAggFactor = 2)), moduleName), + objects = objs, + paths = testPaths + ), + "defineFlammable|could not find function|object 'rstLCC' not found" + ) +}) + +test_that(".inputObjects supplies the default climateVariablesForFire", { + ## the one branch of `.inputObjects` that works as documented (l.502-507) + objs <- toyObjects() + objs$climateVariablesForFire <- NULL + sim <- toyPrepSim(objs) + expect_identical(sim$climateVariablesForFire, list(spread = "MDC", ignition = "MDC")) +}) From 4a2ae04962a965a9d53c401cba293cc564d837c3 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 13:55:54 -0700 Subject: [PATCH 3/5] Label the fuel-class pins accurately They are pinned observations of fireSenseUtils internals, identical on origin/development and on this branch, not hand-derived truths. --- tests/testthat/test-covariates.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-covariates.R b/tests/testthat/test-covariates.R index bb8743f..1b401e9 100644 --- a/tests/testthat/test-covariates.R +++ b/tests/testthat/test-covariates.R @@ -34,11 +34,14 @@ test_that("prepSpreadPredictData builds one row per flammable pixel with this ye expect_identical(which(df$youngAge == 1), c(5L, 6L, 15L)) }) -test_that("spread fuel classes follow the sppEquiv fuel column (pinned from origin/development)", { - ## PINNED FROM BASE: these are the values produced by - ## fireSenseUtils:::fireSenseCovariatesCreate() on origin/development. They are recorded so - ## that a change in how biomass is mapped to fuel classes is visible here rather than - ## downstream in a fitted model. +test_that("spread fuel classes follow the sppEquiv fuel column (regression pin)", { + ## REGRESSION PIN: these are the values observed from + ## fireSenseUtils:::fireSenseCovariatesCreate() when this suite was written. They are + ## identical on origin/development and on this branch (verified by running this file + ## against both), but they are pinned observations of that package's internals, NOT + ## hand-derived truths: only the structural assertions below are hand-checked. They are + ## recorded so that a change in how biomass is mapped to fuel classes is visible here + ## rather than downstream in a fitted model. sim <- toyPrepRun() df <- covDF(sim$fireSense_SpreadCovariates) expect_equal(df$class1[1:4], c(8.006368, 8.006368, 3.605170, 3.605170), tolerance = 1e-6) From 3ac62281faf5e726bc1795c1807b93a56e023b47 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 17:12:27 -0700 Subject: [PATCH 4/5] Fix climateYear shadowing, stale climate rasters, categorical resampling, rstLCC setup A. getCurrentClimate(): the inner lapply FUN had a `currentYear = time(sim)` formal that shadowed the outer binding, so sim$climateYear never had any effect. Removed the formal so the outer value is used. `climateYear` is compared numerically, so its declared metadata class is now "numeric". B. getCurrentClimate(): the build was guarded by `is.null(sim$currentClimateRasters)`, but currentClimateRasters is also a declared OUTPUT, so it persisted and the block ran only once: every year after the first silently used year-one climate. The guard is now keyed on the year (mod$currentClimateYear), preserving the within-year caching. C. Init(): postProcess(rstLCC_RTM, to = rasterToMatch) used the bilinear default on a CATEGORICAL landcover raster, producing invented classes and an all-NA landcoverDT. Now method = "near". D. .inputObjects(): `rstLCCs` was branched on but not declared as an input, so a user-supplied rstLCCs was NULL in the simList; it is now a declared input and the branch is guarded by !suppliedElsewhere("rstLCC_RTM"). The makeFireSenseLCC() call used studyArea=/rasterToMatch=, which the installed signature rejects; now maskTo=/to=. defineFlammable() referenced a local `rstLCC` bound only in the other branch; it now derives the raster from sim$rstLCC_RTM the same way Init() does. Regression tests for each: tests/testthat/test-getCurrentClimate.R, test-realignCategorical.R, test-inputObjectsRstLCC.R, with a shared helper-toyPredict.R of in-memory terra/data.table inputs (no network). --- fireSense_dataPrepPredict.R | 55 ++++++++++----- tests/testthat/helper-toyPredict.R | 89 ++++++++++++++++++++++++ tests/testthat/test-getCurrentClimate.R | 56 +++++++++++++++ tests/testthat/test-inputObjectsRstLCC.R | 26 +++++++ tests/testthat/test-metadata.R | 3 +- tests/testthat/test-realignCategorical.R | 19 +++++ 6 files changed, 229 insertions(+), 19 deletions(-) create mode 100644 tests/testthat/helper-toyPredict.R create mode 100644 tests/testthat/test-getCurrentClimate.R create mode 100644 tests/testthat/test-inputObjectsRstLCC.R create mode 100644 tests/testthat/test-realignCategorical.R diff --git a/fireSense_dataPrepPredict.R b/fireSense_dataPrepPredict.R index c16d46a..c6ba9d2 100644 --- a/fireSense_dataPrepPredict.R +++ b/fireSense_dataPrepPredict.R @@ -8,7 +8,7 @@ defineModule(sim, list( person("Alex M", "Chubaty", role = "ctb", email = "achubaty@for-cast.ca") ), childModules = character(0), - version = list(fireSense_dataPrepPredict = "1.0.2.9000"), + version = list(fireSense_dataPrepPredict = "1.0.3.9000"), timeframe = as.POSIXlt(c(NA, NA)), timeunit = "year", citation = list("citation.bib"), @@ -89,8 +89,8 @@ defineModule(sim, list( "A list detailing which climate variables in `sim$projectedClimateRasters`", "to use for which fire processes (ignition and spread). If the list is length one,", "both processes will use the same variables. The default is to use 'MDC'.")), - expectsInput("climateYear", "character", - paste("optional character vector giving year (e.g. 'year2009') for preparing", + expectsInput("climateYear", "numeric", + paste("optional numeric year (e.g. 2009) for preparing", "the `currentClimateRasters` object. If unsupplied, `time(sim)` is used.", "see PredictiveEcology/climateYear")), expectsInput("currentClimateRasters", "SpatRaster", NA, @@ -124,6 +124,9 @@ defineModule(sim, list( "template raster used only to derive `flammableRTM` if the latter is absent"), expectsInput("rstCurrentBurn", "SpatRaster", "binary raster with 1 representing annual burn"), expectsInput("rstLCC_RTM", "SpatRaster", "a landcover raster - only used if `landcoverDT` is not supplied"), + expectsInput("rstLCCs", "list", NA, paste( + "optional named list of landcover `SpatRaster`s, one per data year, as produced by", + "`fireSense_dataPrepFit`. If supplied, the last element is used as `rstLCC_RTM`.")), expectsInput("sppEquiv", "data.table", "table of LandR species equivalencies"), # expectsInput("standAgeMaps", "list", sourceURL = NA, # "list of length 2 of maps of stand age in dataYear[[1]] and dataYear[[2]]", @@ -235,7 +238,8 @@ Init <- function(sim) { } rstLCC <- if (!LandR::.compareRas(sim$rasterToMatch, sim$rstLCC_RTM, stopOnError = FALSE)) { - postProcess(sim$rstLCC_RTM, to = sim$rasterToMatch) + ## landcover is categorical: nearest-neighbour, never the bilinear default + reproducible::postProcess(sim$rstLCC_RTM, to = sim$rasterToMatch, method = "near") } else { sim$rstLCC_RTM } @@ -298,7 +302,20 @@ Init <- function(sim) { getCurrentClimate <- function(sim) { ## this function has been rewritten due to an undiagnosed bug involving ## digest of a file-backed SpatRaster, and restartSpades() - if (is.null(sim$currentClimateRasters)) { + ## The climate year actually wanted for this event: `sim$climateYear`, when supplied, + ## overrides simulation time (see PredictiveEcology/climateYear). + if (is.null(sim$climateYear)) { + currentYear <- time(sim) + } else { + currentYear <- as.numeric(sim$climateYear) + } + currentYear <- as.numeric(currentYear) # drop time(sim)'s "unit" attribute + + ## Key the cache on the year, not on `is.null()`: `currentClimateRasters` is also a + ## module output, so it persists between years; an `is.null()` guard builds it once and + ## then silently serves stale layers for the rest of the run. + if (is.null(sim$currentClimateRasters) || + !isTRUE(mod$currentClimateYear == currentYear)) { sim$currentClimateRasters <- sim$projectedClimateRasters[[1]] if (!compareGeom(sim$pixelGroupMap, sim$currentClimateRasters, stopOnError = FALSE)) { @@ -311,12 +328,6 @@ getCurrentClimate <- function(sim) { )) - if (is.null(sim$climateYear)) { - currentYear <- time(sim) - } else { - currentYear <- sim$climateYear - } - if (currentYear > max(availableYears)) { cutoff <- quantile(availableYears, probs = 0.9) time <- sample(availableYears[availableYears >= cutoff], size = 1) @@ -324,7 +335,7 @@ getCurrentClimate <- function(sim) { } ## this will work with a list of raster stacks thisYearsClimate <- lapply(sim$projectedClimateRasters, - FUN = function(x, rtm = sim$rasterToMatch, currentYear = time(sim)) { + FUN = function(x, rtm = sim$rasterToMatch) { ras <- x[[paste0("year", currentYear)]] if (!compareGeom(ras, rtm, stopOnError = FALSE)) { message("reprojecting fireSense climate layers") @@ -335,6 +346,7 @@ getCurrentClimate <- function(sim) { ) sim$currentClimateRasters <- terra::rast(thisYearsClimate)#lapply(thisYearsClimate, terra::wrap) + mod$currentClimateYear <- currentYear } if (!compareGeom(sim$pixelGroupMap, sim$currentClimateRasters, stopOnError = FALSE)) { @@ -667,7 +679,7 @@ prepare_SpreadPredict <- function(sim) { ) } - # if (!suppliedElsewhere("rstLCC", sim)) { + if (!suppliedElsewhere("rstLCC_RTM", sim)) { if (suppliedElsewhere("rstLCCs", sim)) { sim$rstLCC_RTM <- tail(sim$rstLCCs, 1)[[1]] } else { @@ -678,8 +690,8 @@ prepare_SpreadPredict <- function(sim) { paste0(P(sim)$dataYear, "_", P(sim)$.studyAreaName) ), destinationPath = inputPath(sim), - studyArea = sim$studyArea, - rasterToMatch = sim$rasterToMatch, + maskTo = sim$studyArea, + to = sim$rasterToMatch, overwrite= TRUE, nonflammableLCC = P(sim)$nonflammableLCC, flammabilityThreshold = P(sim)$flammabilityThreshold, @@ -688,8 +700,7 @@ prepare_SpreadPredict <- function(sim) { sim$rstLCC_RTM <- rstLCC$lcc sim$propFlammable <- rstLCC$flammableProp } - - # } + } if (!suppliedElsewhere("standAgeMap", sim)) { # if (suppliedElsewhere("standAgeMaps", sim)) { @@ -711,7 +722,15 @@ prepare_SpreadPredict <- function(sim) { } if (!suppliedElsewhere("flammableRTM", sim)) { - sim$flammableRTM <- defineFlammable(rstLCC, + ## `rstLCC` only exists when the landcover was built above; otherwise derive it from + ## `rstLCC_RTM`, the same way `Init()` does. + rstLCCforFlammable <- if (!LandR::.compareRas(sim$rasterToMatch, sim$rstLCC_RTM, + stopOnError = FALSE)) { + reproducible::postProcess(sim$rstLCC_RTM, to = sim$rasterToMatch, method = "near") + } else { + sim$rstLCC_RTM + } + sim$flammableRTM <- LandR::defineFlammable(rstLCCforFlammable, nonFlammClasses = P(sim)$nonflammableLCC, to = sim$rasterToMatch) diff --git a/tests/testthat/helper-toyPredict.R b/tests/testthat/helper-toyPredict.R new file mode 100644 index 0000000..15947d7 --- /dev/null +++ b/tests/testthat/helper-toyPredict.R @@ -0,0 +1,89 @@ +## A tiny in-memory landscape for the event-level tests. Nothing is downloaded: every input the +## module's `.inputObjects()` would otherwise build is supplied, so the guards there short-circuit. +## +## 4 x 4 pixels of 250 m. Landcover is categorical (210 forest, 20 water, 50 herb), which is the +## point of the `method = "near"` test. Climate is one MDC stack whose `year` layer is +## constant at (yyyy - 1900), so a wrong year is visible in the values. + +toyCRSp <- "EPSG:3978" + +## setup.R's `moduleName`/`testPaths` are not in scope for helpers, so resolve them here. +toyModuleName <- "fireSense_dataPrepPredict" + +toyRastP <- function(vals, nam = "layer", n = 4) { + r <- terra::rast(nrows = n, ncols = n, xmin = 0, xmax = 1000, ymin = 0, ymax = 1000, + crs = toyCRSp) + r <- terra::setValues(r, vals) + names(r) <- nam + r +} + +toyLCCvalsP <- function() rep(c(210L, 210L, 50L, 20L), times = 4) + +## MDC stack: layer "year2001" is 101 everywhere, "year2002" is 102, ... +toyClimateP <- function(years = 2001:2005) { + lyrs <- lapply(years, function(y) toyRastP(rep(y - 1900, 16), paste0("year", y))) + list(MDC = terra::rast(lyrs)) +} + +toyInputsP <- function(...) { + rtm <- toyRastP(rep(1L, 16), "rtm") + lcc <- toyRastP(toyLCCvalsP(), "lcc") + out <- list( + climateVariablesForFire = list(ignition = "MDC", spread = "MDC"), + projectedClimateRasters = toyClimateP(), + pixelGroupMap = toyRastP(rep(1L, 16), "pixelGroup"), + rasterToMatch = rtm, + rstLCC_RTM = lcc, + ## supplying rstLCCs takes the `suppliedElsewhere("rstLCCs", ...)` branch of + ## .inputObjects(), so nothing is downloaded + rstLCCs = list(year2001 = lcc), + flammableRTM = toyRastP(as.integer(toyLCCvalsP() != 20L), "flammable"), + standAgeMap = toyRastP(rep(80L, 16), "standAge"), + nonForest_timeSinceDisturbance = toyRastP(rep(30L, 16), "TSD"), + nonForestedLCCGroups = list(herb = 50L), + sppEquiv = data.table::data.table(LandR = "Pice_mar", FuelClass = "BlkSprc"), + cohortData = data.table::data.table(pixelGroup = 1L, + speciesCode = factor("Pice_mar"), + age = 80L, B = 3000L) + ) + utils::modifyList(out, list(...)) +} + +toyParamsP <- function(...) { + utils::modifyList(list(whichModulesToPrepare = character(0), + dataYear = 2001, + .useCache = FALSE), list(...)) +} + +toyPathsP <- function() { + root <- withr::local_tempdir(.local_envir = parent.frame()) + mp <- dirname(normalizePath(file.path("..", ".."), winslash = "/", mustWork = TRUE)) + list(cachePath = file.path(root, "cache"), inputPath = file.path(root, "inputs"), + modulePath = mp, outputPath = file.path(root, "outputs")) +} + +toySimInitP <- function(objects = toyInputsP(), params = toyParamsP(), + start = 2001, end = 2003) { + withr::local_options(spades.useRequire = FALSE, spades.moduleCodeChecks = FALSE, + reproducible.verbose = -2) + suppressMessages(SpaDES.core::simInit( + times = list(start = start, end = end), modules = toyModuleName, + params = stats::setNames(list(params), toyModuleName), + objects = objects, paths = toyPathsP())) +} + +## this module's mod$ objects in a simList +toyModP <- function(sim) sim[[".modObjs"]][[toyModuleName]] + +## The module's own functions. Under `convertToPackage()` they live in the module's namespace; +## reaching them through the simList works either way. +toyFunP <- function(sim, nm) get(nm, envir = sim[[".mods"]][[toyModuleName]]) + +## Run named events of this module through spades(), which is what gives the module's functions +## their `mod` and `P()` context. Messages are muffled. +toyRunEventsP <- function(sim, events) { + withr::local_options(spades.useRequire = FALSE, reproducible.verbose = -2) + suppressMessages(suppressWarnings( + SpaDES.core::spades(sim, events = stats::setNames(list(events), toyModuleName), debug = FALSE))) +} diff --git a/tests/testthat/test-getCurrentClimate.R b/tests/testthat/test-getCurrentClimate.R new file mode 100644 index 0000000..457045d --- /dev/null +++ b/tests/testthat/test-getCurrentClimate.R @@ -0,0 +1,56 @@ +## Two defects in getCurrentClimate(), both silent: the wrong year is used, and the right year is +## used only once. The toy climate stack makes either visible, because layer "year" is +## constant at yyyy - 1900. + +test_that("climateYear selects the climate layers, not time(sim)", { + sim <- toySimInitP(objects = toyInputsP(climateYear = 2003), start = 2001, end = 2001) + sim <- toyFunP(sim, "getCurrentClimate")(sim) + ## 2003 -> 103 everywhere. Before the fix the inner function's `currentYear = time(sim)` + ## formal shadowed the outer value and 2001 (101) was used. + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 103) +}) + +test_that("without climateYear, time(sim) selects the climate layers", { + sim <- toySimInitP(start = 2002, end = 2002) + sim <- toyFunP(sim, "getCurrentClimate")(sim) + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 102) +}) + +test_that("the climate rasters are rebuilt when the year changes", { + sim <- toySimInitP(start = 2001, end = 2003) + sim <- toyFunP(sim, "getCurrentClimate")(sim) + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 101) + + ## `currentClimateRasters` is a module output, so it survives into the next year: an + ## `is.null()` guard left it stale (101) forever. It must now follow the year. + SpaDES.core::time(sim) <- 2002 + sim <- toyFunP(sim, "getCurrentClimate")(sim) + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 102) + + SpaDES.core::time(sim) <- 2003 + sim <- toyFunP(sim, "getCurrentClimate")(sim) + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 103) +}) + +test_that("the rasters are not rebuilt twice within the same year", { + ## run through spades() so that the module's `mod` (where the year is remembered) exists + sim <- toySimInitP(start = 2001, end = 2001) + sim <- toyRunEventsP(sim, c("init", "getClimateRasters")) + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 101) + expect_identical(as.numeric(toyModP(sim)$currentClimateYear), 2001) + + ## poison the cached object and run the event again at the same time: the year has not + ## changed, so the rasters must be returned untouched rather than rebuilt + sim$currentClimateRasters <- terra::setValues(sim$currentClimateRasters, rep(-1, 16)) + sim <- SpaDES.core::scheduleEvent(sim, SpaDES.core::start(sim), toyModuleName, + "getClimateRasters") + sim <- toyRunEventsP(sim, "getClimateRasters") + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), -1) +}) + +test_that("a multi-year run advances the climate rasters every year", { + sim <- toySimInitP(start = 2001, end = 2003) + sim <- toyRunEventsP(sim, c("init", "getClimateRasters")) + ## end(sim) is 2003, and getClimateRasters reschedules itself annually + expect_identical(unique(as.vector(terra::values(sim$currentClimateRasters))), 103) +}) diff --git a/tests/testthat/test-inputObjectsRstLCC.R b/tests/testthat/test-inputObjectsRstLCC.R new file mode 100644 index 0000000..43d4118 --- /dev/null +++ b/tests/testthat/test-inputObjectsRstLCC.R @@ -0,0 +1,26 @@ +## .inputObjects() branched on `suppliedElsewhere("rstLCCs", sim)`, but `rstLCCs` was not a declared +## input, so a user-supplied `rstLCCs` was TRUE for the branch and NULL in the simList: rstLCC_RTM +## stayed NULL and Init() then died in .compareRas(). And in the OTHER branch `defineFlammable()` +## referenced a local `rstLCC` that only exists inside that branch. + +test_that("a supplied rstLCCs is visible to .inputObjects() and sets rstLCC_RTM", { + lcc <- toyRastP(toyLCCvalsP(), "lcc") + objs <- toyInputsP(rstLCCs = list(year2001 = lcc)) + objs$rstLCC_RTM <- NULL # must be derived from rstLCCs + objs$flammableRTM <- NULL # exercises the defineFlammable() path too + objs$landcoverDT <- NULL + + sim <- toySimInitP(objects = objs, start = 2001, end = 2001) + expect_s4_class(sim$rstLCC_RTM, "SpatRaster") + expect_equal(as.vector(terra::values(sim$rstLCC_RTM)), as.vector(terra::values(lcc))) + ## 20 is in P(sim)$nonflammableLCC, everything else is flammable + expect_equal(as.vector(terra::values(sim$flammableRTM)), + as.numeric(toyLCCvalsP() != 20L)) +}) + +test_that("a supplied rstLCC_RTM is left alone and never triggers a download", { + objs <- toyInputsP() + objs$rstLCCs <- NULL + sim <- toySimInitP(objects = objs, start = 2001, end = 2001) + expect_equal(as.vector(terra::values(sim$rstLCC_RTM)), as.double(toyLCCvalsP())) +}) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 6c8028b..c763b04 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -18,7 +18,7 @@ test_that("inputs are the expected names and classes", { expect_identical( inputs[order(names(inputs))], c(climateVariablesForFire = "list", - climateYear = "character", + climateYear = "numeric", cohortData = "data.table", currentClimateRasters = "SpatRaster", fireSense_IgnitionFitted = "fireSense_IgnitionFit", @@ -33,6 +33,7 @@ test_that("inputs are the expected names and classes", { rasterToMatch = "SpatRaster", rstCurrentBurn = "SpatRaster", rstLCC_RTM = "SpatRaster", + rstLCCs = "list", sppEquiv = "data.table", standAgeMap = "SpatRaster") ) diff --git a/tests/testthat/test-realignCategorical.R b/tests/testthat/test-realignCategorical.R new file mode 100644 index 0000000..402a7e0 --- /dev/null +++ b/tests/testthat/test-realignCategorical.R @@ -0,0 +1,19 @@ +## Init() realigns rstLCC_RTM onto rasterToMatch when they differ. Landcover is categorical, so the +## postProcess() default (bilinear) invents classes that are in no landcover legend, and +## makeLandcoverDT() then returns an all-NA table of the right shape: a silent failure. + +test_that("misaligned categorical landcover is realigned with nearest neighbour", { + lcc <- toyRastP(toyLCCvalsP(), "lcc") + ## same extent and CRS, shifted half a pixel, so .compareRas() is FALSE and the branch is taken + misaligned <- terra::shift(lcc, dx = 125, dy = 125) + + sim <- toySimInitP(objects = toyInputsP(rstLCC_RTM = misaligned), start = 2001, end = 2001) + sim$landcoverDT <- NULL # so that Init(), not .inputObjects(), builds it + sim <- toyRunEventsP(sim, "init") # Init() builds landcoverDT from the realigned landcover + + dt <- sim$landcoverDT + expect_s3_class(dt, "data.table") + ## the real symptom: an all-NA landcoverDT apart from pixelID + nonID <- setdiff(names(dt), "pixelID") + expect_false(all(vapply(nonID, function(nm) all(is.na(dt[[nm]])), logical(1)))) +}) From cbace6d2c48377374a58879917bcbf85bf0bd52d Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 19:55:56 -0700 Subject: [PATCH 5/5] Remove unused parameters and input; fix whichModulesToPrepare default; add empty save event Removed, never read: parameters .plotInitialTime, .plotInterval, .saveInitialTime, .saveInterval; input fireSense_IgnitionFitted and its check in .inputObjects, which only ran for a Fit module name. whichModulesToPrepare now defaults to the three Predict modules that doEvent tests for. It named fireSense_EscapeFit, which nothing tests for. The save event emits a message and does nothing else. Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_013B4sgRg9EwyHaAQdDzUaQW --- fireSense_dataPrepPredict.R | 30 +++++------------------------ fireSense_dataPrepPredict.Rmd | 3 ++- tests/testthat/test-init.R | 35 +++++++++++++++++++++++++--------- tests/testthat/test-metadata.R | 4 +--- 4 files changed, 34 insertions(+), 38 deletions(-) diff --git a/fireSense_dataPrepPredict.R b/fireSense_dataPrepPredict.R index a2f766e..b882622 100644 --- a/fireSense_dataPrepPredict.R +++ b/fireSense_dataPrepPredict.R @@ -54,29 +54,14 @@ defineModule(sim, list( defineParameter("sppEquivCol", "character", "LandR", NA, NA, desc = "Column of `sppEquiv` with the species names used in `cohortData`."), defineParameter("whichModulesToPrepare", "character", - default = c("fireSense_SpreadPredict", "fireSense_IgnitionPredict", "fireSense_EscapeFit"), + default = c("fireSense_SpreadPredict", "fireSense_IgnitionPredict", "fireSense_EscapePredict"), NA, NA, desc = paste("Predict modules to prepare covariates for: `fireSense_IgnitionPredict` or", "`fireSense_EscapePredict` for the ignition/escape table,", - "`fireSense_SpreadPredict` for the spread table.")), - defineParameter(".plotInitialTime", "numeric", NA, NA, NA, - "Describes the simulation time at which the first plot event should occur." - ), - defineParameter( - ".plotInterval", "numeric", NA, NA, NA, - "Describes the simulation time interval between plot events." - ), + "`fireSense_SpreadPredict` for the spread table. Defaults to all three.")), defineParameter( ".runInitialTime", "numeric", start(sim), NA, NA, "Time of the first climate and covariate preparation events." ), - defineParameter( - ".saveInitialTime", "numeric", NA, NA, NA, - "Describes the simulation time at which the first save event should occur." - ), - defineParameter( - ".saveInterval", "numeric", NA, NA, NA, - "This describes the simulation time interval between save events." - ), defineParameter( ".useCache", "logical", FALSE, NA, NA, paste( @@ -101,8 +86,6 @@ defineModule(sim, list( "If absent, built from `projectedClimateRasters`.")), expectsInput("cohortData", "data.table", sourceURL = NA, desc = "Cohorts by `pixelGroup` (LandR)."), - expectsInput("fireSense_IgnitionFitted", "fireSense_IgnitionFit", sourceURL = NA, - desc = "Fitted ignition model. Not used by the current code."), expectsInput("missingLCCgroup", "character", sourceURL = NA, desc = paste( "Forested pixels that are absent from `cohortData` are assigned to this class.", @@ -211,6 +194,9 @@ doEvent.fireSense_dataPrepPredict <- function(sim, eventTime, eventType) { "fireSense_dataPrepPredict", "prepSpreadPredictData" ) }, + save = { + message("fireSense_dataPrepPredict: the save event does nothing") + }, warning(paste("Undefined event type: \'", current(sim)[1, "eventType", with = FALSE], "\' in module \'", current(sim)[1, "moduleName", with = FALSE], "\'", sep = "" @@ -536,12 +522,6 @@ prepare_SpreadPredict <- function(sim) { userTags = c(cacheTags, "prepInputsStandAgeMap2011")) } - if (!suppliedElsewhere("fireSense_IgnitionFitted", sim)) { - if ("fireSense_IgnitionFit" %in% P(sim)$whichModulesToPrepare) { - stop("please supply fireSense_IgnitionFitted object") - } - } - if (!suppliedElsewhere("flammableRTM", sim)) { sim$flammableRTM <- defineFlammable(rstLCC, nonFlammClasses = P(sim)$nonflammableLCC, diff --git a/fireSense_dataPrepPredict.Rmd b/fireSense_dataPrepPredict.Rmd index a6e9ec2..f951d9f 100644 --- a/fireSense_dataPrepPredict.Rmd +++ b/fireSense_dataPrepPredict.Rmd @@ -80,13 +80,14 @@ knitr::kable(df_params, caption = "List of (ref:fireSense-dataPrepPredict) param ### Events -All events after `init` repeat every `fireTimeStep` years. +All events after `init`, except `save`, repeat every `fireTimeStep` years. - `init`: aligns `standAgeMap` and `rstLCC_RTM` to `rasterToMatch`; builds `landcoverDT` if absent; builds `nonForest_timeSinceDisturbance` if absent, from the fire polygons of the `cutoffForYoungAge` years up to `dataYear`. - `getClimateRasters` (from `.runInitialTime`): if `currentClimateRasters` is absent, takes layer `year` of each element of `projectedClimateRasters`. Stops if it does not match `pixelGroupMap`. - `prepIgAndEscPredictData` (from `.runInitialTime`): builds `fireSense_igAndEscapePred_Covariates`. Scheduled if `whichModulesToPrepare` has `fireSense_IgnitionPredict` or `fireSense_EscapePredict`. - `prepSpreadPredictData` (from `.runInitialTime`): builds `fireSense_SpreadCovariates`. Scheduled if `whichModulesToPrepare` has `fireSense_SpreadPredict`. - `ageNonForest` (from `time(sim) + 1`): adds 1 to `nonForest_timeSinceDisturbance` and resets pixels burned in `rstCurrentBurn` to 0. +- `save`: does nothing except emit a message. The module never schedules it. The module does not plot or save anything. diff --git a/tests/testthat/test-init.R b/tests/testthat/test-init.R index ac05785..581d4da 100644 --- a/tests/testthat/test-init.R +++ b/tests/testthat/test-init.R @@ -104,17 +104,34 @@ test_that("init schedules exactly the events implied by whichModulesToPrepare", expect_identical(evs("fireSense_EscapeFit"), c("ageNonForest", "getClimateRasters")) }) -test_that("KNOWN BUG: the default whichModulesToPrepare prepares no escape covariates", { - ## The shipped default includes `fireSense_EscapeFit`, but `doEvent` tests for - ## `fireSense_EscapePredict`; the owner's decision is that the default should be - ## `fireSense_dataPrepPredict`'s own Predict trio. Either way the default is wrong, so this - ## records the INTENDED assertion -- that the default contains only Predict module names -- - ## as a currently-failing expectation rather than blessing the shipped value. +test_that("the default whichModulesToPrepare is the three Predict modules doEvent tests for", { + ## The default used to include `fireSense_EscapeFit`, which `doEvent` never tests for. md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) default <- md$parameters$default[[which(md$parameters$paramName == "whichModulesToPrepare")]] - expect_failure(expect_true(all(grepl("Predict$", default)))) - ## the offending element, named so the fix is unambiguous - expect_true("fireSense_EscapeFit" %in% default) + expect_setequal(default, c("fireSense_IgnitionPredict", "fireSense_EscapePredict", + "fireSense_SpreadPredict")) + + ## with the default, init schedules both covariate events + sim <- SpaDES.core::spades(toyPrepSim(), events = "init", debug = FALSE) + expect_identical(sort(as.data.frame(SpaDES.core::events(sim))$eventType), + c("ageNonForest", "getClimateRasters", "prepIgAndEscPredictData", + "prepSpreadPredictData")) +}) + +test_that("the save event does nothing", { + sim <- SpaDES.core::spades(toyPrepSim(), events = "init", debug = FALSE) + before <- sapply(ls(sim), function(nm) reproducible::.robustDigest(sim[[nm]])) + queued <- as.data.frame(SpaDES.core::events(sim)) + + sim <- SpaDES.core::scheduleEvent(sim, SpaDES.core::start(sim), moduleName, "save") + expect_message( + expect_no_warning(sim <- SpaDES.core::spades(sim, events = "save", debug = FALSE)), + "the save event does nothing") + + expect_true("save" %in% evOf(SpaDES.core::completed(sim), "save")$eventType) + expect_identical(sapply(ls(sim), function(nm) reproducible::.robustDigest(sim[[nm]])), before) + ## nothing new is scheduled + expect_identical(as.data.frame(SpaDES.core::events(sim)), queued) }) test_that("events reschedule themselves one fireTimeStep ahead", { diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 6c8028b..5a8f1bd 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -21,7 +21,6 @@ test_that("inputs are the expected names and classes", { climateYear = "character", cohortData = "data.table", currentClimateRasters = "SpatRaster", - fireSense_IgnitionFitted = "fireSense_IgnitionFit", flammableRTM = "SpatRaster", landcoverDT = "data.table", lightningMaps = "SpatRaster", @@ -54,8 +53,7 @@ test_that("parameters are the expected names", { md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) expect_identical( sort(md$parameters$paramName), - sort(c(".plotInitialTime", ".plotInterval", ".runInitialTime", ".saveInitialTime", - ".saveInterval", ".useCache", "cutoffForYoungAge", "dataYear", + sort(c(".runInitialTime", ".useCache", "cutoffForYoungAge", "dataYear", "fireTimeStep", "flammabilityThreshold", "forestedLCC", "fuelClassCol", "igAggFactor", "nonflammableLCC", "nonForestCanBeYoungAge", "sppEquivCol", "whichModulesToPrepare"))