Merge pull request #539 from yjunechoe/comparison-preserve-classes

Preserve classes when reading from `validation_set$values`

NEWS.md

@@ -6,6 +6,8 @@
 
 - Fixed a regression in `col_vals_*()` functions, where `vars("col")` was evaluating to the string `"col"`. Behavior of `vars("col")` is now aligned back with `vars(col)` - both evaluate to the column name `col`.
 
+- Warnings/errors arising from comparing `columns` to a `value` of different class (for example, comparing a datetime column to a date value `Sys.Date()` instead of another datetime value `Sys.time()`) are now signalled appropriately at `interrogate()`.
+
 # pointblank 0.12.1
 
 - Ensured that the column string is a symbol before constructing the expression for the `col_vals_*()` functions.

R/interrogate.R

@@ -1436,10 +1436,10 @@ interrogate_set <- function(
       }
 
       extra_variables <- 
-        base::setdiff(table_col_distinct_values, set)
+        table_col_distinct_values[!table_col_distinct_values %in% set]
 
       table_col_distinct_set <-
-        base::intersect(table_col_distinct_values, set)
+        table_col_distinct_values[table_col_distinct_values %in% set]
 
       dplyr::bind_rows(
         dplyr::tibble(set_element = as.character(set)) %>%
@@ -1511,7 +1511,7 @@ interrogate_set <- function(
       }
 
       table_col_distinct_set <-
-        base::intersect(table_col_distinct_values, set)
+        table_col_distinct_values[table_col_distinct_values %in% set]
 
       dplyr::tibble(set_element = as.character(set)) %>%
         dplyr::left_join(

R/utils.R

@@ -165,7 +165,21 @@ get_column_as_sym_at_idx <- function(agent, idx) {
 }
 
 get_values_at_idx <- function(agent, idx) {
-  agent$validation_set[[idx, "values"]] %>% unlist(recursive = FALSE)
+
+  # Get list-column element (`values` is always a length-1 list)
+  values <- agent$validation_set[[idx, "values"]]
+
+  # Expressions (via `col_vals_expr()`) and functions (via `specially()`)
+  # can get the old `unlist()` treatment
+  if (rlang::is_expression(values[[1]]) || rlang::is_function(values[[1]])) {
+    values <- unlist(values, recursive = FALSE)
+  } else {
+    # In other cases (e.g., `values`, `left`, `right`), flatten with subsetting
+    # to preserve class
+    values <- values[[1]]
+  }
+
+  values
 }
 
 get_column_na_pass_at_idx <- function(agent, idx) {

tests/testthat/test-interrogate_simple.R

@@ -2133,3 +2133,25 @@ test_that("vars(col) and vars('col') both evaluate to tbl column", {
   expect_true(test_col_vals_gt(df, x, vars("y")))
 
 })
+
+test_that("class preserved in `value`", {
+
+  # A custom class with a `==` method that simply errors
+  custom_val <- structure(1L, class = "pb-test-custom-class")
+  registerS3method(
+    "==", "pb-test-custom-class", function(x, ...) stop("Bad class for `==`")
+  )
+
+  # We expect error (class preserved) vs. TRUE (class stripped)
+  expect_error(custom_val == 1L)
+  expect_true(unclass(custom_val) == 1L)
+
+  # Error is correctly thrown and safely caught at interrogate
+  expect_no_error({
+    agent <- create_agent(data.frame(col = custom_val)) %>% 
+      col_vals_equal(columns = col, value = 1L) %>% 
+      interrogate()
+  })
+  expect_true(agent$validation_set$eval_error)
+
+})