From 2199e4ba0cebf08b30445114ddd0f0802421d574 Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 09:51:19 -0700 Subject: [PATCH 1/3] Remove dead code; document functions; correct metadata descs and Rmd Removes plotSpreadProbByFuelType() (no caller), the if (FALSE) pre-June-2025 prediction branch, and commented-out code. The live else-branch is unwrapped and dedented; no behaviour change. Co-Authored-By: Claude Fable 5.1 --- R/plotSpreadProbByFuelType.R | 40 ---- fireSense_SpreadPredict.R | 347 +++++++++++------------------------ fireSense_SpreadPredict.Rmd | 28 +-- 3 files changed, 120 insertions(+), 295 deletions(-) delete mode 100644 R/plotSpreadProbByFuelType.R diff --git a/R/plotSpreadProbByFuelType.R b/R/plotSpreadProbByFuelType.R deleted file mode 100644 index bbdc5f8..0000000 --- a/R/plotSpreadProbByFuelType.R +++ /dev/null @@ -1,40 +0,0 @@ -#' Plot spread probability by fuel type and MDC -#' -#' @param spreadProbFuelType data.table. Columns as weather, classType and spreadProb. -#' @param typesOfFuel character. Types of fuel in the order of the formula terms. -#' @param coefToUse character. For labels' purpose. Either bestCoef or meanCoef. -#' @param covMinMax data.table. Covariate min and max. Used to fix weather (MDC) axis. -#' -#' @return list of the original data table and the plot -#' -#' @author Tati Micheletti -#' @export -#' @importFrom ggplot2 ggplot aes geom_line labs -#' @importFrom viridis scale_color_viridis -#' -#' @rdname plotSpreadProbByFuelType -plotSpreadProbByFuelType <- function(spreadProbFuelType, - typesOfFuel, - coefToUse, - covMinMax = NULL){ - # Fix the weather for the plotting! -if (!is.null(covMinMax)) { - correctedWeather <- rescaleKnown(x = spreadProbFuelType[["weather"]], - minNew = covMinMax[["weather"]][1]/1000, - maxNew = covMinMax[["weather"]][2]/1000, - minOrig = 0, maxOrig = 1) -} else { - correctedWeather <- spreadProbFuelType[["weather"]] -} - p1 <- ggplot(data = spreadProbFuelType, - aes(x = correctedWeather, y = spreadProb, group = classType)) + - geom_line(aes(color = classType), size = 1.7) + - scale_color_viridis(discrete = TRUE, option = "D", - name = "Fuel Type", - labels = typesOfFuel) + - labs(y = "spread probability", x = "MDC", - title = paste0("Coefficient: ", coefToUse)) - spreadProbFuelType <- list(DT = spreadProbFuelType, - plot = p1) - return(spreadProbFuelType) -} diff --git a/fireSense_SpreadPredict.R b/fireSense_SpreadPredict.R index 43b3fde..3ac942a 100644 --- a/fireSense_SpreadPredict.R +++ b/fireSense_SpreadPredict.R @@ -19,53 +19,56 @@ defineModule(sim, list( "ggplot2", "viridis", "PredictiveEcology/fireSenseUtils@development (>= 0.1.0)"), parameters = bindrows( - # defineParameter(name = "climCol", class = "character", default = "MDC", min = NA, max = NA, - # desc = "the name of the climate covariate in `sim$fireSense_spreadCovariates`"), defineParameter(name = "coefToUse", class = "character", default = "meanCoef", - desc = paste("Which coefficient to use to predict?", - "The best coefficient (bestCoef) from DEOPtim or ", - "the average (meanCoef; default).")), + desc = paste("Not used. Predictions are the mean over all parameter sets in", + "`studyAreaWithSpreadParams`.")), defineParameter(name = "lowerSpreadProb", class = "numeric", default = 0.13, - desc = "Lower spread probability"), + desc = "Lower asymptote of the 2- and 3-parameter logistic."), defineParameter("maxFireSpread", "numeric", default = 0.28, - desc = paste0("optional. Maximum fire spread average to be passed to the `.objFun`.", - "This puts an upper limit on `spreadProb` during optimization. Expected to be same ", - "as fireSpread_SpreadFit parameter value")), + desc = paste("Upper limit on `spreadProb` used when fitting. Here it is only checked", + "to be the same in every module that defines it.")), defineParameter(name = "mutuallyExclusiveCols", "list", default = list("youngAge" = "fuels"), NA, NA, - desc = paste("a named list, where the name of the list must be a covariate in the data.table.", - "Covariates matching the values in each list element will be set to 0.", - "List content should be a grep regex.")), + desc = "Not used; mutual exclusion is done in `fireSense_dataPrepPredict`."), defineParameter(name = ".runInitialTime", class = "numeric", default = start(sim), - desc = "when to start this module? By default, the start time of the simulation."), + desc = "Time of the first prediction."), defineParameter(name = ".runInterval", class = "numeric", default = 1, - desc = paste("optional. Interval between two runs of this module, expressed in units of", - "simulation time.Defaults to 1 year.")), + desc = "Interval between predictions, in years. `NA` predicts once."), defineParameter(name = ".saveInitialTime", class = "numeric", default = NA, - desc = "optional. When to start saving output to a file."), + desc = "Time of the first `save` event. `NA` means never."), defineParameter(name = ".saveInterval", class = "numeric", default = NA, - desc = "optional. Interval between save events."), + desc = "Interval between `save` events."), defineParameter(".useCache", "logical", FALSE, NA, NA, paste("Should this entire module be run with caching activated?", "This is generally intended for data-type modules, where stochasticity and time are not relevant")) ), inputObjects = bindrows( expectsInput(objectName = "covMinMax_spread", objectClass = "data.table", - desc = "range used to rescale coefficients during spreadFit"), + desc = paste("Minimum and maximum (2 rows) of each covariate in the fitting data,", + "used to rescale the covariates as in `fireSense_SpreadFit`.")), expectsInput(objectName = "fireSense_SpreadCovariates", objectClass = "data.table", - desc = "data.table of covariates with pixelID column corresponding to flammableRTM index."), + desc = paste("This year's covariates, from `fireSense_dataPrepPredict`.", + "`pixelID` is the cell index of `flammableRTM`.")), expectsInput(objectName = "fireSense_SpreadFitted", objectClass = "fireSense_SpreadFit", - desc = "An object of class 'fireSense_SpreadFit' created by the fireSense_SpreadFit module."), + desc = "Not used. The fitted parameters are read from `studyAreaWithSpreadParams`."), expectsInput(objectName = "flammableRTM", objectClass = "SpatRaster", sourceURL = NA, - desc = "RTM with nonflammable pixels coded as 0 and flammable as 1.") + desc = "Binary raster, 1 where the pixel is flammable. Template for `fireSense_SpreadPredicted`.") ), outputObjects = bindrows( createsOutput(objectName = "fireSense_SpreadPredicted", objectClass = "SpatRaster", - desc = "A raster layer of spread probabilities") + desc = "Spread probability of each flammable pixel, this year.") )) ) -## event types -# - type `init` is required for initialiazation +#' Event dispatcher +#' +#' Events: `init`, `run` (predict, repeated every `.runInterval`), `save`. +#' +#' @param sim A `simList`. +#' @param eventTime Time of the event. +#' @param eventType Name of the event. +#' @param debug Not used. +#' +#' @return The `simList`, invisibly. doEvent.fireSense_SpreadPredict <- function(sim, eventTime, eventType, debug = FALSE) { moduleName <- current(sim)$moduleName @@ -107,236 +110,98 @@ doEvent.fireSense_SpreadPredict <- function(sim, eventTime, eventType, debug = F invisible(sim) } -## event functions -# - follow the naming convention `modulenameEventtype()`; -# - `modulenameInit()` function is required for initialization; -# - keep event functions short and clean, modularize by calling subroutines from section below. - +#' Predict this year's spread probability +#' +#' Rescales `sim$fireSense_SpreadCovariates` with `sim$covMinMax_spread`, computes the spread +#' probability for each parameter set (row) in `sim$studyAreaWithSpreadParams$params[[1]]`, +#' and writes the mean over parameter sets to `sim$fireSense_SpreadPredicted`. +#' +#' @param sim A `simList`. +#' +#' @return The `simList`, invisibly. spreadPredictRun <- function(sim) { moduleName <- current(sim)$moduleName fireSense_SpreadCovariates <- copy(sim$fireSense_SpreadCovariates) - # if (!is(sim$fireSense_SpreadFitted, "fireSense_SpreadFit")) { - # stop(moduleName, "> '", sim$fireSense_spreadFitted, "' should be of class 'fireSense_SpreadFit") - # } - # Load inputs in the data container mod_env <- new.env(parent = globalenv()) list2env(fireSense_SpreadCovariates, envir = mod_env) ## In case there is a response in the formula remove it - if (FALSE) { - # The old way prior to June 2, 2025 - - terms <- as.formula(sim$fireSense_SpreadFitted$formula) %>% - terms.formula() %>% - delete.response() - - formula <- reformulate(attr(terms, "term.labels"), intercept = attr(terms, "intercept")) - allxy <- all.vars(formula) - - missing <- !allxy %in% ls(mod_env, all.names = TRUE) - if (s <- sum(missing)) { - stop( - moduleName, "> '", allxy[missing][1L], "'", - if (s > 1) paste0(" (and ", s - 1L, " other", if (s > 2) "s", ")"), - " not found in data objects." - ) - } - - ################################################### - # Convert stacks to lists of data.table objects --> much more compact - ################################################### - # First for stacks that are "annual" - - # # Rescale to numerics and /1000 - if (!is.null(sim$covMinMax_spread)) { - for (cn in names(sim$covMinMax_spread)) { - set( - fireSense_SpreadCovariates, NULL, cn, - rescaleKnown2(x = fireSense_SpreadCovariates[[cn]], - minNew = 0, - maxNew = 1000, - minOrig = sim$covMinMax_spread[[cn]][1], - maxOrig = sim$covMinMax_spread[[cn]][2]) - ) - } - } - - if (!is.null(P(sim)$mutuallyExclusiveCols)) { - fireSense_SpreadCovariates <- makeMutuallyExclusive( - dt = fireSense_SpreadCovariates, - mutuallyExclusiveCols = P(sim)$mutuallyExclusiveCols - ) - } - - colsToUse <- setdiff(names(fireSense_SpreadCovariates), "pixelID") - parsModel <- length(colsToUse) - - - par <- sim$fireSense_SpreadFitted[[P(sim)$coefToUse]] - mat <- as.matrix(fireSense_SpreadCovariates[, ..colsToUse])/1000 # Divide by 1000 for the model prediction - - # matrix multiplication - covPars <- tail(x = par, n = parsModel) - logisticPars <- head(x = par, n = length(par) - parsModel) - # Make sure the order is correct in the matrix - matching <- match(names(covPars), colnames(mat)) - mat <- mat[, matching] - if (length(logisticPars) == 4) { - set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic4p(mat %*% covPars, logisticPars)) - } else if (length(logisticPars) == 3) { - set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic3p(mat %*% covPars, logisticPars, - par1 = P(sim)$lowerSpreadProb)) - } else if (length(logisticPars) == 2) { - set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic2p(mat %*% covPars, logisticPars, - par1 = P(sim)$lowerSpreadProb)) - } - - # Return to raster format - # convert to sim$flammableRTMs - sim$fireSense_SpreadPredicted <- rast(sim$flammableRTM) ## use flammableRTM as template - ## Need to track what is happening with missing pixels - if (FALSE) { - nFlam <- sum(getValues(sim$flammableRTM), na.rm = TRUE) - nLand <- nrow(sim$landcoverDT) - nSpread <- nrow(sim$fireSense_SpreadCovariates) - nIg <- nrow(sim$fireSense_IgnitionAndEscapeCovariates) - } - sim$fireSense_SpreadPredicted[fireSense_SpreadCovariates$pixelID] <- fireSense_SpreadCovariates$spreadProb - - } else { - # sim$studyAreaWithSpreadParams - + terms <- as.formula(sim$fireSense_spreadFormula) %>% + terms.formula() %>% + delete.response() - terms <- as.formula(sim$fireSense_spreadFormula) %>% - terms.formula() %>% - delete.response() - - formula <- reformulate(attr(terms, "term.labels"), intercept = attr(terms, "intercept")) - allxy <- all.vars(formula) - - missing <- !allxy %in% ls(mod_env, all.names = TRUE) - if (s <- sum(missing)) { - stop( - moduleName, "> '", allxy[missing][1L], "'", - if (s > 1) paste0(" (and ", s - 1L, " other", if (s > 2) "s", ")"), - " not found in data objects." - ) - } - - ################################################### - # Convert stacks to lists of data.table objects --> much more compact - ################################################### - # First for stacks that are "annual" - shortAnnDTx1000 <- toX1000(list(fireSense_SpreadCovariates))[[1]] |> setDT() - colsToUse <- setdiff(names(fireSense_SpreadCovariates), "pixelID") - - # Without fitted parameters there is nothing to predict from; say so instead of - # dying in rowMeans() on an empty matrix (which is what an unfitted ELF produced - # when fireSense_SpreadFit had not run first). This must come before anything - # indexes `params[[1]]`: with zero rows that fails first, "subscript out of bounds". - nPar <- tryCatch(NROW(sim$studyAreaWithSpreadParams$params[[1]]), error = function(e) 0L) - if (NROW(sim$studyAreaWithSpreadParams) == 0L || is.null(nPar) || nPar == 0L) - stop("fireSense_SpreadPredict: sim$studyAreaWithSpreadParams holds no fitted spread ", - "parameters for this run (", if (!is.null(sim$.runName)) sim$.runName else "unknown", - "). Either fireSense_SpreadFit has not run yet -- its `run` event must precede this ", - "module's -- or the shared ledger has no row for this polygon.", call. = FALSE) - - logisticPars <- sim$studyAreaWithSpreadParams$params[[1]] - - shortAnnDT <- # shortAnnDTx1000 <- - spreadProbFromIntegerCovs(shortAnnDTx1000 = shortAnnDTx1000, # annDTx1000, nonAnnualDTx1000, - # indexNonAnnual, - yr = time(sim), - covMinMax = sim$covMinMax_spread, - mutuallyExclusive = NULL, # alraedy done in dataPrepPredict - colsToUse = colsToUse, - doAssertions = FALSE, - logisticPars = logisticPars, # covPars, - maxFireSpread = Par$maxFireSpread - # , lowerSpreadProb # this is set at 0.13 - ) - - # THIS IS INSIDE fireSenseUtils::objFunInner - # set(shortAnnDTx1000, NULL, "spreadProb", - # logisticAll(logisticPars, mat = as.matrix(shortAnnDTx1000[, ..colsToUse]), covPars, lowerSpreadProb)) - - parsModel <- length(colsToUse) - # par <- purrr::pmap(.l = list(ind = seq(NROW(sim$studyAreaWithSpreadParams$params[[1]]))), - # sa = sim$studyAreaWithSpreadParams, function(ind, sa) { - # sa$params[[1]][ind,] |> as.vector() |> unlist() - # }) - mat <- as.matrix(shortAnnDT[, ..colsToUse]) - - # for replicate "best" params from DEoptim - spreadProbList <- purrr::pmap(.l = list(ind = seq(NROW(sim$studyAreaWithSpreadParams$params[[1]]))), - sa = sim$studyAreaWithSpreadParams, function(ind, sa) { - par <- sa$params[[1]][ind,] |> as.vector() |> unlist() - # mat <- as.matrix(fireSense_SpreadCovariates[, ..colsToUse])/1000 # Divide by 1000 for the model prediction - - covPars <- intersect(names(par), colsToUse) - covPars <- par[covPars] - logisticPars <- par[setdiff(names(par), names(covPars))] - # params <- paramsSeparate(par, parsModel) - # matrix multiplication - # covPars <- params$covPars - # logisticPars <- params$logisticPars - # Make sure the order is correct in the matrix - matching <- intersect(names(covPars), colnames(mat)) - missingCovs <- setdiff(colnames(mat), names(covPars)) - if (length(missingCovs)) - warning("There are covariates in the sim$fireSense_SpreadCovariates: \n", - paste0(missingCovs, collapse = ", "), - "\n...that are not in the sim$studyAreaWithSpreadParams") - mat <- mat[, matching] - - logisticAll(logisticPars, #fireSense_SpreadCovariates, - mat, covPars, P(sim)$lowerSpreadProb) - }) - spreadProbMat <- do.call(cbind, spreadProbList) - - # spreadProbMat <- spreadProbMat[, which.min(colMeans(spreadProbMat))] - - set(shortAnnDT, NULL, "spreadProb", rowMeans(spreadProbMat)) - - # par <- sim$studyAreaWithSpreadParams$params[[1]][1,] |> as.vector() |> unlist() - # mat <- as.matrix(fireSense_SpreadCovariates[, ..colsToUse])/1000 # Divide by 1000 for the model prediction - # - # # matrix multiplication - # covPars <- tail(x = par, n = parsModel) - # logisticPars <- head(x = par, n = length(par) - parsModel) - # # Make sure the order is correct in the matrix - # matching <- match(names(covPars), colnames(mat)) - # mat <- mat[, matching] - # - # preds <- logisticAll(logisticPars, mat, covPars, P(sim)$lowerSpreadProb) - # if (length(logisticPars) == 4) { - # set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic4p(mat %*% covPars, logisticPars)) - # } else if (length(logisticPars) == 3) { - # set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic3p(mat %*% covPars, logisticPars, - # par1 = P(sim)$lowerSpreadProb)) - # } else if (length(logisticPars) == 2) { - # set(fireSense_SpreadCovariates, NULL, "spreadProb", logistic2p(mat %*% covPars, logisticPars, - # par1 = P(sim)$lowerSpreadProb)) - # } - - # Return to raster format - sim$fireSense_SpreadPredicted <- rast(sim$flammableRTM) ## use flammableRTM as template - ## Need to track what is happening with missing pixels - if (FALSE) { - nFlam <- sum(getValues(sim$flammableRTM), na.rm = TRUE) - nLand <- nrow(sim$landcoverDT) - nSpread <- nrow(sim$fireSense_SpreadCovariates) - nIg <- nrow(sim$fireSense_IgnitionAndEscapeCovariates) - } - sim$fireSense_SpreadPredicted[shortAnnDT$pixelID] <- shortAnnDT$spreadProb + formula <- reformulate(attr(terms, "term.labels"), intercept = attr(terms, "intercept")) + allxy <- all.vars(formula) + missing <- !allxy %in% ls(mod_env, all.names = TRUE) + if (s <- sum(missing)) { + stop( + moduleName, "> '", allxy[missing][1L], "'", + if (s > 1) paste0(" (and ", s - 1L, " other", if (s > 2) "s", ")"), + " not found in data objects." + ) } + # integers x 1000, the form `spreadProbFromIntegerCovs` expects + shortAnnDTx1000 <- toX1000(list(fireSense_SpreadCovariates))[[1]] |> setDT() + colsToUse <- setdiff(names(fireSense_SpreadCovariates), "pixelID") + + # Without fitted parameters there is nothing to predict from; say so instead of + # dying in rowMeans() on an empty matrix (which is what an unfitted ELF produced + # when fireSense_SpreadFit had not run first). This must come before anything + # indexes `params[[1]]`: with zero rows that fails first, "subscript out of bounds". + nPar <- tryCatch(NROW(sim$studyAreaWithSpreadParams$params[[1]]), error = function(e) 0L) + if (NROW(sim$studyAreaWithSpreadParams) == 0L || is.null(nPar) || nPar == 0L) + stop("fireSense_SpreadPredict: sim$studyAreaWithSpreadParams holds no fitted spread ", + "parameters for this run (", if (!is.null(sim$.runName)) sim$.runName else "unknown", + "). Either fireSense_SpreadFit has not run yet -- its `run` event must precede this ", + "module's -- or the shared ledger has no row for this polygon.", call. = FALSE) + + logisticPars <- sim$studyAreaWithSpreadParams$params[[1]] + + shortAnnDT <- + spreadProbFromIntegerCovs(shortAnnDTx1000 = shortAnnDTx1000, + yr = time(sim), + covMinMax = sim$covMinMax_spread, + mutuallyExclusive = NULL, # alraedy done in dataPrepPredict + colsToUse = colsToUse, + doAssertions = FALSE, + logisticPars = logisticPars, + maxFireSpread = Par$maxFireSpread + ) + + parsModel <- length(colsToUse) + mat <- as.matrix(shortAnnDT[, ..colsToUse]) + + # for replicate "best" params from DEoptim + spreadProbList <- purrr::pmap(.l = list(ind = seq(NROW(sim$studyAreaWithSpreadParams$params[[1]]))), + sa = sim$studyAreaWithSpreadParams, function(ind, sa) { + par <- sa$params[[1]][ind,] |> as.vector() |> unlist() + covPars <- intersect(names(par), colsToUse) + covPars <- par[covPars] + logisticPars <- par[setdiff(names(par), names(covPars))] + # Make sure the order is correct in the matrix + matching <- intersect(names(covPars), colnames(mat)) + missingCovs <- setdiff(colnames(mat), names(covPars)) + if (length(missingCovs)) + warning("There are covariates in the sim$fireSense_SpreadCovariates: \n", + paste0(missingCovs, collapse = ", "), + "\n...that are not in the sim$studyAreaWithSpreadParams") + mat <- mat[, matching] + + logisticAll(logisticPars, + mat, covPars, P(sim)$lowerSpreadProb) + }) + spreadProbMat <- do.call(cbind, spreadProbList) + + set(shortAnnDT, NULL, "spreadProb", rowMeans(spreadProbMat)) + + # Return to raster format + sim$fireSense_SpreadPredicted <- rast(sim$flammableRTM) ## use flammableRTM as template + sim$fireSense_SpreadPredicted[shortAnnDT$pixelID] <- shortAnnDT$spreadProb + invisible(sim) } - - - diff --git a/fireSense_SpreadPredict.Rmd b/fireSense_SpreadPredict.Rmd index 0359950..3e19807 100644 --- a/fireSense_SpreadPredict.Rmd +++ b/fireSense_SpreadPredict.Rmd @@ -45,13 +45,17 @@ download.file(url = "https://img.shields.io/badge/Made%20with-Markdown-1f425f.pn ### Module summary -Predicts a surface (raster) of fire spread probabilities using a model previously fit with `fireSense_SpreadFit`. -fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019] +Each year, predicts a raster of fire spread probabilities from the parameters fitted by *fireSense_SpreadFit*, for the spread component of fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019]. + +1. The covariates in `fireSense_SpreadCovariates` are rescaled to [0, 1] using `covMinMax_spread`, the range of the fitting data. +2. For each parameter set (row) in `studyAreaWithSpreadParams$params[[1]]`, the spread probability is a 2- or 3-parameter logistic of the linear combination of the covariates, with lower asymptote `lowerSpreadProb`. +3. `fireSense_SpreadPredicted` is the mean over parameter sets, on the `flammableRTM` grid. ### 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_SpreadPredict", "..")` may be sufficient. +Two objects from *fireSense_SpreadFit* are read from the `simList` though they are not declared as inputs: `studyAreaWithSpreadParams` (the fitted parameters) and `fireSense_spreadFormula` (every term must be a column of `fireSense_SpreadCovariates`). +The module stops if `studyAreaWithSpreadParams` has no parameters. +`maxFireSpread` must have the same value in every module that defines it. Table \@ref(tab:moduleInputs-fireSense-SpreadPredict) shows the full list of module inputs. @@ -72,17 +76,12 @@ knitr::kable(df_params, caption = "List of (ref:fireSense-SpreadPredict) paramet ``` ### Events - -- Module initiation; -- Make predictions. - -### Plotting - -Write what is plotted. -### Saving +- `init`: checks `maxFireSpread` against the other modules; schedules `run` at `.runInitialTime`, and `save` at `.saveInitialTime` if that is not `NA`. +- `run`: makes the prediction described above; repeats every `.runInterval`. +- `save`: calls `spreadPredictSave()`, which does not exist, so it currently fails. Leave `.saveInitialTime` as `NA`. -There is currently nothing saved, but this may change in the future. +The module does not plot anything. ### Module outputs @@ -96,7 +95,8 @@ knitr::kable(df_outputs, caption = "List of (ref:fireSense-SpreadPredict) output ### Links to other modules -Predictions made with this module can be used with the fire spread component of landscape fire models (e.g., `fireSense`). +Runs after *fireSense_dataPrepPredict* (covariates) and *fireSense_SpreadFit* (parameters). `fireSense_SpreadPredicted` is used by *fireSense* to spread fires. +It is normally run as part of the [fireSense](https://github.com/PredictiveEcology/fireSense) module group. ### Getting help From bb333a2c7be509b89af24993399cf8100bb7513c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 11:33:30 -0700 Subject: [PATCH 2/3] Add value-level tests for the run event, its failure paths and event scheduling 74 expectations (was 13). Predicted spreadProb values are hand-computed through the logistic from toy covariates and a toy fitted model, including rescaling with the fit's covMinMax. All pass on development and on this branch. Co-Authored-By: Claude Fable 5.1 --- tests/testthat/setup-toySpread.R | 78 ++++++++++++ tests/testthat/test-events.R | 56 ++++++++ tests/testthat/test-failures.R | 35 +++++ tests/testthat/test-metadata.R | 34 ++++- tests/testthat/test-spreadProb-values.R | 162 ++++++++++++++++++++++++ 5 files changed, 359 insertions(+), 6 deletions(-) create mode 100644 tests/testthat/setup-toySpread.R create mode 100644 tests/testthat/test-events.R create mode 100644 tests/testthat/test-failures.R create mode 100644 tests/testthat/test-spreadProb-values.R diff --git a/tests/testthat/setup-toySpread.R b/tests/testthat/setup-toySpread.R new file mode 100644 index 0000000..80742db --- /dev/null +++ b/tests/testthat/setup-toySpread.R @@ -0,0 +1,78 @@ +## This is a setup file, not a helper: helpers are sourced by pkgload::load_all() into an +## environment that cannot see `moduleName` and `testPaths` from setup.R. +## +## Tests run inside the namespace of the package rendition, which does not import +## data.table, so `dt[i, j]` there is NOT data.table-aware. Tables are therefore edited +## with data.table::set() and base subsetting only. +## +## Toy inputs for the `run` event, small enough that every predicted value can be worked +## out by hand. +## +## flammableRTM is 3 x 3. Cell 5 is non-flammable (0) and cell 9 is NA; neither has a row in +## the covariate table, as in fireSense_dataPrepPredict. Rows are deliberately NOT in +## pixelID order. +## +## The ranges in `covMinMax_spread` are those of the (imaginary) FITTING data and are wider +## than the ranges of the prediction covariates: MDC is 50..150 here but 0..200 in the fit. +toyCovariates <- function() { + data.table::data.table( + pixelID = c(7L, 1L, 3L, 2L, 8L, 4L, 6L), + MDC = c(150, 0, 100, 50, 100, 200, 100), + youngAge = c(0, 0, 0, 1, 1, 0, 0), + fuelA = c(0, 0, 4, 0, 8, 8, 2) + ) +} + +toyParams <- function(...) { + ## one row per retained DEoptim solution: logistic parameters first, then one + ## coefficient per covariate + data.frame(maxAsymptote = 0.25, hillSlope1 = 2, inflectionPoint1 = 1, + MDC = 1.5, youngAge = -0.5, fuelA = 1, ...) +} + +toyInputs <- function(covs = toyCovariates(), params = toyParams(), + formula = "~ MDC + youngAge + fuelA - 1") { + flammableRTM <- terra::rast(nrows = 3, ncols = 3, xmin = 0, xmax = 3, ymin = 0, ymax = 3, + vals = c(1, 1, 1, 1, 0, 1, 1, 1, NA)) + sa <- data.frame(ID = 1L) + sa$params <- list(params) + list(flammableRTM = flammableRTM, + fireSense_SpreadCovariates = covs, + covMinMax_spread = data.table::data.table(MDC = c(0, 200), youngAge = c(0, 1), + fuelA = c(0, 8)), + fireSense_spreadFormula = formula, + studyAreaWithSpreadParams = sa) +} + +toySim <- function(objects = toyInputs(), params = list(), times = list(start = 1, end = 1)) { + SpaDES.core::simInit( + times = c(times, timeunit = "year"), + modules = moduleName, + params = stats::setNames(list(params), moduleName), + objects = objects, + paths = testPaths + ) +} + +toyRun <- function(...) SpaDES.core::spades(toySim(...), debug = FALSE) + +## predicted values, as a plain vector indexed by cell number +predVals <- function(sim) terra::values(sim$fireSense_SpreadPredicted, mat = FALSE) + +## The 3-parameter logistic written out longhand, for the hand calculations below: +## lower + (upper - lower) / (1 + exp(-slope * x)) ^ shape +handLogistic3 <- function(x, upper = 0.25, slope = 2, shape = 1, lower = 0.13) { + lower + (upper - lower) / (1 + exp(-slope * x))^shape +} + +## set one covariate value for one pixel +setCov <- function(covs, pixel, col, value) { + data.table::set(covs, which(covs$pixelID == pixel), col, value) + covs +} + +## rows of completed()/events() for this module and one event type, as a data.frame +evOf <- function(dt, type) { + df <- as.data.frame(dt) + df[df$moduleName == "fireSense_SpreadPredict" & df$eventType == type, , drop = FALSE] +} diff --git a/tests/testthat/test-events.R b/tests/testthat/test-events.R new file mode 100644 index 0000000..4122469 --- /dev/null +++ b/tests/testthat/test-events.R @@ -0,0 +1,56 @@ +## Which events are scheduled, and when. + +test_that("run repeats every .runInterval from .runInitialTime, at priority 5.12", { + sim <- toyRun(times = list(start = 1, end = 3)) + done <- evOf(SpaDES.core::completed(sim), "run") + expect_equal(done$eventTime, c(1, 2, 3)) + expect_equal(unique(done$eventPriority), 5.12) + ## the next one is queued for year 4 + nxt <- evOf(SpaDES.core::events(sim), "run") + expect_equal(nxt$eventTime, 4) + expect_equal(nxt$eventPriority, 5.12) + expect_equal(evOf(SpaDES.core::completed(sim), "init")$eventTime, 1) +}) + +test_that(".runInitialTime delays the first run; .runInterval sets the step", { + sim <- toyRun(params = list(.runInitialTime = 2, .runInterval = 2), + times = list(start = 1, end = 5)) + expect_equal(evOf(SpaDES.core::completed(sim), "run")$eventTime, c(2, 4)) + expect_equal(evOf(SpaDES.core::events(sim), "run")$eventTime, 6) +}) + +test_that(".runInterval = NA predicts once", { + sim <- toyRun(params = list(.runInterval = NA_real_), times = list(start = 1, end = 3)) + expect_equal(evOf(SpaDES.core::completed(sim), "run")$eventTime, 1) + expect_identical(nrow(evOf(SpaDES.core::events(sim), "run")), 0L) + ## and the one prediction is there + expect_equal(predVals(sim)[1], 0.19, tolerance = 1e-7) +}) + +test_that("no save event is scheduled when .saveInitialTime is NA (the default)", { + sim <- toyRun(times = list(start = 1, end = 2)) + expect_identical(nrow(evOf(SpaDES.core::completed(sim), "save")), 0L) + expect_identical(nrow(evOf(SpaDES.core::events(sim), "save")), 0L) +}) + +test_that("nothing is predicted before the first run event", { + sim <- toyRun(params = list(.runInitialTime = 5), times = list(start = 1, end = 2)) + expect_null(sim$fireSense_SpreadPredicted) + expect_equal(evOf(SpaDES.core::events(sim), "run")$eventTime, 5) +}) + +test_that("the prediction follows the covariates from year to year", { + sim <- toySim(times = list(start = 1, end = 1)) + sim <- SpaDES.core::spades(sim, debug = FALSE) + expect_equal(predVals(sim)[4], 0.2491969, tolerance = 1e-6) + ## next year's covariates: cell 4 becomes young, with no fuel and MDC 0 -> x = -0.5 + covs <- toyCovariates() + for (cn in c("MDC", "fuelA")) setCov(covs, 4L, cn, 0) + setCov(covs, 4L, "youngAge", 1) + sim$fireSense_SpreadCovariates <- covs + SpaDES.core::end(sim) <- 2 + sim <- SpaDES.core::spades(sim, debug = FALSE) + ## 0.13 + 0.12 / (1 + exp(1)) = 0.13 + 0.12 * 0.2689414 = 0.1622730 + expect_equal(predVals(sim)[4], 0.1622730, tolerance = 1e-6) + expect_equal(predVals(sim)[1], 0.19, tolerance = 1e-7) +}) diff --git a/tests/testthat/test-failures.R b/tests/testthat/test-failures.R new file mode 100644 index 0000000..7d96297 --- /dev/null +++ b/tests/testthat/test-failures.R @@ -0,0 +1,35 @@ +## Failure paths of the run event, with the message each one gives. + +test_that("a formula term that is not a covariate column stops, naming the term", { + ins <- toyInputs(formula = "~ MDC + youngAge + fuelA + fuelZ - 1") + expect_error(toyRun(ins), "'fuelZ' not found in data objects") +}) + +test_that("several missing terms are counted in the message", { + ins <- toyInputs(formula = "~ MDC + fuelY + fuelZ + fuelW - 1") + expect_error(toyRun(ins), "'fuelY' \\(and 2 others\\) not found in data objects") + ins <- toyInputs(formula = "~ MDC + fuelY + fuelZ - 1") + expect_error(toyRun(ins), "'fuelY' \\(and 1 other\\) not found in data objects") +}) + +test_that("a response on the left of the formula is ignored", { + ins <- toyInputs(formula = "fires ~ MDC + youngAge + fuelA - 1") + expect_equal(predVals(toyRun(ins))[1], 0.19, tolerance = 1e-7) +}) + +test_that("no fitted parameters stops with an explanation that names the run", { + ins <- toyInputs() + ins$studyAreaWithSpreadParams <- NULL + expect_error(toyRun(ins), "holds no fitted spread parameters for this run \\(unknown\\)") + + ins <- toyInputs() + ins$studyAreaWithSpreadParams$params <- list(toyParams()[0, ]) + ins$.runName <- "toyRunName" + expect_error(toyRun(ins), "holds no fitted spread parameters for this run \\(toyRunName\\)") +}) + +test_that("a missing spread formula stops", { + ins <- toyInputs() + ins$fireSense_spreadFormula <- NULL + expect_error(toyRun(ins), "argument is not a valid model") +}) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index d11836a..e60e49a 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -33,12 +33,34 @@ test_that("outputs are the expected names and classes", { ) }) -test_that("parameters are the expected names", { +## deparsed defaults, so that a changed default fails as loudly as a renamed parameter +paramTable <- function(md) { + p <- md$parameters + out <- data.frame( + class = as.character(unlist(p$paramClass)), + default = vapply(p$default, function(d) paste(deparse(as.vector(d)), collapse = ""), ""), + row.names = p$paramName + ) + out[order(rownames(out), method = "radix"), ] # C order, whatever the locale +} + +test_that("parameters have the expected names, classes and defaults", { md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) - expect_identical( - sort(md$parameters$paramName), - sort(c(".runInitialTime", ".runInterval", ".saveInitialTime", ".saveInterval", - ".useCache", "coefToUse", "lowerSpreadProb", "maxFireSpread", - "mutuallyExclusiveCols")) + expected <- data.frame( + class = c("numeric", "numeric", "numeric", "numeric", "logical", "character", + "numeric", "numeric", "list"), + ## .runInitialTime defaults to start(sim), which is 0 when only metadata is parsed + default = c("0", "1", "NA", "NA", "FALSE", "\"meanCoef\"", + "0.13", "0.28", "list(youngAge = \"fuels\")"), + row.names = c(".runInitialTime", ".runInterval", ".saveInitialTime", ".saveInterval", + ".useCache", "coefToUse", "lowerSpreadProb", "maxFireSpread", + "mutuallyExclusiveCols") ) + expect_identical(paramTable(md), expected) +}) + +test_that("fireSenseUtils is a declared dependency, so CI installs it", { + md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) + expect_true(any(grepl("^PredictiveEcology/fireSenseUtils@development", unlist(md$reqdPkgs)))) + expect_identical(md$timeunit, "year") }) diff --git a/tests/testthat/test-spreadProb-values.R b/tests/testthat/test-spreadProb-values.R new file mode 100644 index 0000000..c8230d3 --- /dev/null +++ b/tests/testthat/test-spreadProb-values.R @@ -0,0 +1,162 @@ +## Exact predicted values from a toy fitted model and toy covariates. +## +## The run event (1) turns covariates into integers x 1000, (2) rescales each to [0, 1] with +## the FIT's min/max in `covMinMax_spread`, (3) takes the linear combination with the fitted +## coefficients, (4) puts it through the logistic, (5) averages over parameter rows, and +## (6) writes the values to the cells given by `pixelID`. + +test_that("spread probability is the logistic of covariates rescaled with the fit's min/max", { + sim <- toyRun() + v <- predVals(sim) + + ## Rescaled covariates: MDC / 200, youngAge / 1, fuelA / 8. + ## x = 1.5 * MDC/200 - 0.5 * youngAge + 1 * fuelA/8 + ## cell 1: MDC 0, YA 0, fuelA 0 -> x = 0 -> 0.13 + 0.12 / 2 = 0.19 + ## cell 2: MDC 50, YA 1, fuelA 0 -> x = 0.375 - 0.5 = -0.125 + ## cell 3: MDC 100, YA 0, fuelA 4 -> x = 0.75 + 0.5 = 1.25 + ## cell 4: MDC 200, YA 0, fuelA 8 -> x = 1.5 + 1 = 2.5 + ## cell 6: MDC 100, YA 0, fuelA 2 -> x = 0.75 + 0.25 = 1 + ## cell 7: MDC 150, YA 0, fuelA 0 -> x = 1.125 + ## cell 8: MDC 100, YA 1, fuelA 8 -> x = 0.75 - 0.5 + 1 = 1.25 + expect_equal(v[1], 0.19, tolerance = 1e-7) + ## 0.13 + 0.12 / (1 + exp(0.25)) = 0.13 + 0.12 * 0.4378235 = 0.1825388 + expect_equal(v[2], 0.1825388, tolerance = 1e-6) + ## 0.13 + 0.12 / (1 + exp(-2.5)) = 0.13 + 0.12 * 0.9241418 = 0.2408970 + expect_equal(v[3], 0.2408970, tolerance = 1e-6) + ## 0.13 + 0.12 / (1 + exp(-5)) = 0.13 + 0.12 * 0.9933071 = 0.2491969 + expect_equal(v[4], 0.2491969, tolerance = 1e-6) + expect_equal(v[c(6, 7, 8)], handLogistic3(c(1, 1.125, 1.25)), tolerance = 1e-7) + ## cells 3 and 8 have different covariates but the same linear predictor + expect_equal(v[3], v[8], tolerance = 1e-12) +}) + +test_that("covariates are NOT rescaled to the range of the prediction data", { + ## Drop the MDC = 0 and MDC = 200 rows: MDC now spans 50..150 in the prediction data. + ## Rescaled to its own range, MDC = 50 would become 0 and cell 2 would get + ## x = -0.5 -> 0.1622729. With the fit's 0..200 it is x = -0.125 -> 0.1825388. + covs <- toyCovariates() + covs <- covs[which(covs$MDC > 0 & covs$MDC < 200), ] + sim <- toyRun(toyInputs(covs = covs)) + v <- predVals(sim) + expect_equal(v[2], 0.1825388, tolerance = 1e-6) + expect_gt(abs(v[2] - 0.1622729), 0.02) + ## MDC = 150 stays at 0.75 (own range would make it 1): x = 1.125 + expect_equal(v[7], handLogistic3(1.125), tolerance = 1e-7) +}) + +test_that("a covMinMax that does not start at zero shifts as well as scales", { + ins <- toyInputs() + ins$covMinMax_spread$MDC <- c(100, 300) + ## cell 4: MDC 200 -> (200 - 100) / 200 = 0.5 -> x = 0.75 + 1 = 1.75 + ## cell 7: MDC 150 -> 0.25 -> x = 0.375 + v <- predVals(toyRun(ins)) + expect_equal(v[c(4, 7)], handLogistic3(c(1.75, 0.375)), tolerance = 1e-7) +}) + +test_that("values land in the cells named by pixelID; all other cells are NA", { + sim <- toyRun() + v <- predVals(sim) + expect_identical(which(!is.na(v)), c(1L, 2L, 3L, 4L, 6L, 7L, 8L)) + expect_true(all(is.na(v[c(5, 9)]))) + ## same grid as flammableRTM + expect_true(terra::compareGeom(sim$fireSense_SpreadPredicted, sim$flammableRTM)) + expect_identical(terra::nlyr(sim$fireSense_SpreadPredicted), 1) +}) + +test_that("row order of the covariate table does not matter", { + covs <- toyCovariates() + a <- predVals(toyRun(toyInputs(covs = covs[order(covs$pixelID), ]))) + b <- predVals(toyRun(toyInputs(covs = covs[order(-covs$pixelID), ]))) + expect_equal(a, b, tolerance = 1e-12) + expect_equal(a[1], 0.19, tolerance = 1e-7) +}) + +test_that("the run event leaves sim$fireSense_SpreadCovariates untouched", { + sim <- toyRun() + ## the x 1000 integer conversion is done by reference, so it must be done on a copy + expect_equal(sim$fireSense_SpreadCovariates, toyCovariates()) + expect_identical(sim$fireSense_SpreadCovariates$MDC, c(150, 0, 100, 50, 100, 200, 100)) +}) + +test_that("covariates are rounded to 3 decimals by the x 1000 integer step", { + covs <- toyCovariates() + setCov(covs, 1L, "youngAge", 0.1236) # -> 124L -> 0.124 + setCov(covs, 7L, "youngAge", 0.1234) # -> 123L -> 0.123 + v <- predVals(toyRun(toyInputs(covs = covs))) + ## cell 1: x = -0.5 * 0.124 = -0.062 ; cell 7: x = 1.125 - 0.5 * 0.123 = 1.0635 + expect_equal(v[1], handLogistic3(-0.062), tolerance = 1e-9) + expect_equal(v[7], handLogistic3(1.0635), tolerance = 1e-9) + ## and not the unrounded value, which differs in the 5th decimal + expect_gt(abs(v[1] - handLogistic3(-0.5 * 0.1236)), 1e-6) +}) + +test_that("the prediction is the mean over parameter rows", { + p <- rbind(toyParams(), toyParams()) + p$maxAsymptote <- c(0.25, 0.35) + p$MDC <- c(1.5, 0) + v <- predVals(toyRun(toyInputs(params = p))) + ## cell 1, x = 0 for both rows: (0.13 + 0.12/2 + 0.13 + 0.22/2) / 2 = (0.19 + 0.24) / 2 + expect_equal(v[1], 0.215, tolerance = 1e-7) + ## cell 7 (MDC 150, no fuel): row 1 x = 1.125; row 2 has no MDC effect, x = 0 -> 0.24 + expect_equal(v[7], (handLogistic3(1.125) + 0.24) / 2, tolerance = 1e-7) +}) + +test_that("a single parameter row and a single pixel both work", { + covs <- toyCovariates() + covs <- covs[which(covs$pixelID == 3L), ] + v <- predVals(toyRun(toyInputs(covs = covs))) + expect_identical(which(!is.na(v)), 3L) + expect_equal(v[3], 0.2408970, tolerance = 1e-6) +}) + +test_that("coefficients are matched to covariates by name, not by position", { + p <- toyParams()[, c("maxAsymptote", "hillSlope1", "inflectionPoint1", "fuelA", "youngAge", "MDC")] + v <- predVals(toyRun(toyInputs(params = p))) + expect_equal(v[c(2, 3, 4)], c(0.1825388, 0.2408970, 0.2491969), tolerance = 1e-6) +}) + +test_that("two logistic parameters use the 2-parameter logistic (shape fixed at 0.5)", { + p <- toyParams() + p$inflectionPoint1 <- NULL + v <- predVals(toyRun(toyInputs(params = p))) + ## cell 1, x = 0: 0.13 + 0.12 / sqrt(2) = 0.2148528 + expect_equal(v[1], 0.2148528, tolerance = 1e-6) + ## cell 4, x = 2.5: 0.13 + 0.12 / sqrt(1 + exp(-5)) = 0.2495964 + expect_equal(v[4], 0.13 + 0.12 / sqrt(1 + exp(-5)), tolerance = 1e-7) +}) + +test_that("the shape parameter of the 3-parameter logistic is used", { + p <- toyParams() + p$inflectionPoint1 <- 2 + v <- predVals(toyRun(toyInputs(params = p))) + ## cell 1, x = 0: 0.13 + 0.12 / 2^2 = 0.16 + expect_equal(v[1], 0.16, tolerance = 1e-7) +}) + +test_that("lowerSpreadProb is the lower asymptote", { + v <- predVals(toyRun(params = list(lowerSpreadProb = 0.05))) + ## cell 1, x = 0: 0.05 + (0.25 - 0.05) / 2 = 0.15 + expect_equal(v[1], 0.15, tolerance = 1e-7) + ## strongly negative x tends to the lower asymptote: make MDC's coefficient -40 + p <- toyParams(); p$MDC <- -40 + v <- predVals(toyRun(toyInputs(params = p), params = list(lowerSpreadProb = 0.05))) + ## cell 4: x = -40 + 1 = -39 -> 0.05 + 0.2 / (1 + exp(78)) = 0.05 to 1e-12 + expect_equal(v[4], 0.05, tolerance = 1e-9) +}) + +test_that("maxFireSpread does not change the prediction", { + a <- predVals(toyRun(params = list(maxFireSpread = 0.28))) + b <- predVals(toyRun(params = list(maxFireSpread = 0.20))) + expect_identical(a, b) + expect_equal(a[4], 0.2491969, tolerance = 1e-6) # above 0.20: not capped +}) + +test_that("a covariate with no fitted coefficient is dropped with a warning", { + covs <- toyCovariates() + data.table::set(covs, NULL, "fuelB", 5) + ins <- toyInputs(covs = covs) + ins$covMinMax_spread$fuelB <- c(0, 10) + expect_warning(sim <- toyRun(ins), "fuelB\\s+\\.\\.\\.that are not in the sim\\$studyAreaWithSpreadParams") + ## fuelB contributes nothing + expect_equal(predVals(sim)[c(1, 3)], c(0.19, 0.2408970), tolerance = 1e-6) +}) From 2d9f7180fe487db5c2fb56af45716fd85ed4156f Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Sun, 20 Sep 2026 19:52:04 -0700 Subject: [PATCH 3/3] Remove unread parameters and input; make the save event do nothing Removed parameters coefToUse, mutuallyExclusiveCols and .saveInterval, and input fireSense_SpreadFitted: nothing reads them. The save event called spreadPredictSave(), which does not exist; it now only emits a message. Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_013B4sgRg9EwyHaAQdDzUaQW --- fireSense_SpreadPredict.R | 19 +++---------------- fireSense_SpreadPredict.Rmd | 2 +- tests/testthat/test-events.R | 13 +++++++++++++ tests/testthat/test-metadata.R | 12 ++++-------- 4 files changed, 21 insertions(+), 25 deletions(-) diff --git a/fireSense_SpreadPredict.R b/fireSense_SpreadPredict.R index 3ac942a..e1f1326 100644 --- a/fireSense_SpreadPredict.R +++ b/fireSense_SpreadPredict.R @@ -19,24 +19,17 @@ defineModule(sim, list( "ggplot2", "viridis", "PredictiveEcology/fireSenseUtils@development (>= 0.1.0)"), parameters = bindrows( - defineParameter(name = "coefToUse", class = "character", default = "meanCoef", - desc = paste("Not used. Predictions are the mean over all parameter sets in", - "`studyAreaWithSpreadParams`.")), defineParameter(name = "lowerSpreadProb", class = "numeric", default = 0.13, desc = "Lower asymptote of the 2- and 3-parameter logistic."), defineParameter("maxFireSpread", "numeric", default = 0.28, desc = paste("Upper limit on `spreadProb` used when fitting. Here it is only checked", "to be the same in every module that defines it.")), - defineParameter(name = "mutuallyExclusiveCols", "list", default = list("youngAge" = "fuels"), NA, NA, - desc = "Not used; mutual exclusion is done in `fireSense_dataPrepPredict`."), defineParameter(name = ".runInitialTime", class = "numeric", default = start(sim), desc = "Time of the first prediction."), defineParameter(name = ".runInterval", class = "numeric", default = 1, desc = "Interval between predictions, in years. `NA` predicts once."), defineParameter(name = ".saveInitialTime", class = "numeric", default = NA, - desc = "Time of the first `save` event. `NA` means never."), - defineParameter(name = ".saveInterval", class = "numeric", default = NA, - desc = "Interval between `save` events."), + desc = "Time of the `save` event, which does nothing. `NA` means never."), defineParameter(".useCache", "logical", FALSE, NA, NA, paste("Should this entire module be run with caching activated?", "This is generally intended for data-type modules, where stochasticity and time are not relevant")) @@ -48,8 +41,6 @@ defineModule(sim, list( expectsInput(objectName = "fireSense_SpreadCovariates", objectClass = "data.table", desc = paste("This year's covariates, from `fireSense_dataPrepPredict`.", "`pixelID` is the cell index of `flammableRTM`.")), - expectsInput(objectName = "fireSense_SpreadFitted", objectClass = "fireSense_SpreadFit", - desc = "Not used. The fitted parameters are read from `studyAreaWithSpreadParams`."), expectsInput(objectName = "flammableRTM", objectClass = "SpatRaster", sourceURL = NA, desc = "Binary raster, 1 where the pixel is flammable. Template for `fireSense_SpreadPredicted`.") ), @@ -61,7 +52,7 @@ defineModule(sim, list( #' Event dispatcher #' -#' Events: `init`, `run` (predict, repeated every `.runInterval`), `save`. +#' Events: `init`, `run` (predict, repeated every `.runInterval`), `save` (does nothing). #' #' @param sim A `simList`. #' @param eventTime Time of the event. @@ -95,11 +86,7 @@ doEvent.fireSense_SpreadPredict <- function(sim, eventTime, eventType, debug = F } }, save = { - sim <- spreadPredictSave(sim) - - if (!is.na(P(sim)$.saveInterval)) { - sim <- scheduleEvent(sim, time(sim) + P(sim)$.saveInterval, moduleName, "save", .last()) - } + message("fireSense_SpreadPredict: the save event does nothing") }, warning(paste("Undefined event type: '", current(sim)[1, "eventType", with = FALSE], "' in module '", current(sim)[1, "moduleName", with = FALSE], "'", diff --git a/fireSense_SpreadPredict.Rmd b/fireSense_SpreadPredict.Rmd index 3e19807..057c57f 100644 --- a/fireSense_SpreadPredict.Rmd +++ b/fireSense_SpreadPredict.Rmd @@ -79,7 +79,7 @@ knitr::kable(df_params, caption = "List of (ref:fireSense-SpreadPredict) paramet - `init`: checks `maxFireSpread` against the other modules; schedules `run` at `.runInitialTime`, and `save` at `.saveInitialTime` if that is not `NA`. - `run`: makes the prediction described above; repeats every `.runInterval`. -- `save`: calls `spreadPredictSave()`, which does not exist, so it currently fails. Leave `.saveInitialTime` as `NA`. +- `save`: does nothing, and says so in a message. The module does not plot anything. diff --git a/tests/testthat/test-events.R b/tests/testthat/test-events.R index 4122469..78d1a47 100644 --- a/tests/testthat/test-events.R +++ b/tests/testthat/test-events.R @@ -33,6 +33,19 @@ test_that("no save event is scheduled when .saveInitialTime is NA (the default)" expect_identical(nrow(evOf(SpaDES.core::events(sim), "save")), 0L) }) +test_that("the save event says it does nothing, and leaves sim as it was", { + ref <- toyRun(times = list(start = 1, end = 2)) + expect_message( + sim <- toyRun(params = list(.saveInitialTime = 1), times = list(start = 1, end = 2)), + "the save event does nothing", fixed = TRUE + ) + expect_equal(evOf(SpaDES.core::completed(sim), "save")$eventTime, 1) + ## same objects, same prediction, same queue: it is not rescheduled either + expect_identical(sort(ls(sim)), sort(ls(ref))) + expect_identical(predVals(sim), predVals(ref)) + expect_identical(as.data.frame(SpaDES.core::events(sim)), as.data.frame(SpaDES.core::events(ref))) +}) + test_that("nothing is predicted before the first run event", { sim <- toyRun(params = list(.runInitialTime = 5), times = list(start = 1, end = 2)) expect_null(sim$fireSense_SpreadPredicted) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index e60e49a..90f3616 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -19,7 +19,6 @@ test_that("inputs are the expected names and classes", { inputs[order(names(inputs))], c(covMinMax_spread = "data.table", fireSense_SpreadCovariates = "data.table", - fireSense_SpreadFitted = "fireSense_SpreadFit", flammableRTM = "SpatRaster") ) }) @@ -47,14 +46,11 @@ paramTable <- function(md) { test_that("parameters have the expected names, classes and defaults", { md <- SpaDES.core::moduleMetadata(module = moduleName, path = modulePath) expected <- data.frame( - class = c("numeric", "numeric", "numeric", "numeric", "logical", "character", - "numeric", "numeric", "list"), + class = c("numeric", "numeric", "numeric", "logical", "numeric", "numeric"), ## .runInitialTime defaults to start(sim), which is 0 when only metadata is parsed - default = c("0", "1", "NA", "NA", "FALSE", "\"meanCoef\"", - "0.13", "0.28", "list(youngAge = \"fuels\")"), - row.names = c(".runInitialTime", ".runInterval", ".saveInitialTime", ".saveInterval", - ".useCache", "coefToUse", "lowerSpreadProb", "maxFireSpread", - "mutuallyExclusiveCols") + default = c("0", "1", "NA", "FALSE", "0.13", "0.28"), + row.names = c(".runInitialTime", ".runInterval", ".saveInitialTime", ".useCache", + "lowerSpreadProb", "maxFireSpread") ) expect_identical(paramTable(md), expected) })