Read the fitted models' objective with xgb.config()

NEWS.md

@@ -1,5 +1,6 @@
 # fireSense_ignitionPredict (development version)
 
+- Fix: the objective of the fitted models is read with `xgboost::xgb.config()` (falling back to `attr(model, "params")`), not `model$params`, which is `NULL` for xgboost >= 3 boosters, so every prediction run stopped at the ignition step. `xgboost (>= 3.0.0)` is now in `reqdPkgs`.
 - 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.

fireSense_ignitionPredict.R

@@ -17,7 +17,7 @@ defineModule(sim, list(
   citation = list("citation.bib"),
   documentation = list("README.txt", "fireSense_ignitionPredict.Rmd"),
   reqdPkgs = list(
-    "data.table", "magrittr", "terra",
+    "data.table", "magrittr", "terra", "xgboost (>= 3.0.0)",
     "PredictiveEcology/SpaDES.core@development (>= 3.0.4)",
     "PredictiveEcology/reproducible@development",
     "PredictiveEcology/fireSenseUtils@development (>=0.1.0)"
@@ -259,6 +259,8 @@ foldMeanPrediction <- function(fit, newdata) {
   rowMeans(do.call(cbind, preds))
 }
 
+isOneString <- function(x) is.character(x) && length(x) == 1L && !is.na(x)
+
 #' The objective the fitted models were fitted with
 #'
 #' `fireSense_burn` draws from the predicted means with the distribution this implies, so every fold of
@@ -272,10 +274,12 @@ 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))
+      o <- tryCatch(xgboost::xgb.config(model)$learner$objective$name, error = function(e) NULL)
+      if (!isOneString(o)) o <- tryCatch(attr(model, "params")$objective, error = function(e) NULL)
+      if (!isOneString(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")
+             " model (tried `xgboost::xgb.config(model)$learner$objective$name` and `attr(model, \"params\")$objective`);",
+             " fireSense_burn needs it to draw from the predictions")
       o
     }, "")
     if (length(unique(obj)) > 1L)

tests/testthat/setup-toyIgnition.R

@@ -5,8 +5,8 @@
 ## data.table, so `dt[i, j]` there is NOT data.table-aware: tables are handled with base
 ## subsetting and data.table::set() only.
 ##
-## The fitted models are stand-ins of class "toyFold". xgboost is not among the module's
-## `reqdPkgs`, so CI does not have it; and a stand-in lets a test see exactly what the
+## The fitted models are stand-ins of class "toyFold" (test-xgboost-objective.R uses real boosters).
+## A stand-in lets a test see exactly what the
 ## module hands to predict(). Each "model" is a function of `newdata`; every call is
 ## logged in `toyLog`.
 
@@ -26,9 +26,9 @@ predict.toyFold <- function(object, newdata, ...) {
 }
 registerS3method("predict", "toyFold", predict.toyFold)
 
-## `objective` is what an xgboost model keeps in `$params$objective`; both fitted processes are Poisson counts
+## `objective` is what a reloaded xgboost model keeps in `attr(, "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")
+  structure(list(fun = fun, label = label), params = list(objective = objective), class = "toyFold")
 
 ## calls logged for one model label, in call order
 toyCalls <- function(label) {

tests/testthat/test-multiELF.R

@@ -43,10 +43,10 @@ test_that("with several fits, a missing ELF raster or mismatched lists stop with
 
 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"
+  attr(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"
+  attr(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\\)")
 })
 

tests/testthat/test-run-values.R

@@ -56,23 +56,23 @@ test_that("the distribution is read from the fitted models' objective", {
   expect_identical(sim$fireSense_IgAndEscapeDistribution,
                    list(ignition = "count:poisson", escape = "count:poisson"))
   ins <- twoFolds()
-  ins$fireSense_EscapeFitted$modelList$model$Fold1$params$objective <- "reg:tweedie"
+  attr(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("an unreadable objective stops", {
   ins <- twoFolds()
-  ins$fireSense_IgnitionFitted$modelList$model$Fold1$params <- NULL
+  attr(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
+  attr(ins$fireSense_EscapeFitted$modelList$model$Fold1, "params")$objective <- NULL
   expect_error(toyIgRun(ins), "cannot read the objective of a fitted escape model")
 })
 
 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"
+  attr(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")
 })
 

tests/testthat/test-xgboost-objective.R

@@ -0,0 +1,29 @@
+## Real xgboost boosters, as the ledger stores them: saved and read back, which makes them
+## external pointers with no `$params` (xgboost >= 3).
+realBooster <- function(objective = "count:poisson", seed = 1) {
+  set.seed(seed)
+  x <- matrix(rnorm(200), ncol = 2, dimnames = list(NULL, c("MDC", "youngAge")))
+  y <- rpois(100, exp(0.3 * x[, 1]))
+  b <- xgboost::xgboost(x, y, objective = objective, nrounds = 3, nthreads = 1,
+                        max_depth = 2)
+  f <- tempfile(fileext = ".rds")
+  on.exit(unlink(f))
+  saveRDS(b, f)
+  readRDS(f)
+}
+
+ledgerFit <- function(b1, b2)
+  list(elf = "A", ign = list(modelList = list(model = list(Fold1 = b1, Fold2 = b2),
+                                              scaleData = toyScaleData())))
+
+test_that("the objective of saved and reloaded xgboost models is read", {
+  skip_if_not_installed("xgboost")
+  fits <- list(ledgerFit(realBooster(), realBooster(seed = 2)))
+  expect_identical(fitObjective(fits, "ign"), "count:poisson")
+})
+
+test_that("xgboost folds with different objectives stop", {
+  skip_if_not_installed("xgboost")
+  fits <- list(ledgerFit(realBooster(), realBooster("reg:squarederror")))
+  expect_error(fitObjective(fits, "ign"), "different objectives: count:poisson, reg:squarederror")
+})