Merge pull request #71 from r-lib/better-verbose_materialize

Better verbose materialize
r-lib · Sep 12, 2024 · 2b4cba5 · 2b4cba5
2 parents 9c22ca9 + dfbc08c
commit 2b4cba5
Show file tree

Hide file tree

Showing 15 changed files with 208 additions and 34 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: sparsevctrs
 Title: Sparse Vectors for Use in Data Frames
-Version: 0.1.0.9000
+Version: 0.1.0.9001
 Authors@R: c(
     person("Emil", "Hvitfeldt", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-0679-1945")),
@@ -37,4 +37,4 @@ Config/Needs/website: tidyverse/tidytemplate, rmarkdown, lobstr, ggplot2,
 Config/testthat/edition: 3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1.9000
+RoxygenNote: 7.3.2
diff --git a/src/altrep-sparse-double.c b/src/altrep-sparse-double.c
@@ -13,17 +13,14 @@ SEXP ffi_altrep_new_sparse_double(SEXP x) {
 }
 
 SEXP alrep_sparse_double_Materialize(SEXP x) {
-  if (!Rf_isNull(Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"))
-      )) {
-    Rprintf("sparsevctrs: Sparse vector materialized\n");
-  }
-
   SEXP out = R_altrep_data2(x);
 
   if (out != R_NilValue) {
     return out;
   }
 
+  verbose_materialize();
+
   SEXP val = extract_val(x);
   const double* v_val = REAL_RO(val);
 

diff --git a/src/altrep-sparse-integer.c b/src/altrep-sparse-integer.c
@@ -13,17 +13,14 @@ SEXP ffi_altrep_new_sparse_integer(SEXP x) {
 }
 
 SEXP alrep_sparse_integer_Materialize(SEXP x) {
-  if (!Rf_isNull(Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"))
-      )) {
-    Rprintf("sparsevctrs: Sparse vector materialized\n");
-  }
-
   SEXP out = R_altrep_data2(x);
 
   if (out != R_NilValue) {
     return out;
   }
 
+  verbose_materialize();
+
   SEXP val = extract_val(x);
   const int* v_val = INTEGER_RO(val);
 

diff --git a/src/altrep-sparse-logical.c b/src/altrep-sparse-logical.c
@@ -13,17 +13,14 @@ SEXP ffi_altrep_new_sparse_logical(SEXP x) {
 }
 
 SEXP alrep_sparse_logical_Materialize(SEXP x) {
-  if (!Rf_isNull(Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"))
-      )) {
-    Rprintf("sparsevctrs: Sparse vector materialized\n");
-  }
-
   SEXP out = R_altrep_data2(x);
 
   if (out != R_NilValue) {
     return out;
   }
 
+  verbose_materialize();
+
   SEXP val = extract_val(x);
   const int* v_val = LOGICAL_RO(val);
 

diff --git a/src/altrep-sparse-string.c b/src/altrep-sparse-string.c
@@ -13,17 +13,14 @@ SEXP ffi_altrep_new_sparse_string(SEXP x) {
 }
 
 SEXP alrep_sparse_string_Materialize(SEXP x) {
-  if (!Rf_isNull(Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"))
-      )) {
-    Rprintf("sparsevctrs: Sparse vector materialized\n");
-  }
-
   SEXP out = R_altrep_data2(x);
 
   if (out != R_NilValue) {
     return out;
   }
 
+  verbose_materialize();
+
   SEXP val = extract_val(x);
 
   SEXP pos = extract_pos(x);

diff --git a/src/sparse-utils.c b/src/sparse-utils.c
@@ -122,3 +122,31 @@ bool is_index_handleable(SEXP x) {
 
   return true;
 }
+
+void verbose_materialize(void) {
+  SEXP option = Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"));
+
+  if (!Rf_isNull(option)) {
+    if (TYPEOF(option) == LGLSXP) {
+      Rprintf("sparsevctrs: Sparse vector materialized\n");
+    }
+    if (TYPEOF(option) == REALSXP) {
+      if (*REAL_RO(option) == 3) {
+        Rf_error("sparsevctrs: Sparse vector materialized");
+      } else if (*REAL_RO(option) == 2) {
+        Rf_warning("sparsevctrs: Sparse vector materialized");
+      } else {
+        Rprintf("sparsevctrs: Sparse vector materialized\n");
+      }
+    }
+    if (TYPEOF(option) == INTSXP) {
+      if (*INTEGER_RO(option) == 3) {
+        Rf_error("sparsevctrs: Sparse vector materialized");
+      } else if (*INTEGER_RO(option) == 2) {
+        Rf_warning("sparsevctrs: Sparse vector materialized");
+      } else {
+        Rprintf("sparsevctrs: Sparse vector materialized\n");
+      }
+    }
+  }
+}
diff --git a/src/sparse-utils.h b/src/sparse-utils.h
@@ -29,4 +29,6 @@ R_xlen_t binary_search(int needle, const int* v_haystack, R_xlen_t size);
 
 bool is_index_handleable(SEXP x);
 
+void verbose_materialize(void);
+
 #endif
diff --git a/tests/testthat/_snaps/sparse_character.md b/tests/testthat/_snaps/sparse_character.md
@@ -285,10 +285,29 @@
 # verbose testing
 
     Code
-      sparse_character("A", 1, 1)[]
+      tmp <- x[]
     Output
       sparsevctrs: Sparse vector materialized
-      [1] "A"
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Warning:
+      sparsevctrs: Sparse vector materialized
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Error:
+      ! sparsevctrs: Sparse vector materialized
 
 # printing works #48
 

diff --git a/tests/testthat/_snaps/sparse_double.md b/tests/testthat/_snaps/sparse_double.md
@@ -295,10 +295,29 @@
 # verbose testing
 
     Code
-      sparse_double(1, 1, 1)[]
+      tmp <- x[]
     Output
       sparsevctrs: Sparse vector materialized
-      [1] 1
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Warning:
+      sparsevctrs: Sparse vector materialized
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Error:
+      ! sparsevctrs: Sparse vector materialized
 
 # printing works #48
 

diff --git a/tests/testthat/_snaps/sparse_integer.md b/tests/testthat/_snaps/sparse_integer.md
@@ -304,10 +304,29 @@
 # verbose testing
 
     Code
-      sparse_integer(1, 1, 1)[]
+      tmp <- x[]
     Output
       sparsevctrs: Sparse vector materialized
-      [1] 1
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Warning:
+      sparsevctrs: Sparse vector materialized
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Error:
+      ! sparsevctrs: Sparse vector materialized
 
 # printing works #48
 

diff --git a/tests/testthat/_snaps/sparse_logical.md b/tests/testthat/_snaps/sparse_logical.md
@@ -260,8 +260,27 @@
 # verbose testing
 
     Code
-      sparse_logical(TRUE, 1, 1)[]
+      tmp <- x[]
     Output
       sparsevctrs: Sparse vector materialized
-      [1] TRUE
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Warning:
+      sparsevctrs: Sparse vector materialized
+    Code
+      tmp <- x[]
+
+---
+
+    Code
+      tmp <- x[]
+    Condition
+      Error:
+      ! sparsevctrs: Sparse vector materialized
 
diff --git a/tests/testthat/test-sparse_character.R b/tests/testthat/test-sparse_character.R
@@ -268,8 +268,28 @@ test_that("default argument is working", {
 test_that("verbose testing", {
   withr::local_options("sparsevctrs.verbose_materialize" = TRUE)
 
+  x <- sparse_character("A", 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 2)
+
+  x <- sparse_character("A", 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 3)
+
+  x <- sparse_character("A", 1, 1)
   expect_snapshot(
-    sparse_character("A", 1, 1)[]
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
   )
 })
 

diff --git a/tests/testthat/test-sparse_double.R b/tests/testthat/test-sparse_double.R
@@ -446,8 +446,28 @@ test_that("default argument is working", {
 test_that("verbose testing", {
   withr::local_options("sparsevctrs.verbose_materialize" = TRUE)
 
+  x <- sparse_double(1, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 2)
+
+  x <- sparse_double(1, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 3)
+
+  x <- sparse_double(1, 1, 1)
   expect_snapshot(
-    sparse_double(1, 1, 1)[]
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
   )
 })
 

diff --git a/tests/testthat/test-sparse_integer.R b/tests/testthat/test-sparse_integer.R
@@ -452,8 +452,28 @@ test_that("default argument is working", {
 test_that("verbose testing", {
   withr::local_options("sparsevctrs.verbose_materialize" = TRUE)
 
+  x <- sparse_integer(1, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 2)
+
+  x <- sparse_integer(1, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 3)
+
+  x <- sparse_integer(1, 1, 1)
   expect_snapshot(
-    sparse_integer(1, 1, 1)[]
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
   )
 })
 

diff --git a/tests/testthat/test-sparse_logical.R b/tests/testthat/test-sparse_logical.R
@@ -280,8 +280,28 @@ test_that("default argument is working", {
 
 test_that("verbose testing", {
   withr::local_options("sparsevctrs.verbose_materialize" = TRUE)
+
+  x <- sparse_logical(TRUE, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
+
+  withr::local_options("sparsevctrs.verbose_materialize" = 2)
+
+  x <- sparse_logical(TRUE, 1, 1)
+  expect_snapshot({
+    tmp <- x[]
+    tmp <- x[]
+  })
 
+  withr::local_options("sparsevctrs.verbose_materialize" = 3)
+
+  x <- sparse_logical(TRUE, 1, 1)
   expect_snapshot(
-    sparse_logical(TRUE, 1, 1)[]
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
   )
 })