From 639f364772f17b3f8e077f41ab928980ffbfcd1c Mon Sep 17 00:00:00 2001 From: Eliot McIntire Date: Thu, 15 Oct 2026 12:56:56 -0700 Subject: [PATCH] Predict expected ignitions and escapes only; draws move to fireSense_burn IgnitionPredictRun() predicted ignitions, drew them (rpois), predicted escapes only where one was drawn, drew escapes (rbinom) and placed ignitions on fine pixels. It now predicts both surfaces for every coarse pixel and reports the fitted objective in fireSense_IgAndEscapeDistribution. placeIgnitions(), coarseToFineMap() and fineCoarseTable() and ignitionsAndEscapes move to fireSense_burn. Co-Authored-By: Claude Opus 5.5 --- NEWS.md | 5 + fireSense_ignitionPredict.R | 206 +++++++---------------- fireSense_ignitionPredict.Rmd | 14 +- tests/testthat/setup-toyIgnition.R | 27 +-- tests/testthat/test-coarse-to-fine-map.R | 73 -------- tests/testthat/test-escaped.R | 46 ----- tests/testthat/test-events.R | 3 +- tests/testthat/test-failures.R | 23 --- tests/testthat/test-metadata.R | 5 +- tests/testthat/test-multiELF.R | 26 ++- tests/testthat/test-place-ignitions.R | 62 ------- tests/testthat/test-run-values.R | 112 +++++------- 12 files changed, 142 insertions(+), 460 deletions(-) delete mode 100644 tests/testthat/test-coarse-to-fine-map.R delete mode 100644 tests/testthat/test-escaped.R delete mode 100644 tests/testthat/test-place-ignitions.R diff --git a/NEWS.md b/NEWS.md index 6c1cf7f..85efce2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,10 @@ # fireSense_ignitionPredict (development version) +- Breaking: the module now only predicts; it draws nothing and no longer makes `ignitionsAndEscapes`. `fireSense_burn` draws the ignitions and escapes from the new `fireSense_IgAndEscapeDistribution` and `fireSense_IgAndEscapeProbRas`, and places them (`placeIgnitions()`, `coarseToFineMap()` and `fineCoarseTable()` moved there). `flammableRTM` is no longer an input. +- `fireSense_IgAndEscapeProbRas` layer `escapeProb` is the expected escapes per pixel and year for every pixel (it was NA where no ignition was drawn), no longer clamped to [0, 1]; `ignitionProb` is the expected ignitions. +- New output `fireSense_IgAndEscapeDistribution`, `list(ignition, escape)`, the objective read from the fitted models; stops if it cannot be read or folds or ELFs disagree. +- Escapes now follow the fitted Poisson model (drawn in `fireSense_burn` as Poisson, capped at the ignitions), not `rbinom(ignitions, min(mean, 1))`; a seed no longer reproduces earlier runs. + - A year with no ignitions now gives a 0-row `ignitionsAndEscapes` with the same columns and types (`pixelID`, `igProb`, `ignitions`, `escapeProb`, `escapes`, `escaped`) as any other year. Before, it had no columns, so code reading `$pixelID` got `NULL` (`fireSenseUtils::hindcastSimulated()` failed). Years with ignitions are unchanged. - `SpaDES.core` is now in `reqdPkgs` (`scheduleEvent()`, `P()`, `Plots()` are used). diff --git a/fireSense_ignitionPredict.R b/fireSense_ignitionPredict.R index 8404b8b..8ea738f 100644 --- a/fireSense_ignitionPredict.R +++ b/fireSense_ignitionPredict.R @@ -1,8 +1,8 @@ defineModule(sim, list( name = "fireSense_ignitionPredict", description = paste( - "Predicts annual ignition and escape probabilities from the models fitted by", - "fireSense_ignitionFit and fireSense_EscapeFit, and draws the pixels that ignite and escape."), + "Predicts the expected number of ignitions and of escapes per coarse pixel and year from the models fitted by", + "fireSense_ignitionFit and fireSense_EscapeFit. It draws nothing: fireSense_burn draws the ignitions and escapes."), keywords = c("fire frequency", "additive property", "poisson", "negative binomial", "fireSense"), authors = c( person("Eliot", "McIntire", email = "eliot.mcintire@nrcan-rncan.gc.ca", role = c("aut", "cre")), @@ -75,21 +75,18 @@ defineModule(sim, list( "`pixelID` is the cell index of `ignitionFitRTM`." ) ), - expectsInput("flammableRTM", "SpatRaster", - sourceURL = NA, - desc = "Binary raster, 1 where the pixel is flammable." - ), ), outputObjects = bindrows( createsOutput("fireSense_IgAndEscapeProbRas", "SpatRaster", - desc = paste("Two layers, `ignitionProb` (expected ignitions per pixel) and `escapeProb`,", - "at the resolution of `ignitionFitRTM`.") + desc = paste("Two layers at the resolution of `ignitionFitRTM`, for every pixel with covariates:", + "`ignitionProb`, the expected number of ignitions per pixel and year, and `escapeProb`,", + "the expected number of escapes per pixel and year, given at least one ignition.", + "Both are means of the fitted distributions in `fireSense_IgAndEscapeDistribution`,", + "not probabilities.") ), - createsOutput( - "ignitionsAndEscapes", "data.table", - paste("One row per ignited pixel, in random order: `pixelID` (cell index of `flammableRTM`),", - "`igProb`, `ignitions`, `escapeProb`, `escapes` of the coarse pixel it was drawn from, and", - "`escaped`, whether this ignition escaped: exactly `escapes` of a coarse pixel's rows are TRUE.") + createsOutput("fireSense_IgAndEscapeDistribution", "list", + desc = paste("`list(ignition = , escape = )`: the objective of the fitted models (e.g. `\"count:poisson\"`),", + "which says how `fireSense_burn` draws from the means in `fireSense_IgAndEscapeProbRas`.") ) ) )) @@ -132,15 +129,15 @@ doEvent.fireSense_ignitionPredict <- function(sim, eventTime, eventType, debug = return(invisible(sim)) } -#' Predict and draw this year's ignitions and escapes +#' Predict this year's expected ignitions and escapes #' -#' Averages the per-fold predictions of the ignition models, draws ignitions per coarse pixel -#' (Poisson), then does the same for escapes (binomial, given ignition). Each ignition is placed in -#' a random flammable `flammableRTM` pixel inside its coarse pixel. +#' Averages the per-fold predictions of the ignition models and of the escape models, for every coarse +#' pixel with covariates. Nothing is drawn: `fireSense_burn` draws ignitions and escapes from these means, +#' with the distribution named in `fireSense_IgAndEscapeDistribution`. #' #' @param sim A `simList`. #' -#' @return The `simList`, invisibly, with `fireSense_IgAndEscapeProbRas` and `ignitionsAndEscapes`. +#' @return The `simList`, invisibly, with `fireSense_IgAndEscapeProbRas` and `fireSense_IgAndEscapeDistribution`. IgnitionPredictRun <- function(sim) { igCov <- copy(sim$fireSense_igAndEscapePred_Covariates) @@ -151,56 +148,29 @@ IgnitionPredictRun <- function(sim) { # The models were fitted on covariates standardized once, over all fitting years; a year's # own mean and sd would make every year look average. ## The fitted models: one ignition and one escape fit, or one of each per fitted ELF (named by ELF), each - ## applied to the coarse pixels of its own ELF (sim$rasterToMatchLargeELF). The Poisson and binomial draws - ## are made once over all pixels, as before, so one ELF gives exactly the old result. + ## applied to the coarse pixels of its own ELF (sim$rasterToMatchLargeELF). fits <- ignitionFitsByELF(sim, igCov$pixelID) + sim$fireSense_IgAndEscapeDistribution <- list(ignition = fitObjective(fits, "ign"), + escape = fitObjective(fits, "esc")) - # From here, it makes predictions from each KFold, then averages them to get the probabilities for - # each cell; same for Escape, which is conditional on having ignited. - predsIgns <- rep(NA_real_, NROW(igCov)) + # From here, it makes predictions from each KFold, then averages them to get the expected counts for + # each cell; same for Escape (expected escapes given an ignition), for every cell. + predsIgns <- predsEscs <- rep(NA_real_, NROW(igCov)) for (f in fits) { covsHere <- igCov[f$rows] # The models were fitted on covariates standardized once, over all fitting years; a year's # own mean and sd would make every year look average. - if (rescaleVars) covsHere <- scaleAsFit(covsHere, f$ign$scaleData, "fireSense_IgnitionFitted") - predsIgns[f$rows] <- foldMeanPrediction(f$ign, covsHere) - } - igns <- rpois(NROW(predsIgns), lambda = predsIgns) # can't use rtweedie because don't know the dispersion parameter - - whHasIgns <- which(igns > 0) - predsEscs <- rep(NA_real_, NROW(igCov)) - for (f in fits) { - rowsEsc <- intersect(whHasIgns, f$rows) - covsHere <- igCov[rowsEsc] - if (rescaleVars) covsHere <- scaleAsFit(covsHere, f$esc$scaleData, "fireSense_EscapeFitted") - # the escape model is tweedie, so can go above 1, below 0 rarely - predsEscs[rowsEsc] <- foldMeanPrediction(f$esc, covsHere, clamp01 = TRUE) + covsIgn <- if (rescaleVars) scaleAsFit(covsHere, f$ign$scaleData, "fireSense_IgnitionFitted") else covsHere + covsEsc <- if (rescaleVars) scaleAsFit(covsHere, f$esc$scaleData, "fireSense_EscapeFitted") else covsHere + predsIgns[f$rows] <- foldMeanPrediction(f$ign, covsIgn) + predsEscs[f$rows] <- foldMeanPrediction(f$esc, covsEsc) } - predsEscs <- predsEscs[whHasIgns] - escs <- rbinom(NROW(predsEscs), size = igns[whHasIgns], prob = predsEscs) - - set(igCov, NULL, c("igProb", "ignitions"), list(predsIgns, igns)) - set(igCov, whHasIgns, c("escapeProb", "escapes"), list(predsEscs, escs)) - # Ignite - accounting for spatial resolution of models - - # disaggregate the coarse raster to size of flammableRTM - # draw ignitions/escapes from smaller pixel size - # The fine-to-coarse cell mapping does not change within a run, so it is computed once (in mod$). - igRasDT <- fineCoarseTable(coarseToFineMap(sim$ignitionFitRTM, sim$flammableRTM, store = mod), - sim$flammableRTM) - # nomatch = NULL --> removes pixels that aren't in igCov, which are non flammable - igs <- igRasDT[igCov, on = c("chunkyPixels" = "pixelID"), nomatch = NULL] - # randomly sample - # use unique because of multiple pixelID per chunkyPixel - drawTable <- unique(igs[ignitions > 0, .(chunkyPixels, ignitions, escapes)]) - pixelID_igs <- placeIgnitions(igs, drawTable) - - #for posterior analysis + #for posterior analysis, and for fireSense_burn to draw from igProbRas <- rast(sim$ignitionFitRTM) - igProbRas[igCov$pixelID] <- igCov$igProb + igProbRas[igCov$pixelID] <- predsIgns escapeProbRas <- igProbRas - escapeProbRas[igCov$pixelID] <- igCov$escapeProb + escapeProbRas[igCov$pixelID] <- predsEscs sim$fireSense_IgAndEscapeProbRas <- c(igProbRas, escapeProbRas) names(sim$fireSense_IgAndEscapeProbRas) <- c("ignitionProb", "escapeProb") @@ -208,17 +178,6 @@ IgnitionPredictRun <- function(sim) { #TODO: implement proper plotting control Plots(igProbRas, types = Par$.plots, filename = paste0("IgnitionProbability_yr", time(sim))) } - ## `escapes` counts the coarse pixel's escapes and is repeated on each of its ignitions, so which of - ## them escaped is drawn here: exactly `escapes` of the coarse pixel's rows. Drawn after every pixel - ## is placed, so the placements do not change. - if (NROW(pixelID_igs)) { - pixelID_igs[, escaped := seq_len(.N) %in% sample.int(.N, min(escapes[1], .N)), by = "chunkyPixels"] - } else { - set(pixelID_igs, NULL, "escaped", logical(0)) - } - set(pixelID_igs, NULL, "chunkyPixels", NULL) - randomOrder <- sample.int(nrow(pixelID_igs)) # sample(1:0) would give 2 rows - sim$ignitionsAndEscapes <- pixelID_igs[randomOrder,] #Randomize order return(invisible(sim)) } @@ -260,7 +219,7 @@ scaleAsFit <- function(covariates, scaleData, fittedName) { #' #' @param sim A `simList`. #' @param pixelID the cells of `sim$ignitionFitRTM` to predict. -#' @return list, one element per fit, each with `ign`, `esc` and `rows` (indices into `pixelID`). +#' @return list, one element per fit, each with `ign`, `esc`, `rows` (indices into `pixelID`) and `elf` (its name). ignitionFitsByELF <- function(sim, pixelID) { ignL <- sim$fireSense_IgnitionFittedList if (length(ignL) > 1L) { @@ -280,91 +239,52 @@ ignitionFitsByELF <- function(sim, pixelID) { warning("fireSense_ignitionPredict: ", noELF, " coarse pixels are in no ELF with an ignition fit; ", "they get no ignitions", call. = FALSE) return(lapply(names(ignL), function(id) - list(ign = ignL[[id]], esc = escL[[id]], rows = which(elf == id)))) + list(ign = ignL[[id]], esc = escL[[id]], rows = which(elf == id), elf = id))) } list(list(ign = sim$fireSense_IgnitionFitted, esc = sim$fireSense_EscapeFitted, - rows = seq_along(pixelID))) + rows = seq_along(pixelID), elf = "(one fit)")) } -## Mean over the K-fold models of one fit's predictions -foldMeanPrediction <- function(fit, newdata, clamp01 = FALSE) { +## The K-fold models of one fit: those whose name contains "Fold" +foldModels <- function(fit) { mods <- fit$modelList$model modsOnly <- mods[grep("Fold", names(mods))] if (is.null(modsOnly) || !length(modsOnly)) stop("Not tested anymore") - preds <- lapply(modsOnly, function(model) { - p <- predict(model, newdata = newdata) - if (clamp01) pmax(pmin(1, p), 0) else p - }) - rowMeans(do.call(cbind, preds)) -} - -#' Which coarse cell each fine cell falls in -#' -#' Regridding the coarse ignition raster onto `flammableRTM` ("near", because the cells may not be -#' round multiples) took about 3 s a year at 6.7M cells, and the mapping never changes within a run. -#' It is computed once, from the coarse cell numbers, and kept in `store`; it is rebuilt if the extent, -#' dimensions or crs of either raster change. -#' -#' @param coarse,fine `SpatRaster`s: `ignitionFitRTM` and `flammableRTM`. -#' @param store An environment to keep the mapping in (the module's `mod`). -#' -#' @return A vector with one element per fine cell: its coarse cell number, `NA` outside the coarse raster. -coarseToFineMap <- function(coarse, fine, store) { - gridKey <- function(r) list(as.vector(terra::ext(r)), dim(r), terra::crs(r)) - key <- list(gridKey(coarse), gridKey(fine)) - if (!is.null(store$coarseToFine) && identical(store$coarseToFine$key, key)) - return(store$coarseToFine$map) - - coarseIds <- rast(coarse) - coarseIds[] <- seq_len(ncell(coarseIds)) - coarseIds <- postProcess(coarseIds, to = fine, method = "near") - map <- as.vector(terra::values(coarseIds, mat = FALSE)) - store$coarseToFine <- list(key = key, map = map) - map + modsOnly } -#' The fine cells and their coarse cells, for one year -#' -#' @param map The result of `coarseToFineMap()`. -#' @param fine `flammableRTM`: cells not equal to 1 are left out. -#' -#' @return A `data.table` with `pixelID` (fine cell) and `chunkyPixels` (coarse cell). -fineCoarseTable <- function(map, fine) { - flam <- fine[] - keep <- which(!is.na(map) & !(!is.na(flam) & flam != 1)) - data.table(pixelID = keep, chunkyPixels = map[keep]) +## Mean over the K-fold models of one fit's predictions; a count is not below 0 +foldMeanPrediction <- function(fit, newdata) { + preds <- lapply(foldModels(fit), function(model) pmax(predict(model, newdata = newdata), 0)) + rowMeans(do.call(cbind, preds)) } -#' Place each coarse pixel's ignitions on its fine pixels -#' -#' For each row of `drawTable`, draws `ignitions` of the fine pixels of that coarse pixel and returns -#' their rows of `igs`, in `igs` row order. One `split()` of the candidate rows and a pixelID-to-row -#' lookup replace a scan of all of `igs` for every ignited coarse pixel. +#' The objective the fitted models were fitted with #' -#' The `sample()` calls are made in `drawTable` order, on the candidate `pixelID`s in `igs` order. This -#' includes the `sample(x, size)` behaviour for a single candidate `x`, which draws from `1:x`; the -#' pixels with those IDs are then returned, wherever they are. That quirk is kept so results do not change. +#' `fireSense_burn` draws from the predicted means with the distribution this implies, so every fold of +#' every ELF must have been fitted with the same one. #' -#' @param igs `data.table` of fine pixels with `pixelID`, `igProb`, `ignitions`, `escapeProb`, `escapes` -#' and `chunkyPixels` (the coarse pixel). -#' @param drawTable `data.table` with one row per ignited coarse pixel: `chunkyPixels`, `ignitions`. +#' @param fits The result of `ignitionFitsByELF()`. +#' @param process `"ign"` (ignition) or `"esc"` (escape). #' -#' @return A `data.table` with the `igs` columns `pixelID`, `igProb`, `ignitions`, `escapeProb`, -#' `escapes`, `chunkyPixels`, for the drawn pixels. -placeIgnitions <- function(igs, drawTable) { - sel <- which(igs$chunkyPixels %in% drawTable$chunkyPixels) - rowsByChunk <- split(sel, igs$chunkyPixels[sel]) - rowOfPixel <- integer(max(igs$pixelID, 0L)) - rowOfPixel[igs$pixelID] <- seq_len(nrow(igs)) - cols <- c("pixelID", "igProb", "ignitions", "escapeProb", "escapes", "chunkyPixels") - out <- vector("list", nrow(drawTable)) - for (i in seq_len(nrow(drawTable))) { - rows <- rowsByChunk[[as.character(drawTable$chunkyPixels[i])]] - drawn <- sample(igs$pixelID[rows], size = drawTable$ignitions[i]) - hit <- rowOfPixel[drawn[drawn >= 1 & drawn <= length(rowOfPixel)]] - out[[i]] <- igs[sort(hit[hit > 0]), ..cols] - } - ## no ignited coarse pixel: rbindlist(list()) has no columns, so keep the schema of a normal year - if (!length(out)) return(igs[integer(0), ..cols]) - rbindlist(out) +#' @return The objective, e.g. `"count:poisson"`. +fitObjective <- function(fits, process) { + what <- c(ign = "ignition", esc = "escape")[[process]] + perELF <- lapply(fits, function(f) { + obj <- vapply(foldModels(f[[process]]), function(model) { + o <- tryCatch(model$params$objective, error = function(e) NULL) + if (!is.character(o) || length(o) != 1L || is.na(o)) + stop("fireSense_ignitionPredict: cannot read the objective of a fitted ", what, + " model (`model$params$objective`); fireSense_burn needs it to draw from the predictions") + o + }, "") + if (length(unique(obj)) > 1L) + stop("fireSense_ignitionPredict: the folds of the ", what, " model of ELF ", f$elf, + " have different objectives: ", paste(unique(obj), collapse = ", ")) + obj[[1L]] + }) + if (length(unique(unlist(perELF))) > 1L) + stop("fireSense_ignitionPredict: the ELFs' ", what, " models have different objectives: ", + paste0(vapply(fits, `[[`, "", "elf"), " (", unlist(perELF), ")", collapse = ", ")) + perELF[[1L]] } diff --git a/fireSense_ignitionPredict.Rmd b/fireSense_ignitionPredict.Rmd index 2f559b1..86e022a 100644 --- a/fireSense_ignitionPredict.Rmd +++ b/fireSense_ignitionPredict.Rmd @@ -45,12 +45,12 @@ download.file(url = "https://img.shields.io/badge/Made%20with-Markdown-1f425f.pn ### Module summary -Each year, predicts ignitions and escapes from the models fitted by *fireSense_ignitionFit* and *fireSense_EscapeFit*, for the ignition component of fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019]. +Each year, predicts the expected number of ignitions and of escapes from the models fitted by *fireSense_ignitionFit* and *fireSense_EscapeFit*, for the ignition component of fireSense [@Marchal:2017a; @Marchal:2017b; @Marchal:2019]. 1. The covariates in `fireSense_igAndEscapePred_Covariates` are rescaled with `fireSenseUtils::prepareCovariatesOuter()`, the function used for fitting (`rescaleVars`, `modelAlgorithm`). -2. Expected ignitions per coarse pixel are the mean of the predictions of the per-fold ignition models; the number of ignitions is drawn from a Poisson. -3. For coarse pixels with ignitions, the escape probability is the mean of the per-fold escape models, clamped to [0, 1]; escapes are drawn from a binomial with size = ignitions. -4. Each ignition is placed in a randomly chosen flammable pixel of `flammableRTM` inside its coarse pixel. +2. Expected ignitions per coarse pixel are the mean of the predictions of the per-fold ignition models. +3. Expected escapes per coarse pixel (given an ignition) are the mean of the per-fold escape models, for every pixel. Predictions below 0 are made 0. +4. The objective the models were fitted with is passed on in `fireSense_IgAndEscapeDistribution`. Nothing is drawn here: *fireSense_burn* draws the ignitions and escapes, places them and spreads the fires. Only `xgboost` models are supported. @@ -80,12 +80,12 @@ knitr::kable(df_params, caption = "List of (ref:fireSense-ignitionPredict) param ### Events - `init`: schedules `run` at `.runInitialTime`, and `save` at `.saveInitialTime` if that is not `NA`. -- `run`: makes the predictions and draws described above; repeats every `.runInterval`. +- `run`: makes the predictions described above; repeats every `.runInterval`. - `save`: does nothing but say so. To save the predicted raster, name `fireSense_IgAndEscapeProbRas` in `outputs(sim)`. ### Plotting -If `.saveInterval` is not `NA`, the ignition probability raster is plotted each year with `Plots()`. +If `.saveInterval` is not `NA`, the expected-ignitions raster is plotted each year with `Plots()`. ### Module outputs @@ -99,7 +99,7 @@ knitr::kable(df_outputs, caption = "List of (ref:fireSense-ignitionPredict) outp ### Links to other modules -Runs after *fireSense_dataPrepPredict*, which supplies the covariates. `ignitionsAndEscapes` is used by *fireSense* to start fires. +Runs after *fireSense_dataPrepPredict*, which supplies the covariates. `fireSense_IgAndEscapeProbRas` and `fireSense_IgAndEscapeDistribution` are used by *fireSense_burn*, which draws the ignitions and escapes and starts the fires. It is normally run as part of the [fireSense](https://github.com/PredictiveEcology/fireSense) module group. ### Getting help diff --git a/tests/testthat/setup-toyIgnition.R b/tests/testthat/setup-toyIgnition.R index acd3707..a49eaa8 100644 --- a/tests/testthat/setup-toyIgnition.R +++ b/tests/testthat/setup-toyIgnition.R @@ -26,7 +26,9 @@ predict.toyFold <- function(object, newdata, ...) { } registerS3method("predict", "toyFold", predict.toyFold) -toyFold <- function(fun, label) structure(list(fun = fun, label = label), class = "toyFold") +## `objective` is what an xgboost model keeps in `$params$objective`; both fitted processes are Poisson counts +toyFold <- function(fun, label, objective = "count:poisson") + structure(list(fun = fun, label = label, params = list(objective = objective)), class = "toyFold") ## calls logged for one model label, in call order toyCalls <- function(label) { @@ -34,25 +36,7 @@ toyCalls <- function(label) { lapply(keys, get, envir = toyLog) } -## Grids, both 0..4 x 0..4. The fine (simulation) grid is 8 x 8 with 0.5-unit cells; the -## coarse (fitting) grid is 2 x 2 with 2-unit cells, so each coarse cell holds 16 fine cells: -## coarse 1 = fine rows 1-4, cols 1-4; coarse 2 = rows 1-4, cols 5-8; -## coarse 3 = rows 5-8, cols 1-4; coarse 4 = rows 5-8, cols 5-8. -## Fine cell number = (row - 1) * 8 + col. -coarseOfFine <- function(cell) { - row <- (cell - 1) %/% 8 + 1 - col <- (cell - 1) %% 8 + 1 - (row > 4) * 2 + (col > 4) + 1 -} - -## By default fine cells 5 and 6 (in coarse 2) and 64 (in coarse 4) are not flammable. -toyFlammable <- function(nonFlammable = c(5L, 6L, 64L)) { - r <- terra::rast(nrows = 8, ncols = 8, xmin = 0, xmax = 4, ymin = 0, ymax = 4, vals = 1, - crs = "EPSG:3005") - r[nonFlammable] <- 0 - r -} - +## The coarse (fitting) grid is 2 x 2 with 2-unit cells over 0..4 x 0..4. toyCoarse <- function() { terra::rast(nrows = 2, ncols = 2, xmin = 0, xmax = 4, ymin = 0, ymax = 4, vals = 1, crs = "EPSG:3005") @@ -74,7 +58,6 @@ toyScaleData <- function(center = c(pixelID = 2.5, MDC = 100, youngAge = 0.5, ye ## `ignFuns` and `escFuns` are lists of functions of newdata, one per fold toyIgInputs <- function(ignFuns, escFuns, covs = toyIgCovariates(), foldNames = paste0("Fold", seq_along(ignFuns)), - flammableRTM = toyFlammable(), ignScaleData = toyScaleData(), escScaleData = toyScaleData()) { ign <- Map(toyFold, ignFuns, paste0("ign", seq_along(ignFuns))) esc <- Map(toyFold, escFuns, paste0("esc", seq_along(escFuns))) @@ -88,7 +71,6 @@ toyIgInputs <- function(ignFuns, escFuns, covs = toyIgCovariates(), list(modelList = list(model = esc), scaleData = escScaleData), class = "fireSense_EscapeFit"), fireSense_igAndEscapePred_Covariates = covs, - flammableRTM = flammableRTM, ignitionFitRTM = toyCoarse() ) } @@ -117,7 +99,6 @@ toyIgRun <- function(objects, ..., seed = 42) { }) } -igTable <- function(sim) as.data.frame(sim$ignitionsAndEscapes) probVals <- function(sim) terra::values(sim$fireSense_IgAndEscapeProbRas) ## a constant prediction, whatever the covariates diff --git a/tests/testthat/test-coarse-to-fine-map.R b/tests/testthat/test-coarse-to-fine-map.R deleted file mode 100644 index 08510a8..0000000 --- a/tests/testthat/test-coarse-to-fine-map.R +++ /dev/null @@ -1,73 +0,0 @@ -## The coarse-to-fine regrid of the ignition raster is done once, not every year. The fine-grid result -## must be what the per-year postProcess() regrid gave. - -## reference: the per-year code before the mapping was kept -oldFineTable <- function(coarse, fine, pixelIDs) { - igRas <- terra::rast(coarse) - igRas[pixelIDs] <- pixelIDs - igRas <- postProcess(igRas, to = fine, method = "near") - igRas[fine[] != 1] <- NA - list(ras = igRas, dt = data.table::as.data.table(igRas, cells = TRUE)) -} - -## grids whose cells are not round multiples of each other -gridCoarse <- function() terra::rast(nrows = 3, ncols = 4, xmin = 0, xmax = 10, ymin = 0, ymax = 9, - vals = 1, crs = "EPSG:3005") -gridFine <- function(nonFlammable = c(3L, 17L, 40L), na = 25L, nr = 11, nc = 13) { - r <- terra::rast(nrows = nr, ncols = nc, xmin = 0, xmax = 10, ymin = 0, ymax = 9, vals = 1, - crs = "EPSG:3005") - r[nonFlammable] <- 0 - r[na] <- NA - r -} - -newFineTable <- function(coarse, fine, store, pixelIDs) { - dt <- fineCoarseTable(coarseToFineMap(coarse, fine, store), fine) - dt[dt$chunkyPixels %in% pixelIDs, ] -} - -test_that("the kept mapping gives the fine-grid ignition raster the per-year regrid gave, in two years", { - coarse <- gridCoarse(); fine <- gridFine() - store <- new.env() - for (ids in list(c(1L, 2L, 5L, 6L, 9L, 12L), c(2L, 3L, 4L, 7L, 8L, 10L, 11L))) { # year 1, year 2 - old <- oldFineTable(coarse, fine, ids) - new <- newFineTable(coarse, fine, store, ids) - expect_identical(as.numeric(new$pixelID), as.numeric(old$dt$cell)) - expect_identical(as.numeric(new$chunkyPixels), as.numeric(old$dt[[2]])) - ## and as a raster: values, extent, crs - r <- terra::rast(fine); r[] <- NA - r[new$pixelID] <- new$chunkyPixels - ## (terra holds NA as NaN after the regrid; the same missing cells) - expect_equal(terra::values(r, mat = FALSE), terra::values(old$ras, mat = FALSE)) - expect_identical(as.vector(terra::ext(r)), as.vector(terra::ext(old$ras))) - expect_identical(terra::crs(r), terra::crs(old$ras)) - } -}) - -test_that("the mapping is computed once, and rebuilt when either grid changes", { - coarse <- gridCoarse(); fine <- gridFine() - store <- new.env() - map1 <- coarseToFineMap(coarse, fine, store) - store$coarseToFine$marker <- "first" - ## same grids (a different object, a different flammable pattern): reused - map2 <- coarseToFineMap(gridCoarse(), gridFine(nonFlammable = 1:5), store) - expect_identical(store$coarseToFine$marker, "first") - expect_identical(map1, map2) - ## a finer grid: rebuilt, and right - fine2 <- gridFine(nr = 9, nc = 16) - map3 <- coarseToFineMap(coarse, fine2, store) - expect_null(store$coarseToFine$marker) - expect_length(map3, terra::ncell(fine2)) - ids <- 1:12 - old <- oldFineTable(coarse, fine2, ids) - new <- newFineTable(coarse, fine2, store, ids) - expect_identical(as.numeric(new$chunkyPixels), as.numeric(old$dt[[2]])) - ## a changed coarse grid: rebuilt - coarse2 <- terra::rast(nrows = 2, ncols = 2, xmin = 0, xmax = 10, ymin = 0, ymax = 9, vals = 1, - crs = "EPSG:3005") - map4 <- coarseToFineMap(coarse2, fine2, store) - expect_true(max(map4, na.rm = TRUE) <= 4) - ## a changed extent with the same dimensions: rebuilt - coarse3 <- coarse; terra::ext(coarse3) <- c(0, 10, 0, 18) - expect_false(identical(coarseToFineMap(coarse3, fine2, store), map3)) -}) diff --git a/tests/testthat/test-escaped.R b/tests/testthat/test-escaped.R deleted file mode 100644 index d3e1188..0000000 --- a/tests/testthat/test-escaped.R +++ /dev/null @@ -1,46 +0,0 @@ -## `escapes` is the coarse pixel's number of escapes, repeated on each of its ignitions. fireSense spread -## `escapes` fires from EVERY ignition row, so a coarse pixel with 4 ignitions and 2 escapes gave 8 escaped -## fires. `escaped` marks which ignitions escaped: exactly `escapes` of each coarse pixel's rows. - -## the toy of test-run-values.R: two ignition folds, coarse cells 2 and 3 can ignite -twoFolds <- function(escFuns = list(constant(1)), ...) { - toyIgInputs(list(byPixel(c(0, 2, 3, 0)), byPixel(c(0, 4, 3, 0))), escFuns, ...) -} - -test_that("exactly `escapes` of each coarse pixel's ignitions escaped", { - for (seed in 1:5) { - ig <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = seed)) - expect_type(ig$escaped, "logical") - coarse <- coarseOfFine(ig$pixelID) - per <- tapply(ig$escaped, coarse, sum) - esc <- tapply(ig$escapes, coarse, `[`, 1) - expect_identical(as.integer(per), as.integer(esc)) - expect_identical(sum(ig$escaped), sum(tapply(ig$escapes, coarse, `[`, 1))) - } -}) - -test_that("a year with no ignitions gives a 0-row table with the columns and types of a normal year", { - normal <- toyIgRun(twoFolds(list(constant(0.5))), seed = 42)$ignitionsAndEscapes - none <- toyIgRun(toyIgInputs(list(byPixel(c(0, 0, 0, 0)), byPixel(c(0, 0, 0, 0))), list(constant(0.5))), - seed = 42)$ignitionsAndEscapes - expect_identical(nrow(none), 0L) - expect_true(all(c("pixelID", "escaped") %in% names(none))) - expect_identical(names(none), names(normal)) - expect_identical(vapply(none, typeof, ""), vapply(normal, typeof, "")) - expect_identical(none$pixelID, integer(0)) - expect_identical(none$escaped, logical(0)) -}) - -test_that("every ignition escapes with probability 1, none with probability 0", { - ig1 <- igTable(toyIgRun(twoFolds(list(constant(1))))) - ig0 <- igTable(toyIgRun(twoFolds(list(constant(0))))) - expect_identical(ig1$escaped, rep(TRUE, nrow(ig1))) - expect_identical(ig0$escaped, rep(FALSE, nrow(ig0))) -}) - -test_that("the seed-42 placements are unchanged, and 5 of the 8 ignitions escape (2 + 3), not 20", { - ig <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = 42)) - ig <- ig[order(ig$pixelID), ] - expect_identical(ig$pixelID, c(14L, 15L, 21L, 23L, 34L, 36L, 50L, 58L)) - expect_identical(sum(ig$escaped), 5L) -}) diff --git a/tests/testthat/test-events.R b/tests/testthat/test-events.R index 5d243f3..50ba0b4 100644 --- a/tests/testthat/test-events.R +++ b/tests/testthat/test-events.R @@ -45,7 +45,6 @@ test_that("the save event says it does nothing, and changes nothing", { expect_equal(evOf(SpaDES.core::completed(with), "save")$eventTime, 2001) expect_identical(nrow(evOf(SpaDES.core::events(with), "save")), 0L) expect_identical(sort(ls(with)), sort(ls(without))) - expect_identical(igTable(with), igTable(without)) expect_identical(probVals(with), probVals(without)) expect_identical(with$fireSense_IgnitionFitted, without$fireSense_IgnitionFitted) expect_length(list.files(SpaDES.core::outputPath(with), recursive = TRUE), 0L) @@ -54,6 +53,6 @@ test_that("the save event says it does nothing, and changes nothing", { test_that("nothing is predicted before the first run event", { sim <- toyIgRun(inputsNoIgnition(), params = list(.runInitialTime = 2005), times = list(start = 2001, end = 2002)) - expect_null(sim$ignitionsAndEscapes) expect_null(sim$fireSense_IgAndEscapeProbRas) + expect_null(sim$fireSense_IgAndEscapeDistribution) }) diff --git a/tests/testthat/test-failures.R b/tests/testthat/test-failures.R index e637a3d..32d986d 100644 --- a/tests/testthat/test-failures.R +++ b/tests/testthat/test-failures.R @@ -3,26 +3,3 @@ test_that("a fitted object without a list of fold models stops", { ins$fireSense_IgnitionFitted$modelList$model <- NULL expect_error(toyIgRun(ins), "Not tested anymore") }) - -test_that("an ignition placed in a coarse cell with ONE flammable fine cell lands in that cell", { - skip(paste("known defect: sample(x, size) with length-1 x samples from 1:x, so the ignition", - "can land in any lower-numbered fine cell, in another coarse cell")) - ## coarse 4 = fine rows 5-8, cols 5-8; leave only fine cell 64 flammable in it - nf <- setdiff(as.integer(outer(5:8, (4:7) * 8, `+`)), 64L) - for (seed in 1:8) { - ins <- toyIgInputs(list(byPixel(c(0, 0, 0, 0.7))), list(constant(1)), - flammableRTM = toyFlammable(nf)) - ig <- igTable(toyIgRun(ins, seed = seed)) - expect_true(all(ig$pixelID == 64L)) - } -}) - -test_that("more ignitions than flammable fine cells does not stop the simulation", { - skip(paste("known defect: sample() without replacement errors with 'cannot take a sample", - "larger than the population' when ignitions > flammable fine cells in the coarse cell")) - nf <- setdiff(as.integer(outer(5:8, (4:7) * 8, `+`)), 64L) - ins <- toyIgInputs(list(byPixel(c(0, 0, 0, 20))), list(constant(1)), - flammableRTM = toyFlammable(nf)) - ig <- igTable(toyIgRun(ins)) - expect_true(all(ig$pixelID == 64L)) -}) diff --git a/tests/testthat/test-metadata.R b/tests/testthat/test-metadata.R index 2e14c10..3cd3ba3 100644 --- a/tests/testthat/test-metadata.R +++ b/tests/testthat/test-metadata.R @@ -22,7 +22,6 @@ test_that("inputs are the expected names and classes", { fireSense_igAndEscapePred_Covariates = "data.table", fireSense_IgnitionFitted = "fireSense_IgnitionFit", fireSense_IgnitionFittedList = "list", - flammableRTM = "SpatRaster", rasterToMatchLargeELF = "SpatRaster") ) }) @@ -32,8 +31,8 @@ test_that("outputs are the expected names and classes", { outputs <- stats::setNames(md$outputObjects$objectClass, md$outputObjects$objectName) expect_identical( outputs[order(names(outputs))], - c(fireSense_IgAndEscapeProbRas = "SpatRaster", - ignitionsAndEscapes = "data.table") + c(fireSense_IgAndEscapeDistribution = "list", + fireSense_IgAndEscapeProbRas = "SpatRaster") ) }) diff --git a/tests/testthat/test-multiELF.R b/tests/testthat/test-multiELF.R index 346faf4..7fd36ed 100644 --- a/tests/testthat/test-multiELF.R +++ b/tests/testthat/test-multiELF.R @@ -1,6 +1,5 @@ ## Several fitted ELFs in one study area (the 2-ELF Mackenzie forecast, 2026-09). Each ELF's ignition and -## escape models, fitted in that ELF's own run, predict the coarse pixels of that ELF. Poisson and binomial -## draws are still made once over all pixels. +## escape models, fitted in that ELF's own run, predict the coarse pixels of that ELF. ## ## Toy: ELF "A" is the left half of the grid (coarse cells 1 and 3), "B" the right half (2 and 4). ## A's ignition model predicts 2 everywhere it is asked, B's predicts 5. @@ -16,7 +15,7 @@ multiInputs <- function() { a <- fitPair(constant(2), constant(0.5), "A"); b <- fitPair(constant(5), constant(0.5), "B") o$fireSense_IgnitionFittedList <- list(A = a$ign, B = b$ign) o$fireSense_EscapeFittedList <- list(A = a$esc, B = b$esc) - elf <- toyFlammable(integer(0)) + elf <- terra::rast(nrows = 8, ncols = 8, xmin = 0, xmax = 4, ymin = 0, ymax = 4, crs = "EPSG:3005") terra::values(elf) <- rep(rep(1:2, each = 4), times = 8) # fine cols 1-4 -> 1 (A), 5-8 -> 2 (B) levels(elf) <- data.frame(id = 1:2, ELFind = c("A", "B")) o$rasterToMatchLargeELF <- elf @@ -28,9 +27,10 @@ test_that("each ELF's ignition model predicts only its own coarse pixels", { expect_equal(toyCalls("ignA")[[1]]$pixelID, c(1L, 3L)) expect_equal(toyCalls("ignB")[[1]]$pixelID, c(2L, 4L)) expect_equal(probVals(sim)[, "ignitionProb"], c(2, 5, 2, 5)) - ## escapes: each ELF's escape model sees only its own ignited pixels - expect_true(all(toyCalls("escA")[[1]]$pixelID %in% c(1L, 3L))) - expect_true(all(toyCalls("escB")[[1]]$pixelID %in% c(2L, 4L))) + ## escapes: the escape surface is complete, each ELF's escape model predicts its own pixels + expect_equal(toyCalls("escA")[[1]]$pixelID, c(1L, 3L)) + expect_equal(toyCalls("escB")[[1]]$pixelID, c(2L, 4L)) + expect_equal(probVals(sim)[, "escapeProb"], c(0.5, 0.5, 0.5, 0.5)) expect_length(toyCalls("ign1"), 0L) # the single fit is ignored }) @@ -40,3 +40,17 @@ test_that("with several fits, a missing ELF raster or mismatched lists stop with o <- multiInputs(); o$fireSense_EscapeFittedList <- o$fireSense_EscapeFittedList["A"] expect_error(toyIgRun(o), "same ELFs") }) + +test_that("ELFs fitted with different objectives stop, naming the ELFs and objectives", { + o <- multiInputs() + o$fireSense_IgnitionFittedList$B$modelList$model$Fold1$params$objective <- "reg:tweedie" + expect_error(toyIgRun(o), "ELFs' ignition models have different objectives: A \\(count:poisson\\), B \\(reg:tweedie\\)") + o <- multiInputs() + o$fireSense_EscapeFittedList$A$modelList$model$Fold1$params$objective <- "reg:squarederror" + expect_error(toyIgRun(o), "ELFs' escape models have different objectives: A \\(reg:squarederror\\), B \\(count:poisson\\)") +}) + +test_that("with several ELFs sharing an objective, the distribution is that objective", { + expect_identical(toyIgRun(multiInputs())$fireSense_IgAndEscapeDistribution, + list(ignition = "count:poisson", escape = "count:poisson")) +}) diff --git a/tests/testthat/test-place-ignitions.R b/tests/testthat/test-place-ignitions.R deleted file mode 100644 index 02aa656..0000000 --- a/tests/testthat/test-place-ignitions.R +++ /dev/null @@ -1,62 +0,0 @@ -## Placing ignitions on fine pixels must give the same pixels and the same random stream as the -## per-coarse-pixel scans of the whole fine-pixel table it replaced. - -## reference: the code before placeIgnitions() (kept here only to compare against) -oldPlaceIgnitions <- function(igs, drawTable) { - lapply(drawTable$chunkyPixels, - FUN = function(n, draw = drawTable, ig = igs) { - sampledChunk <- draw[chunkyPixels == n] - pixelID_pop <- igs[chunkyPixels == sampledChunk$chunkyPixels] - drawn <- sample(pixelID_pop$pixelID, size = sampledChunk$ignitions) - ig[pixelID %in% drawn, .(pixelID, igProb, ignitions, escapeProb, escapes, chunkyPixels)] - }) |> - data.table::rbindlist() -} - -## fine pixels (not in pixelID order, as after a join) of coarse pixels 1-6; coarse pixel `ignited` have -## ignitions; coarse 3 has a single fine pixel, coarse 6 has none ignited -toyIgs <- function(ignitions = c(`1` = 2L, `2` = 1L, `3` = 1L, `4` = 3L, `5` = 0L, `6` = 0L), - ids = c(3L, 1L, 5L, 2L, 9L, 4L, 11L, 7L, 6L, 12L, 8L, 10L, 15L, 13L, 14L, 20L, 18L, 17L, 16L, 19L), - chunk = c(1, 1, 2, 1, 2, 2, 3, 4, 4, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 6)) { - igs <- data.table::data.table(pixelID = ids, chunkyPixels = chunk) - igs[, `:=`(igProb = seq_len(.N) / 100, ignitions = ignitions[as.character(chunkyPixels)], - escapeProb = seq_len(.N) / 50, escapes = 1L)] - data.table::setcolorder(igs, c("pixelID", "igProb", "ignitions", "escapeProb", "escapes", "chunkyPixels")) - igs -} -drawTableOf <- function(igs) unique(igs[ignitions > 0, .(chunkyPixels, ignitions, escapes)]) - -compareToOld <- function(igs, seed) { - drawTable <- drawTableOf(igs) - set.seed(seed); old <- oldPlaceIgnitions(igs, drawTable); seedOld <- .Random.seed - set.seed(seed); new <- placeIgnitions(igs, drawTable); seedNew <- .Random.seed - expect_identical(new, old) - expect_identical(seedNew, seedOld) - invisible(new) -} - -test_that("placeIgnitions gives the old ignitions and random stream, for several seeds", { - ## coarse 5 and 6 have no ignitions (no candidates drawn); coarse 3 has exactly one candidate but - ## here its pixel ID is 11, so the single-candidate draw is from 1:11 -- the old behaviour, kept - igs <- toyIgs() - for (seed in c(1, 2, 3, 42, 2024, 99999)) compareToOld(igs, seed) -}) - -test_that("coarse pixels with zero ignitions place nothing and use no random numbers", { - igs <- toyIgs(ignitions = c(`1` = 0L, `2` = 0L, `3` = 0L, `4` = 0L, `5` = 0L, `6` = 0L)) - set.seed(5); before <- .Random.seed - res <- placeIgnitions(igs, drawTableOf(igs)) - expect_identical(nrow(res), 0L) - expect_identical(.Random.seed, before) -}) - -test_that("a coarse pixel with one candidate keeps the sample(x, size) draw from 1:x", { - ## only coarse 3 is ignited; its one fine pixel has ID 11. The old code draws from 1:11 - igs <- toyIgs(ignitions = c(`1` = 0L, `2` = 0L, `3` = 1L, `4` = 0L, `5` = 0L, `6` = 0L)) - for (seed in 1:20) compareToOld(igs, seed) - ## an ID of 1 draws pixel 1 (from 1:1) - igs1 <- toyIgs(ignitions = c(`1` = 0L, `2` = 0L, `3` = 1L, `4` = 0L, `5` = 0L, `6` = 0L)) - igs1[chunkyPixels == 3, pixelID := 1L] - igs1[pixelID == 1L & chunkyPixels != 3, pixelID := 21L] - for (seed in 1:5) compareToOld(igs1, seed) -}) diff --git a/tests/testthat/test-run-values.R b/tests/testthat/test-run-values.R index 5e3f32a..8a40922 100644 --- a/tests/testthat/test-run-values.R +++ b/tests/testthat/test-run-values.R @@ -1,12 +1,13 @@ -## What the run event predicts and draws, on a 2 x 2 coarse grid over an 8 x 8 fine grid. +## What the run event predicts, on a 2 x 2 coarse grid. Nothing is drawn: the module makes expected-value +## surfaces and fireSense_burn draws from them. ## Default toy: two ignition folds that predict 0, 2, 3, 0 and 0, 4, 3, 0 expected -## ignitions for coarse cells 1..4, so only coarse cells 2 and 3 can ignite. +## ignitions for coarse cells 1..4. twoFolds <- function(escFuns = list(constant(1)), ...) { toyIgInputs(list(byPixel(c(0, 2, 3, 0)), byPixel(c(0, 4, 3, 0))), escFuns, ...) } -test_that("ignition probability is the mean of the per-fold predictions, on the coarse grid", { +test_that("ignition surface is the mean of the per-fold predictions, on the coarse grid", { sim <- toyIgRun(twoFolds()) ras <- sim$fireSense_IgAndEscapeProbRas expect_identical(names(ras), c("ignitionProb", "escapeProb")) @@ -15,22 +16,25 @@ test_that("ignition probability is the mean of the per-fold predictions, on the expect_equal(probVals(sim)[, "ignitionProb"], c(0, 3, 3, 0)) }) -test_that("escape probability is the fold mean, clamped to [0, 1] per fold, only where there are ignitions", { - ## fold 1 predicts 1.7 (clamped to 1), fold 2 predicts 0.5: mean 0.75 +test_that("the escape surface is the fold mean of the escape model for every pixel, not clamped to 1", { + ## folds predict 1.7 and 0.5: mean 1.1, a count, so above 1 sim <- toyIgRun(twoFolds(list(constant(1.7), constant(0.5)))) - expect_equal(probVals(sim)[, "escapeProb"], c(NA, 0.75, 0.75, NA)) - ## fold 1 predicts -0.5 (clamped to 0), fold 2 predicts 0.1: mean 0.05 + expect_equal(probVals(sim)[, "escapeProb"], rep(1.1, 4)) + ## also where there are no expected ignitions (cells 1 and 4) + expect_false(anyNA(probVals(sim)[, "escapeProb"])) +}) + +test_that("predictions below 0 are made 0 per fold", { + ## fold 1 predicts -0.5 (made 0), fold 2 predicts 0.1: mean 0.05 sim <- toyIgRun(twoFolds(list(constant(-0.5), constant(0.1)))) - expect_equal(probVals(sim)[, "escapeProb"], c(NA, 0.05, 0.05, NA)) - expect_equal(unique(igTable(sim)$escapeProb), 0.05) + expect_equal(probVals(sim)[, "escapeProb"], rep(0.05, 4)) }) -test_that("escape models only see the coarse cells that ignited", { - sim <- toyIgRun(twoFolds()) +test_that("escape models see every coarse cell, ignition models too", { + toyIgRun(twoFolds()) escCalls <- toyCalls("esc1") expect_length(escCalls, 1L) - expect_identical(escCalls[[1]]$pixelID, 2:3) - ## the ignition models see all four + expect_identical(escCalls[[1]]$pixelID, 1:4) expect_identical(toyCalls("ign1")[[1]]$pixelID, 1:4) expect_identical(toyCalls("ign2")[[1]]$pixelID, 1:4) }) @@ -43,67 +47,43 @@ test_that("only models whose name contains 'Fold' are used", { expect_length(toyCalls("ign3"), 0L) }) -test_that("each ignition is a distinct flammable fine cell inside its own coarse cell", { - for (seed in 1:3) { - sim <- toyIgRun(twoFolds(), seed = seed) - ig <- igTable(sim) - expect_identical(names(ig), c("pixelID", "igProb", "ignitions", "escapeProb", "escapes", "escaped")) - expect_gt(nrow(ig), 0) - expect_false(anyDuplicated(ig$pixelID) > 0) - coarse <- coarseOfFine(ig$pixelID) - expect_true(all(coarse %in% c(2, 3))) # coarse 1 and 4 have 0 expected ignitions - expect_false(any(ig$pixelID %in% c(5, 6))) # not flammable, though inside coarse 2 - ## one row per ignition: a coarse cell with n ignitions has n rows, each saying n - expect_identical(as.vector(table(coarse)[as.character(coarse)]), as.integer(ig$ignitions)) - expect_equal(ig$igProb, rep(3, nrow(ig))) - } +test_that("no ignitionsAndEscapes is made: the draws are fireSense_burn's", { + expect_null(toyIgRun(twoFolds())$ignitionsAndEscapes) }) -test_that("escapes are certain with probability 1 and impossible with probability 0", { - ig <- igTable(toyIgRun(twoFolds(list(constant(1))))) - expect_identical(ig$escapes, ig$ignitions) - expect_true(all(ig$ignitions >= 1L)) - ig <- igTable(toyIgRun(twoFolds(list(constant(0))))) - expect_identical(ig$escapes, rep(0L, nrow(ig))) - expect_gt(nrow(ig), 0) +test_that("the distribution is read from the fitted models' objective", { + sim <- toyIgRun(twoFolds()) + expect_identical(sim$fireSense_IgAndEscapeDistribution, + list(ignition = "count:poisson", escape = "count:poisson")) + ins <- twoFolds() + ins$fireSense_EscapeFitted$modelList$model$Fold1$params$objective <- "reg:tweedie" + expect_identical(toyIgRun(ins)$fireSense_IgAndEscapeDistribution, + list(ignition = "count:poisson", escape = "reg:tweedie")) }) -test_that("the draws are reproducible under set.seed", { - a <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = 7)) - b <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = 7)) - expect_identical(a, b) - d <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = 8)) - expect_false(identical(a, d)) +test_that("an unreadable objective stops", { + ins <- twoFolds() + ins$fireSense_IgnitionFitted$modelList$model$Fold1$params <- NULL + expect_error(toyIgRun(ins), "cannot read the objective of a fitted ignition model") + ins <- twoFolds() + ins$fireSense_EscapeFitted$modelList$model$Fold1$params$objective <- NULL + expect_error(toyIgRun(ins), "cannot read the objective of a fitted escape model") }) -test_that("no expected ignitions anywhere gives no ignitions", { - sim <- toyIgRun(toyIgInputs(list(constant(0)), list(constant(1)))) - expect_identical(nrow(sim$ignitionsAndEscapes), 0L) - expect_equal(probVals(sim)[, "ignitionProb"], c(0, 0, 0, 0)) - expect_true(all(is.na(probVals(sim)[, "escapeProb"]))) - expect_length(toyCalls("esc1")[[1]]$pixelID, 0L) +test_that("folds with different objectives stop", { + ins <- toyIgInputs(list(byPixel(c(0, 2, 3, 0)), byPixel(c(0, 4, 3, 0))), list(constant(1))) + ins$fireSense_IgnitionFitted$modelList$model$Fold2$params$objective <- "reg:tweedie" + expect_error(toyIgRun(ins), "folds of the ignition model.*different objectives: count:poisson, reg:tweedie") }) -test_that("coarse cells with an NA covariate are dropped: no prediction, no ignition", { +test_that("coarse cells with an NA covariate are dropped: no prediction", { covs <- toyIgCovariates() data.table::set(covs, 2L, "MDC", NA_real_) ## fold predicts 3 wherever it is asked sim <- toyIgRun(toyIgInputs(list(constant(3)), list(constant(1)), covs = covs)) expect_identical(toyCalls("ign1")[[1]]$pixelID, c(1L, 3L, 4L)) expect_equal(probVals(sim)[, "ignitionProb"], c(3, NA, 3, 3)) - expect_false(any(coarseOfFine(igTable(sim)$pixelID) == 2)) -}) - -test_that("a fully non-flammable coarse cell gets no ignitions even if the model predicts them", { - ## coarse 2 = fine rows 1-4, cols 5-8 - nf <- as.integer(outer(5:8, (0:3) * 8, `+`)) - expect_true(all(coarseOfFine(nf) == 2)) - sim <- toyIgRun(twoFolds(flammableRTM = toyFlammable(nf))) - ig <- igTable(sim) - expect_gt(nrow(ig), 0) - expect_true(all(coarseOfFine(ig$pixelID) == 3)) - ## the probability raster still reports the prediction for coarse 2 - expect_equal(probVals(sim)[, "ignitionProb"], c(0, 3, 3, 0)) + expect_equal(probVals(sim)[, "escapeProb"], c(1, NA, 1, 1)) }) test_that("the covariate table in the simList is not modified", { @@ -111,15 +91,3 @@ test_that("the covariate table in the simList is not modified", { expect_equal(as.data.frame(sim$fireSense_igAndEscapePred_Covariates), as.data.frame(toyIgCovariates())) }) - -test_that("draws with seed 42 match development", { - ## Stochastic, so pinned: values from origin/development at 277672d (R 4.6.1). - ## `ignitions` and `escapes` are the counts of the coarse cell, repeated on each of its rows. - ig <- igTable(toyIgRun(twoFolds(list(constant(0.5))), seed = 42)) - ig <- ig[order(ig$pixelID), ] - expect_identical(ig$pixelID, c(14L, 15L, 21L, 23L, 34L, 36L, 50L, 58L)) - ## cells 14..23 are in coarse 2 (4 ignitions, 2 escapes); 34..58 in coarse 3 (4 and 3) - expect_identical(as.integer(ig$ignitions), rep(4L, 8)) - expect_identical(as.integer(ig$escapes), rep(c(2L, 3L), each = 4)) - expect_equal(ig$escapeProb, rep(0.5, 8)) -})