let fit_xy() take dgCMatrix input

DESCRIPTION

@@ -32,6 +32,7 @@ Imports:
     prettyunits,
     purrr (>= 1.0.0),
     rlang (>= 1.1.0),
+    sparsevctrs (>= 0.1.0.9000),
     stats,
     tibble (>= 2.1.1),
     tidyr (>= 1.3.0),
@@ -52,6 +53,7 @@ Suggests:
     LiblineaR,
     MASS,
     Matrix,
+    methods,
     mgcv,
     modeldata,
     nlme,
@@ -78,5 +80,6 @@ Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
 Remotes:  
-    tidymodels/hardhat
+    tidymodels/hardhat,
+    r-lib/sparsevctrs
 RoxygenNote: 7.3.1

R/convert_data.R

@@ -374,12 +374,21 @@ maybe_matrix <- function(x) {
                         "converted to numeric matrix: {non_num_cols}.")
       rlang::abort(msg)
     }
-    x <- as.matrix(x)
+    x <- maybe_sparse_matrix(x)
   }
   # leave alone if matrix or sparse matrix
   x
 }
 
+maybe_sparse_matrix <- function(x) {
+  if (any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))) {
+    res <- sparsevctrs::coerce_to_sparse_matrix(x)
+  } else {
+    res <- as.matrix(x)
+  }
+  res
+}
+
 #' @rdname maybe_matrix
 #' @export
 maybe_data_frame <- function(x) {

R/fit.R

@@ -275,6 +275,8 @@ fit_xy.model_spec <-
       }
     }
 
+    x <- to_sparse_data_frame(x, object)
+
     cl <- match.call(expand.dots = TRUE)
     eval_env <- rlang::env()
     eval_env$x <- x
