From f7c1fd88774c62d3a7c5ce7dfface85e4c0a2ade Mon Sep 17 00:00:00 2001 From: Emil Hvitfeldt Date: Sun, 23 Aug 2026 14:39:44 -0700 Subject: [PATCH] Replace the .extract_* functions with generics The eleven exported .extract_* functions had no shared contract. Their names suggest two shapes; there are four, and the _classprob suffix covers two of them: A xgb, lgb, catboost, rf, ranger _trees flat list of tree exprs B rf, ranger _classprob level-keyed list of A C rpart, partykit _classprob one expr per level D earth, glmnet _multiclass one deparsed string per level Replace them with four generics whose return shapes are documented: tidypredict_trees() for A, tidypredict_class_trees() for B, tidypredict_class_exprs() for C and D, and tidypredict_n_trees(), which consumers currently substitute for by reading $ntree, $num.trees, niter or a JSON dump directly. Two behaviour changes fall out of unifying C and D. earth and glmnet now return language objects rather than deparsed strings, so that every extractor returns expressions. And the partykit result is keyed by outcome level; it was unnamed, which left callers assuming its order matched levels() of the outcome. rpart was already keyed, so only partykit changes here. The old names remain as thin wrappers. They are exported and each had an Rd, albeit with \keyword{internal}, so an unknown caller is possible. The earth and glmnet wrappers deparse to preserve their return type, and the partykit wrapper drops the new names. deprecate_soft() rather than deprecate_warn(): orbital calls these from its own namespace in sixteen places, and warning there would surface a message to orbital users about a function they neither called nor can avoid. Verified that a plain orbital session emits no warning while a direct caller still gets one. Also note catboost's niter counts boosting rounds, not trees: for multiclass models the two differ by the number of classes, so tidypredict_n_trees() counts trees rather than trusting it. --- DESCRIPTION | 1 + NAMESPACE | 24 ++ NEWS.md | 6 + R/deprec-extractors.R | 198 ++++++++++ R/extractors.R | 118 ++++++ R/model-catboost.R | 27 +- R/model-earth.R | 22 +- R/model-glmnet.R | 27 +- R/model-lightgbm.R | 26 +- R/model-partykit.R | 22 +- R/model-ranger.R | 51 +-- R/model-rf.R | 64 ++- R/model-rpart.R | 24 +- R/model-xgboost.R | 29 +- man/deprecated-extractors.Rd | 62 +++ man/dot-extract_catboost_trees.Rd | 15 - man/dot-extract_earth_multiclass.Rd | 15 - man/dot-extract_glmnet_multiclass.Rd | 17 - man/dot-extract_lgb_trees.Rd | 15 - man/dot-extract_partykit_classprob.Rd | 15 - man/dot-extract_ranger_classprob.Rd | 15 - man/dot-extract_ranger_trees.Rd | 15 - man/dot-extract_rf_classprob.Rd | 15 - man/dot-extract_rf_trees.Rd | 15 - man/dot-extract_rpart_classprob.Rd | 15 - man/dot-extract_xgb_trees.Rd | 15 - man/tidypredict_extractors.Rd | 80 ++++ tests/testthat/_snaps/deprec-extractors.md | 220 +++++++++++ tests/testthat/_snaps/model-catboost.md | 8 +- tests/testthat/_snaps/model-earth.md | 20 +- tests/testthat/_snaps/model-glmnet.md | 14 +- tests/testthat/_snaps/model-lightgbm.md | 8 +- tests/testthat/_snaps/model-partykit.md | 8 +- tests/testthat/_snaps/model-ranger.md | 30 +- tests/testthat/_snaps/model-rf.md | 32 +- tests/testthat/_snaps/model-rpart.md | 16 +- tests/testthat/_snaps/model-xgboost.md | 8 +- tests/testthat/test-deprec-extractors.R | 429 +++++++++++++++++++++ tests/testthat/test-model-catboost.R | 22 +- tests/testthat/test-model-earth.R | 30 +- tests/testthat/test-model-glmnet.R | 47 ++- tests/testthat/test-model-lightgbm.R | 22 +- tests/testthat/test-model-partykit.R | 23 +- tests/testthat/test-model-ranger.R | 64 +-- tests/testthat/test-model-rf.R | 61 +-- tests/testthat/test-model-rpart.R | 25 +- tests/testthat/test-model-xgboost.R | 28 +- 47 files changed, 1532 insertions(+), 531 deletions(-) create mode 100644 R/deprec-extractors.R create mode 100644 R/extractors.R create mode 100644 man/deprecated-extractors.Rd delete mode 100644 man/dot-extract_catboost_trees.Rd delete mode 100644 man/dot-extract_earth_multiclass.Rd delete mode 100644 man/dot-extract_glmnet_multiclass.Rd delete mode 100644 man/dot-extract_lgb_trees.Rd delete mode 100644 man/dot-extract_partykit_classprob.Rd delete mode 100644 man/dot-extract_ranger_classprob.Rd delete mode 100644 man/dot-extract_ranger_trees.Rd delete mode 100644 man/dot-extract_rf_classprob.Rd delete mode 100644 man/dot-extract_rf_trees.Rd delete mode 100644 man/dot-extract_rpart_classprob.Rd delete mode 100644 man/dot-extract_xgb_trees.Rd create mode 100644 man/tidypredict_extractors.Rd create mode 100644 tests/testthat/_snaps/deprec-extractors.md create mode 100644 tests/testthat/test-deprec-extractors.R diff --git a/DESCRIPTION b/DESCRIPTION index 836bc7a1..16f79d64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,6 +29,7 @@ Imports: generics, jsonlite, knitr, + lifecycle, purrr, rlang (>= 1.1.1), tibble, diff --git a/NAMESPACE b/NAMESPACE index bacb4785..71c863ce 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -64,6 +64,14 @@ S3method(parse_model,xgb.Booster) S3method(parse_model,xrf) S3method(print,tidypredict_test) S3method(tidy,pm_regression) +S3method(tidypredict_class_exprs,default) +S3method(tidypredict_class_exprs,earth) +S3method(tidypredict_class_exprs,multnet) +S3method(tidypredict_class_exprs,party) +S3method(tidypredict_class_exprs,rpart) +S3method(tidypredict_class_trees,default) +S3method(tidypredict_class_trees,randomForest) +S3method(tidypredict_class_trees,ranger) S3method(tidypredict_fit,"_xgb.Booster") S3method(tidypredict_fit,C5.0) S3method(tidypredict_fit,H2OBinomialModel) @@ -111,6 +119,12 @@ S3method(tidypredict_interval,default) S3method(tidypredict_interval,glm) S3method(tidypredict_interval,list) S3method(tidypredict_interval,lm) +S3method(tidypredict_n_trees,catboost.Model) +S3method(tidypredict_n_trees,default) +S3method(tidypredict_n_trees,lgb.Booster) +S3method(tidypredict_n_trees,randomForest) +S3method(tidypredict_n_trees,ranger) +S3method(tidypredict_n_trees,xgb.Booster) S3method(tidypredict_test,"_xgb.Booster") S3method(tidypredict_test,C5.0) S3method(tidypredict_test,H2OBinomialModel) @@ -149,6 +163,12 @@ S3method(tidypredict_test,rpart) S3method(tidypredict_test,sda) S3method(tidypredict_test,xgb.Booster) S3method(tidypredict_test,xrf) +S3method(tidypredict_trees,catboost.Model) +S3method(tidypredict_trees,default) +S3method(tidypredict_trees,lgb.Booster) +S3method(tidypredict_trees,randomForest) +S3method(tidypredict_trees,ranger) +S3method(tidypredict_trees,xgb.Booster) export(.build_case_when_tree) export(.build_linear_pred) export(.build_nested_case_when_tree) @@ -175,14 +195,18 @@ export(as_parsed_model) export(parse_model) export(set_catboost_categories) export(tidy) +export(tidypredict_class_exprs) +export(tidypredict_class_trees) export(tidypredict_fit) export(tidypredict_interval) export(tidypredict_load) +export(tidypredict_n_trees) export(tidypredict_save) export(tidypredict_sql) export(tidypredict_sql_interval) export(tidypredict_test) export(tidypredict_to_column) +export(tidypredict_trees) import(rlang) importFrom(dplyr,case_when) importFrom(dplyr,mutate) diff --git a/NEWS.md b/NEWS.md index 43d0f006..d23f1592 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,12 @@ - Fixed `cforest()` models failing with "'language' object cannot be coerced to type 'symbol'" under partykit 1.3-0. That release added a shim to partykit's methods that identifies the caller with `as.name()`, which errors when the generic is reached as `partykit::gettree()`. (#434) +- New generics expose the pieces `tidypredict_fit()` is assembled from, so that packages generating their own code from a fitted model can reuse tidypredict's parsing: `tidypredict_trees()` returns per-tree expressions, `tidypredict_class_trees()` returns per-tree expressions for each outcome level, `tidypredict_class_exprs()` returns one finished expression per outcome level, and `tidypredict_n_trees()` returns the number of trees. See `?tidypredict_extractors`. (#433) + +- The eleven `.extract_*()` functions are deprecated in favour of those generics. They were exported but documented as internal, and each is now a thin wrapper that warns. Two of them change return type under the new names: `.extract_earth_multiclass()` and `.extract_glmnet_multiclass()` returned deparsed strings, while `tidypredict_class_exprs()` returns language objects like every other extractor. (#433) + +- `tidypredict_class_exprs()` on a `partykit` model is named by outcome level. The `.extract_partykit_classprob()` it replaces returned an unnamed list, which left callers assuming its order matched `levels()` of the outcome. (#433) + - The error raised when no method knows how to handle a model at all now carries the condition class `tidypredict_unsupported_model`. Many other errors also say "are not supported", but they report an unsupported *configuration* of a model that is otherwise handled, so the wording alone could not distinguish the two. Packages that wrap `tidypredict_fit()`, such as orbital, need that distinction to decide whether to fall back or to report the model as unsupported. (#432) - New articles for `kernlab::ksvm()`, `mboost::blackboost()` and `xrf::xrf()`, and the model list menu now links to the `LiblineaR` and `quantreg` sections directly. (#317) diff --git a/R/deprec-extractors.R b/R/deprec-extractors.R new file mode 100644 index 00000000..48730bae --- /dev/null +++ b/R/deprec-extractors.R @@ -0,0 +1,198 @@ +# Deprecated in favour of the generics in extractors.R. +# +# These were exported and documented with `\keyword{internal}` for orbital's +# use. They are kept as thin wrappers for one cycle rather than removed +# outright, since being exported means an unknown caller is possible. +# +# `deprecate_soft()` rather than `deprecate_warn()`: orbital still calls these +# from its own namespace, and warning there would surface a message to orbital +# users about a function they did not call and cannot avoid. Soft deprecation +# still warns a direct caller, which is who can act on it. +# +# Two of them change return type as well as name, and cannot be made +# type-compatible: `.extract_earth_multiclass()` and +# `.extract_glmnet_multiclass()` returned deparsed strings, while +# `tidypredict_class_exprs()` returns language objects like every other +# extractor. The wrappers deparse the result to keep the old behaviour intact. + +#' Deprecated model extractors +#' +#' @description +#' `r lifecycle::badge("deprecated")` +#' +#' These functions have been replaced by generics with documented return +#' shapes. See [tidypredict_extractors]. +#' +#' | Deprecated | Replacement | +#' | --- | --- | +#' | `.extract_xgb_trees()`, `.extract_lgb_trees()`, `.extract_catboost_trees()`, `.extract_rf_trees()`, `.extract_ranger_trees()` | [tidypredict_trees()] | +#' | `.extract_rf_classprob()`, `.extract_ranger_classprob()` | [tidypredict_class_trees()] | +#' | `.extract_rpart_classprob()`, `.extract_partykit_classprob()`, `.extract_earth_multiclass()`, `.extract_glmnet_multiclass()` | [tidypredict_class_exprs()] | +#' +#' @param model A fitted model object. +#' @param penalty The penalty value to use for coefficient extraction. +#' +#' @returns The same values these functions have always returned. Note that +#' [tidypredict_class_exprs()] returns language objects where +#' `.extract_earth_multiclass()` and `.extract_glmnet_multiclass()` return +#' strings. +#' +#' @keywords internal +#' @name deprecated-extractors +NULL + +#' @rdname deprecated-extractors +#' @export +.extract_xgb_trees <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_xgb_trees()", + "tidypredict_trees()" + ) + check_extractor_class(model, "xgb.Booster") + tidypredict_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_lgb_trees <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_lgb_trees()", + "tidypredict_trees()" + ) + check_extractor_class(model, "lgb.Booster") + tidypredict_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_catboost_trees <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_catboost_trees()", + "tidypredict_trees()" + ) + check_extractor_class(model, "catboost.Model") + tidypredict_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_rf_trees <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_rf_trees()", + "tidypredict_trees()" + ) + check_extractor_class(model, "randomForest") + tidypredict_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_ranger_trees <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_ranger_trees()", + "tidypredict_trees()" + ) + check_extractor_class(model, "ranger") + tidypredict_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_rf_classprob <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_rf_classprob()", + "tidypredict_class_trees()" + ) + check_extractor_class(model, "randomForest") + tidypredict_class_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_ranger_classprob <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_ranger_classprob()", + "tidypredict_class_trees()" + ) + check_extractor_class(model, "ranger") + tidypredict_class_trees(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_rpart_classprob <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_rpart_classprob()", + "tidypredict_class_exprs()" + ) + check_extractor_class(model, "rpart") + # This one was already named by outcome level, so it is passed through as is. + tidypredict_class_exprs(model) +} + +#' @rdname deprecated-extractors +#' @export +.extract_partykit_classprob <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_partykit_classprob()", + "tidypredict_class_exprs()" + ) + check_extractor_class(model, "party") + # The generic gained outcome-level names; this returned an unnamed list. + unname(tidypredict_class_exprs(model)) +} + +#' @rdname deprecated-extractors +#' @export +.extract_earth_multiclass <- function(model) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_earth_multiclass()", + "tidypredict_class_exprs()" + ) + check_extractor_class(model, "earth") + deparse_class_exprs(tidypredict_class_exprs(model)) +} + +#' @rdname deprecated-extractors +#' @export +.extract_glmnet_multiclass <- function(model, penalty = NULL) { + lifecycle::deprecate_soft( + "1.1.1", + ".extract_glmnet_multiclass()", + "tidypredict_class_exprs()" + ) + check_extractor_class(model, "multnet") + deparse_class_exprs(tidypredict_class_exprs(model, penalty = penalty)) +} + +# The old functions checked the class themselves and reported it against +# `model`. Dispatch would report it against `x` and name a different function, +# so the check is kept here to leave the deprecated messages unchanged. +check_extractor_class <- function( + model, + cls, + call = rlang::caller_env() +) { + if (!inherits(model, cls)) { + cli::cli_abort( + "{.arg model} must be {.cls {cls}}, not {.obj_type_friendly {model}}.", + call = call + ) + } + + invisible(model) +} + +deparse_class_exprs <- function(x) { + lapply(x, function(e) deparse1(e, control = "digits17")) +} diff --git a/R/extractors.R b/R/extractors.R new file mode 100644 index 00000000..722e6cb2 --- /dev/null +++ b/R/extractors.R @@ -0,0 +1,118 @@ +#' Extract model internals as expressions +#' +#' @description +#' These generics expose the pieces `tidypredict_fit()` is assembled from, +#' rather than the finished formula. They exist so that packages generating +#' their own code from a fitted model, such as orbital, can reuse +#' tidypredict's parsing instead of reimplementing it per model class. +#' +#' Each generic has a single fixed return shape, described below. A model class +#' implements whichever generics make sense for it: a random forest has trees +#' and a tree count, a `glmnet` multinomial model has neither. +#' +#' @param x A fitted model object. +#' @param ... Additional arguments passed to methods. `multnet` models accept +#' `penalty`, which is required when the model was fitted with more than one +#' value of lambda. +#' +#' @returns +#' `tidypredict_trees()` returns an unnamed list with one element per tree, +#' each a language object. +#' +#' `tidypredict_class_trees()` returns a list named by outcome level, in model +#' order. Each element is itself an unnamed list of per-tree language objects +#' for that level, so the result is `tidypredict_trees()` nested one level +#' deeper. What the leaves hold depends on the model: `randomForest` gives +#' 0/1 votes, `ranger` gives class probabilities. +#' +#' `tidypredict_class_exprs()` returns a list named by outcome level, in model +#' order, with one language object per level. Unlike +#' `tidypredict_class_trees()` there is no per-tree structure and nothing to +#' combine: each expression computes that level's value on its own. +#' +#' `tidypredict_n_trees()` returns a single integer, the number of trees in the +#' ensemble. For multiclass boosters this counts every tree, including the +#' per-class copies, so it is not the same as the number of boosting rounds. +#' +#' Wherever an expression is described above, a **bare numeric value** may +#' appear in its place when the model has nothing to branch on. Callers must +#' handle both. This happens for a single-leaf tree, a stump, and also for a +#' degenerate expression such as a `glmnet` class whose coefficients are all +#' zero. Note that the constant can appear alongside language objects in the +#' same result, so the element type is not uniform within one list. +#' +#' @details +#' Two shapes that look similar are worth keeping apart. +#' `tidypredict_class_trees()` returns many trees per level that a caller has +#' to sum or average, and needs `tidypredict_n_trees()` to do it. +#' `tidypredict_class_exprs()` returns one finished expression per level. Both +#' are named by outcome level so that callers never have to assume the order +#' matches `levels()` of the outcome. +#' +#' @examplesIf rlang::is_installed("randomForest") +#' model <- randomForest::randomForest(mpg ~ ., data = mtcars, ntree = 5) +#' +#' tidypredict_n_trees(model) +#' +#' trees <- tidypredict_trees(model) +#' length(trees) +#' trees[[1]] +#' +#' @name tidypredict_extractors +NULL + +#' @rdname tidypredict_extractors +#' @export +tidypredict_trees <- function(x, ...) { + UseMethod("tidypredict_trees") +} + +#' @export +tidypredict_trees.default <- function(x, ...) { + abort_no_extractor(x, "tidypredict_trees") +} + +#' @rdname tidypredict_extractors +#' @export +tidypredict_class_trees <- function(x, ...) { + UseMethod("tidypredict_class_trees") +} + +#' @export +tidypredict_class_trees.default <- function(x, ...) { + abort_no_extractor(x, "tidypredict_class_trees") +} + +#' @rdname tidypredict_extractors +#' @export +tidypredict_class_exprs <- function(x, ...) { + UseMethod("tidypredict_class_exprs") +} + +#' @export +tidypredict_class_exprs.default <- function(x, ...) { + abort_no_extractor(x, "tidypredict_class_exprs") +} + +#' @rdname tidypredict_extractors +#' @export +tidypredict_n_trees <- function(x, ...) { + UseMethod("tidypredict_n_trees") +} + +#' @export +tidypredict_n_trees.default <- function(x, ...) { + abort_no_extractor(x, "tidypredict_n_trees") +} + +# Distinct from abort_model_unsupported(): the model class may well be +# supported by tidypredict_fit() and simply not expose this particular piece. +# A random forest has trees, a glmnet model does not. +abort_no_extractor <- function(x, generic, call = rlang::caller_env()) { + cli::cli_abort( + "{.fn {generic}} is not available for models of class + {.cls {class(x)[[1]]}}.", + class = "tidypredict_no_extractor", + call = call + ) +} diff --git a/R/model-catboost.R b/R/model-catboost.R index cd8b41bc..321a3c3f 100644 --- a/R/model-catboost.R +++ b/R/model-catboost.R @@ -902,21 +902,20 @@ build_nested_catboost_categorical <- function(split_info, cat_mapping) { expr(!!col_name != !!category) } -# For {orbital} ----------------------------------------------- +# Extractors -------------------------------------------------- -#' Extract processed CatBoost trees -#' -#' For use in orbital package. -#' @param model A CatBoost model object -#' @keywords internal #' @export -.extract_catboost_trees <- function(model) { - if (!inherits(model, "catboost.Model")) { - cli::cli_abort( - "{.arg model} must be {.cls catboost.Model}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_trees.catboost.Model <- function(x, ...) { + rlang::check_dots_empty() - parsedmodel <- parse_model(model) - extract_catboost_trees_nested(parsedmodel) + extract_catboost_trees_nested(parse_model(x)) +} + +#' @export +tidypredict_n_trees.catboost.Model <- function(x, ...) { + rlang::check_dots_empty() + + # Not `niter`: for multiclass models CatBoost stores one tree per class per + # round, so `niter` is the number of rounds rather than the number of trees. + length(tidypredict_trees(x)) } diff --git a/R/model-earth.R b/R/model-earth.R index e8bac642..cc55eb31 100644 --- a/R/model-earth.R +++ b/R/model-earth.R @@ -167,19 +167,12 @@ collapse_lists <- function(label, coef, lst) { ) } -# For {orbital} -#' Extract multiclass linear predictors for earth models -#' -#' For use in orbital package. -#' @param model An earth model object with multiple classes (glm.list with >1 elements) -#' @keywords internal +# Extractors -------------------------------------------------- + #' @export -.extract_earth_multiclass <- function(model) { - if (!inherits(model, "earth")) { - cli::cli_abort( - "{.arg model} must be {.cls earth}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_exprs.earth <- function(x, ...) { + rlang::check_dots_empty() + model <- x if (is.null(model$glm.list) || length(model$glm.list) < 2) { cli::cli_abort( @@ -202,10 +195,7 @@ collapse_lists <- function(label, coef, lst) { # Parse and build expression parsedmodel <- parse_model(model_single) - expr <- build_fit_formula(parsedmodel) - - # Deparse to string, preserving numeric precision - deparse1(expr, control = "digits17") + build_fit_formula(parsedmodel) }) names(eqs) <- class_names diff --git a/R/model-glmnet.R b/R/model-glmnet.R index e8a9e4b6..9a18da4c 100644 --- a/R/model-glmnet.R +++ b/R/model-glmnet.R @@ -175,22 +175,14 @@ tidypredict_fit.pm_multiclass_regression <- function(model) { paste(terms, collapse = " + ") } -#' Extract multiclass linear predictors for glmnet models -#' -#' For use in orbital package. -#' @param model A glmnet model object with class "multnet" -#' @param penalty The penalty value to use for coefficient extraction -#' @keywords internal +# Extractors -------------------------------------------------- + #' @export -.extract_glmnet_multiclass <- function(model, penalty = NULL) { - if (!inherits(model, "multnet")) { - cli::cli_abort( - "{.arg model} must be {.cls multnet}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_exprs.multnet <- function(x, ..., penalty = NULL) { + rlang::check_dots_empty() if (is.null(penalty)) { - if (length(model$lambda) != 1) { + if (length(x$lambda) != 1) { cli::cli_abort( c( "glmnet model has multiple penalty values.", @@ -198,18 +190,21 @@ tidypredict_fit.pm_multiclass_regression <- function(model) { ) ) } - penalty <- model$lambda + penalty <- x$lambda } # Get coefficients for each class at the specified penalty - coefs_list <- stats::coef(model, s = penalty) + coefs_list <- stats::coef(x, s = penalty) class_names <- names(coefs_list) # Build linear predictor expression for each class eqs <- lapply(coefs_list, function(coef_mat) { coef_names <- rownames(coef_mat) coef_values <- as.numeric(coef_mat) - .build_linear_pred(coef_names, coef_values) + # .build_linear_pred() returns a string; the generic promises a language + # object. A model with every coefficient zero gives "0", which parses to a + # bare numeric, consistent with how stumps are returned elsewhere. + str2lang(.build_linear_pred(coef_names, coef_values)) }) names(eqs) <- class_names diff --git a/R/model-lightgbm.R b/R/model-lightgbm.R index f1f0c1b7..b96cefbd 100644 --- a/R/model-lightgbm.R +++ b/R/model-lightgbm.R @@ -894,20 +894,20 @@ build_nested_lgb_node <- function( expr(case_when(!!condition ~ !!left_subtree, .default = !!right_subtree)) } -# For {orbital} ----------------------------------------------- +# Extractors -------------------------------------------------- -#' Extract processed LightGBM trees -#' -#' For use in orbital package. -#' @param model A LightGBM model object -#' @keywords internal #' @export -.extract_lgb_trees <- function(model) { - if (!inherits(model, "lgb.Booster")) { - cli::cli_abort( - "{.arg model} must be {.cls lgb.Booster}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_trees.lgb.Booster <- function(x, ...) { + rlang::check_dots_empty() + + extract_lgb_trees_nested(x) +} + +#' @export +tidypredict_n_trees.lgb.Booster <- function(x, ...) { + rlang::check_dots_empty() - extract_lgb_trees_nested(model) + # Trees with a single leaf are dropped by the extractor, so this counts the + # trees actually returned rather than the number LightGBM reports. + length(tidypredict_trees(x)) } diff --git a/R/model-partykit.R b/R/model-partykit.R index fb6b9c3b..548f1697 100644 --- a/R/model-partykit.R +++ b/R/model-partykit.R @@ -289,19 +289,12 @@ tidypredict_fit.party <- function(model, ...) { generate_nested_case_when_tree(tree_info, missing = "na") } -# For {orbital} -#' Extract classprob trees for partykit models -#' -#' For use in orbital package. -#' @param model A partykit model object -#' @keywords internal +# Extractors -------------------------------------------------- + #' @export -.extract_partykit_classprob <- function(model) { - if (!inherits(model, "party")) { - cli::cli_abort( - "{.arg model} must be {.cls party}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_exprs.party <- function(x, ...) { + rlang::check_dots_empty() + model <- x extract_classprob <- function(model) { mod <- model$fitted @@ -326,12 +319,15 @@ tidypredict_fit.party <- function(model, ...) { tree_info_full <- partykit_tree_info_full(model) - map(seq_len(ncol(preds)), function(i) { + res <- map(seq_len(ncol(preds)), function(i) { generate_nested_case_when_tree( tree_info_with_predictions(tree_info_full, preds[, i]), missing = "na" ) }) + # The generic is named by outcome level so callers never have to assume this + # matches `levels()` of the outcome positionally. + stats::setNames(res, colnames(preds)) } build_tree_formula.pm_tree_party <- function(model) { diff --git a/R/model-ranger.R b/R/model-ranger.R index fc3c6746..ad0b0a6d 100644 --- a/R/model-ranger.R +++ b/R/model-ranger.R @@ -353,23 +353,14 @@ tidypredict_test.ranger <- function( test_results_numeric(base, te[, "fit_te"], threshold, model$call) } -# For {orbital} ----------------------------------------------- +# Extractors -------------------------------------------------- -#' Extract classification probability trees for ranger models -#' -#' For use in orbital package. -#' @param model A ranger model object fitted with `probability = TRUE` -#' @keywords internal #' @export -.extract_ranger_classprob <- function(model) { - if (!inherits(model, "ranger")) { - cli::cli_abort( - "{.arg model} must be {.cls ranger}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_trees.ranger <- function(x, ...) { + rlang::check_dots_empty() # Get class levels from treeInfo - tree <- ranger_tree_info(model, 1) + tree <- ranger_tree_info(x, 1) pred_cols <- grep("^pred\\.", names(tree), value = TRUE) if (length(pred_cols) == 0) { @@ -386,8 +377,8 @@ tidypredict_test.ranger <- function( # For each class, generate nested case_when expressions for all trees res <- list() for (lvl in lvls) { - tree_exprs <- map(seq_len(model$num.trees), function(tree_no) { - build_nested_ranger_prob_tree(model, tree_no, lvl) + tree_exprs <- map(seq_len(x$num.trees), function(tree_no) { + build_nested_ranger_prob_tree(x, tree_no, lvl) }) res[[lvl]] <- tree_exprs } @@ -399,37 +390,35 @@ build_nested_ranger_prob_tree <- function(model, tree_no, class_level) { build_nested_ranger_tree(model, tree_no, paste0("pred.", class_level)) } -#' Extract regression trees for ranger models -#' -#' For use in orbital package. -#' @param model A ranger model object (regression) -#' @keywords internal #' @export -.extract_ranger_trees <- function(model) { - if (!inherits(model, "ranger")) { - cli::cli_abort( - "{.arg model} must be {.cls ranger}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_trees.ranger <- function(x, ...) { + rlang::check_dots_empty() # Check if this is a classification model - first_tree <- ranger_tree_info(model, 1) + first_tree <- ranger_tree_info(x, 1) first_pred <- first_tree$prediction[first_tree$terminal][1] if (is.character(first_pred) || is.factor(first_pred)) { cli::cli_abort( c( "Classification models are not supported.", - i = "Use {.fn .extract_ranger_classprob} for classification models." + i = "Use {.fn tidypredict_class_trees} for classification models." ) ) } - n_trees <- model$num.trees - map(seq_len(n_trees), function(tree_no) { - build_nested_ranger_tree(model, tree_no) + map(seq_len(x$num.trees), function(tree_no) { + build_nested_ranger_tree(x, tree_no) }) } +#' @export +tidypredict_n_trees.ranger <- function(x, ...) { + rlang::check_dots_empty() + + # ranger stores this as a double. + as.integer(x$num.trees) +} + build_tree_formula.pm_tree_ranger <- function(model) { expr_mean(map( model$tree_info_list, diff --git a/R/model-rf.R b/R/model-rf.R index ecd3ef54..5edaa5bc 100644 --- a/R/model-rf.R +++ b/R/model-rf.R @@ -299,46 +299,43 @@ tidypredict_fit_randomForest <- function(parsedmodel) { expr_mean(generate_case_when_trees(parsedmodel)) } -# For {orbital} ----------------------------------------------- +# Extractors -------------------------------------------------- -#' Extract classification vote trees for randomForest models -#' -#' For use in orbital package. -#' @param model A randomForest model object -#' @keywords internal #' @export -.extract_rf_classprob <- function(model) { - if (!inherits(model, "randomForest")) { - cli::cli_abort( - "{.arg model} must be {.cls randomForest}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_trees.randomForest <- function(x, ...) { + rlang::check_dots_empty() - # Check if this is a classification model - if (is.null(model$classes)) { + if (is.null(x$classes)) { cli::cli_abort( c( "Model is not a classification model.", - i = "Use {.fn tidypredict_fit} for regression models." + i = "Use {.fn tidypredict_trees} for regression models." ) ) } - # Get class levels from the model - lvls <- model$classes - term_labels <- names(model$forest$ncat) + lvls <- x$classes + term_labels <- names(x$forest$ncat) # For each class, generate nested case_when expressions for all trees res <- list() for (lvl in lvls) { - tree_exprs <- map(seq_len(model$ntree), function(tree_no) { - build_nested_rf_vote_tree(model, tree_no, term_labels, lvl) + tree_exprs <- map(seq_len(x$ntree), function(tree_no) { + build_nested_rf_vote_tree(x, tree_no, term_labels, lvl) }) res[[lvl]] <- tree_exprs } res } +#' @export +tidypredict_n_trees.randomForest <- function(x, ...) { + rlang::check_dots_empty() + + # randomForest stores this as a double. + as.integer(x$ntree) +} + # Build nested case_when for randomForest voting tree build_nested_rf_vote_tree <- function( model, @@ -359,42 +356,31 @@ build_nested_rf_vote_tree <- function( ) } -#' Extract regression trees for randomForest models -#' -#' For use in orbital package. -#' @param model A randomForest model object (regression) -#' @keywords internal #' @export -.extract_rf_trees <- function(model) { - if (!inherits(model, "randomForest")) { - cli::cli_abort( - "{.arg model} must be {.cls randomForest}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_trees.randomForest <- function(x, ...) { + rlang::check_dots_empty() - # Check if this is a classification model - if (!is.null(model$classes)) { + if (!is.null(x$classes)) { cli::cli_abort( c( "Classification models are not supported.", - i = "Use {.fn .extract_rf_classprob} for classification models." + i = "Use {.fn tidypredict_class_trees} for classification models." ) ) } # The bias correction applies to the forest average, so it cannot be carried # by the individual tree expressions returned here. - if (!is.null(model$coefs)) { + if (!is.null(x$coefs)) { cli::cli_abort( "Models fitted with {.code corr.bias = TRUE} are not supported." ) } - n_trees <- model$ntree - term_labels <- names(model$forest$ncat) + term_labels <- names(x$forest$ncat) - map(seq_len(n_trees), function(tree_no) { - build_nested_rf_tree(model, tree_no, term_labels) + map(seq_len(x$ntree), function(tree_no) { + build_nested_rf_tree(x, tree_no, term_labels) }) } diff --git a/R/model-rpart.R b/R/model-rpart.R index 92e93a66..0297dc24 100644 --- a/R/model-rpart.R +++ b/R/model-rpart.R @@ -240,27 +240,21 @@ tidypredict_test.rpart <- function( test_results_numeric(base, te$fit_te, threshold, model$call) } -# For {orbital} -#' Extract classprob trees for rpart models -#' -#' For use in orbital package. -#' @param model An rpart model object -#' @keywords internal +# Extractors -------------------------------------------------- + #' @export -.extract_rpart_classprob <- function(model) { - if (!inherits(model, "rpart")) { - cli::cli_abort( - "{.arg model} must be {.cls rpart}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_class_exprs.rpart <- function(x, ...) { + rlang::check_dots_empty() - if (model$method != "class") { + if (x$method != "class") { cli::cli_abort( - "{.arg model} must be a classification model (method = 'class')." + "Only classification models are supported, not {.code method = {x$method}}." ) } - lapply(rpart_classprob_tree_info(model), generate_nested_case_when_tree) + # rpart_classprob_tree_info() is already keyed by outcome level and lapply() + # keeps those names, which is what the generic promises. + lapply(rpart_classprob_tree_info(x), generate_nested_case_when_tree) } # One tree_info per outcome level, where the node predictions are the class diff --git a/R/model-xgboost.R b/R/model-xgboost.R index 4ea04373..e2506dd3 100644 --- a/R/model-xgboost.R +++ b/R/model-xgboost.R @@ -583,22 +583,21 @@ build_fit_formula_xgb <- function(parsedmodel) { apply_xgb_objective(f, objective, base_score) } -# For {orbital} ----------------------------------------------- +# Extractors -------------------------------------------------- -#' Extract processed xgboost trees -#' -#' For use in orbital package. -#' @param model An xgb.Booster model -#' @keywords internal #' @export -.extract_xgb_trees <- function(model) { - if (!inherits(model, "xgb.Booster")) { - cli::cli_abort( - "{.arg model} must be {.cls xgb.Booster}, not {.obj_type_friendly {model}}." - ) - } +tidypredict_trees.xgb.Booster <- function(x, ...) { + rlang::check_dots_empty() - json_params <- get_xgb_json_params(model) - trees <- extract_xgb_trees_nested(model) - apply_dart_weights(trees, json_params$weight_drop) + json_params <- get_xgb_json_params(x) + trees <- extract_xgb_trees_nested(x) + # The generic promises an unnamed list; split() names these "0", "1", ... + unname(apply_dart_weights(trees, json_params$weight_drop)) +} + +#' @export +tidypredict_n_trees.xgb.Booster <- function(x, ...) { + rlang::check_dots_empty() + + length(tidypredict_trees(x)) } diff --git a/man/deprecated-extractors.Rd b/man/deprecated-extractors.Rd new file mode 100644 index 00000000..8ac5836e --- /dev/null +++ b/man/deprecated-extractors.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/deprec-extractors.R +\name{deprecated-extractors} +\alias{deprecated-extractors} +\alias{.extract_xgb_trees} +\alias{.extract_lgb_trees} +\alias{.extract_catboost_trees} +\alias{.extract_rf_trees} +\alias{.extract_ranger_trees} +\alias{.extract_rf_classprob} +\alias{.extract_ranger_classprob} +\alias{.extract_rpart_classprob} +\alias{.extract_partykit_classprob} +\alias{.extract_earth_multiclass} +\alias{.extract_glmnet_multiclass} +\title{Deprecated model extractors} +\usage{ +.extract_xgb_trees(model) + +.extract_lgb_trees(model) + +.extract_catboost_trees(model) + +.extract_rf_trees(model) + +.extract_ranger_trees(model) + +.extract_rf_classprob(model) + +.extract_ranger_classprob(model) + +.extract_rpart_classprob(model) + +.extract_partykit_classprob(model) + +.extract_earth_multiclass(model) + +.extract_glmnet_multiclass(model, penalty = NULL) +} +\arguments{ +\item{model}{A fitted model object.} + +\item{penalty}{The penalty value to use for coefficient extraction.} +} +\value{ +The same values these functions have always returned. Note that +\code{\link[=tidypredict_class_exprs]{tidypredict_class_exprs()}} returns language objects where +\code{.extract_earth_multiclass()} and \code{.extract_glmnet_multiclass()} return +strings. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} + +These functions have been replaced by generics with documented return +shapes. See \link{tidypredict_extractors}.\tabular{ll}{ + Deprecated \tab Replacement \cr + \code{.extract_xgb_trees()}, \code{.extract_lgb_trees()}, \code{.extract_catboost_trees()}, \code{.extract_rf_trees()}, \code{.extract_ranger_trees()} \tab \code{\link[=tidypredict_trees]{tidypredict_trees()}} \cr + \code{.extract_rf_classprob()}, \code{.extract_ranger_classprob()} \tab \code{\link[=tidypredict_class_trees]{tidypredict_class_trees()}} \cr + \code{.extract_rpart_classprob()}, \code{.extract_partykit_classprob()}, \code{.extract_earth_multiclass()}, \code{.extract_glmnet_multiclass()} \tab \code{\link[=tidypredict_class_exprs]{tidypredict_class_exprs()}} \cr +} +} +\keyword{internal} diff --git a/man/dot-extract_catboost_trees.Rd b/man/dot-extract_catboost_trees.Rd deleted file mode 100644 index 308f5027..00000000 --- a/man/dot-extract_catboost_trees.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-catboost.R -\name{.extract_catboost_trees} -\alias{.extract_catboost_trees} -\title{Extract processed CatBoost trees} -\usage{ -.extract_catboost_trees(model) -} -\arguments{ -\item{model}{A CatBoost model object} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_earth_multiclass.Rd b/man/dot-extract_earth_multiclass.Rd deleted file mode 100644 index f8761625..00000000 --- a/man/dot-extract_earth_multiclass.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-earth.R -\name{.extract_earth_multiclass} -\alias{.extract_earth_multiclass} -\title{Extract multiclass linear predictors for earth models} -\usage{ -.extract_earth_multiclass(model) -} -\arguments{ -\item{model}{An earth model object with multiple classes (glm.list with >1 elements)} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_glmnet_multiclass.Rd b/man/dot-extract_glmnet_multiclass.Rd deleted file mode 100644 index f581a3bb..00000000 --- a/man/dot-extract_glmnet_multiclass.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-glmnet.R -\name{.extract_glmnet_multiclass} -\alias{.extract_glmnet_multiclass} -\title{Extract multiclass linear predictors for glmnet models} -\usage{ -.extract_glmnet_multiclass(model, penalty = NULL) -} -\arguments{ -\item{model}{A glmnet model object with class "multnet"} - -\item{penalty}{The penalty value to use for coefficient extraction} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_lgb_trees.Rd b/man/dot-extract_lgb_trees.Rd deleted file mode 100644 index 8a281f12..00000000 --- a/man/dot-extract_lgb_trees.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-lightgbm.R -\name{.extract_lgb_trees} -\alias{.extract_lgb_trees} -\title{Extract processed LightGBM trees} -\usage{ -.extract_lgb_trees(model) -} -\arguments{ -\item{model}{A LightGBM model object} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_partykit_classprob.Rd b/man/dot-extract_partykit_classprob.Rd deleted file mode 100644 index 60f2d44b..00000000 --- a/man/dot-extract_partykit_classprob.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-partykit.R -\name{.extract_partykit_classprob} -\alias{.extract_partykit_classprob} -\title{Extract classprob trees for partykit models} -\usage{ -.extract_partykit_classprob(model) -} -\arguments{ -\item{model}{A partykit model object} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_ranger_classprob.Rd b/man/dot-extract_ranger_classprob.Rd deleted file mode 100644 index e6d80086..00000000 --- a/man/dot-extract_ranger_classprob.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-ranger.R -\name{.extract_ranger_classprob} -\alias{.extract_ranger_classprob} -\title{Extract classification probability trees for ranger models} -\usage{ -.extract_ranger_classprob(model) -} -\arguments{ -\item{model}{A ranger model object fitted with \code{probability = TRUE}} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_ranger_trees.Rd b/man/dot-extract_ranger_trees.Rd deleted file mode 100644 index be575782..00000000 --- a/man/dot-extract_ranger_trees.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-ranger.R -\name{.extract_ranger_trees} -\alias{.extract_ranger_trees} -\title{Extract regression trees for ranger models} -\usage{ -.extract_ranger_trees(model) -} -\arguments{ -\item{model}{A ranger model object (regression)} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_rf_classprob.Rd b/man/dot-extract_rf_classprob.Rd deleted file mode 100644 index 929d027a..00000000 --- a/man/dot-extract_rf_classprob.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-rf.R -\name{.extract_rf_classprob} -\alias{.extract_rf_classprob} -\title{Extract classification vote trees for randomForest models} -\usage{ -.extract_rf_classprob(model) -} -\arguments{ -\item{model}{A randomForest model object} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_rf_trees.Rd b/man/dot-extract_rf_trees.Rd deleted file mode 100644 index bfde2020..00000000 --- a/man/dot-extract_rf_trees.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-rf.R -\name{.extract_rf_trees} -\alias{.extract_rf_trees} -\title{Extract regression trees for randomForest models} -\usage{ -.extract_rf_trees(model) -} -\arguments{ -\item{model}{A randomForest model object (regression)} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_rpart_classprob.Rd b/man/dot-extract_rpart_classprob.Rd deleted file mode 100644 index 408c7403..00000000 --- a/man/dot-extract_rpart_classprob.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-rpart.R -\name{.extract_rpart_classprob} -\alias{.extract_rpart_classprob} -\title{Extract classprob trees for rpart models} -\usage{ -.extract_rpart_classprob(model) -} -\arguments{ -\item{model}{An rpart model object} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/dot-extract_xgb_trees.Rd b/man/dot-extract_xgb_trees.Rd deleted file mode 100644 index 66471aef..00000000 --- a/man/dot-extract_xgb_trees.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model-xgboost.R -\name{.extract_xgb_trees} -\alias{.extract_xgb_trees} -\title{Extract processed xgboost trees} -\usage{ -.extract_xgb_trees(model) -} -\arguments{ -\item{model}{An xgb.Booster model} -} -\description{ -For use in orbital package. -} -\keyword{internal} diff --git a/man/tidypredict_extractors.Rd b/man/tidypredict_extractors.Rd new file mode 100644 index 00000000..85218052 --- /dev/null +++ b/man/tidypredict_extractors.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extractors.R +\name{tidypredict_extractors} +\alias{tidypredict_extractors} +\alias{tidypredict_trees} +\alias{tidypredict_class_trees} +\alias{tidypredict_class_exprs} +\alias{tidypredict_n_trees} +\title{Extract model internals as expressions} +\usage{ +tidypredict_trees(x, ...) + +tidypredict_class_trees(x, ...) + +tidypredict_class_exprs(x, ...) + +tidypredict_n_trees(x, ...) +} +\arguments{ +\item{x}{A fitted model object.} + +\item{...}{Additional arguments passed to methods. \code{multnet} models accept +\code{penalty}, which is required when the model was fitted with more than one +value of lambda.} +} +\value{ +\code{tidypredict_trees()} returns an unnamed list with one element per tree, +each a language object. + +\code{tidypredict_class_trees()} returns a list named by outcome level, in model +order. Each element is itself an unnamed list of per-tree language objects +for that level, so the result is \code{tidypredict_trees()} nested one level +deeper. What the leaves hold depends on the model: \code{randomForest} gives +0/1 votes, \code{ranger} gives class probabilities. + +\code{tidypredict_class_exprs()} returns a list named by outcome level, in model +order, with one language object per level. Unlike +\code{tidypredict_class_trees()} there is no per-tree structure and nothing to +combine: each expression computes that level's value on its own. + +\code{tidypredict_n_trees()} returns a single integer, the number of trees in the +ensemble. For multiclass boosters this counts every tree, including the +per-class copies, so it is not the same as the number of boosting rounds. + +Wherever an expression is described above, a \strong{bare numeric value} may +appear in its place when the model has nothing to branch on. Callers must +handle both. This happens for a single-leaf tree, a stump, and also for a +degenerate expression such as a \code{glmnet} class whose coefficients are all +zero. Note that the constant can appear alongside language objects in the +same result, so the element type is not uniform within one list. +} +\description{ +These generics expose the pieces \code{tidypredict_fit()} is assembled from, +rather than the finished formula. They exist so that packages generating +their own code from a fitted model, such as orbital, can reuse +tidypredict's parsing instead of reimplementing it per model class. + +Each generic has a single fixed return shape, described below. A model class +implements whichever generics make sense for it: a random forest has trees +and a tree count, a \code{glmnet} multinomial model has neither. +} +\details{ +Two shapes that look similar are worth keeping apart. +\code{tidypredict_class_trees()} returns many trees per level that a caller has +to sum or average, and needs \code{tidypredict_n_trees()} to do it. +\code{tidypredict_class_exprs()} returns one finished expression per level. Both +are named by outcome level so that callers never have to assume the order +matches \code{levels()} of the outcome. +} +\examples{ +\dontshow{if (rlang::is_installed("randomForest")) withAutoprint(\{ # examplesIf} +model <- randomForest::randomForest(mpg ~ ., data = mtcars, ntree = 5) + +tidypredict_n_trees(model) + +trees <- tidypredict_trees(model) +length(trees) +trees[[1]] +\dontshow{\}) # examplesIf} +} diff --git a/tests/testthat/_snaps/deprec-extractors.md b/tests/testthat/_snaps/deprec-extractors.md new file mode 100644 index 00000000..c91788c2 --- /dev/null +++ b/tests/testthat/_snaps/deprec-extractors.md @@ -0,0 +1,220 @@ +# .extract_xgb_trees() is deprecated + + Code + x <- .extract_xgb_trees(model) + Condition + Warning: + `.extract_xgb_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + +# .extract_xgb_trees() errors on the wrong class + + Code + .extract_xgb_trees(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_xgb_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + Error in `.extract_xgb_trees()`: + ! `model` must be , not a object. + +# .extract_lgb_trees() is deprecated + + Code + x <- .extract_lgb_trees(model) + Condition + Warning: + `.extract_lgb_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + +# .extract_lgb_trees() errors on the wrong class + + Code + .extract_lgb_trees(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_lgb_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + Error in `.extract_lgb_trees()`: + ! `model` must be , not a object. + +# .extract_catboost_trees() is deprecated + + Code + x <- .extract_catboost_trees(model) + Condition + Warning: + `.extract_catboost_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + +# .extract_catboost_trees() errors on the wrong class + + Code + .extract_catboost_trees(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_catboost_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + Error in `.extract_catboost_trees()`: + ! `model` must be , not a object. + +# .extract_rf_trees() is deprecated + + Code + x <- .extract_rf_trees(model) + Condition + Warning: + `.extract_rf_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + +# .extract_rf_trees() errors on the wrong class + + Code + .extract_rf_trees(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_rf_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + Error in `.extract_rf_trees()`: + ! `model` must be , not a object. + +# .extract_ranger_trees() is deprecated + + Code + x <- .extract_ranger_trees(model) + Condition + Warning: + `.extract_ranger_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + +# .extract_ranger_trees() errors on the wrong class + + Code + .extract_ranger_trees(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_ranger_trees()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_trees()` instead. + Error in `.extract_ranger_trees()`: + ! `model` must be , not a object. + +# .extract_rf_classprob() is deprecated + + Code + x <- .extract_rf_classprob(model) + Condition + Warning: + `.extract_rf_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_trees()` instead. + +# .extract_rf_classprob() errors on the wrong class + + Code + .extract_rf_classprob(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_rf_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_trees()` instead. + Error in `.extract_rf_classprob()`: + ! `model` must be , not a object. + +# .extract_ranger_classprob() is deprecated + + Code + x <- .extract_ranger_classprob(model) + Condition + Warning: + `.extract_ranger_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_trees()` instead. + +# .extract_ranger_classprob() errors on the wrong class + + Code + .extract_ranger_classprob(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_ranger_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_trees()` instead. + Error in `.extract_ranger_classprob()`: + ! `model` must be , not a object. + +# .extract_rpart_classprob() is deprecated + + Code + x <- .extract_rpart_classprob(model) + Condition + Warning: + `.extract_rpart_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + +# .extract_rpart_classprob() errors on the wrong class + + Code + .extract_rpart_classprob(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_rpart_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + Error in `.extract_rpart_classprob()`: + ! `model` must be , not a object. + +# .extract_partykit_classprob() is deprecated + + Code + x <- .extract_partykit_classprob(model) + Condition + Warning: + `.extract_partykit_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + +# .extract_partykit_classprob() errors on the wrong class + + Code + .extract_partykit_classprob(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_partykit_classprob()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + Error in `.extract_partykit_classprob()`: + ! `model` must be , not a object. + +# .extract_earth_multiclass() is deprecated + + Code + x <- .extract_earth_multiclass(model) + Condition + Warning: + `.extract_earth_multiclass()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + +# .extract_earth_multiclass() errors on the wrong class + + Code + .extract_earth_multiclass(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_earth_multiclass()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + Error in `.extract_earth_multiclass()`: + ! `model` must be , not a object. + +# .extract_glmnet_multiclass() is deprecated + + Code + x <- .extract_glmnet_multiclass(model) + Condition + Warning: + `.extract_glmnet_multiclass()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + +# .extract_glmnet_multiclass() errors on the wrong class + + Code + .extract_glmnet_multiclass(lm(mpg ~ wt, mtcars)) + Condition + Warning: + `.extract_glmnet_multiclass()` was deprecated in tidypredict 1.1.1. + i Please use `tidypredict_class_exprs()` instead. + Error in `.extract_glmnet_multiclass()`: + ! `model` must be , not a object. + diff --git a/tests/testthat/_snaps/model-catboost.md b/tests/testthat/_snaps/model-catboost.md index 34d1ee24..64241c8a 100644 --- a/tests/testthat/_snaps/model-catboost.md +++ b/tests/testthat/_snaps/model-catboost.md @@ -24,13 +24,13 @@ ! CatBoost models require a matrix for predictions. i Pass the prediction matrix via the `xg_df` argument. -# .extract_catboost_trees errors on non-catboost model +# tidypredict_trees errors on non-catboost model Code - .extract_catboost_trees(lm(mpg ~ wt, data = mtcars)) + tidypredict_trees(lm(mpg ~ wt, data = mtcars)) Condition - Error in `.extract_catboost_trees()`: - ! `model` must be , not a object. + Error in `tidypredict_trees()`: + ! `tidypredict_trees()` is not available for models of class . # multiclass model requires num_class >= 2 diff --git a/tests/testthat/_snaps/model-earth.md b/tests/testthat/_snaps/model-earth.md index 1caaf51e..c06d7b78 100644 --- a/tests/testthat/_snaps/model-earth.md +++ b/tests/testthat/_snaps/model-earth.md @@ -21,29 +21,29 @@ Error in `acceptable_contrasts()`: ! The treatment contrast is the only one supported at this time. Field(s) with an invalid contrast are: "f". -# .extract_earth_multiclass errors on non-earth model +# tidypredict_class_exprs errors on non-earth model Code - .extract_earth_multiclass(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_earth_multiclass()`: - ! `model` must be , not a object. + Error in `tidypredict_class_exprs()`: + ! `tidypredict_class_exprs()` is not available for models of class . -# .extract_earth_multiclass errors on binary model +# tidypredict_class_exprs errors on binary model Code - .extract_earth_multiclass(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_earth_multiclass()`: + Error in `tidypredict_class_exprs()`: ! Model does not contain multiclass information. i Fit the earth model with `glm = TRUE` for classification. -# .extract_earth_multiclass errors on regression model +# tidypredict_class_exprs errors on regression model Code - .extract_earth_multiclass(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_earth_multiclass()`: + Error in `tidypredict_class_exprs()`: ! Model does not contain multiclass information. i Fit the earth model with `glm = TRUE` for classification. diff --git a/tests/testthat/_snaps/model-glmnet.md b/tests/testthat/_snaps/model-glmnet.md index 2b723a42..cf425600 100644 --- a/tests/testthat/_snaps/model-glmnet.md +++ b/tests/testthat/_snaps/model-glmnet.md @@ -96,20 +96,20 @@ ! Multivariate gaussian glmnet models are not supported. i Models fit with `family = "mgaussian"` have multiple outcome columns which is not supported. -# .extract_glmnet_multiclass errors on non-multnet model +# tidypredict_class_exprs errors on non-multnet model Code - .extract_glmnet_multiclass(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_glmnet_multiclass()`: - ! `model` must be , not an object. + Error in `tidypredict_class_exprs()`: + ! `tidypredict_class_exprs()` is not available for models of class . -# .extract_glmnet_multiclass errors with multiple penalties +# tidypredict_class_exprs errors with multiple penalties Code - .extract_glmnet_multiclass(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_glmnet_multiclass()`: + Error in `tidypredict_class_exprs()`: ! glmnet model has multiple penalty values. i Specify a single `penalty` value. diff --git a/tests/testthat/_snaps/model-lightgbm.md b/tests/testthat/_snaps/model-lightgbm.md index c8b19644..6cc12e36 100644 --- a/tests/testthat/_snaps/model-lightgbm.md +++ b/tests/testthat/_snaps/model-lightgbm.md @@ -79,11 +79,11 @@ ! LightGBM models require a matrix for predictions. i Pass the prediction matrix via the `xg_df` argument. -# .extract_lgb_trees errors on non-lgb.Booster +# tidypredict_trees errors on non-lgb.Booster Code - .extract_lgb_trees(list()) + tidypredict_trees(list()) Condition - Error in `.extract_lgb_trees()`: - ! `model` must be , not an empty list. + Error in `tidypredict_trees()`: + ! `tidypredict_trees()` is not available for models of class . diff --git a/tests/testthat/_snaps/model-partykit.md b/tests/testthat/_snaps/model-partykit.md index 300500d7..8d166e31 100644 --- a/tests/testthat/_snaps/model-partykit.md +++ b/tests/testthat/_snaps/model-partykit.md @@ -5,11 +5,11 @@ Output [1] "case_when(is.na(cyl) ~ NA, cyl <= 4 ~ 26.6636363636364, .default = case_when(is.na(cyl) ~ \n NA, cyl <= 6 ~ 19.7428571428571, .default = 15.1))" -# .extract_partykit_classprob errors on non-party model +# tidypredict_class_exprs errors on non-party model Code - .extract_partykit_classprob(list()) + tidypredict_class_exprs(list()) Condition - Error in `.extract_partykit_classprob()`: - ! `model` must be , not an empty list. + Error in `tidypredict_class_exprs()`: + ! `tidypredict_class_exprs()` is not available for models of class . diff --git a/tests/testthat/_snaps/model-ranger.md b/tests/testthat/_snaps/model-ranger.md index 379378ed..ca395744 100644 --- a/tests/testthat/_snaps/model-ranger.md +++ b/tests/testthat/_snaps/model-ranger.md @@ -48,39 +48,39 @@ i A survival forest predicts a curve over time rather than a single value, which cannot be written as a single formula. i Only regression models can be converted to tidy formulas. -# .extract_ranger_classprob errors on non-ranger model +# tidypredict_class_trees errors on non-ranger model Code - .extract_ranger_classprob(model) + tidypredict_class_trees(model) Condition - Error in `.extract_ranger_classprob()`: - ! `model` must be , not a object. + Error in `tidypredict_class_trees()`: + ! `tidypredict_class_trees()` is not available for models of class . -# .extract_ranger_classprob errors without probability = TRUE +# tidypredict_class_trees errors without probability = TRUE Code - .extract_ranger_classprob(model) + tidypredict_class_trees(model) Condition - Error in `.extract_ranger_classprob()`: + Error in `tidypredict_class_trees()`: ! Model does not contain probability information. i Fit the ranger model with `probability = TRUE`. -# .extract_ranger_trees errors on non-ranger model +# tidypredict_trees errors on non-ranger model Code - .extract_ranger_trees(model) + tidypredict_trees(model) Condition - Error in `.extract_ranger_trees()`: - ! `model` must be , not a object. + Error in `tidypredict_trees()`: + ! `tidypredict_trees()` is not available for models of class . -# .extract_ranger_trees errors on classification model +# tidypredict_trees errors on classification model Code - .extract_ranger_trees(model) + tidypredict_trees(model) Condition - Error in `.extract_ranger_trees()`: + Error in `tidypredict_trees()`: ! Classification models are not supported. - i Use `.extract_ranger_classprob()` for classification models. + i Use `tidypredict_class_trees()` for classification models. # v2 parsed classification model errors diff --git a/tests/testthat/_snaps/model-rf.md b/tests/testthat/_snaps/model-rf.md index aee4daf2..f73d7841 100644 --- a/tests/testthat/_snaps/model-rf.md +++ b/tests/testthat/_snaps/model-rf.md @@ -35,37 +35,37 @@ i Only regression models can be converted to tidy formulas. i Classification requires a voting mechanism that cannot be expressed as a single formula. -# .extract_rf_classprob errors on non-randomForest model +# tidypredict_class_trees errors on non-randomForest model Code - .extract_rf_classprob(model) + tidypredict_class_trees(model) Condition - Error in `.extract_rf_classprob()`: - ! `model` must be , not a object. + Error in `tidypredict_class_trees()`: + ! `tidypredict_class_trees()` is not available for models of class . -# .extract_rf_classprob errors on regression model +# tidypredict_class_trees errors on regression model Code - .extract_rf_classprob(model) + tidypredict_class_trees(model) Condition - Error in `.extract_rf_classprob()`: + Error in `tidypredict_class_trees()`: ! Model is not a classification model. - i Use `tidypredict_fit()` for regression models. + i Use `tidypredict_trees()` for regression models. -# .extract_rf_trees errors on non-randomForest model +# tidypredict_trees errors on non-randomForest model Code - .extract_rf_trees(model) + tidypredict_trees(model) Condition - Error in `.extract_rf_trees()`: - ! `model` must be , not a object. + Error in `tidypredict_trees()`: + ! `tidypredict_trees()` is not available for models of class . -# .extract_rf_trees errors on classification model +# tidypredict_trees errors on classification model Code - .extract_rf_trees(model) + tidypredict_trees(model) Condition - Error in `.extract_rf_trees()`: + Error in `tidypredict_trees()`: ! Classification models are not supported. - i Use `.extract_rf_classprob()` for classification models. + i Use `tidypredict_class_trees()` for classification models. diff --git a/tests/testthat/_snaps/model-rpart.md b/tests/testthat/_snaps/model-rpart.md index ac4203a8..a6b9deec 100644 --- a/tests/testthat/_snaps/model-rpart.md +++ b/tests/testthat/_snaps/model-rpart.md @@ -5,19 +5,19 @@ Output [1] "case_when(case_when(!is.na(cyl) ~ cyl < 5, !is.na(am) ~ !am < \n 0.5, .default = FALSE) ~ 26.6636363636364, .default = case_when(case_when(!is.na(cyl) ~ \n cyl < 7, !is.na(am) ~ !am < 0.5, .default = FALSE) ~ 19.7428571428571, \n .default = 15.1))" -# .extract_rpart_classprob errors on non-rpart model +# tidypredict_class_exprs errors on non-rpart model Code - .extract_rpart_classprob(list()) + tidypredict_class_exprs(list()) Condition - Error in `.extract_rpart_classprob()`: - ! `model` must be , not an empty list. + Error in `tidypredict_class_exprs()`: + ! `tidypredict_class_exprs()` is not available for models of class . -# .extract_rpart_classprob errors on regression model +# tidypredict_class_exprs errors on regression model Code - .extract_rpart_classprob(model) + tidypredict_class_exprs(model) Condition - Error in `.extract_rpart_classprob()`: - ! `model` must be a classification model (method = 'class'). + Error in `tidypredict_class_exprs()`: + ! Only classification models are supported, not `method = anova`. diff --git a/tests/testthat/_snaps/model-xgboost.md b/tests/testthat/_snaps/model-xgboost.md index 996399e1..7b1fa38f 100644 --- a/tests/testthat/_snaps/model-xgboost.md +++ b/tests/testthat/_snaps/model-xgboost.md @@ -26,13 +26,13 @@ Error in `xgb.DMatrix()`: ! xgb.DMatrix does not support construction from NULL -# .extract_xgb_trees errors on non-xgb.Booster +# tidypredict_trees errors on non-xgb.Booster Code - .extract_xgb_trees(list()) + tidypredict_trees(list()) Condition - Error in `.extract_xgb_trees()`: - ! `model` must be , not an empty list. + Error in `tidypredict_trees()`: + ! `tidypredict_trees()` is not available for models of class . # NULL objective with non-zero base_score warns user diff --git a/tests/testthat/test-deprec-extractors.R b/tests/testthat/test-deprec-extractors.R new file mode 100644 index 00000000..1e66bb6d --- /dev/null +++ b/tests/testthat/test-deprec-extractors.R @@ -0,0 +1,429 @@ +# Model constructors mirror the ones used in the corresponding test-model-*.R +# files so the deprecated wrappers are exercised on the same fixtures. + +deprec_xgb_model <- function() { + xgb_data <- xgboost::xgb.DMatrix( + as.matrix(mtcars[, -9]), + label = mtcars$am + ) + + xgboost::xgb.train( + params = list( + max_depth = 2L, + objective = "reg:squarederror", + base_score = 0.5 + ), + data = xgb_data, + nrounds = 4L, + verbose = 0 + ) +} + +deprec_lgb_model <- function() { + set.seed(123) + X <- data.matrix(mtcars[, c("mpg", "cyl", "disp")]) + dtrain <- lightgbm::lgb.Dataset( + X, + label = mtcars$hp, + colnames = c("mpg", "cyl", "disp") + ) + lightgbm::lgb.train( + params = list( + num_leaves = 4L, + learning_rate = 1.0, + objective = "regression", + min_data_in_leaf = 1L + ), + data = dtrain, + nrounds = 10L, + verbose = -1L + ) +} + +deprec_catboost_model <- function() { + set.seed(123) + X <- data.matrix(mtcars[, c("mpg", "cyl", "disp")]) + + pool <- catboost_catboost.load_pool( + X, + label = mtcars$hp, + feature_names = as.list(c("mpg", "cyl", "disp")) + ) + + catboost_catboost.train( + pool, + params = list( + iterations = 10L, + depth = 3L, + learning_rate = 0.5, + loss_function = "RMSE", + logging_level = "Silent", + allow_writing_files = FALSE + ) + ) +} + +deprec_earth_multiclass_model <- function() { + # `earth()` needs its own contrast function on the search path to expand a + # factor outcome, matching how test-model-earth.R fits these models. + library(earth) + suppressWarnings( + earth::earth( + Species ~ ., + data = iris, + glm = list(family = binomial) + ) + ) +} + +skip_if_no_earth_multiclass <- function() { + skip_if_not_installed("earth") + skip_if_not( + exists("contr.earth.response", where = asNamespace("earth")), + "earth multiclass not available" + ) +} + +deprec_multnet_model <- function() { + glmnet::glmnet( + as.matrix(iris[, 1:4]), + iris$Species, + family = "multinomial", + lambda = 0.5 + ) +} + +# .extract_xgb_trees() ------------------------------------------------------- + +test_that(".extract_xgb_trees() is deprecated", { + skip_if_not_installed("xgboost") + model <- deprec_xgb_model() + + expect_snapshot(x <- .extract_xgb_trees(model)) +}) + +test_that(".extract_xgb_trees() still returns the old shape", { + skip_if_not_installed("xgboost") + withr::local_options(lifecycle_verbosity = "quiet") + model <- deprec_xgb_model() + + trees <- .extract_xgb_trees(model) + + expect_type(trees, "list") + expect_length(trees, 4) + expect_type(trees[[1]], "language") +}) + +test_that(".extract_xgb_trees() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_xgb_trees(lm(mpg ~ wt, mtcars))) +}) + +# .extract_lgb_trees() ------------------------------------------------------- + +test_that(".extract_lgb_trees() is deprecated", { + skip_if_not_installed("lightgbm") + model <- deprec_lgb_model() + + expect_snapshot(x <- .extract_lgb_trees(model)) +}) + +test_that(".extract_lgb_trees() still returns the old shape", { + skip_if_not_installed("lightgbm") + withr::local_options(lifecycle_verbosity = "quiet") + model <- deprec_lgb_model() + + trees <- .extract_lgb_trees(model) + + expect_type(trees, "list") + expect_identical(trees, tidypredict_trees(model)) +}) + +test_that(".extract_lgb_trees() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_lgb_trees(lm(mpg ~ wt, mtcars))) +}) + +# .extract_catboost_trees() -------------------------------------------------- + +test_that(".extract_catboost_trees() is deprecated", { + skip_if_not_installed("catboost") + model <- deprec_catboost_model() + + expect_snapshot(x <- .extract_catboost_trees(model)) +}) + +test_that(".extract_catboost_trees() still returns the old shape", { + skip_if_not_installed("catboost") + withr::local_options(lifecycle_verbosity = "quiet") + model <- deprec_catboost_model() + + trees <- .extract_catboost_trees(model) + + expect_type(trees, "list") + expect_length(trees, 10) + expect_type(trees[[1]], "language") +}) + +test_that(".extract_catboost_trees() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_catboost_trees(lm(mpg ~ wt, mtcars))) +}) + +# .extract_rf_trees() -------------------------------------------------------- + +test_that(".extract_rf_trees() is deprecated", { + skip_if_not_installed("randomForest") + set.seed(123) + model <- randomForest::randomForest(mpg ~ cyl + disp, mtcars, ntree = 3) + + expect_snapshot(x <- .extract_rf_trees(model)) +}) + +test_that(".extract_rf_trees() still returns the old shape", { + skip_if_not_installed("randomForest") + withr::local_options(lifecycle_verbosity = "quiet") + set.seed(123) + model <- randomForest::randomForest(mpg ~ cyl + disp, mtcars, ntree = 3) + + trees <- .extract_rf_trees(model) + + expect_type(trees, "list") + expect_length(trees, 3) + expect_type(trees[[1]], "language") +}) + +test_that(".extract_rf_trees() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_rf_trees(lm(mpg ~ wt, mtcars))) +}) + +# .extract_ranger_trees() ---------------------------------------------------- + +test_that(".extract_ranger_trees() is deprecated", { + skip_if_not_installed("ranger") + model <- ranger::ranger( + mpg ~ cyl + disp, + data = mtcars, + num.trees = 3, + max.depth = 2, + seed = 100, + num.threads = 2 + ) + + expect_snapshot(x <- .extract_ranger_trees(model)) +}) + +test_that(".extract_ranger_trees() still returns the old shape", { + skip_if_not_installed("ranger") + withr::local_options(lifecycle_verbosity = "quiet") + model <- ranger::ranger( + mpg ~ cyl + disp, + data = mtcars, + num.trees = 3, + max.depth = 2, + seed = 100, + num.threads = 2 + ) + + trees <- .extract_ranger_trees(model) + + expect_type(trees, "list") + expect_length(trees, 3) + expect_type(trees[[1]], "language") +}) + +test_that(".extract_ranger_trees() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_ranger_trees(lm(mpg ~ wt, mtcars))) +}) + +# .extract_rf_classprob() ---------------------------------------------------- + +test_that(".extract_rf_classprob() is deprecated", { + skip_if_not_installed("randomForest") + set.seed(123) + model <- randomForest::randomForest( + Species ~ Sepal.Length + Sepal.Width, + data = iris, + ntree = 3 + ) + + expect_snapshot(x <- .extract_rf_classprob(model)) +}) + +test_that(".extract_rf_classprob() still returns the old shape", { + skip_if_not_installed("randomForest") + withr::local_options(lifecycle_verbosity = "quiet") + set.seed(123) + model <- randomForest::randomForest( + Species ~ Sepal.Length + Sepal.Width, + data = iris, + ntree = 3 + ) + + result <- .extract_rf_classprob(model) + + expect_named(result, levels(iris$Species)) + expect_length(result[[1]], 3) +}) + +test_that(".extract_rf_classprob() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_rf_classprob(lm(mpg ~ wt, mtcars))) +}) + +# .extract_ranger_classprob() ------------------------------------------------ + +test_that(".extract_ranger_classprob() is deprecated", { + skip_if_not_installed("ranger") + model <- ranger::ranger( + Species ~ Sepal.Length + Sepal.Width, + data = iris, + num.trees = 3, + max.depth = 2, + seed = 123, + num.threads = 2, + probability = TRUE + ) + + expect_snapshot(x <- .extract_ranger_classprob(model)) +}) + +test_that(".extract_ranger_classprob() still returns the old shape", { + skip_if_not_installed("ranger") + withr::local_options(lifecycle_verbosity = "quiet") + model <- ranger::ranger( + Species ~ Sepal.Length + Sepal.Width, + data = iris, + num.trees = 3, + max.depth = 2, + seed = 123, + num.threads = 2, + probability = TRUE + ) + + result <- .extract_ranger_classprob(model) + + expect_named(result, levels(iris$Species)) + expect_length(result[[1]], 3) +}) + +test_that(".extract_ranger_classprob() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_ranger_classprob(lm(mpg ~ wt, mtcars))) +}) + +# .extract_rpart_classprob() ------------------------------------------------- + +test_that(".extract_rpart_classprob() is deprecated", { + skip_if_not_installed("rpart") + model <- rpart::rpart(Species ~ Sepal.Length + Sepal.Width, data = iris) + + expect_snapshot(x <- .extract_rpart_classprob(model)) +}) + +test_that(".extract_rpart_classprob() still returns the old shape", { + skip_if_not_installed("rpart") + withr::local_options(lifecycle_verbosity = "quiet") + model <- rpart::rpart(Species ~ Sepal.Length + Sepal.Width, data = iris) + + exprs <- .extract_rpart_classprob(model) + + expect_named(exprs, levels(iris$Species)) + expect_type(exprs[[1]], "language") +}) + +test_that(".extract_rpart_classprob() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_rpart_classprob(lm(mpg ~ wt, mtcars))) +}) + +# .extract_partykit_classprob() ---------------------------------------------- + +test_that(".extract_partykit_classprob() is deprecated", { + skip_if_not_installed("partykit") + model <- partykit::ctree(Species ~ Sepal.Length + Sepal.Width, data = iris) + + expect_snapshot(x <- .extract_partykit_classprob(model)) +}) + +test_that(".extract_partykit_classprob() still returns an unnamed list", { + skip_if_not_installed("partykit") + withr::local_options(lifecycle_verbosity = "quiet") + model <- partykit::ctree(Species ~ Sepal.Length + Sepal.Width, data = iris) + + exprs <- .extract_partykit_classprob(model) + + expect_null(names(exprs)) + expect_length(exprs, 3) + expect_type(exprs[[1]], "language") + expect_identical(exprs, unname(tidypredict_class_exprs(model))) +}) + +test_that(".extract_partykit_classprob() errors on the wrong class", { + expect_snapshot( + error = TRUE, + .extract_partykit_classprob(lm(mpg ~ wt, mtcars)) + ) +}) + +# .extract_earth_multiclass() ------------------------------------------------ + +test_that(".extract_earth_multiclass() is deprecated", { + skip_if_no_earth_multiclass() + model <- deprec_earth_multiclass_model() + + expect_snapshot(x <- .extract_earth_multiclass(model)) +}) + +test_that(".extract_earth_multiclass() still returns character strings", { + skip_if_no_earth_multiclass() + withr::local_options(lifecycle_verbosity = "quiet") + model <- deprec_earth_multiclass_model() + + result <- .extract_earth_multiclass(model) + + expect_named(result, levels(iris$Species)) + expect_type(result[[1]], "character") + expect_length(result[[1]], 1) +}) + +test_that(".extract_earth_multiclass() errors on the wrong class", { + expect_snapshot(error = TRUE, .extract_earth_multiclass(lm(mpg ~ wt, mtcars))) +}) + +# .extract_glmnet_multiclass() ----------------------------------------------- + +test_that(".extract_glmnet_multiclass() is deprecated", { + skip_if_not_installed("glmnet") + model <- deprec_multnet_model() + + expect_snapshot(x <- .extract_glmnet_multiclass(model)) +}) + +test_that(".extract_glmnet_multiclass() still returns character strings", { + skip_if_not_installed("glmnet") + withr::local_options(lifecycle_verbosity = "quiet") + model <- deprec_multnet_model() + + result <- .extract_glmnet_multiclass(model) + + expect_named(result, levels(iris$Species)) + expect_type(result[[1]], "character") + expect_length(result[[1]], 1) +}) + +test_that(".extract_glmnet_multiclass() accepts a penalty", { + skip_if_not_installed("glmnet") + withr::local_options(lifecycle_verbosity = "quiet") + model <- glmnet::glmnet( + as.matrix(iris[, 1:4]), + iris$Species, + family = "multinomial" + ) + + result <- .extract_glmnet_multiclass(model, penalty = 0.01) + + expect_named(result, levels(iris$Species)) + expect_type(result[[1]], "character") +}) + +test_that(".extract_glmnet_multiclass() errors on the wrong class", { + expect_snapshot( + error = TRUE, + .extract_glmnet_multiclass(lm(mpg ~ wt, mtcars)) + ) +}) diff --git a/tests/testthat/test-model-catboost.R b/tests/testthat/test-model-catboost.R index 85a0fff4..d95c75c8 100644 --- a/tests/testthat/test-model-catboost.R +++ b/tests/testthat/test-model-catboost.R @@ -1161,23 +1161,23 @@ test_that("tidypredict_test requires matrix", { expect_snapshot(tidypredict_test(model), error = TRUE) }) -test_that(".extract_catboost_trees returns list of expressions", { +test_that("tidypredict_trees returns list of expressions", { skip_if_not_installed("catboost") model <- make_catboost_model() - trees <- .extract_catboost_trees(model) + trees <- tidypredict_trees(model) expect_type(trees, "list") expect_length(trees, 10) expect_type(trees[[1]], "language") }) -test_that(".extract_catboost_trees combined results match tidypredict_fit", { +test_that("tidypredict_trees combined results match tidypredict_fit", { skip_if_not_installed("catboost") model <- make_catboost_model() test_data <- mtcars[, c("mpg", "cyl", "disp")] - trees <- .extract_catboost_trees(model) + trees <- tidypredict_trees(model) eval_env <- rlang::new_environment( data = as.list(test_data), parent = asNamespace("dplyr") @@ -1193,13 +1193,23 @@ test_that(".extract_catboost_trees combined results match tidypredict_fit", { expect_equal(combined, fit_result) }) -test_that(".extract_catboost_trees errors on non-catboost model", { +test_that("tidypredict_trees errors on non-catboost model", { expect_snapshot( - .extract_catboost_trees(lm(mpg ~ wt, data = mtcars)), + tidypredict_trees(lm(mpg ~ wt, data = mtcars)), error = TRUE ) }) +test_that("tidypredict_n_trees counts the extracted trees", { + skip_if_not_installed("catboost") + model <- make_catboost_model() + + expect_identical( + tidypredict_n_trees(model), + length(tidypredict_trees(model)) + ) +}) + # YAML serialization tests ------------------------------------------------ test_that("model can be saved and re-loaded", { diff --git a/tests/testthat/test-model-earth.R b/tests/testthat/test-model-earth.R index 2856f35e..a609b14b 100644 --- a/tests/testthat/test-model-earth.R +++ b/tests/testthat/test-model-earth.R @@ -459,16 +459,16 @@ test_that("inverse.gaussian family works (#195)", { expect_equal(tidy, native) }) -# Tests for .extract_earth_multiclass() +# Tests for tidypredict_class_exprs() -test_that(".extract_earth_multiclass errors on non-earth model", { +test_that("tidypredict_class_exprs errors on non-earth model", { skip_if_not_installed("earth") model <- lm(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_earth_multiclass(model)) + expect_snapshot(error = TRUE, tidypredict_class_exprs(model)) }) -test_that(".extract_earth_multiclass errors on binary model", { +test_that("tidypredict_class_exprs errors on binary model", { skip_if_not_installed("earth") suppressWarnings( model <- earth::earth( @@ -478,17 +478,17 @@ test_that(".extract_earth_multiclass errors on binary model", { ) ) - expect_snapshot(error = TRUE, .extract_earth_multiclass(model)) + expect_snapshot(error = TRUE, tidypredict_class_exprs(model)) }) -test_that(".extract_earth_multiclass errors on regression model", { +test_that("tidypredict_class_exprs errors on regression model", { skip_if_not_installed("earth") model <- earth::earth(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_earth_multiclass(model)) + expect_snapshot(error = TRUE, tidypredict_class_exprs(model)) }) -test_that(".extract_earth_multiclass returns correct structure", { +test_that("tidypredict_class_exprs returns correct structure", { skip_if_not_installed("earth") skip_if_not( exists("contr.earth.response", where = asNamespace("earth")), @@ -504,15 +504,15 @@ test_that(".extract_earth_multiclass returns correct structure", { ) ) - result <- .extract_earth_multiclass(model) + result <- tidypredict_class_exprs(model) expect_type(result, "list") expect_length(result, 3) expect_named(result, levels(iris$Species)) - expect_type(result[[1]], "character") + expect_type(result[[1]], "language") }) -test_that(".extract_earth_multiclass produces correct predictions", { +test_that("tidypredict_class_exprs produces correct predictions", { skip_if_not_installed("earth") skip_if_not( exists("contr.earth.response", where = asNamespace("earth")), @@ -528,13 +528,13 @@ test_that(".extract_earth_multiclass produces correct predictions", { ) ) - eqs <- .extract_earth_multiclass(model) + eqs <- tidypredict_class_exprs(model) n_rows <- nrow(iris) # Evaluate each expression - earth GLM outputs are already on probability scale # (not logits), so we don't apply softmax probs <- sapply(eqs, function(eq) { - val <- rlang::eval_tidy(rlang::parse_expr(eq), iris) + val <- rlang::eval_tidy(eq, iris) if (length(val) == 1) rep(val, n_rows) else val }) @@ -544,7 +544,7 @@ test_that(".extract_earth_multiclass produces correct predictions", { expect_equal(unname(probs), unname(native), tolerance = 1e-6) }) -test_that(".extract_earth_multiclass works with degree > 1", { +test_that("tidypredict_class_exprs works with degree > 1", { skip_if_not_installed("earth") skip_if_not( exists("contr.earth.response", where = asNamespace("earth")), @@ -561,7 +561,7 @@ test_that(".extract_earth_multiclass works with degree > 1", { ) ) - result <- .extract_earth_multiclass(model) + result <- tidypredict_class_exprs(model) expect_type(result, "list") expect_length(result, 3) diff --git a/tests/testthat/test-model-glmnet.R b/tests/testthat/test-model-glmnet.R index b8d6d8c6..7ae924a6 100644 --- a/tests/testthat/test-model-glmnet.R +++ b/tests/testthat/test-model-glmnet.R @@ -442,33 +442,48 @@ test_that("mgaussian family errors with helpful message (#199)", { expect_snapshot(error = TRUE, tidypredict_fit(model)) }) -# Tests for .extract_glmnet_multiclass() +# Tests for tidypredict_class_exprs() -test_that(".extract_glmnet_multiclass returns correct structure", { +test_that("tidypredict_class_exprs returns correct structure", { skip_if_not_installed("glmnet") model <- glmnet::glmnet( as.matrix(iris[, 1:4]), iris$Species, family = "multinomial", - lambda = 0.5 + lambda = 0.01 ) - result <- .extract_glmnet_multiclass(model) + result <- tidypredict_class_exprs(model) expect_type(result, "list") expect_length(result, 3) expect_named(result, levels(iris$Species)) - expect_type(result[[1]], "character") + expect_type(result[[1]], "language") +}) + +test_that("tidypredict_class_exprs returns a bare numeric for zero coefs", { + skip_if_not_installed("glmnet") + model <- glmnet::glmnet( + as.matrix(iris[, 1:4]), + iris$Species, + family = "multinomial", + lambda = 10 + ) + + result <- tidypredict_class_exprs(model) + + expect_named(result, levels(iris$Species)) + expect_equal(result[[1]], 0) }) -test_that(".extract_glmnet_multiclass errors on non-multnet model", { +test_that("tidypredict_class_exprs errors on non-multnet model", { skip_if_not_installed("glmnet") model <- glmnet::glmnet(mtcars[, -1], mtcars$mpg, lambda = 1) - expect_snapshot(error = TRUE, .extract_glmnet_multiclass(model)) + expect_snapshot(error = TRUE, tidypredict_class_exprs(model)) }) -test_that(".extract_glmnet_multiclass errors with multiple penalties", { +test_that("tidypredict_class_exprs errors with multiple penalties", { skip_if_not_installed("glmnet") model <- glmnet::glmnet( as.matrix(iris[, 1:4]), @@ -476,10 +491,10 @@ test_that(".extract_glmnet_multiclass errors with multiple penalties", { family = "multinomial" ) - expect_snapshot(error = TRUE, .extract_glmnet_multiclass(model)) + expect_snapshot(error = TRUE, tidypredict_class_exprs(model)) }) -test_that(".extract_glmnet_multiclass works with explicit penalty", { +test_that("tidypredict_class_exprs works with explicit penalty", { skip_if_not_installed("glmnet") model <- glmnet::glmnet( as.matrix(iris[, 1:4]), @@ -487,13 +502,13 @@ test_that(".extract_glmnet_multiclass works with explicit penalty", { family = "multinomial" ) - result <- .extract_glmnet_multiclass(model, penalty = 0.01) + result <- tidypredict_class_exprs(model, penalty = 0.01) expect_type(result, "list") expect_length(result, 3) }) -test_that(".extract_glmnet_multiclass handles sparse coefficients", { +test_that("tidypredict_class_exprs handles sparse coefficients", { skip_if_not_installed("glmnet") # High penalty should zero out many coefficients @@ -504,13 +519,13 @@ test_that(".extract_glmnet_multiclass handles sparse coefficients", { lambda = 10 ) - result <- .extract_glmnet_multiclass(model) + result <- tidypredict_class_exprs(model) expect_type(result, "list") expect_length(result, 3) }) -test_that(".extract_glmnet_multiclass produces correct predictions", { +test_that("tidypredict_class_exprs produces correct predictions", { skip_if_not_installed("glmnet") model <- glmnet::glmnet( as.matrix(iris[, 1:4]), @@ -519,12 +534,12 @@ test_that(".extract_glmnet_multiclass produces correct predictions", { lambda = 0.01 ) - eqs <- .extract_glmnet_multiclass(model) + eqs <- tidypredict_class_exprs(model) n_rows <- nrow(iris) # Evaluate each linear predictor, recycling scalars to full length logits <- sapply(eqs, function(eq) { - val <- rlang::eval_tidy(rlang::parse_expr(eq), iris) + val <- rlang::eval_tidy(eq, iris) if (length(val) == 1) rep(val, n_rows) else val }) diff --git a/tests/testthat/test-model-lightgbm.R b/tests/testthat/test-model-lightgbm.R index 4acca61d..0a511389 100644 --- a/tests/testthat/test-model-lightgbm.R +++ b/tests/testthat/test-model-lightgbm.R @@ -2327,7 +2327,7 @@ test_that("tidypredict_test respects max_rows parameter", { expect_equal(nrow(result$raw_results), 10) }) -test_that(".extract_lgb_trees returns list of tree expressions", { +test_that("tidypredict_trees returns list of tree expressions", { skip_if_not_installed("lightgbm") set.seed(123) @@ -2351,7 +2351,7 @@ test_that(".extract_lgb_trees returns list of tree expressions", { verbose = -1L ) - trees <- .extract_lgb_trees(model) + trees <- tidypredict_trees(model) expect_type(trees, "list") expect_length(trees, 5) @@ -2360,12 +2360,12 @@ test_that(".extract_lgb_trees returns list of tree expressions", { expect_all_equal(types, "language") }) -test_that(".extract_lgb_trees combined results match tidypredict_fit", { +test_that("tidypredict_trees combined results match tidypredict_fit", { skip_if_not_installed("lightgbm") model <- make_lgb_model() test_data <- mtcars[, c("mpg", "cyl", "disp")] - trees <- .extract_lgb_trees(model) + trees <- tidypredict_trees(model) eval_env <- rlang::new_environment( data = as.list(test_data), parent = asNamespace("dplyr") @@ -2378,8 +2378,18 @@ test_that(".extract_lgb_trees combined results match tidypredict_fit", { expect_equal(combined, fit_result) }) -test_that(".extract_lgb_trees errors on non-lgb.Booster", { - expect_snapshot(.extract_lgb_trees(list()), error = TRUE) +test_that("tidypredict_trees errors on non-lgb.Booster", { + expect_snapshot(tidypredict_trees(list()), error = TRUE) +}) + +test_that("tidypredict_n_trees counts the extracted trees", { + skip_if_not_installed("lightgbm") + model <- make_lgb_model() + + expect_identical( + tidypredict_n_trees(model), + length(tidypredict_trees(model)) + ) }) test_that("tidypredict works with parsnip/bonsai lightgbm model", { diff --git a/tests/testthat/test-model-partykit.R b/tests/testthat/test-model-partykit.R index f31d8a4c..1ce9b4ab 100644 --- a/tests/testthat/test-model-partykit.R +++ b/tests/testthat/test-model-partykit.R @@ -75,26 +75,27 @@ test_that("formulas produce correct predictions", { ) }) -# .extract_partykit_classprob tests ------------------------------------------ +# tidypredict_class_exprs tests ---------------------------------------------- -test_that(".extract_partykit_classprob returns list of expressions", { +test_that("tidypredict_class_exprs returns list of expressions", { skip_if_not_installed("partykit") model <- partykit::ctree(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_partykit_classprob(model) + exprs <- tidypredict_class_exprs(model) expect_type(exprs, "list") expect_length(exprs, 3) - expect_true(all(vapply(exprs, typeof, character(1)) == "language")) + expect_named(exprs, levels(iris$Species)) + expect_all_equal(vapply(exprs, typeof, character(1)), "language") }) -test_that(".extract_partykit_classprob results match predict probabilities", { +test_that("tidypredict_class_exprs results match predict probabilities", { skip_if_not_installed("partykit") model <- partykit::ctree(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_partykit_classprob(model) + exprs <- tidypredict_class_exprs(model) eval_env <- rlang::new_environment( data = as.list(iris), parent = asNamespace("dplyr") @@ -107,10 +108,10 @@ test_that(".extract_partykit_classprob results match predict probabilities", { expect_equal(unname(combined), unname(native)) }) -test_that(".extract_partykit_classprob errors on non-party model", { +test_that("tidypredict_class_exprs errors on non-party model", { skip_if_not_installed("partykit") - expect_snapshot(.extract_partykit_classprob(list()), error = TRUE) + expect_snapshot(tidypredict_class_exprs(list()), error = TRUE) }) test_that("stump trees (no splits) work correctly (#196)", { @@ -165,12 +166,12 @@ test_that("tidypredict_fit works for classification", { expect_equal(fit_pred, original_pred) }) -test_that(".extract_partykit_classprob matches original model probabilities", { +test_that("tidypredict_class_exprs matches original model probabilities", { skip_if_not_installed("partykit") model <- partykit::ctree(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_partykit_classprob(model) + exprs <- tidypredict_class_exprs(model) eval_env <- rlang::new_environment( data = as.list(iris), @@ -455,7 +456,7 @@ test_that("an unused outcome level matches predict()", { as.character(predict(model, df, type = "response")) ) - exprs <- .extract_partykit_classprob(model) + exprs <- tidypredict_class_exprs(model) eval_env <- rlang::new_environment( data = as.list(df), parent = asNamespace("dplyr") diff --git a/tests/testthat/test-model-ranger.R b/tests/testthat/test-model-ranger.R index b7f9e52f..a13b41b4 100644 --- a/tests/testthat/test-model-ranger.R +++ b/tests/testthat/test-model-ranger.R @@ -166,9 +166,9 @@ test_that("probability and survival forests error with clear message (#301)", { expect_snapshot(parse_model(model), error = TRUE) }) -# Tests for .extract_ranger_classprob() +# Tests for tidypredict_class_trees() -test_that(".extract_ranger_classprob returns correct structure", { +test_that("tidypredict_class_trees returns correct structure", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -181,7 +181,7 @@ test_that(".extract_ranger_classprob returns correct structure", { probability = TRUE ) - result <- .extract_ranger_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 3) @@ -190,14 +190,14 @@ test_that(".extract_ranger_classprob returns correct structure", { expect_length(result[[1]], 3) }) -test_that(".extract_ranger_classprob errors on non-ranger model", { +test_that("tidypredict_class_trees errors on non-ranger model", { skip_if_not_installed("ranger") model <- lm(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_ranger_classprob(model)) + expect_snapshot(error = TRUE, tidypredict_class_trees(model)) }) -test_that(".extract_ranger_classprob errors without probability = TRUE", { +test_that("tidypredict_class_trees errors without probability = TRUE", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -210,10 +210,10 @@ test_that(".extract_ranger_classprob errors without probability = TRUE", { probability = FALSE ) - expect_snapshot(error = TRUE, .extract_ranger_classprob(model)) + expect_snapshot(error = TRUE, tidypredict_class_trees(model)) }) -test_that(".extract_ranger_classprob works with binary classification", { +test_that("tidypredict_class_trees works with binary classification", { skip_if_not_installed("ranger") mtcars$vs <- factor(mtcars$vs) @@ -227,14 +227,14 @@ test_that(".extract_ranger_classprob works with binary classification", { probability = TRUE ) - result <- .extract_ranger_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 2) expect_named(result, c("0", "1")) }) -test_that(".extract_ranger_classprob produces correct probabilities", { +test_that("tidypredict_class_trees produces correct probabilities", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -247,7 +247,7 @@ test_that(".extract_ranger_classprob produces correct probabilities", { probability = TRUE ) - class_trees <- .extract_ranger_classprob(model) + class_trees <- tidypredict_class_trees(model) n_trees <- model$num.trees # Sum probabilities for each class @@ -268,7 +268,7 @@ test_that(".extract_ranger_classprob produces correct probabilities", { expect_equal(unname(probs), unname(native), tolerance = 1e-10) }) -test_that(".extract_ranger_classprob works with single tree", { +test_that("tidypredict_class_trees works with single tree", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -281,7 +281,7 @@ test_that(".extract_ranger_classprob works with single tree", { probability = TRUE ) - result <- .extract_ranger_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 3) @@ -289,9 +289,9 @@ test_that(".extract_ranger_classprob works with single tree", { expect_length(result[[1]], 1) }) -# Tests for .extract_ranger_trees() (regression) +# Tests for tidypredict_trees() (regression) -test_that(".extract_ranger_trees returns correct structure", { +test_that("tidypredict_trees returns correct structure", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -303,21 +303,21 @@ test_that(".extract_ranger_trees returns correct structure", { num.threads = 2 ) - result <- .extract_ranger_trees(model) + result <- tidypredict_trees(model) expect_type(result, "list") expect_length(result, 5) expect_all_true(vapply(result, is.language, logical(1))) }) -test_that(".extract_ranger_trees errors on non-ranger model", { +test_that("tidypredict_trees errors on non-ranger model", { skip_if_not_installed("ranger") model <- lm(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_ranger_trees(model)) + expect_snapshot(error = TRUE, tidypredict_trees(model)) }) -test_that(".extract_ranger_trees errors on classification model", { +test_that("tidypredict_trees errors on classification model", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -329,10 +329,10 @@ test_that(".extract_ranger_trees errors on classification model", { num.threads = 2 ) - expect_snapshot(error = TRUE, .extract_ranger_trees(model)) + expect_snapshot(error = TRUE, tidypredict_trees(model)) }) -test_that(".extract_ranger_trees produces correct predictions when averaged", { +test_that("tidypredict_trees produces correct predictions when averaged", { skip_if_not_installed("ranger") model <- ranger::ranger( @@ -344,7 +344,7 @@ test_that(".extract_ranger_trees produces correct predictions when averaged", { num.threads = 2 ) - trees <- .extract_ranger_trees(model) + trees <- tidypredict_trees(model) n_trees <- length(trees) tree_preds <- sapply(trees, function(e) rlang::eval_tidy(e, mtcars)) @@ -355,6 +355,24 @@ test_that(".extract_ranger_trees produces correct predictions when averaged", { expect_equal(avg_pred, native) }) +# Tests for tidypredict_n_trees() + +test_that("tidypredict_n_trees matches the forest size", { + skip_if_not_installed("ranger") + + model <- ranger::ranger( + mpg ~ cyl + disp + hp, + data = mtcars, + num.trees = 5, + max.depth = 2, + seed = 100, + num.threads = 2 + ) + + expect_equal(tidypredict_n_trees(model), model$num.trees) + expect_equal(tidypredict_n_trees(model), length(tidypredict_trees(model))) +}) + # Backwards compatibility tests for v2 parsed models test_that("v2 parsed ranger model can be loaded and used", { @@ -575,7 +593,7 @@ test_that("factor splits match predict() for a probability forest (#283)", { respect.unordered.factors = "partition" ) - trees <- .extract_ranger_classprob(model) + trees <- tidypredict_class_trees(model) probs <- sapply(trees, function(exprs) { rowMeans(sapply(exprs, \(e) rlang::eval_tidy(e, df))) }) diff --git a/tests/testthat/test-model-rf.R b/tests/testthat/test-model-rf.R index 90699f1a..1d994e63 100644 --- a/tests/testthat/test-model-rf.R +++ b/tests/testthat/test-model-rf.R @@ -131,9 +131,9 @@ test_that("v2 parsed classification model errors", { expect_snapshot(tidypredict_fit(pm), error = TRUE) }) -# Tests for .extract_rf_classprob() +# Tests for tidypredict_class_trees() -test_that(".extract_rf_classprob returns correct structure", { +test_that("tidypredict_class_trees returns correct structure", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -142,7 +142,7 @@ test_that(".extract_rf_classprob returns correct structure", { ntree = 3 ) - result <- .extract_rf_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 3) @@ -151,21 +151,21 @@ test_that(".extract_rf_classprob returns correct structure", { expect_length(result[[1]], 3) }) -test_that(".extract_rf_classprob errors on non-randomForest model", { +test_that("tidypredict_class_trees errors on non-randomForest model", { model <- lm(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_rf_classprob(model)) + expect_snapshot(error = TRUE, tidypredict_class_trees(model)) }) -test_that(".extract_rf_classprob errors on regression model", { +test_that("tidypredict_class_trees errors on regression model", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest(mpg ~ ., data = mtcars, ntree = 3) - expect_snapshot(error = TRUE, .extract_rf_classprob(model)) + expect_snapshot(error = TRUE, tidypredict_class_trees(model)) }) -test_that(".extract_rf_classprob works with binary classification", { +test_that("tidypredict_class_trees works with binary classification", { skip_if_not_installed("randomForest") set.seed(123) mtcars$vs <- factor(mtcars$vs) @@ -175,14 +175,14 @@ test_that(".extract_rf_classprob works with binary classification", { ntree = 3 ) - result <- .extract_rf_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 2) expect_named(result, c("0", "1")) }) -test_that(".extract_rf_classprob produces correct vote counts", { +test_that("tidypredict_class_trees produces correct vote counts", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -191,7 +191,7 @@ test_that(".extract_rf_classprob produces correct vote counts", { ntree = 5 ) - class_trees <- .extract_rf_classprob(model) + class_trees <- tidypredict_class_trees(model) n_trees <- model$ntree # Sum votes for each class @@ -212,7 +212,7 @@ test_that(".extract_rf_classprob produces correct vote counts", { expect_equal(unname(probs), unname(native), tolerance = 1e-10) }) -test_that(".extract_rf_classprob works with single tree", { +test_that("tidypredict_class_trees works with single tree", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -221,7 +221,7 @@ test_that(".extract_rf_classprob works with single tree", { ntree = 1 ) - result <- .extract_rf_classprob(model) + result <- tidypredict_class_trees(model) expect_type(result, "list") expect_length(result, 3) @@ -229,9 +229,9 @@ test_that(".extract_rf_classprob works with single tree", { expect_length(result[[1]], 1) }) -# Tests for .extract_rf_trees() (regression) +# Tests for tidypredict_trees() (regression) -test_that(".extract_rf_trees returns correct structure", { +test_that("tidypredict_trees returns correct structure", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -240,20 +240,20 @@ test_that(".extract_rf_trees returns correct structure", { ntree = 5 ) - result <- .extract_rf_trees(model) + result <- tidypredict_trees(model) expect_type(result, "list") expect_length(result, 5) expect_all_true(vapply(result, is.language, logical(1))) }) -test_that(".extract_rf_trees errors on non-randomForest model", { +test_that("tidypredict_trees errors on non-randomForest model", { model <- lm(mpg ~ ., data = mtcars) - expect_snapshot(error = TRUE, .extract_rf_trees(model)) + expect_snapshot(error = TRUE, tidypredict_trees(model)) }) -test_that(".extract_rf_trees errors on classification model", { +test_that("tidypredict_trees errors on classification model", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -262,10 +262,10 @@ test_that(".extract_rf_trees errors on classification model", { ntree = 3 ) - expect_snapshot(error = TRUE, .extract_rf_trees(model)) + expect_snapshot(error = TRUE, tidypredict_trees(model)) }) -test_that(".extract_rf_trees produces correct predictions when averaged", { +test_that("tidypredict_trees produces correct predictions when averaged", { skip_if_not_installed("randomForest") set.seed(123) model <- randomForest::randomForest( @@ -274,7 +274,7 @@ test_that(".extract_rf_trees produces correct predictions when averaged", { ntree = 5 ) - trees <- .extract_rf_trees(model) + trees <- tidypredict_trees(model) n_trees <- length(trees) tree_preds <- sapply(trees, function(e) rlang::eval_tidy(e, mtcars)) @@ -285,6 +285,21 @@ test_that(".extract_rf_trees produces correct predictions when averaged", { expect_equal(avg_pred, native) }) +# Tests for tidypredict_n_trees() + +test_that("tidypredict_n_trees matches the forest size", { + skip_if_not_installed("randomForest") + set.seed(123) + model <- randomForest::randomForest( + mpg ~ cyl + disp + hp, + data = mtcars, + ntree = 5 + ) + + expect_equal(tidypredict_n_trees(model), model$ntree) + expect_equal(tidypredict_n_trees(model), length(tidypredict_trees(model))) +}) + test_that("parsed models use the right split variable at every node (#232)", { skip_if_not_installed("randomForest") set.seed(123) @@ -431,7 +446,7 @@ test_that("factor splits match predict() for class probabilities (#282)", { ) model <- randomForest::randomForest(am ~ wt + gear, data = df) - trees <- .extract_rf_classprob(model) + trees <- tidypredict_class_trees(model) probs <- sapply(trees, function(exprs) { rowMeans(sapply(exprs, \(e) rlang::eval_tidy(e, df))) }) diff --git a/tests/testthat/test-model-rpart.R b/tests/testthat/test-model-rpart.R index 610f0822..4db713cb 100644 --- a/tests/testthat/test-model-rpart.R +++ b/tests/testthat/test-model-rpart.R @@ -129,24 +129,25 @@ test_that("produced case_when uses .default", { expect_match(fit_text, "\\.default") }) -# .extract_rpart_classprob tests ------------------------------------------ +# tidypredict_class_exprs tests ------------------------------------------- -test_that(".extract_rpart_classprob returns list of expressions", { +test_that("tidypredict_class_exprs returns list of expressions", { skip_if_not_installed("rpart") model <- rpart::rpart(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_rpart_classprob(model) + exprs <- tidypredict_class_exprs(model) expect_type(exprs, "list") expect_length(exprs, 3) - expect_true(all(vapply(exprs, typeof, character(1)) == "language")) + expect_named(exprs, levels(iris$Species)) + expect_all_equal(vapply(exprs, typeof, character(1)), "language") }) -test_that(".extract_rpart_classprob results match predict probabilities", { +test_that("tidypredict_class_exprs results match predict probabilities", { skip_if_not_installed("rpart") model <- rpart::rpart(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_rpart_classprob(model) + exprs <- tidypredict_class_exprs(model) eval_env <- rlang::new_environment( data = as.list(iris), parent = asNamespace("dplyr") @@ -159,15 +160,15 @@ test_that(".extract_rpart_classprob results match predict probabilities", { expect_equal(unname(combined), unname(native)) }) -test_that(".extract_rpart_classprob errors on non-rpart model", { +test_that("tidypredict_class_exprs errors on non-rpart model", { skip_if_not_installed("rpart") - expect_snapshot(.extract_rpart_classprob(list()), error = TRUE) + expect_snapshot(tidypredict_class_exprs(list()), error = TRUE) }) -test_that(".extract_rpart_classprob errors on regression model", { +test_that("tidypredict_class_exprs errors on regression model", { skip_if_not_installed("rpart") model <- rpart::rpart(mpg ~ cyl + wt, data = mtcars) - expect_snapshot(.extract_rpart_classprob(model), error = TRUE) + expect_snapshot(tidypredict_class_exprs(model), error = TRUE) }) # Nested case_when tests -------------------------------------------------- @@ -194,11 +195,11 @@ test_that("tidypredict_fit works for classification", { expect_equal(fit_pred, original_pred) }) -test_that(".extract_rpart_classprob matches original model probabilities", { +test_that("tidypredict_class_exprs matches original model probabilities", { skip_if_not_installed("rpart") model <- rpart::rpart(Species ~ Sepal.Length + Sepal.Width, data = iris) - exprs <- .extract_rpart_classprob(model) + exprs <- tidypredict_class_exprs(model) eval_env <- rlang::new_environment( data = as.list(iris), diff --git a/tests/testthat/test-model-xgboost.R b/tests/testthat/test-model-xgboost.R index 592bf599..a47c1df5 100644 --- a/tests/testthat/test-model-xgboost.R +++ b/tests/testthat/test-model-xgboost.R @@ -1136,24 +1136,36 @@ test_that("tidypredict_test respects max_rows parameter", { expect_equal(nrow(result$raw_results), 10) }) -test_that(".extract_xgb_trees returns list of expressions", { +test_that("tidypredict_trees returns an unnamed list of expressions", { skip_if_not_installed("xgboost") model <- make_xgb_model(nrounds = 4L) - trees <- .extract_xgb_trees(model) + trees <- tidypredict_trees(model) expect_type(trees, "list") expect_length(trees, 4) + expect_null(names(trees)) for (tree in trees) { expect_type(tree, "language") } }) -test_that(".extract_xgb_trees combined results match tidypredict_fit", { +test_that("tidypredict_n_trees counts every tree", { + skip_if_not_installed("xgboost") + model <- make_xgb_model(nrounds = 4L) + + expect_identical(tidypredict_n_trees(model), 4L) + expect_identical( + tidypredict_n_trees(model), + length(tidypredict_trees(model)) + ) +}) + +test_that("tidypredict_trees combined results match tidypredict_fit", { skip_if_not_installed("xgboost") model <- make_xgb_model(nrounds = 4L, objective = "reg:squarederror") - trees <- .extract_xgb_trees(model) + trees <- tidypredict_trees(model) eval_env <- rlang::new_environment( data = as.list(mtcars), parent = asNamespace("dplyr") @@ -1168,11 +1180,11 @@ test_that(".extract_xgb_trees combined results match tidypredict_fit", { expect_equal(combined, fit_result) }) -test_that(".extract_xgb_trees errors on non-xgb.Booster", { - expect_snapshot(.extract_xgb_trees(list()), error = TRUE) +test_that("tidypredict_trees errors on non-xgb.Booster", { + expect_snapshot(tidypredict_trees(list()), error = TRUE) }) -test_that(".extract_xgb_trees combined results match tidypredict_fit for DART", { +test_that("tidypredict_trees combined results match tidypredict_fit for DART", { skip_if_not_installed("xgboost") # Add 0.1 to avoid exact split boundaries (float32 vs float64 precision) @@ -1198,7 +1210,7 @@ test_that(".extract_xgb_trees combined results match tidypredict_fit for DART", verbose = 0 ) - trees <- .extract_xgb_trees(model) + trees <- tidypredict_trees(model) eval_env <- rlang::new_environment( data = as.list(mtcars_adj), parent = asNamespace("dplyr")