Faster is_sparse_vector()

NEWS.md

@@ -8,6 +8,8 @@
 
 * Helper function `has_sparse_elements()` has been added (#70)
 
+* `is_sparse_vector()` has been rewritten for speed improvement. (#76)
+
 # sparsevctrs 0.1.0
 
 * Initial CRAN submission.

R/type-predicates.R

@@ -34,21 +34,7 @@ NULL
 #' @rdname type-predicates
 #' @export
 is_sparse_vector <- function(x) {
-  res <- .Call(ffi_extract_altrep_class, x)
-  if (is.null(res)) {
-    return(FALSE)
-  }
-
-  res <- as.character(res[[1]])
-
-  valid <- c(
-    "altrep_sparse_double", 
-    "altrep_sparse_integer", 
-    "altrep_sparse_string",
-    "altrep_sparse_logical"
-  )
-
-  res %in% valid
+  .Call(ffi_is_sparse_vector, x)
 }
 
 #' @rdname type-predicates

src/init.c

@@ -35,6 +35,7 @@ static const R_CallMethodDef CallEntries[] = {
     {"ffi_altrep_sparse_values", (DL_FUNC) &ffi_altrep_sparse_values, 1},
     {"ffi_altrep_sparse_default", (DL_FUNC) &ffi_altrep_sparse_default, 1},
     {"ffi_extract_altrep_class", (DL_FUNC) &ffi_extract_altrep_class, 1},
+    {"ffi_is_sparse_vector", (DL_FUNC) &ffi_is_sparse_vector, 1},
     {NULL, NULL, 0}};
 
 void R_init_sparsevctrs(DllInfo* dll) {

src/sparse-utils.c

@@ -68,6 +68,18 @@ SEXP ffi_extract_altrep_class(SEXP x) {
   return ATTRIB(ALTREP_CLASS(x));
 }
 
+static inline SEXP altrep_package(SEXP x) {
+  return VECTOR_ELT(Rf_PairToVectorList(ATTRIB(ALTREP_CLASS(x))), 1);
+}
+
+SEXP ffi_is_sparse_vector(SEXP x) {
+  if (!is_altrep(x)) {
+    return (Rf_ScalarLogical(FALSE));
+  }
+
+  return Rf_ScalarLogical(altrep_package(x) == Rf_install("sparsevctrs"));
+}
+
 static inline R_xlen_t midpoint(R_xlen_t lhs, R_xlen_t rhs) {
   return lhs + (rhs - lhs) / 2;
 }

src/sparse-utils.h

@@ -25,6 +25,8 @@ bool is_altrep(SEXP x);
 
 SEXP ffi_extract_altrep_class(SEXP x);
 
+SEXP ffi_is_sparse_vector(SEXP x);
+
 R_xlen_t binary_search(int needle, const int* v_haystack, R_xlen_t size);
 
 bool is_index_handleable(SEXP x);