modify extractors functions to work with altrep_sparse vectors

R/altrep.R

@@ -117,3 +117,15 @@ new_sparse_real <- function(value, position, length) {
 
   .Call(ffi_altrep_new_sparse_real, x)
 }
+
+is_sparse_vector <- function(x) {
+  res <- .Call(ffi_extract_altrep_class, x)
+  if (is.null(res)) {
+    return(FALSE)
+  }
+
+  res <- as.character(res[[1]])
+
+  res %in% c("altrep_sparse_real")
+ }
+

R/convert.R

@@ -8,9 +8,9 @@
 #' @seealso [tibble_to_sparse()]
 #'
 #' @examplesIf rlang::is_installed("rsparse")
-#' data("movielens100k", package = "rsparse")
+#' # data("movielens100k", package = "rsparse")
 #'
-#' sparse_to_tibble(movielens100k)
+#' # sparse_to_tibble(movielens100k)
 sparse_to_tibble <- function(x) {
   start <- x@p[seq(1, length(x@p) - 1)] + 1
   end <- x@p[seq(2, length(x@p))]
@@ -43,12 +43,12 @@ sparse_to_tibble <- function(x) {
 #' @seealso [sparse_to_tibble()]
 #'
 #' @examples
-#' mts <- mtcars
-#' mts$new <- new_sparse_vector(c(1, 4, 8), c(8, 1, 20), nrow(mts))
+#' # mts <- mtcars
+#' # mts$new <- new_sparse_vector(c(1, 4, 8), c(8, 1, 20), nrow(mts))
 #'
-#' tibble_to_sparse(mtcars)
+#' # tibble_to_sparse(mtcars)
 #'
-#' tibble_to_sparse(mts)
+#' # tibble_to_sparse(mts)
 tibble_to_sparse <- function(x) {
   any_sparse_vector <- any(
     vapply(x, inherits, "sparse_vector", FUN.VALUE = logical(1))

R/extractors.R

@@ -1,17 +1,15 @@
 .positions <- function(x) {
-  if (inherits(x, "sparse_vector")) {
-    res <- attr(x, "positions")
-  } else {
-    res <- seq_along(x)
+  if (!is_sparse_vector(x)) {
+    return(seq_along(x))
   }
-  res
+
+  .Call(ffi_altrep_sparse_positions, x)
 }
 
 .values <- function(x) {
-  if (inherits(x, "sparse_vector")) {
-    res <- attr(x, "values")
-  } else {
-    res <- x
+  if (!is_sparse_vector(x)) {
+    return(x)
   }
-  res
+
+  .Call(ffi_altrep_sparse_values, x)
 }

src/altrep-sparse-extractors.c

@@ -0,0 +1,14 @@
+#define R_NO_REMAP
+#include <R.h>
+#include <Rinternals.h>
+#include "altrep-sparse-utils.h"
+
+SEXP ffi_altrep_sparse_positions(SEXP x) {
+  SEXP out = extract_pos(x);
+  return out;
+}
+
+SEXP ffi_altrep_sparse_values(SEXP x) {
+  SEXP out = extract_val(x);
+  return out;
+}

src/altrep-sparse-extractors.h

@@ -0,0 +1,10 @@
+#ifndef SPARSEVCTRS_SPARSE_EXTRACTORS_H
+#define SPARSEVCTRS_SPARSE_EXTRACTORS_H
+
+#include <Rinternals.h>
+
+SEXP ffi_altrep_sparse_positions(SEXP x);
+
+SEXP ffi_altrep_sparse_values(SEXP x);
+
+#endif

src/altrep-sparse-utils.c

@@ -22,3 +22,15 @@ R_xlen_t extract_len(SEXP x) {
 
   return out;
 }
+
+int is_altrep(SEXP x) {
+  return ALTREP(x);
+}
+
+SEXP ffi_extract_altrep_class(SEXP x) {
+  if (!is_altrep(x)) {
+    return(R_NilValue);
+  }
+
+  return ATTRIB(ALTREP_CLASS(x));
+}

src/altrep-sparse-utils.h

@@ -9,4 +9,8 @@ SEXP extract_pos(SEXP x);
 
 R_xlen_t extract_len(SEXP x);
 
+SEXP is_altrep(SEXP x);
+
+SEXP ffi_extract_altrep_class(SEXP x);
+
 #endif

src/init.c

@@ -1,11 +1,16 @@
 #include <Rinternals.h>
+#include "altrep-sparse-extractors.h"
+#include "altrep-sparse-utils.h"
 
 // Defined in altrep-sparse-real.c
 extern SEXP ffi_altrep_new_sparse_real(SEXP);
 extern void sparsevctrs_init_altrep_sparse_real(DllInfo*);
 
 static const R_CallMethodDef CallEntries[] = {
     {"ffi_altrep_new_sparse_real", (DL_FUNC) &ffi_altrep_new_sparse_real, 1},
+    {"ffi_altrep_sparse_positions", (DL_FUNC) &ffi_altrep_sparse_positions, 1},
+    {"ffi_altrep_sparse_values", (DL_FUNC) &ffi_altrep_sparse_values, 1},
+    {"ffi_extract_altrep_class", (DL_FUNC) &ffi_extract_altrep_class, 1},
     {NULL, NULL, 0}
 };
 

tests/testthat/test-altrep.R

@@ -185,4 +185,13 @@ test_that("materialization works with new_sparse_real()", {
   x_dense <- c(10, 0, 0, 0, 13, 0, 0, 20, 0, 0)
 
   expect_identical(x_sparse[], x_dense)
+})
+
+
+test_that("is_sparse_vector works", {
+  expect_true(is_sparse_vector(new_sparse_real(1, 1, 1)))
+
+  expect_false(is_sparse_vector(c(1, 1, 1)))
+  expect_false(is_sparse_vector(1:10))
+  expect_false(is_sparse_vector(NULL))
 })

tests/testthat/test-extractors.R

@@ -0,0 +1,47 @@
+test_that(".positions works with altrep_sparse_real", {
+  expect_identical(
+    .positions(new_sparse_real(1, 5, 10)),
+    5L
+  )
+
+  expect_identical(
+    .positions(new_sparse_real(1:3, 5:7, 10)),
+    5:7
+  )
+})
+
+test_that(".positions works with numeric vectors", {
+  expect_identical(
+    .positions(c(1, 6, 4, 2)),
+    seq_len(4)
+  )
+
+  expect_identical(
+    .positions(101:200),
+    1:100
+  )
+})
+
+test_that(".values works with altrep_sparse_real", {
+  expect_identical(
+    .values(new_sparse_real(1, 5, 10)),
+    1
+  )
+
+  expect_identical(
+    .values(new_sparse_real(1:3, 5:7, 10)),
+    c(1, 2, 3)
+  )
+})
+
+test_that(".values works with numeric vectors", {
+  expect_identical(
+    .values(c(1, 6, 4, 2)),
+    c(1, 6, 4, 2)
+  )
+
+  expect_identical(
+    .values(101:200),
+    101:200
+  )
+})