refactor out is_sparse_tibble()

Author: EmilHvitfeldt

R/convert_data.R

@@ -406,7 +406,7 @@ maybe_sparse_matrix <- function(x) {
     return(x)
   }
 
-  if (any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))) {
+  if (is_sparse_tibble(x)) {
     res <- sparsevctrs::coerce_to_sparse_matrix(x)
   } else {
     res <- as.matrix(x)

R/fit.R

@@ -174,8 +174,7 @@ fit.model_spec <-
     eval_env$formula <- formula
     eval_env$weights <- wts
 
-    if ((!allow_sparse(object)) &&
-        any(vapply(data, sparsevctrs::is_sparse_vector, logical(1)))) {
+    if ((!allow_sparse(object)) && is_sparse_tibble(data)) {
       cli::cli_warn(
         "{.arg data} is a sparse tibble, but {.fn {class(object)[1]}} with
         engine {.code {object$engine}} doesn't accept that. Converting to 

R/fit_helpers.R

@@ -131,7 +131,7 @@ form_xy <- function(object, control, env,
   remove_intercept <- encoding_info %>% dplyr::pull(remove_intercept)
   allow_sparse_x <- encoding_info %>% dplyr::pull(allow_sparse_x)
 
-  if (allow_sparse_x && any(vapply(env$data, sparsevctrs::is_sparse_vector, logical(1)))) {
+  if (allow_sparse_x && is_sparse_tibble(env$data)) {
     target <- "dgCMatrix"
   }
 

R/sparsevctrs.R

@@ -8,8 +8,7 @@ to_sparse_data_frame <- function(x, object) {
        engine {.code {object$engine}} doesn't accept that.")
     }
   } else if (is.data.frame(x)) {
-    if ((!allow_sparse(object)) &&
-        any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))) {
+    if ((!allow_sparse(object)) && is_sparse_tibble(x)) {
       cli::cli_warn(
         "{.arg x} is a sparse tibble, but {.fn {class(object)[1]}} with
         engine {.code {object$engine}} doesn't accept that. Converting to 
@@ -22,4 +21,8 @@ to_sparse_data_frame <- function(x, object) {
     }
   }
   x
+}
+
+is_sparse_tibble <- function(x) {
+  any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))
 }

tests/testthat/test-sparsevctrs.R

@@ -112,7 +112,7 @@ test_that("maybe_sparse_matrix() is used correctly", {
 
   local_mocked_bindings(
     maybe_sparse_matrix = function(x) {
-      if (any(vapply(x, sparsevctrs::is_sparse_vector, logical(1)))) {
+      if (is_sparse_tibble(x)) {
         stop("sparse vectors detected")
       } else {
         stop("no sparse vectors detected")