allow for warnings and errors from verbose_materialize()

r-lib · Sep 12, 2024 · 127adcc · 127adcc
1 parent b3bad53
commit 127adcc
Show file tree

Hide file tree

Showing 9 changed files with 176 additions and 11 deletions.
diff --git a/src/sparse-utils.c b/src/sparse-utils.c
@@ -124,8 +124,29 @@ bool is_index_handleable(SEXP x) {
 }
 
 void verbose_materialize(void) {
-  if (!Rf_isNull(Rf_GetOption1(Rf_install("sparsevctrs.verbose_materialize"))
-      )) {
-    Rprintf("sparsevctrs: Sparse vector materialized\n");
+  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/tests/testthat/_snaps/sparse_character.md b/tests/testthat/_snaps/sparse_character.md
@@ -291,6 +291,24 @@
     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
 
     Code

diff --git a/tests/testthat/_snaps/sparse_double.md b/tests/testthat/_snaps/sparse_double.md
@@ -301,6 +301,24 @@
     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
 
     Code

diff --git a/tests/testthat/_snaps/sparse_integer.md b/tests/testthat/_snaps/sparse_integer.md
@@ -310,6 +310,24 @@
     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
 
     Code

diff --git a/tests/testthat/_snaps/sparse_logical.md b/tests/testthat/_snaps/sparse_logical.md
@@ -266,3 +266,21 @@
     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
@@ -270,9 +270,27 @@ test_that("verbose testing", {
 
   x <- sparse_character("A", 1, 1)
   expect_snapshot({
-   tmp <- x[]
-   tmp <- x[]
+    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(
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
+  )
 })
 
 test_that("printing works #48", {

diff --git a/tests/testthat/test-sparse_double.R b/tests/testthat/test-sparse_double.R
@@ -448,9 +448,27 @@ test_that("verbose testing", {
 
   x <- sparse_double(1, 1, 1)
   expect_snapshot({
-   tmp <- x[]
-   tmp <- x[]
+    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(
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
+  )
 })
 
 test_that("printing works #48", {

diff --git a/tests/testthat/test-sparse_integer.R b/tests/testthat/test-sparse_integer.R
@@ -454,9 +454,27 @@ test_that("verbose testing", {
 
   x <- sparse_integer(1, 1, 1)
   expect_snapshot({
-   tmp <- x[]
-   tmp <- x[]
+    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(
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
+  )
 })
 
 test_that("printing works #48", {

diff --git a/tests/testthat/test-sparse_logical.R b/tests/testthat/test-sparse_logical.R
@@ -283,7 +283,25 @@ test_that("verbose testing", {
 
   x <- sparse_logical(TRUE, 1, 1)
   expect_snapshot({
-   tmp <- x[]
-   tmp <- x[]
+    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(
+    error = TRUE,
+    {
+      tmp <- x[]
+    }
+  )
 })