From 82065a126933ffa307c0de785ffa35740b93a396 Mon Sep 17 00:00:00 2001 From: "Simon P. Couch" Date: Wed, 25 Jan 2023 10:10:58 -0800 Subject: [PATCH] add butcher methods for mixOmics output (#249) * add butcher methods for mixOmics output * correct PR number * install mixOmics for pkg check * install via DESCRIPTION `Config/Needs` * skip eval if suggested package is missing --- DESCRIPTION | 2 + NAMESPACE | 6 ++ NEWS.md | 3 + R/mixOmics.R | 88 +++++++++++++++++++++++++++++ man/axe-pls.Rd | 69 ++++++++++++++++++++++ tests/testthat/test-mixOmics.R | 52 +++++++++++++++++ vignettes/available-axe-methods.Rmd | 3 +- 7 files changed, 222 insertions(+), 1 deletion(-) create mode 100644 R/mixOmics.R create mode 100644 man/axe-pls.Rd create mode 100644 tests/testthat/test-mixOmics.R diff --git a/DESCRIPTION b/DESCRIPTION index e7124a9..5ab71a1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -76,6 +76,8 @@ VignetteBuilder: knitr Config/Needs/website: tidyverse/tidytemplate +Config/Needs/check: + bioc::mixOmics Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.2.3 diff --git a/NAMESPACE b/NAMESPACE index a20f9e4..bf61088 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,8 @@ S3method(axe_call,kknn) S3method(axe_call,ksvm) S3method(axe_call,lm) S3method(axe_call,mda) +S3method(axe_call,mixo_pls) +S3method(axe_call,mixo_spls) S3method(axe_call,ml_model) S3method(axe_call,model_fit) S3method(axe_call,multnet) @@ -57,6 +59,8 @@ S3method(axe_data,gausspr) S3method(axe_data,glm) S3method(axe_data,kproto) S3method(axe_data,ksvm) +S3method(axe_data,mixo_pls) +S3method(axe_data,mixo_spls) S3method(axe_data,ml_model) S3method(axe_data,model_fit) S3method(axe_data,regbagg) @@ -124,6 +128,8 @@ S3method(axe_fitted,kproto) S3method(axe_fitted,ksvm) S3method(axe_fitted,lm) S3method(axe_fitted,mda) +S3method(axe_fitted,mixo_pls) +S3method(axe_fitted,mixo_spls) S3method(axe_fitted,ml_model) S3method(axe_fitted,model_fit) S3method(axe_fitted,nnet) diff --git a/NEWS.md b/NEWS.md index 11bd097..ca83844 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # butcher (development version) +* Added butcher methods for `mixOmics::pls()`, `mixOmics::spls()`, + and `mixOmics::plsda()` (#249). + * Added butcher methods for `klaR::rda()` and `klaR::NaiveBayes()` (#246). * Added butcher methods for `ipred::bagging()` (#245). diff --git a/R/mixOmics.R b/R/mixOmics.R new file mode 100644 index 0000000..e472434 --- /dev/null +++ b/R/mixOmics.R @@ -0,0 +1,88 @@ +#' Axing mixOmics models +#' +#' `mixo_pls` (via `pls()`), `mixo_spls` (via `spls()`), and `mixo_plsda` +#' (via `plsda()`) objects are created with the mixOmics package, +#' leveraged to fit partial least squares models. +#' +#' The mixOmics package is not available on CRAN, but can be installed +#' from the Bioconductor repository via `remotes::install_bioc("mixOmics")`. +#' +#' @inheritParams butcher +#' +#' @return Axed `mixo_pls`, `mixo_spls`, or `mixo_plsda` object. +#' +#' @examplesIf rlang::is_installed("mixOmics") +#' library(butcher) +#' do.call(library, list(package = "mixOmics")) +#' +#' # pls ------------------------------------------------------------------ +#' fit_mod <- function() { +#' boop <- runif(1e6) +#' pls(matrix(rnorm(2e4), ncol = 2), rnorm(1e4), mode = "classic") +#' } +#' +#' mod_fit <- fit_mod() +#' mod_res <- butcher(mod_fit) +#' +#' weigh(mod_fit) +#' weigh(mod_res) +#' +#' new_data <- matrix(1:2, ncol = 2) +#' colnames(new_data) <- c("X1", "X2") +#' predict(mod_fit, new_data) +#' predict(mod_res, new_data) +#' +#' @name axe-pls +#' @aliases axe-mixo_pls +NULL + +#' @rdname axe-pls +#' @export +axe_call.mixo_pls <- function(x, verbose = FALSE, ...) { + old <- x + x <- exchange(x, "call", call("dummy_call")) + + add_butcher_attributes( + x, + old, + verbose = verbose + ) +} + +#' @rdname axe-pls +#' @export +axe_call.mixo_spls <- axe_call.mixo_pls + +#' @rdname axe-pls +#' @export +axe_data.mixo_pls <- function(x, verbose = FALSE, ...) { + old <- x + x <- exchange(x, "input.X", character(0L)) + + add_butcher_attributes( + x, + old, + verbose = verbose + ) +} + +#' @rdname axe-pls +#' @export +axe_data.mixo_spls <- axe_data.mixo_pls + +#' @rdname axe-pls +#' @export +axe_fitted.mixo_pls <- function(x, verbose = FALSE, ...) { + old <- x + x$names <- exchange(x$names, "sample", matrix(NA)) + + add_butcher_attributes( + x, + old, + verbose = verbose + ) +} + +#' @rdname axe-pls +#' @export +axe_fitted.mixo_spls <- axe_fitted.mixo_pls diff --git a/man/axe-pls.Rd b/man/axe-pls.Rd new file mode 100644 index 0000000..a71233e --- /dev/null +++ b/man/axe-pls.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mixOmics.R +\name{axe-pls} +\alias{axe-pls} +\alias{axe-mixo_pls} +\alias{axe_call.mixo_pls} +\alias{axe_call.mixo_spls} +\alias{axe_data.mixo_pls} +\alias{axe_data.mixo_spls} +\alias{axe_fitted.mixo_pls} +\alias{axe_fitted.mixo_spls} +\title{Axing mixOmics models} +\usage{ +\method{axe_call}{mixo_pls}(x, verbose = FALSE, ...) + +\method{axe_call}{mixo_spls}(x, verbose = FALSE, ...) + +\method{axe_data}{mixo_pls}(x, verbose = FALSE, ...) + +\method{axe_data}{mixo_spls}(x, verbose = FALSE, ...) + +\method{axe_fitted}{mixo_pls}(x, verbose = FALSE, ...) + +\method{axe_fitted}{mixo_spls}(x, verbose = FALSE, ...) +} +\arguments{ +\item{x}{A model object.} + +\item{verbose}{Print information each time an axe method is executed. +Notes how much memory is released and what functions are +disabled. Default is \code{FALSE}.} + +\item{...}{Any additional arguments related to axing.} +} +\value{ +Axed `mixo_pls`, `mixo_spls`, or `mixo_plsda` object. +} +\description{ +`mixo_pls` (via `pls()`), `mixo_spls` (via `spls()`), and `mixo_plsda` +(via `plsda()`) objects are created with the mixOmics package, +leveraged to fit partial least squares models. +} +\details{ +The mixOmics package is not available on CRAN, but can be installed +from the Bioconductor repository via `remotes::install_bioc("mixOmics")`. +} +\examples{ +\dontshow{if (rlang::is_installed("mixOmics")) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +library(butcher) +do.call(library, list(package = "mixOmics")) + +# pls ------------------------------------------------------------------ +fit_mod <- function() { + boop <- runif(1e6) + pls(matrix(rnorm(2e4), ncol = 2), rnorm(1e4), mode = "classic") +} + +mod_fit <- fit_mod() +mod_res <- butcher(mod_fit) + +weigh(mod_fit) +weigh(mod_res) + +new_data <- matrix(1:2, ncol = 2) +colnames(new_data) <- c("X1", "X2") +predict(mod_fit, new_data) +predict(mod_res, new_data) +\dontshow{\}) # examplesIf} +} diff --git a/tests/testthat/test-mixOmics.R b/tests/testthat/test-mixOmics.R new file mode 100644 index 0000000..d29cd0a --- /dev/null +++ b/tests/testthat/test-mixOmics.R @@ -0,0 +1,52 @@ +test_that("pls + predict() works", { + skip_on_cran() + skip_if_not_installed("mixOmics") + suppressPackageStartupMessages(do.call(library, list(package = "mixOmics"))) + fit <- pls(matrix(rnorm(2e2), ncol = 2), rnorm(1e2), mode = "classic") + x <- axe_call(fit) + expect_equal(x$call, rlang::expr(dummy_call())) + x <- axe_data(fit) + expect_identical(x$input.X, character(0L)) + x <- axe_fitted(fit) + expect_equal(x$names$sample, matrix(NA)) + x <- butcher(fit) + new_data <- matrix(1:2, ncol = 2) %>% `colnames<-`(c("X1", "X2")) + expect_equal( + predict(x, new_data) %>% purrr::discard_at("call"), + predict(fit, new_data) %>% purrr::discard_at("call") + ) +}) + +test_that("spls + predict() works", { + skip_on_cran() + skip_if_not_installed("mixOmics") + suppressPackageStartupMessages(do.call(library, list(package = "mixOmics"))) + fit <- spls(matrix(rnorm(2e2), ncol = 2), rnorm(1e2)) + x <- axe_call(fit) + expect_equal(x$call, rlang::expr(dummy_call())) + x <- axe_data(fit) + expect_identical(x$input.X, character(0L)) + x <- axe_fitted(fit) + expect_equal(x$names$sample, matrix(NA)) + x <- butcher(fit) + new_data <- matrix(1:2, ncol = 2) %>% `colnames<-`(c("X1", "X2")) + expect_equal(predict(x, new_data) %>% purrr::discard_at("call"), + predict(fit, new_data) %>% purrr::discard_at("call")) +}) + +test_that("plsda + predict() works", { + skip_on_cran() + skip_if_not_installed("mixOmics") + suppressPackageStartupMessages(do.call(library, list(package = "mixOmics"))) + fit <- plsda(matrix(rnorm(2e2), ncol = 2), sample(c("a", "b"), 1e2, replace = TRUE)) + x <- axe_call(fit) + expect_equal(x$call, rlang::expr(dummy_call())) + x <- axe_data(fit) + expect_identical(x$input.X, character(0L)) + x <- axe_fitted(fit) + expect_equal(x$names$sample, matrix(NA)) + x <- butcher(fit) + new_data <- matrix(1:2, ncol = 2) %>% `colnames<-`(c("X1", "X2")) + expect_equal(predict(x, new_data) %>% purrr::discard_at("call"), + predict(fit, new_data) %>% purrr::discard_at("call")) +}) diff --git a/vignettes/available-axe-methods.Rmd b/vignettes/available-axe-methods.Rmd index 297fe95..58032ef 100644 --- a/vignettes/available-axe-methods.Rmd +++ b/vignettes/available-axe-methods.Rmd @@ -11,7 +11,8 @@ vignette: > knitr::opts_chunk$set( collapse = TRUE, comment = "#>", - eval = requireNamespace("dplyr", quietly = TRUE) + eval = requireNamespace("dplyr", quietly = TRUE) & + requireNamespace("clisymbols", quietly = TRUE) ) ```