From a269563b2a4493b1f0a6501ff7c5ed763e11eeb4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=E2=80=98topepo=E2=80=99?= Date: Sat, 24 Oct 2026 11:06:19 -0400 Subject: [PATCH] S3 methods for bagger objects --- .Rbuildignore | 1 + .claude/CLAUDE.md | 1 + DESCRIPTION | 2 + NAMESPACE | 4 + NEWS.md | 4 + R/bagger.R | 179 ++++++++++++++++++++++++ R/generics.R | 4 +- R/lgb.Booster.R | 3 +- R/rpart.R | 7 +- man/active_predictors.Rd | 11 +- man/as.party.bagger.Rd | 43 ++++++ man/extract_rules.Rd | 7 +- man/num_ensemble_members.Rd | 13 +- plans/2026-10-23-1317-bagger-methods.md | 74 ++++++++++ tests/testthat/_snaps/bagger.md | 169 ++++++++++++++++++++++ tests/testthat/helper-data.R | 16 +-- tests/testthat/test-C5.0.R | 3 +- tests/testthat/test-bagger.R | 157 +++++++++++++++++++++ tests/testthat/test-rpart.R | 12 ++ 19 files changed, 679 insertions(+), 31 deletions(-) create mode 100644 R/bagger.R create mode 100644 man/as.party.bagger.Rd create mode 100644 plans/2026-10-23-1317-bagger-methods.md create mode 100644 tests/testthat/_snaps/bagger.md create mode 100644 tests/testthat/test-bagger.R diff --git a/.Rbuildignore b/.Rbuildignore index 396f9c3..7828385 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -17,3 +17,4 @@ ^cran-comments\.md$ ^_pkgdown\.yml$ +^plans$ diff --git a/.claude/CLAUDE.md b/.claude/CLAUDE.md index e85ba91..d974757 100644 --- a/.claude/CLAUDE.md +++ b/.claude/CLAUDE.md @@ -37,6 +37,7 @@ air format . * Use the base pipe operator (`|>`) not the magrittr pipe (`%>%`) * Don't use `_$x` or `_$[["x"]]` since this package must work on R 4.1. * Use `\() ...` for single-line anonymous functions. For all other cases, use `function() {...}` +* Never put an inline `if`/`else` (or `ifelse()`) inside another expression, such as `paste0("a_", if (x) "b" else "c")`. Assign the result to a temporary object on its own line and use that. ### Testing diff --git a/DESCRIPTION b/DESCRIPTION index e8bd1ef..708e76a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,6 +29,7 @@ Imports: tibble Suggests: aorsf, + baguette, C50, catboost, Cubist, @@ -39,6 +40,7 @@ Suggests: lightgbm, modeldata, palmerpenguins, + parsnip, randomForest, ranger, rpart, diff --git a/NAMESPACE b/NAMESPACE index 233f9a9..648e8fb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ S3method(active_predictors,C5.0) S3method(active_predictors,ObliqueForest) +S3method(active_predictors,bagger) S3method(active_predictors,bart) S3method(active_predictors,catboost.Model) S3method(active_predictors,cforest) @@ -14,6 +15,7 @@ S3method(active_predictors,ranger) S3method(active_predictors,rpart) S3method(active_predictors,xgb.Booster) S3method(as.party,C5.0) +S3method(as.party,bagger) S3method(as.party,bart) S3method(as.party,catboost.Model) S3method(as.party,grf) @@ -23,6 +25,7 @@ S3method(as.party,ranger) S3method(as.party,xgb.Booster) S3method(extract_rules,C5.0) S3method(extract_rules,ObliqueForest) +S3method(extract_rules,bagger) S3method(extract_rules,bart) S3method(extract_rules,catboost.Model) S3method(extract_rules,cforest) @@ -36,6 +39,7 @@ S3method(extract_rules,rpart) S3method(extract_rules,xgb.Booster) S3method(num_ensemble_members,C5.0) S3method(num_ensemble_members,ObliqueForest) +S3method(num_ensemble_members,bagger) S3method(num_ensemble_members,bart) S3method(num_ensemble_members,catboost.Model) S3method(num_ensemble_members,cforest) diff --git a/NEWS.md b/NEWS.md index cbad4eb..824450b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,10 @@ * `extract_rules()` methods gain an `add_statistics` argument that appends the columns `num_rule_terms` and `num_rule_predictors`. +* `active_predictors()`, `as.party()`, `extract_rules()`, and `num_ensemble_members()` now have methods for bagged trees from the baguette package (`bagger`, from `parsnip::bag_tree()` with the "rpart" or "C5.0" engine). The `tree` argument selects ensemble members, and `as.party()` needs the training data because the bootstrap samples are not saved. + +* `extract_rules()` for rpart models now uses the `xlevels` attribute to label categorical splits with factor levels, so it works for models that no longer have access to their training data. + * `rect_split_to_expr()` now accepts numeric vectors for the `%in%` operator. # lorax 0.1.0 diff --git a/R/bagger.R b/R/bagger.R new file mode 100644 index 0000000..c7288c2 --- /dev/null +++ b/R/bagger.R @@ -0,0 +1,179 @@ +# Methods for bagged trees from the baguette package (`bag_tree()` with the +# "rpart" or "C5.0" engine). The ensemble members are single trees stored as +# parsnip model fits in `model_df`, so `tree` is the index of the member. + +bagger_check <- function(x, call = rlang::caller_env()) { + rlang::check_installed("baguette", call = call) + engine <- x$base_model[1] + if (!engine %in% c("CART", "C5.0")) { + cli::cli_abort( + "Only bagged {.val CART} and {.val C5.0} trees are supported, not {.val {engine}}.", + call = call + ) + } + invisible(x) +} + +bagger_check_tree <- function(tree, x, call = rlang::caller_env()) { + if (!is.numeric(tree) || !all(tree == as.integer(tree))) { + cli::cli_abort( + "{.arg tree} must be an integer vector, not {.obj_type_friendly {tree}}.", + call = call + ) + } + tree <- as.integer(tree) + num_trees <- nrow(x$model_df) + if (any(tree < 1L) || any(tree > num_trees)) { + cli::cli_abort( + "{.arg tree} values must be between 1 and {num_trees}.", + call = call + ) + } + tree +} + +bagger_member <- function(x, i) { + x$model_df$model[[i]]$fit +} + +#' @rdname num_ensemble_members +#' @export +num_ensemble_members.bagger <- function(x, ...) { + bagger_check(x) + nrow(x$model_df) +} + +# Members are fit on bootstrap samples that are not kept, so the model frame +# and node assignments are rebuilt from the supplied data. +bagger_rpart_party <- function( + member, + data, + outcome, + call = rlang::caller_env() +) { + rlang::check_installed("rpart", call = call) + predictors <- attr(member$terms, "term.labels") + missing_cols <- setdiff(c(predictors, outcome), names(data)) + if (length(missing_cols) > 0) { + cli::cli_abort( + "{.arg data} is missing column{?s} {.val {missing_cols}}.", + call = call + ) + } + + data[[".outcome"]] <- data[[outcome]] + mf <- stats::model.frame( + member$terms, + data = data, + na.action = stats::na.pass + ) + + # A first pass finds the terminal node of each row, which is used to set the + # fitted values (and the missing value routing) in the second pass. + member$model <- mf + member$where <- rep(which(member$frame$var == "")[1], nrow(mf)) + first <- partykit::as.party(member) + node_ids <- stats::predict(first, newdata = mf, type = "node") + member$where <- node_ids + + partykit::as.party(member) +} + +#' Convert a bagged tree to a party object +#' +#' Convert a single tree from a bagged model created by \pkg{baguette} (e.g., +#' `parsnip::bag_tree()`) to a party object for use with \pkg{partykit} +#' visualization and analysis tools. Both the "rpart" and "C5.0" engines are +#' supported. +#' +#' @param obj A `bagger` object, which is the `fit` element of a fitted +#' `bag_tree()` model. +#' @param tree A single integer specifying which tree (ensemble member) to +#' convert. Must be between 1 and the number of bagged trees. +#' @param data A data frame with the training data, including the outcome. The +#' bootstrap samples used to fit each tree are not saved, so this is used for +#' the node assignments and predictions in the party object. +#' @param ... Not currently used. +#' +#' @return A `party` object from the \pkg{partykit} package. +#' +#' @examplesIf rlang::is_installed(c("baguette", "parsnip", "rpart", "palmerpenguins")) +#' data(penguins, package = "palmerpenguins") +#' penguins <- na.omit(penguins) +#' +#' set.seed(1) +#' bag_fit <- parsnip::bag_tree(mode = "classification", tree_depth = 3) |> +#' parsnip::set_engine("rpart", times = 3) |> +#' parsnip::fit(species ~ ., data = penguins) +#' +#' as.party(bag_fit$fit, tree = 2L, data = penguins) +#' +#' @export +as.party.bagger <- function(obj, tree = 1L, data = NULL, ...) { + bagger_check(obj) + if (is.null(data)) { + cli::cli_abort("{.arg data} is required for {.fn as.party.bagger}.") + } + if (!is.numeric(tree) || length(tree) != 1) { + cli::cli_abort( + "{.arg tree} must be a single integer, not {.obj_type_friendly {tree}}." + ) + } + tree <- bagger_check_tree(tree, obj) + + member <- bagger_member(obj, tree) + if (obj$base_model[1] == "C5.0") { + return(as.party(member, tree = 1L, data = data)) + } + + outcome <- names(obj$blueprint$ptypes$outcomes) + bagger_rpart_party(member, data, outcome) +} + +#' @rdname extract_rules +#' @param tree Integer vector specifying which trees (ensemble members) to +#' extract rules from. Default is `1L` for the first tree. Values must be +#' between 1 and the number of bagged trees. +#' @export +extract_rules.bagger <- function(x, tree = 1L, add_statistics = FALSE, ...) { + check_bool(add_statistics) + bagger_check(x) + tree <- bagger_check_tree(tree, x) + + results <- lapply(tree, function(i) { + res <- extract_rules(bagger_member(x, i)) + res$tree <- rep(i, nrow(res)) + res[c("id", "rules", "tree")] + }) + + res <- dplyr::bind_rows(results) |> + dplyr::arrange(tree, id) + engine_class <- ifelse(x$base_model[1] == "CART", "rpart", "C5.0") + engine_class <- paste0("rule_set_", engine_class) + class(res) <- c( + engine_class, + "rule_set", + "tbl_df", + "tbl", + "data.frame" + ) + + maybe_add_rule_statistics(res, add_statistics) +} + +#' @rdname active_predictors +#' @param tree Integer vector specifying which trees (ensemble members) to +#' extract active predictors from. Default is `1L` for the first tree. Values +#' must be between 1 and the number of bagged trees. +#' @export +active_predictors.bagger <- function(x, tree = 1L, ...) { + bagger_check(x) + tree <- bagger_check_tree(tree, x) + + results <- lapply(tree, function(i) { + vars <- active_predictors(bagger_member(x, i))$active_predictors[[1]] + new_active_predictors(vars, tree = i) + }) + + dplyr::bind_rows(results) +} diff --git a/R/generics.R b/R/generics.R index ff3239b..125ef44 100644 --- a/R/generics.R +++ b/R/generics.R @@ -84,8 +84,8 @@ active_predictors <- function(x, ...) { #' Count the number of members in an ensemble #' -#' Ensembles of trees or rules, such as random forests or boosted models, -#' contain multiple models. This generic returns how many there are. For most +#' Ensembles of trees or rules, such as random forests, bagged trees, or boosted +#' models, contain multiple models. This generic returns how many there are. For most #' models this is the number of trees. For C5.0 models it is the number of #' boosting trials and, for Cubist models, the number of committees. For #' multiclass boosted models (e.g., from \pkg{xgboost} and \pkg{lightgbm}), the diff --git a/R/lgb.Booster.R b/R/lgb.Booster.R index 5246ebf..f575fcb 100644 --- a/R/lgb.Booster.R +++ b/R/lgb.Booster.R @@ -832,9 +832,10 @@ lgb_build_partynode <- function( if (is_cat_split) { # Codes in the threshold go to the left child, all others to the right left_codes <- lgb_parse_cat_threshold(node_row$threshold) + child_index <- ifelse(cat_codes[[feature_name]] %in% left_codes, 1L, 2L) split <- partykit::partysplit( varid = as.integer(varid), - index = ifelse(cat_codes[[feature_name]] %in% left_codes, 1L, 2L) + index = child_index ) } else { split_val <- as.numeric(node_row$threshold) diff --git a/R/rpart.R b/R/rpart.R index 3ee932c..ca2f0af 100644 --- a/R/rpart.R +++ b/R/rpart.R @@ -149,9 +149,10 @@ rpart_get_split_info <- function(node_id, child_id, x) { # rpart-specific helper to get factor level names rpart_get_factor_levels <- function(var_name, level_indices, x) { - # First try xlevels (fastest) - if (!is.null(x$xlevels) && var_name %in% names(x$xlevels)) { - return(x$xlevels[[var_name]][level_indices]) + # First try xlevels (fastest); rpart stores it as an attribute + xlevels <- attr(x, "xlevels") %||% x$xlevels + if (!is.null(xlevels) && var_name %in% names(xlevels)) { + return(xlevels[[var_name]][level_indices]) } # Try to get from the model's data via environment diff --git a/man/active_predictors.Rd b/man/active_predictors.Rd index 646b210..31b1440 100644 --- a/man/active_predictors.Rd +++ b/man/active_predictors.Rd @@ -1,11 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/C5.0.R, R/ObliqueForest.R, R/bart.R, -% R/catboost.Model.R, R/cforest.R, R/cubist.R, R/generics.R, R/grf.R, -% R/lgb.Booster.R, R/party.R, R/randomForest.R, R/ranger.R, R/rpart.R, -% R/xgb.Booster.R +% Please edit documentation in R/C5.0.R, R/ObliqueForest.R, R/bagger.R, +% R/bart.R, R/catboost.Model.R, R/cforest.R, R/cubist.R, R/generics.R, +% R/grf.R, R/lgb.Booster.R, R/party.R, R/randomForest.R, R/ranger.R, +% R/rpart.R, R/xgb.Booster.R \name{active_predictors.C5.0} \alias{active_predictors.C5.0} \alias{active_predictors.ObliqueForest} +\alias{active_predictors.bagger} \alias{active_predictors.bart} \alias{active_predictors.catboost.Model} \alias{active_predictors.cforest} @@ -24,6 +25,8 @@ \method{active_predictors}{ObliqueForest}(x, tree = 1L, ...) +\method{active_predictors}{bagger}(x, tree = 1L, ...) + \method{active_predictors}{bart}(x, tree = 1L, ...) \method{active_predictors}{catboost.Model}(x, tree = 1L, ...) diff --git a/man/as.party.bagger.Rd b/man/as.party.bagger.Rd new file mode 100644 index 0000000..99a8619 --- /dev/null +++ b/man/as.party.bagger.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bagger.R +\name{as.party.bagger} +\alias{as.party.bagger} +\title{Convert a bagged tree to a party object} +\usage{ +\method{as.party}{bagger}(obj, tree = 1L, data = NULL, ...) +} +\arguments{ +\item{obj}{A \code{bagger} object, which is the \code{fit} element of a fitted +\code{bag_tree()} model.} + +\item{tree}{A single integer specifying which tree (ensemble member) to +convert. Must be between 1 and the number of bagged trees.} + +\item{data}{A data frame with the training data, including the outcome. The +bootstrap samples used to fit each tree are not saved, so this is used for +the node assignments and predictions in the party object.} + +\item{...}{Not currently used.} +} +\value{ +A \code{party} object from the \pkg{partykit} package. +} +\description{ +Convert a single tree from a bagged model created by \pkg{baguette} (e.g., +\code{parsnip::bag_tree()}) to a party object for use with \pkg{partykit} +visualization and analysis tools. Both the "rpart" and "C5.0" engines are +supported. +} +\examples{ +\dontshow{if (rlang::is_installed(c("baguette", "parsnip", "rpart", "palmerpenguins"))) withAutoprint(\{ # examplesIf} +data(penguins, package = "palmerpenguins") +penguins <- na.omit(penguins) + +set.seed(1) +bag_fit <- parsnip::bag_tree(mode = "classification", tree_depth = 3) |> + parsnip::set_engine("rpart", times = 3) |> + parsnip::fit(species ~ ., data = penguins) + +as.party(bag_fit$fit, tree = 2L, data = penguins) +\dontshow{\}) # examplesIf} +} diff --git a/man/extract_rules.Rd b/man/extract_rules.Rd index f284ea0..6aeb4c0 100644 --- a/man/extract_rules.Rd +++ b/man/extract_rules.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/C5.0.R, R/cforest.R, R/generics.R, R/grf.R, -% R/randomForest.R, R/ranger.R +% Please edit documentation in R/C5.0.R, R/bagger.R, R/cforest.R, R/generics.R, +% R/grf.R, R/randomForest.R, R/ranger.R \name{extract_rules.C5.0} \alias{extract_rules.C5.0} +\alias{extract_rules.bagger} \alias{extract_rules.cforest} \alias{extract_rules} \alias{extract_rules.grf} @@ -12,6 +13,8 @@ \usage{ \method{extract_rules}{C5.0}(x, tree = 1L, add_statistics = FALSE, ...) +\method{extract_rules}{bagger}(x, tree = 1L, add_statistics = FALSE, ...) + \method{extract_rules}{cforest}(x, tree = 1L, add_statistics = FALSE, ...) extract_rules(x, ...) diff --git a/man/num_ensemble_members.Rd b/man/num_ensemble_members.Rd index 6490926..745110e 100644 --- a/man/num_ensemble_members.Rd +++ b/man/num_ensemble_members.Rd @@ -1,10 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/C5.0.R, R/ObliqueForest.R, R/bart.R, -% R/catboost.Model.R, R/cforest.R, R/cubist.R, R/generics.R, R/grf.R, -% R/lgb.Booster.R, R/randomForest.R, R/ranger.R, R/xgb.Booster.R +% Please edit documentation in R/C5.0.R, R/ObliqueForest.R, R/bagger.R, +% R/bart.R, R/catboost.Model.R, R/cforest.R, R/cubist.R, R/generics.R, +% R/grf.R, R/lgb.Booster.R, R/randomForest.R, R/ranger.R, R/xgb.Booster.R \name{num_ensemble_members.C5.0} \alias{num_ensemble_members.C5.0} \alias{num_ensemble_members.ObliqueForest} +\alias{num_ensemble_members.bagger} \alias{num_ensemble_members.bart} \alias{num_ensemble_members.catboost.Model} \alias{num_ensemble_members.cforest} @@ -21,6 +22,8 @@ \method{num_ensemble_members}{ObliqueForest}(x, ...) +\method{num_ensemble_members}{bagger}(x, ...) + \method{num_ensemble_members}{bart}(x, ...) \method{num_ensemble_members}{catboost.Model}(x, ...) @@ -50,8 +53,8 @@ num_ensemble_members(x, ...) A single integer. } \description{ -Ensembles of trees or rules, such as random forests or boosted models, -contain multiple models. This generic returns how many there are. For most +Ensembles of trees or rules, such as random forests, bagged trees, or boosted +models, contain multiple models. This generic returns how many there are. For most models this is the number of trees. For C5.0 models it is the number of boosting trials and, for Cubist models, the number of committees. For multiclass boosted models (e.g., from \pkg{xgboost} and \pkg{lightgbm}), the diff --git a/plans/2026-10-23-1317-bagger-methods.md b/plans/2026-10-23-1317-bagger-methods.md new file mode 100644 index 0000000..9b17996 --- /dev/null +++ b/plans/2026-10-23-1317-bagger-methods.md @@ -0,0 +1,74 @@ +# Methods for baguette bagged trees (CART and C5.0) + +## Overview + +baguette fits bagged trees through `parsnip::bag_tree()` (engines "rpart" and "C5.0"). `baguette::bagger()` is an S3 generic, not the spec constructor. The fitted engine object (`fit$fit`) has class `c("bagger", "hardhat_model", "hardhat_scalar")`. lorax dispatches only on raw engine classes, so the new methods are `*.bagger` and take the engine object, not the parsnip `model_fit`. + +Structure of a `bagger` object (verified locally with baguette, rpart and C50 installed): + +- `model_df`: tibble with list column `model`, one row per member. Each element is a parsnip `model_fit`, and `$fit` is a butchered `rpart` or `C5.0` object. +- `imp`: tibble with `term`, `value`, `std.error`, `used`. +- `base_model`: `c("CART", )` or `c("C5.0", )`, which tells the engines apart. +- Each C5.0 member has `trials["Actual"] == 1`. +- Butchered rpart keeps `frame` and `splits`, but `xlevels` is an attribute, not a list element, and `call$data` is a dummy. + +Members are single trees, so the `tree` argument is the member index, as for `randomForest`. + +## Checklist + +- [x] Copy this plan to `plans/2026-10-23-{hhmm}-bagger-methods.md` in the repo (plan mode only lets me write the auto-named file) and reference it in the issue +- [x] Fix `rpart_get_factor_levels()` in `R/rpart.R` to also read `attr(x, "xlevels")` +- [x] Add `R/bagger.R` with `num_ensemble_members.bagger`, `active_predictors.bagger`, `extract_rules.bagger`, `var_imp.bagger` +- [x] Add `baguette` and `parsnip` to Suggests in `DESCRIPTION` +- [x] Add tests in `tests/testthat/test-bagger.R` (snapshots) and a rpart categorical-xlevels test in `test-rpart.R` +- [x] Add a `NEWS.md` bullet and any new words to `inst/WORDLIST` +- [x] `devtools::document()`, `air format .`, run tests, `devtools::check()` + +## Details + +### `R/bagger.R` + +Internal helpers: + +- `bagger_members(x)`: `x$model_df$model`. +- `bagger_member_fit(x, i)`: `x$model_df$model[[i]]$fit`. +- `bagger_check_tree(tree, x)`: same validation as `extract_rules.randomForest` (integer-valued, within `1:num_ensemble_members(x)`), using `cli::cli_abort`. +- `bagger_engine(x)`: `x$base_model[1]`, either `"CART"` or `"C5.0"`. Abort for anything else. + +Methods (each with `rlang::check_installed("baguette")` and roxygen via `@rdname`, no new topics): + +- `num_ensemble_members.bagger`: `nrow(x$model_df)` as an integer. Update the roxygen description of the generic in `R/generics.R` to mention bagged trees. +- `active_predictors.bagger(x, tree = 1L, ...)`: for each requested member call `active_predictors()` on the member fit (rpart or C5.0 method) and rebuild with `new_active_predictors(vars, tree = i)`, following `rf_extract_one`. Check what `new_active_predictors()` accepts before reusing the single-tree result. +- `extract_rules.bagger(x, tree = 1L, add_statistics = FALSE, ...)`: call `extract_rules()` on each member fit, set the `tree` column to the member index (C5.0 already has one, rpart does not), `bind_rows`, arrange by `tree` then `id`, then `maybe_add_rule_statistics()`. Keep the engine-specific `rule_set_*` class in addition to `rule_set`, matching what the per-engine method returns. +- `var_imp.bagger(object, complete = TRUE, ...)`: use `object$imp` (`term`, `value` renamed to `estimate`), and complete over predictor names from `object$blueprint` when `complete = TRUE`. Check how `complete_results()` and `terms_predictor_names()` work to choose the predictor source, since there is no `terms` object. + +Out of scope: `as.party.bagger` (no `as.party` for rpart in lorax) and methods on the parsnip `model_fit`. + +### `R/rpart.R` fix + +`rpart_get_factor_levels()` checks `x$xlevels`, which is NULL for real rpart objects and falls through to a data lookup that fails for butchered models. Add `attr(x, "xlevels")` as the first source. This also fixes categorical splits for plain `rpart` fits with a dummy call. + +### Tests + +- Use `skip_on_cran()` and `skip_if_not_installed()` for `baguette`, `parsnip`, `rpart`, `C50`, per existing files. +- Fit small models (`times = 3`) with `set.seed()`. Use mixed-type data (`get_wa_trees_data()`) so categorical splits are covered, plus a regression fit. +- Use `expect_snapshot()` for rule output and `expect_snapshot(error = TRUE)` for bad `tree` values (no `expect_error()`), per CLAUDE.md. +- Cover: `num_ensemble_members` equals `times`, multi-tree `extract_rules` has the right `tree` values, `add_statistics`, `active_predictors` for a vector of trees, `var_imp` with and without `complete`, and both engines. + +### Docs and housekeeping + +- `NEWS.md`: one bullet under "lorax (development version)", placed alphabetically by function name (the new methods mention `extract_rules()` and others), no line wrapping, with the issue number. +- `_pkgdown.yml` has no reference index, so no change. +- Per CLAUDE.md, no commit, push or PR unless explicitly asked. + +## Verification + +- `Rscript -e "devtools::test(filter = '^bagger')"` and `filter = '^rpart'` +- `Rscript -e "devtools::test()"` for the full suite +- Check by hand that `extract_rules(bag_fit$fit, tree = 1:2)` for both engines matches `extract_rules()` on the member fits +- `Rscript -e "devtools::document()"`, `air format .`, `Rscript -e "devtools::check()"` + +## Follow-up (2026-10-23) + +- [x] Add `as.party.bagger()` (rpart members use `partykit::as.party.rpart()` after rebuilding the model frame and node assignments from user-supplied `data`; C5.0 members delegate to `as.party.C5.0()`) +- [x] Drop `var_imp.bagger()`: baguette already registers a `var_imp.bagger` method (returns `object$imp`), and lorax's version overwrote it on load diff --git a/tests/testthat/_snaps/bagger.md b/tests/testthat/_snaps/bagger.md new file mode 100644 index 0000000..ee023ba --- /dev/null +++ b/tests/testthat/_snaps/bagger.md @@ -0,0 +1,169 @@ +# extract_rules.bagger() works with bagged CART + + Code + res$rules + Output + [[1]] + bill_length_mm < 42.35 & bill_depth_mm >= 14.6 + + [[2]] + bill_length_mm < 42.35 & bill_depth_mm < 14.6 + + [[3]] + bill_length_mm >= 42.35 & island %in% c("Dream", "Torgersen") & + island == "Torgersen" + + [[4]] + bill_length_mm >= 42.35 & island %in% c("Dream", "Torgersen") & + island == "Dream" + + [[5]] + bill_length_mm >= 42.35 & island == "Biscoe" & bill_depth_mm >= + 18.15 + + [[6]] + bill_length_mm >= 42.35 & island == "Biscoe" & bill_depth_mm < + 18.15 + + [[7]] + bill_length_mm < 42.35 & bill_depth_mm >= 15.1 + + [[8]] + bill_length_mm < 42.35 & bill_depth_mm < 15.1 + + [[9]] + bill_length_mm >= 42.35 & island %in% c("Dream", "Torgersen") & + island == "Torgersen" + + [[10]] + bill_length_mm >= 42.35 & island %in% c("Dream", "Torgersen") & + island == "Dream" + + [[11]] + bill_length_mm >= 42.35 & island == "Biscoe" & bill_depth_mm >= + 17.8 + + [[12]] + bill_length_mm >= 42.35 & island == "Biscoe" & bill_depth_mm < + 17.8 + + +# extract_rules.bagger() works with bagged C5.0 + + Code + res$rules[res$tree == 3] + Output + [[1]] + is.na(bill_depth_mm) + + [[2]] + bill_depth_mm <= 16.4 & island == "Biscoe" + + [[3]] + bill_depth_mm <= 16.4 & island == "Biscoe" + + [[4]] + bill_depth_mm <= 16.4 & island == "Biscoe" + + [[5]] + bill_depth_mm > 16.4 & is.na(bill_length_mm) + + [[6]] + bill_depth_mm > 16.4 & bill_length_mm <= 44.5 & is.na(bill_depth_mm) + + [[7]] + bill_depth_mm > 16.4 & bill_length_mm <= 44.5 & bill_depth_mm <= + 16.700001 & is.na(bill_length_mm) + + [[8]] + bill_depth_mm > 16.4 & bill_length_mm <= 44.5 & bill_depth_mm <= + 16.700001 & bill_length_mm <= 40.200001 + + [[9]] + bill_depth_mm > 16.4 & bill_length_mm <= 44.5 & bill_depth_mm <= + 16.700001 & bill_length_mm > 40.200001 + + [[10]] + bill_depth_mm > 16.4 & bill_length_mm <= 44.5 & bill_depth_mm > + 16.700001 + + [[11]] + bill_depth_mm > 16.4 & bill_length_mm > 44.5 & island == "Biscoe" & + is.na(bill_depth_mm) + + [[12]] + bill_depth_mm > 16.4 & bill_length_mm > 44.5 & island == "Biscoe" & + bill_depth_mm <= 18.799999 + + [[13]] + bill_depth_mm > 16.4 & bill_length_mm > 44.5 & island == "Biscoe" & + bill_depth_mm > 18.799999 + + [[14]] + bill_depth_mm > 16.4 & bill_length_mm > 44.5 & island == "Biscoe" + + +# extract_rules.bagger() validates tree + + Code + extract_rules(fit, tree = 4L) + Condition + Error in `extract_rules()`: + ! `tree` values must be between 1 and 3. + +--- + + Code + extract_rules(fit, tree = "a") + Condition + Error in `extract_rules()`: + ! `tree` must be an integer vector, not a string. + +# active_predictors.bagger() validates tree + + Code + active_predictors(fit, tree = 0L) + Condition + Error in `active_predictors()`: + ! `tree` values must be between 1 and 3. + +# bagger methods reject unsupported base models + + Code + num_ensemble_members(fit) + Condition + Error in `num_ensemble_members()`: + ! Only bagged "CART" and "C5.0" trees are supported, not "MARS". + +# as.party.bagger() validates its arguments + + Code + as.party(fit, tree = 1L) + Condition + Error in `as.party()`: + ! `data` is required for `as.party.bagger()`. + +--- + + Code + as.party(fit, tree = 4L, data = data) + Condition + Error in `as.party()`: + ! `tree` values must be between 1 and 3. + +--- + + Code + as.party(fit, tree = 1:2, data = data) + Condition + Error in `as.party()`: + ! `tree` must be a single integer, not an integer vector. + +--- + + Code + as.party(fit, data = data[-2]) + Condition + Error in `as.party()`: + ! `data` is missing column "island". + diff --git a/tests/testthat/helper-data.R b/tests/testthat/helper-data.R index c9c8059..54a79f2 100644 --- a/tests/testthat/helper-data.R +++ b/tests/testthat/helper-data.R @@ -174,19 +174,9 @@ get_structured_regression_data <- function(n = 100) { # Create outcome with clear conditional structure # This ensures Cubist will create meaningful splits - y <- ifelse( - X$x1 > 5, - ifelse( - X$x2 > 5, - X$x1 + X$x2, # High x1, high x2 - X$x1 - X$x2 - ), # High x1, low x2 - ifelse( - X$x3 == "A", - 2 * X$x2, # Low x1, category A - X$x1 + 3 - ) - ) # Low x1, category B or C + y_high_x1 <- ifelse(X$x2 > 5, X$x1 + X$x2, X$x1 - X$x2) + y_low_x1 <- ifelse(X$x3 == "A", 2 * X$x2, X$x1 + 3) + y <- ifelse(X$x1 > 5, y_high_x1, y_low_x1) y <- y + rnorm(n, sd = 0.5) list(x = X, y = y) diff --git a/tests/testthat/test-C5.0.R b/tests/testthat/test-C5.0.R index 173a644..b5657b1 100644 --- a/tests/testthat/test-C5.0.R +++ b/tests/testthat/test-C5.0.R @@ -1079,7 +1079,8 @@ test_that("num_ensemble_members() uses the actual number of C5.0 trials", { set.seed(2817) data <- data.frame(x = runif(100), z = runif(100)) - data$y <- factor(ifelse(data$x > 0.5, "a", "b")) + y_labels <- ifelse(data$x > 0.5, "a", "b") + data$y <- factor(y_labels) c5_early <- C50::C5.0(y ~ ., data = data, trials = 10) expect_identical(unname(c5_early$trials["Requested"]), 10) diff --git a/tests/testthat/test-bagger.R b/tests/testthat/test-bagger.R new file mode 100644 index 0000000..3a807d6 --- /dev/null +++ b/tests/testthat/test-bagger.R @@ -0,0 +1,157 @@ +skip_on_cran() + +fit_bagger <- function(formula, data, engine, mode = "classification") { + skip_if_not_installed("baguette") + skip_if_not_installed("parsnip") + engine_pkg <- ifelse(engine == "rpart", "rpart", "C50") + skip_if_not_installed(engine_pkg) + + set.seed(528) + parsnip::bag_tree(mode = mode, tree_depth = 3) |> + parsnip::set_engine(engine, times = 3) |> + parsnip::fit(formula, data = data) |> + purrr::pluck("fit") +} + +test_that("num_ensemble_members.bagger() returns the number of trees", { + data <- get_factor_data() + + for (engine in c("rpart", "C5.0")) { + fit <- fit_bagger(y ~ ., data, engine) + expect_identical(num_ensemble_members(fit), 3L) + } + + fit <- fit_bagger(mpg ~ ., get_mtcars_data(), "rpart", "regression") + expect_identical(num_ensemble_members(fit), 3L) +}) + +test_that("extract_rules.bagger() works with bagged CART", { + data <- get_factor_data() + fit <- fit_bagger(y ~ ., data, "rpart") + + res <- extract_rules(fit, tree = 1:2) + expect_s3_class(res, c("rule_set_rpart", "rule_set")) + expect_named(res, c("id", "rules", "tree")) + expect_setequal(res$tree, 1:2) + expect_snapshot(res$rules) + + one <- extract_rules(fit, tree = 2L) + expect_identical(one$rules, extract_rules(fit$model_df$model[[2]]$fit)$rules) +}) + +test_that("extract_rules.bagger() works with bagged C5.0", { + data <- get_factor_data() + fit <- fit_bagger(y ~ ., data, "C5.0") + + res <- extract_rules(fit, tree = 1:3) + expect_s3_class(res, c("rule_set_C5.0", "rule_set")) + expect_named(res, c("id", "rules", "tree")) + expect_setequal(res$tree, 1:3) + expect_snapshot(res$rules[res$tree == 3]) +}) + +test_that("extract_rules.bagger() works with regression", { + fit <- fit_bagger(mpg ~ ., get_mtcars_data(), "rpart", "regression") + + res <- extract_rules(fit, tree = 1:3) + expect_s3_class(res, "rule_set") + expect_setequal(res$tree, 1:3) +}) + +test_that("extract_rules.bagger() adds statistics", { + fit <- fit_bagger(y ~ ., get_factor_data(), "rpart") + + res <- extract_rules(fit, add_statistics = TRUE) + expect_named( + res, + c("id", "rules", "tree", "num_rule_terms", "num_rule_predictors") + ) +}) + +test_that("extract_rules.bagger() uses factor levels", { + fit <- fit_bagger(y ~ ., get_single_factor_data(), "rpart") + + res <- extract_rules(fit, tree = 1:3) + rule_text <- vapply(res$rules, rlang::expr_text, character(1)) + expect_false(any(grepl("c\\(\"?[0-9]", rule_text))) +}) + +test_that("extract_rules.bagger() validates tree", { + fit <- fit_bagger(y ~ ., get_factor_data(), "rpart") + + expect_snapshot(extract_rules(fit, tree = 4L), error = TRUE) + expect_snapshot(extract_rules(fit, tree = "a"), error = TRUE) +}) + +test_that("active_predictors.bagger() works", { + data <- get_factor_data() + + for (engine in c("rpart", "C5.0")) { + fit <- fit_bagger(y ~ ., data, engine) + res <- active_predictors(fit, tree = 1:3) + expect_named(res, c("active_predictors", "tree")) + expect_identical(res$tree, 1:3) + expect_all_true( + unlist(res$active_predictors) %in% setdiff(names(data), "y") + ) + } +}) + +test_that("active_predictors.bagger() validates tree", { + fit <- fit_bagger(y ~ ., get_factor_data(), "C5.0") + + expect_snapshot(active_predictors(fit, tree = 0L), error = TRUE) +}) + +test_that("bagger methods reject unsupported base models", { + fit <- fit_bagger(y ~ ., get_factor_data(), "rpart") + fit$base_model <- c("MARS", "classification") + + expect_snapshot(num_ensemble_members(fit), error = TRUE) +}) + +test_that("as.party.bagger() works with bagged CART", { + data <- get_factor_data() + fit <- fit_bagger(y ~ ., data, "rpart") + member <- fit$model_df$model[[2]]$fit + + res <- as.party(fit, tree = 2L, data = data) + expect_s3_class(res, "constparty") + expect_identical(nrow(res$data), nrow(data)) + expect_setequal( + partykit::nodeids(res, terminal = TRUE), + which(member$frame$var == "") + ) + expect_identical( + as.character(predict(res, newdata = res$data)), + as.character(predict(member, newdata = data, type = "class")) + ) +}) + +test_that("as.party.bagger() works with bagged CART regression", { + data <- get_mtcars_data() + fit <- fit_bagger(mpg ~ ., data, "rpart", "regression") + + res <- as.party(fit, tree = 1L, data = data) + expect_s3_class(res, "party") + expect_identical(nrow(res$data), nrow(data)) +}) + +test_that("as.party.bagger() works with bagged C5.0", { + data <- get_factor_data() + fit <- fit_bagger(y ~ ., data, "C5.0") + + res <- as.party(fit, tree = 3L, data = data) + expect_s3_class(res, "party") + expect_identical(nrow(res$data), nrow(data)) +}) + +test_that("as.party.bagger() validates its arguments", { + data <- get_factor_data() + fit <- fit_bagger(y ~ ., data, "rpart") + + expect_snapshot(as.party(fit, tree = 1L), error = TRUE) + expect_snapshot(as.party(fit, tree = 4L, data = data), error = TRUE) + expect_snapshot(as.party(fit, tree = 1:2, data = data), error = TRUE) + expect_snapshot(as.party(fit, data = data[-2]), error = TRUE) +}) diff --git a/tests/testthat/test-rpart.R b/tests/testthat/test-rpart.R index 2082d06..f11eae6 100644 --- a/tests/testthat/test-rpart.R +++ b/tests/testthat/test-rpart.R @@ -144,6 +144,18 @@ test_that("extract_rules.rpart() works with single factor predictor", { } }) +test_that("extract_rules.rpart() uses xlevels when the data are unavailable", { + skip_if_not_installed("rpart") + + data <- get_single_factor_data() + model <- rpart::rpart(y ~ x, data = data) + model$call$data <- quote(dummy) + + rules <- extract_rules(model) + rule_text <- vapply(rules$rules, rlang::expr_text, character(1)) + expect_true(any(grepl("Biscoe|Dream|Torgersen", rule_text))) +}) + test_that("extract_rules.rpart() works with single-node tree", { skip_if_not_installed("rpart") skip_if_not_installed("palmerpenguins")