Merge pull request #1121 from tidymodels/sparse-input

let `fit_xy()` take dgCMatrix input

Author: EmilHvitfeldt

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,
@@ -77,4 +79,6 @@ Config/testthat/edition: 3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
+Remotes:  
+    r-lib/sparsevctrs
 RoxygenNote: 7.3.2

NEWS.md

@@ -1,5 +1,7 @@
 # parsnip (development version)
 
+* `fit_xy()` can now take dgCMatrix input for `x` argument (#1121).
+
 * Transitioned package errors and warnings to use cli (#1147 and #1148 by
   @shum461, #1153 by @RobLBaker and @wright13, #1154 by @JamesHWade, #1160, 
   #1161).

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

@@ -55,6 +55,11 @@
 #' a "reverse Kaplan-Meier" curve that models the probability of censoring. This
 #' may be used later to compute inverse probability censoring weights for
 #' performance measures.
+#' 
+#' Sparse data is supported, with the use of the `x` argument in `fit_xy()`. See
+#' `allow_sparse_x` column of [parsnip::get_encoding()] for sparse input 
+#' compatibility.
+#' 
 #' @examplesIf !parsnip:::is_cran_check()
 #' # Although `glm()` only has a formula interface, different
 #' # methods for specifying the model can be used
@@ -274,6 +279,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
@@ -380,7 +387,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,12 @@
+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_abort(
+      "{.arg x} is a sparse matrix, but {.fn {class(object)[1]}} with
+       engine {.code {object$engine}} doesn't accept that.")
+    }
+  }
+  x
+}

man/fit.Rd

@@ -0,0 +1,65 @@
+# sparse matrices can be passed to `fit_xy()
+
+    Code
+      lm_fit <- fit_xy(spec, x = hotel_data[1:100, -1], y = hotel_data[1:100, 1])
+    Condition
+      Error in `to_sparse_data_frame()`:
+      ! `x` is a sparse matrix, but `linear_reg()` with engine `lm` doesn't accept that.
+
+# 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/_snaps/sparsevctrs.md

@@ -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/helper-objects.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-rand_forest_ranger.R

@@ -0,0 +1,99 @@
+test_that("sparse matrices can be passed to `fit_xy()", {
+  skip_if_not_installed("xgboost")
+
+  hotel_data <- sparse_hotel_rates()
+
+  spec <- boost_tree() %>%
+    set_mode("regression") %>%
+    set_engine("xgboost")
+
+  expect_no_error(
+    lm_fit <- fit_xy(spec, x = hotel_data[, -1], y = hotel_data[, 1])
+  )
+
+  spec <- linear_reg() %>%
+    set_mode("regression") %>%
+    set_engine("lm")
+
+  expect_snapshot(
+    lm_fit <- fit_xy(spec, x = hotel_data[1:100, -1], y = hotel_data[1:100, 1]),
+    error = TRUE
+  )
+})
+
+test_that("to_sparse_data_frame() is used correctly", {
+  skip_if_not_installed("xgboost")
+  
+  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 <- boost_tree() %>%
+    set_mode("regression") %>%
+    set_engine("xgboost")
+
+  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("xgboost")
+  
+  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 <- boost_tree() %>%
+    set_mode("regression") %>%
+    set_engine("xgboost")
+
+  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])
+  )
+})