diff --git a/DESCRIPTION b/DESCRIPTION index d4f286e..c1c6bb1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -63,6 +63,7 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Collate: 'bound_prediction.R' + 'butcher.R' 'cal-apply-binary.R' 'cal-apply-impl.R' 'cal-apply-multi.R' diff --git a/NEWS.md b/NEWS.md index 7be95a0..95e2855 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,8 @@ * Add `required_pkgs()` methods to `int_conformal_cv()`, `int_conformal_full()`, `int_conformal_quantile()`, and `int_conformal_split()`. (#190) +* Add butcher methods to `int_conformal_cv()`, `int_conformal_full()`, `int_conformal_quantile()`, and `int_conformal_split()`. (#194) + # probably 1.1.1 * Updated unit tests for new ggplot2 release (#180). diff --git a/R/butcher.R b/R/butcher.R new file mode 100644 index 0000000..a0d1a96 --- /dev/null +++ b/R/butcher.R @@ -0,0 +1,173 @@ +#' Butcher methods for conformal inteference intervals +#' +#' These methods allow you to use the butcher package to reduce the size of a +#' conformal inference interval object. After calling `butcher::butcher()` on a +#' conformal inference interval object, the only guarantee is that you will +#' still be able to `predict()` from that conformal inference interval object. +#' Other functions may not work as expected. +#' +#' @param x A conformal inference interval object. +#' @param verbose Should information be printed about how much memory is freed +#' from butchering? +#' @param ... Extra arguments possibly used by underlying methods. +#' +#' @keywords internal +#' @name inf_conformal-butcher + +# int_conformal_full + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_call.int_conformal_full <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_call(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_ctrl.int_conformal_full <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_ctrl(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_data.int_conformal_full <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_data(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_env.int_conformal_full <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_env(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_fitted.int_conformal_full <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_fitted(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# int_conformal_split + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_call.int_conformal_split <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_call(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_ctrl.int_conformal_split <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_ctrl(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_data.int_conformal_split <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_data(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_env.int_conformal_split <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_env(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_fitted.int_conformal_split <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_fitted(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# int_conformal_quantile + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_call.int_conformal_quantile <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_call(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_ctrl.int_conformal_quantile <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_ctrl(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_data.int_conformal_quantile <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_data(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_env.int_conformal_quantile <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_env(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_fitted.int_conformal_quantile <- function(x, verbose = FALSE, ...) { + x$wflow <- butcher::axe_fitted(x$wflow, verbose = verbose, ...) + add_butcher_class(x) +} + +# int_conformal_cv + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_call.int_conformal_cv <- function(x, verbose = FALSE, ...) { + x$models <- purrr::map(x$models, butcher::axe_call, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_ctrl.int_conformal_cv <- function(x, verbose = FALSE, ...) { + x$models <- purrr::map(x$models, butcher::axe_ctrl, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_data.int_conformal_cv <- function(x, verbose = FALSE, ...) { + x$models <- purrr::map(x$models, butcher::axe_data, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_env.int_conformal_cv <- function(x, verbose = FALSE, ...) { + x$models <- purrr::map(x$models, butcher::axe_env, verbose = verbose, ...) + add_butcher_class(x) +} + +# @export - onLoad +#' @rdname inf_conformal-butcher +axe_fitted.int_conformal_cv <- function(x, verbose = FALSE, ...) { + x$models <- purrr::map(x$models, butcher::axe_fitted, verbose = verbose, ...) + add_butcher_class(x) +} + +# ------------------------------------------------------------------------------ + +# butcher:::add_butcher_class +add_butcher_class <- function(x) { + if (!any(grepl("butcher", class(x)))) { + class(x) <- append(paste0("butchered_", rev(class(x))[1]), class(x)) + } + x +} diff --git a/R/zzz.R b/R/zzz.R index b252929..7a8c19f 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,4 +1,28 @@ .onLoad <- function(libname, pkgname) { vctrs::s3_register("tune::collect_metrics", "cal_rset") vctrs::s3_register("tune::collect_predictions", "cal_rset") + + vctrs::s3_register("butcher::axe_call", "int_conformal_cv") + vctrs::s3_register("butcher::axe_ctrl", "int_conformal_cv") + vctrs::s3_register("butcher::axe_data", "int_conformal_cv") + vctrs::s3_register("butcher::axe_env", "int_conformal_cv") + vctrs::s3_register("butcher::axe_fitted", "int_conformal_cv") + + vctrs::s3_register("butcher::axe_call", "int_conformal_full") + vctrs::s3_register("butcher::axe_ctrl", "int_conformal_full") + vctrs::s3_register("butcher::axe_data", "int_conformal_full") + vctrs::s3_register("butcher::axe_env", "int_conformal_full") + vctrs::s3_register("butcher::axe_fitted", "int_conformal_full") + + vctrs::s3_register("butcher::axe_call", "int_conformal_split") + vctrs::s3_register("butcher::axe_ctrl", "int_conformal_split") + vctrs::s3_register("butcher::axe_data", "int_conformal_split") + vctrs::s3_register("butcher::axe_env", "int_conformal_split") + vctrs::s3_register("butcher::axe_fitted", "int_conformal_split") + + vctrs::s3_register("butcher::axe_call", "int_conformal_quantile") + vctrs::s3_register("butcher::axe_ctrl", "int_conformal_quantile") + vctrs::s3_register("butcher::axe_data", "int_conformal_quantile") + vctrs::s3_register("butcher::axe_env", "int_conformal_quantile") + vctrs::s3_register("butcher::axe_fitted", "int_conformal_quantile") } diff --git a/man/inf_conformal-butcher.Rd b/man/inf_conformal-butcher.Rd new file mode 100644 index 0000000..e235a62 --- /dev/null +++ b/man/inf_conformal-butcher.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/butcher.R +\name{inf_conformal-butcher} +\alias{inf_conformal-butcher} +\alias{axe_call.int_conformal_full} +\alias{axe_ctrl.int_conformal_full} +\alias{axe_data.int_conformal_full} +\alias{axe_env.int_conformal_full} +\alias{axe_fitted.int_conformal_full} +\alias{axe_call.int_conformal_split} +\alias{axe_ctrl.int_conformal_split} +\alias{axe_data.int_conformal_split} +\alias{axe_env.int_conformal_split} +\alias{axe_fitted.int_conformal_split} +\alias{axe_call.int_conformal_quantile} +\alias{axe_ctrl.int_conformal_quantile} +\alias{axe_data.int_conformal_quantile} +\alias{axe_env.int_conformal_quantile} +\alias{axe_fitted.int_conformal_quantile} +\alias{axe_call.int_conformal_cv} +\alias{axe_ctrl.int_conformal_cv} +\alias{axe_data.int_conformal_cv} +\alias{axe_env.int_conformal_cv} +\alias{axe_fitted.int_conformal_cv} +\title{Butcher methods for conformal inteference intervals} +\usage{ +\method{axe_call}{int_conformal_full}(x, verbose = FALSE, ...) + +\method{axe_ctrl}{int_conformal_full}(x, verbose = FALSE, ...) + +\method{axe_data}{int_conformal_full}(x, verbose = FALSE, ...) + +\method{axe_env}{int_conformal_full}(x, verbose = FALSE, ...) + +\method{axe_fitted}{int_conformal_full}(x, verbose = FALSE, ...) + +\method{axe_call}{int_conformal_split}(x, verbose = FALSE, ...) + +\method{axe_ctrl}{int_conformal_split}(x, verbose = FALSE, ...) + +\method{axe_data}{int_conformal_split}(x, verbose = FALSE, ...) + +\method{axe_env}{int_conformal_split}(x, verbose = FALSE, ...) + +\method{axe_fitted}{int_conformal_split}(x, verbose = FALSE, ...) + +\method{axe_call}{int_conformal_quantile}(x, verbose = FALSE, ...) + +\method{axe_ctrl}{int_conformal_quantile}(x, verbose = FALSE, ...) + +\method{axe_data}{int_conformal_quantile}(x, verbose = FALSE, ...) + +\method{axe_env}{int_conformal_quantile}(x, verbose = FALSE, ...) + +\method{axe_fitted}{int_conformal_quantile}(x, verbose = FALSE, ...) + +\method{axe_call}{int_conformal_cv}(x, verbose = FALSE, ...) + +\method{axe_ctrl}{int_conformal_cv}(x, verbose = FALSE, ...) + +\method{axe_data}{int_conformal_cv}(x, verbose = FALSE, ...) + +\method{axe_env}{int_conformal_cv}(x, verbose = FALSE, ...) + +\method{axe_fitted}{int_conformal_cv}(x, verbose = FALSE, ...) +} +\arguments{ +\item{x}{A conformal inference interval object.} + +\item{verbose}{Should information be printed about how much memory is freed +from butchering?} + +\item{...}{Extra arguments possibly used by underlying methods.} +} +\description{ +These methods allow you to use the butcher package to reduce the size of a +conformal inference interval object. After calling \code{butcher::butcher()} on a +conformal inference interval object, the only guarantee is that you will +still be able to \code{predict()} from that conformal inference interval object. +Other functions may not work as expected. +} +\keyword{internal} diff --git a/tests/testthat/test-butcher.R b/tests/testthat/test-butcher.R new file mode 100644 index 0000000..27f8d51 --- /dev/null +++ b/tests/testthat/test-butcher.R @@ -0,0 +1,111 @@ +test_that("attaches the butcher class", { + skip_if_not_installed("butcher") + skip_if_not_installed("modeldata") + + suppressPackageStartupMessages(library(workflows)) + suppressPackageStartupMessages(library(modeldata)) + suppressPackageStartupMessages(library(purrr)) + suppressPackageStartupMessages(library(rsample)) + suppressPackageStartupMessages(library(tune)) + suppressPackageStartupMessages(library(parsnip)) + suppressPackageStartupMessages(library(butcher)) + + set.seed(2) + sim_train <- sim_regression(500) + sim_cal <- sim_regression(200) + + # We'll use a neural network model + mlp_spec <- + mlp(hidden_units = 5, penalty = 0.01) |> + set_mode("regression") + + mlp_wflow <- + workflow() |> + add_model(mlp_spec) |> + add_formula(outcome ~ .) + + fit <- fit(mlp_wflow, data = sim_train) + + c_int <- int_conformal_split(fit, sim_cal) + c_int <- butcher(c_int) + expect_s3_class(c_int, "butchered_int_conformal_split") + + c_int <- int_conformal_full(fit, sim_cal) + c_int <- butcher(c_int) + expect_s3_class(c_int, "butchered_int_conformal_full") + + c_int <- int_conformal_quantile(fit, sim_cal, sim_cal) + c_int <- butcher(c_int) + expect_s3_class(c_int, "butchered_int_conformal_quantile") + + ctrl <- control_resamples(save_pred = TRUE, extract = I) + + res <- mlp_wflow |> + fit_resamples(resamples = vfold_cv(sim_train, v = 2), control = ctrl) + + fit <- int_conformal_cv(res) + + c_int <- int_conformal_cv(res) + c_int <- butcher(c_int) + expect_s3_class(c_int, "butchered_int_conformal_cv") +}) + +test_that("butcher works", { + skip_if_not_installed("butcher") + skip_if_not_installed("modeldata") + + suppressPackageStartupMessages(library(workflows)) + suppressPackageStartupMessages(library(modeldata)) + suppressPackageStartupMessages(library(purrr)) + suppressPackageStartupMessages(library(rsample)) + suppressPackageStartupMessages(library(tune)) + suppressPackageStartupMessages(library(parsnip)) + suppressPackageStartupMessages(library(butcher)) + + set.seed(2) + sim_train <- sim_regression(500) + sim_cal <- sim_regression(200) + + # We'll use a neural network model + mlp_spec <- + mlp(hidden_units = 5, penalty = 0.01) |> + set_mode("regression") + + mlp_wflow <- + workflow() |> + add_model(mlp_spec) |> + add_formula(outcome ~ .) + + fit <- fit(mlp_wflow, data = sim_train) + + c_int <- int_conformal_split(fit, sim_cal) + expect_identical( + butcher(c_int)$wflow, + butcher(c_int$wflow) + ) + + c_int <- int_conformal_full(fit, sim_cal) + expect_identical( + butcher(c_int)$wflow, + butcher(c_int$wflow) + ) + + c_int <- int_conformal_quantile(fit, sim_cal, sim_cal) + expect_identical( + butcher(c_int)$wflow, + butcher(c_int$wflow) + ) + + ctrl <- control_resamples(save_pred = TRUE, extract = I) + + res <- mlp_wflow |> + fit_resamples(resamples = vfold_cv(sim_train, v = 2), control = ctrl) + + fit <- int_conformal_cv(res) + + c_int <- int_conformal_cv(res) + expect_identical( + butcher(c_int)$models, + lapply(c_int$models, butcher) + ) +})