Forest serialization

.Rbuildignore

@@ -14,6 +14,7 @@
 ^vignettes/test$
 ^README\.Rmd$
 ^attic$
+^\.superpowers$
 ^doc$
 ^Meta$
 ^.vscode$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: randomPlantedForest
 Title: Random Planted Forest: A Directly Interpretable Tree Ensemble
-Version: 0.3.0
+Version: 0.3.0.9000
 Authors@R: c(
     person(c("Joseph", "Theo"), "Meyer", role = "aut"),
     person("Munir", "Hiabu", role = "aut"),
@@ -24,6 +24,7 @@ Imports:
     Rcpp,
     utils
 Suggests:
+    bundle,
     knitr,
     mvtnorm,
     recipes,

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(bundle::bundle,rpf)
 S3method(predict,rpf)
 S3method(print,rpf)
 S3method(print,rpf_forest)
@@ -16,6 +17,9 @@ export(predict_components)
 export(preprocess_predictors_predict)
 export(purify)
 export(rpf)
+export(rpf_is_valid)
+export(rpf_marshal)
+export(rpf_unmarshal)
 import(checkmate)
 importFrom(Rcpp,loadModule)
 importFrom(Rcpp,sourceCpp)

NEWS.md

@@ -1,3 +1,17 @@
+# randomPlantedForest 0.3.0.9000
+
+* New `rpf_marshal()` / `rpf_unmarshal()` serialize a fitted forest to a plain
+  R list and back, making `saveRDS()`-based storage of rpf models possible (#52).
+  Purified forests restore their purified state directly; training data is only
+  embedded with `include_data = TRUE` (required to `purify()` after restoring).
+  Blobs record the blob format version and the package version they were
+  created with; restoring under an older package than the one that saved the
+  model warns. Malformed or corrupt blobs error instead of reading out of bounds.
+* New `rpf_is_valid()` checks whether an rpf object's internal model is usable;
+  `predict()`, `purify()` and `predict_components()` now give an actionable
+  error for rpf objects restored via `readRDS()` without marshaling.
+* New `bundle::bundle()` method for rpf models wrapping the marshaling API.
+
 # randomPlantedForest 0.3.0
 
 ## Major changes (#61)

R/bundle.R

@@ -0,0 +1,25 @@
+#' Bundle an rpf model
+#'
+#' Method for [bundle::bundle()] wrapping [rpf_marshal()]/[rpf_unmarshal()],
+#' so rpf models work with the standard tidymodels serialization workflow.
+#' Training data is not included; see [rpf_marshal()] for the implications.
+#'
+#' @param x An [rpf] object.
+#' @param ... Unused.
+#' @return An object of class `bundled_rpf` for `bundle()`, or the restored
+#'   [rpf] object for `unbundle()`.
+#' @examplesIf requireNamespace("bundle", quietly = TRUE)
+#' fit <- rpf(mpg ~ wt + cyl, data = mtcars, ntrees = 10)
+#' b <- bundle::bundle(fit)
+#' tmp <- tempfile(fileext = ".rds")
+#' saveRDS(b, tmp)
+#' restored <- bundle::unbundle(readRDS(tmp))
+#' predict(restored, mtcars)
+#' @exportS3Method bundle::bundle
+bundle.rpf <- function(x, ...) {
+  bundle::bundle_constr(
+    object = rpf_marshal(x),
+    situate = bundle::situate_constr(function(object) randomPlantedForest::rpf_unmarshal(object)),
+    desc_class = "rpf"
+  )
+}

R/marshal.R

@@ -0,0 +1,126 @@
+#' Serialize and restore Random Planted Forests
+#'
+#' `rpf_marshal()` converts an [rpf] object into a plain R list safe for
+#' [saveRDS()]; `rpf_unmarshal()` reverses it. The C++ forest behind an `rpf`
+#' object does not survive R serialization, so this explicit round-trip is
+#' required to store or transfer fitted models.
+#'
+#' Training data is only included with `include_data = TRUE`; without it, a
+#' restored forest can predict (including purified prediction if the forest
+#' was purified before marshaling) but can never be purified afterwards.
+#'
+#' @param x An object of class `rpf`.
+#' @param include_data `[FALSE]`: Store training data in the blob, enabling
+#'   [purify()] after restoring.
+#' @param blob An object of class `rpf_marshaled` created by `rpf_marshal()`.
+#' @return `rpf_marshal()` returns a list of class `rpf_marshaled`;
+#'   `rpf_unmarshal()` returns an object of class [rpf].
+#' @export
+#' @examples
+#' fit <- rpf(mpg ~ wt + cyl, data = mtcars, ntrees = 10)
+#' blob <- rpf_marshal(fit)
+#' tmp <- tempfile(fileext = ".rds")
+#' saveRDS(blob, tmp)
+#' restored <- rpf_unmarshal(readRDS(tmp))
+#' all.equal(predict(fit, mtcars), predict(restored, mtcars))
+rpf_marshal <- function(x, include_data = FALSE) {
+  checkmate::assert_class(x, "rpf")
+  checkmate::assert_flag(include_data)
+  check_rpf_alive(x)
+
+  purified <- x$fit$is_purified()
+  fit_state <- list(
+    version = 1L,
+    pkg_version = utils::packageVersion("randomPlantedForest"),
+    model = x$fit$get_model(),
+    bounds = x$fit$get_bounds(),
+    dims = x$fit$get_shape(),
+    purified = purified,
+    grid = if (purified) x$fit$get_grid_leaves(),
+    data = if (include_data) x$fit$get_data(),
+    # $forest (export_forest = TRUE) duplicates $model; rebuilt on unmarshal
+    had_forest = !is.null(x$forest)
+  )
+
+  out <- unclass(x)
+  out$fit <- NULL
+  out$forest <- NULL
+  out$fit_state <- fit_state
+  structure(out, class = "rpf_marshaled")
+}
+
+#' @rdname rpf_marshal
+#' @export
+rpf_unmarshal <- function(blob) {
+  checkmate::assert_class(blob, "rpf_marshaled")
+  state <- blob$fit_state
+  if (!identical(state$version, 1L)) {
+    stop("Unsupported rpf_marshaled version: ", state$version)
+  }
+  installed <- utils::packageVersion("randomPlantedForest")
+  if (!is.null(state$pkg_version) && state$pkg_version > installed) {
+    warning(
+      "This model was marshaled with randomPlantedForest ", state$pkg_version,
+      " but version ", installed, " is installed. Restoring may not be reliable.",
+      call. = FALSE
+    )
+  }
+
+  pars <- rpf_param_vector(blob$params, blob$mode)
+  fit <- if (blob$mode == "classification") {
+    methods::new(ClassificationRPF, blob$params$loss, pars)
+  } else {
+    methods::new(RandomPlantedForest, pars)
+  }
+  fit$set_shape(
+    state$dims$feature_size,
+    state$dims$value_size,
+    state$dims$sample_size,
+    state$bounds$lower,
+    state$bounds$upper
+  )
+  if (!is.null(state$data)) {
+    fit$set_training_data(as.matrix(state$data$Y), as.matrix(state$data$X))
+  }
+  fit$set_model(state$model)
+  if (state$purified) {
+    fit$set_grid_leaves(state$grid)
+  }
+
+  forest <- NULL
+  if (isTRUE(state$had_forest)) {
+    forest <- fit$get_model()
+    class(forest) <- "rpf_forest"
+  }
+
+  out <- blob
+  out$fit_state <- NULL
+  out <- unclass(out)
+  fields <- out[setdiff(names(out), c("fit", "blueprint", "forest"))]
+  do.call(new_rpf, c(list(fit = fit, blueprint = blob$blueprint, forest = forest), fields))
+}
+
+#' Check whether an rpf object's C++ forest is still alive
+#'
+#' The C++ forest does not survive [saveRDS()]; an `rpf` object restored via
+#' [readRDS()] without [rpf_marshal()]/[rpf_unmarshal()] is unusable.
+#' @param x An object of class `rpf`.
+#' @return `TRUE` if the underlying model can be used, `FALSE` otherwise.
+#' @export
+rpf_is_valid <- function(x) {
+  checkmate::assert_class(x, "rpf")
+  !inherits(try(x$fit$is_purified(), silent = TRUE), "try-error")
+}
+
+check_rpf_alive <- function(x) {
+  if (!rpf_is_valid(x)) {
+    stop(
+      "The C++ forest behind this rpf object is gone - most likely it was ",
+      "saved with saveRDS() and restored with readRDS().\n",
+      "Use blob <- rpf_marshal(x) before saving and rpf_unmarshal(blob) ",
+      "after loading. See ?rpf_marshal.",
+      call. = FALSE
+    )
+  }
+  invisible(x)
+}

R/predict_components.R

@@ -70,6 +70,7 @@
 #'
 predict_components <- function(object, new_data, max_interaction = NULL, predictors = NULL) {
   checkmate::assert_class(object, classes = "rpf")
+  check_rpf_alive(object)
 
   # if max_interaction is not provided, we use the max from the rpf model fit
   if (is.null(max_interaction)) {

R/predict_rpf.R

@@ -30,6 +30,7 @@
 #' rpfit <- rpf(y = mtcars$mpg, x = mtcars[, c("cyl", "wt")])
 #' predict(rpfit, mtcars[, c("cyl", "wt")])
 predict.rpf <- function(object, new_data, type = ifelse(object$mode == "regression", "numeric", "prob"), ...) {
+  check_rpf_alive(object)
   # Enforces column order, type, column names, etc
   processed <- hardhat::forge(new_data, object$blueprint)
 

R/purify.R

@@ -43,6 +43,7 @@ purify.default <- function(x, ...) {
 #' @importFrom utils capture.output
 purify.rpf <- function(x, ..., maxp_interaction = NULL, mode = 2L, nthreads = NULL) {
   checkmate::assert_class(x, "rpf")
+  check_rpf_alive(x)
   checkmate::assert_int(mode, lower = 1, upper = 2)
   if (!is.null(nthreads)) {
     checkmate::assert_int(nthreads, lower = 1)
@@ -66,5 +67,6 @@ purify.rpf <- function(x, ..., maxp_interaction = NULL, mode = 2L, nthreads = NU
 #' @rdname purify
 is_purified <- function(x) {
   checkmate::assert_class(x, "rpf")
+  check_rpf_alive(x)
   x$fit$is_purified()
 }