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

@@ -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

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)

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).

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

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"))
+})

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)
 )
 ```