@@ -387,7 +389,7 @@ inher <- function(x, cls, cl) {
 
 check_interface <- function(formula, data, cl, model) {
   inher(formula, "formula", cl)
-  inher(data, c("data.frame", "tbl_spark"), cl)
+  inher(data, c("data.frame", "dgCMatrix", "tbl_spark"), cl)
 
   # Determine the `fit()` interface
   form_interface <- !is.null(formula) & !is.null(data)

R/sparsevctrs.R

@@ -0,0 +1,14 @@
+to_sparse_data_frame <- function(x, object) {
+  if (methods::is(x, "sparseMatrix")) {
+    if (allow_sparse(object)) {
+      x <- sparsevctrs::coerce_to_sparse_data_frame(x)
+    } else {
+      cli::cli_warn(c(
+        "!" = "{.arg x} is a sparse matrix, but model doesn't accept that.",
+        "i" = "Converted {.arg x} to data.frame."
+      ))
+      x <- as.data.frame(x)
+    }
+  }
+  x
+}

tests/testthat/_snaps/sparsevctrs.md

@@ -0,0 +1,57 @@
+# to_sparse_data_frame() is used correctly
+
+    Code
+      fit_xy(spec, x = mtcars[, -1], y = mtcars[, 1])
+    Condition
+      Error in `to_sparse_data_frame()`:
+      ! x is not sparse
+
+---
+
+    Code
+      fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+    Condition
+      Error in `to_sparse_data_frame()`:
+      ! x is spare, and sparse is not allowed
+
+---
+
+    Code
+      fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+    Condition
+      Error in `to_sparse_data_frame()`:
+      ! x is spare, and sparse is allowed
+
+# maybe_sparse_matrix() is used correctly
+
+    Code
+      fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+    Condition
+      Error in `maybe_sparse_matrix()`:
+      ! sparse vectors detected
+
+---
+
+    Code
+      fit_xy(spec, x = mtcars[, -1], y = mtcars[, 1])
+    Condition
+      Error in `maybe_sparse_matrix()`:
+      ! no sparse vectors detected
+
+---
+
+    Code
+      fit_xy(spec, x = as.data.frame(mtcars)[, -1], y = as.data.frame(mtcars)[, 1])
+    Condition
+      Error in `maybe_sparse_matrix()`:
+      ! no sparse vectors detected
+
+---
+
+    Code
+      fit_xy(spec, x = tibble::as_tibble(mtcars)[, -1], y = tibble::as_tibble(mtcars)[,
+        1])
+    Condition
+      Error in `maybe_sparse_matrix()`:
+      ! no sparse vectors detected
+

tests/testthat/helper-objects.R

@@ -24,3 +24,30 @@ is_tf_ok <- function() {
   }
   res
 }
+
+# ------------------------------------------------------------------------------
+# For sparse tibble testing
+
+sparse_hotel_rates <- function() {
+  # 99.2 sparsity
+  hotel_rates <- modeldata::hotel_rates
+
+  prefix_colnames <- function(x, prefix) {
+    colnames(x) <- paste(colnames(x), prefix, sep = "_")
+    x
+  }
+
+  dummies_country <- hardhat::fct_encode_one_hot(hotel_rates$country)
+  dummies_company <- hardhat::fct_encode_one_hot(hotel_rates$company)
+  dummies_agent <- hardhat::fct_encode_one_hot(hotel_rates$agent)
+
+  res <- dplyr::bind_cols(
+    hotel_rates["avg_price_per_room"],
+    prefix_colnames(dummies_country, "country"),
+    prefix_colnames(dummies_company, "company"),
+    prefix_colnames(dummies_agent, "agent")
+  )
+
+  res <- as.matrix(res)
+  Matrix::Matrix(res, sparse = TRUE)
+}

tests/testthat/test-rand_forest_ranger.R

@@ -475,16 +475,6 @@ test_that('ranger and sparse matrices', {
 
   expect_equal(extract_fit_engine(from_df), extract_fit_engine(from_mat))
   expect_equal(extract_fit_engine(from_df), extract_fit_engine(from_sparse))
-
-  rf_spec <-
-    rand_forest(trees = 10) %>%
-    set_engine("randomForest", seed = 2) %>%
-    set_mode("regression")
-  expect_error(
-    rf_spec %>% fit_xy(mtcar_smat, mtcars$mpg),
-    "Sparse matrices not supported"
-  )
-
 })
 
 

tests/testthat/test-sparsevctrs.R

@@ -0,0 +1,90 @@
+test_that("sparse matrices can be passed to `fit_xy()", {
+  skip_if_not_installed("LiblineaR")
+
+  hotel_data <- sparse_hotel_rates()
+
+  spec <- svm_linear() %>%
+    set_mode("regression") %>%
+    set_engine("LiblineaR")
+
+  expect_no_error(
+    lm_fit <- fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+  )
+})
+
+test_that("to_sparse_data_frame() is used correctly", {
+  skip_if_not_installed("LiblineaR")
+
+  local_mocked_bindings(
+    to_sparse_data_frame = function(x, object) {
+      if (methods::is(x, "sparseMatrix")) {
+        if (allow_sparse(object)) {
+          stop("x is spare, and sparse is allowed")
+        } else {
+          stop("x is spare, and sparse is not allowed")
+        }
+      }
+      stop("x is not sparse")
+    }
+  )
+
+  hotel_data <- sparse_hotel_rates()
+
+  spec <- linear_reg() %>%
+    set_engine("lm")
+
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = mtcars[, -1], y = mtcars[, 1])
+  )
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+  )
+
+  spec <- svm_linear() %>%
+    set_mode("regression") %>%
+    set_engine("LiblineaR")
+
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+  )
+})
+
+test_that("maybe_sparse_matrix() is used correctly", {
+  skip_if_not_installed("LiblineaR")
+
+  local_mocked_bindings(
+    maybe_sparse_matrix = function(x) {
+      if (any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))) {
+        stop("sparse vectors detected")
+      } else {
+        stop("no sparse vectors detected")
+      }
+    }
+  )
+
+  hotel_data <- sparse_hotel_rates()
+
+  spec <- svm_linear() %>%
+    set_mode("regression") %>%
+    set_engine("LiblineaR")
+
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+  )
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = mtcars[, -1], y = mtcars[, 1])
+  )
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = as.data.frame(mtcars)[, -1], y = as.data.frame(mtcars)[, 1])
+  )
+  expect_snapshot(
+    error = TRUE,
+    fit_xy(spec, x = tibble::as_tibble(mtcars)[, -1], y = tibble::as_tibble(mtcars)[, 1])
+  )
+})