Use collapse::%!=%

DESCRIPTION

@@ -21,7 +21,7 @@ Imports:
     tibble,
     pillar,
     purrr,
-    collapse (>= 2.0.0),
+    collapse (>= 2.0.9),
     data.table
 URL: https://eutwt.github.io/versus/, https://github.com/eutwt/versus
 BugReports: https://github.com/eutwt/versus/issues

NAMESPACE

@@ -13,6 +13,7 @@ export(weave_diffs_wide)
 import(cli)
 import(dplyr)
 import(rlang)
+importFrom(collapse,"%!=%")
 importFrom(collapse,add_vars)
 importFrom(collapse,frename)
 importFrom(collapse,ss)

R/compare.R

@@ -222,24 +222,6 @@ get_contents <- function(table_a, table_b, by) {
   out
 }
 
-get_diff_rows <- function(col, table_a, table_b, matches, allow_both_NA) {
-  col_a <- fsubset(table_a, matches$common$a, col)[[1]]
-  col_b <- fsubset(table_b, matches$common$b, col)[[1]]
-  matches$common %>%
-    fsubset(not_equal(col_a, col_b, allow_both_NA)) %>%
-    frename(c("row_a", "row_b"))
-}
-
-not_equal <- function(col_a, col_b, allow_both_NA) {
-  neq <- col_a != col_b
-  if (allow_both_NA) {
-    out <- fcoalesce(neq, is.na(col_a) != is.na(col_b))
-  } else {
-    out <- fcoalesce(neq, is.na(col_a) | is.na(col_b))
-  }
-  out
-}
-
 store_tables <- function(table_a, table_b) {
   inform_dt_copy(table_a, table_b)
   env <- new_environment()

R/get-diff-rows.R

@@ -0,0 +1,45 @@
+get_diff_rows <- function(col, table_a, table_b, matches, allow_both_NA) {
+  col_a <- fsubset(table_a, matches$common$a, col)[[1]]
+  col_b <- fsubset(table_b, matches$common$b, col)[[1]]
+  matches$common %>%
+    fsubset(not_equal(col_a, col_b, allow_both_NA)) %>%
+    frename(c("row_a", "row_b"))
+}
+
+not_equal <- function(col_a, col_b, allow_both_NA) {
+  if (allow_both_NA && is_simple_class(col_a, col_b) && !is_empty(col_a)) {
+    return(col_a %!=% col_b)
+  }
+  is_not_equal(col_a, col_b, allow_both_NA)
+}
+
+is_not_equal <- function(col_a, col_b, allow_both_NA) {
+  neq <- col_a != col_b
+  if (allow_both_NA) {
+    out <- fcoalesce(neq, is.na(col_a) != is.na(col_b))
+  } else {
+    out <- fcoalesce(neq, is.na(col_a) | is.na(col_b))
+  }
+  out
+}
+
+is_simple_class <- function(col_a, col_b) {
+  class_a <- class(col_a)
+  if (!identical(class_a, class(col_b))) {
+    return(FALSE)
+  }
+  simple_classes <- list(
+    "logical",
+    "character",
+    "numeric",
+    "Date",
+    "integer",
+    c("POSIXct", "POSIXt")
+  )
+  for (cls in simple_classes) {
+    if (identical(class_a, cls)) {
+      return(TRUE)
+    }
+  }
+  return(FALSE)
+}

R/versus.R

@@ -14,6 +14,6 @@
 #' @importFrom purrr map imap map_int map_lgl map2_lgl map_chr reduce map_if
 #' @importFrom purrr pmap pmap_lgl compose
 #' @importFrom tibble tibble rownames_to_column enframe
-#' @importFrom collapse ss add_vars frename whichNA
+#' @importFrom collapse ss add_vars frename whichNA %!=%
 #' @importFrom data.table fcoalesce copy
 "_PACKAGE"

tests/testthat/test-get-diff-rows.R

@@ -0,0 +1,29 @@
+
+test_that("missing values are handled correctly", {
+  x <- c(NA_real_, 1, 1, NA_real_, 1)
+  y <- c(NA_real_, 1, 2, 1, NA_real_)
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+
+  x <- c(NA_real_, 1, 1, NA_real_, 1) %>% as.Date(origin = '1900-01-01')
+  y <- c(NA_real_, 1, 2, 1, NA_real_)  %>% as.Date(origin = '1900-01-01')
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+
+  x <- c(NA_integer_, 1L, 1L, NA_integer_, 1L)
+  y <- c(NA_integer_, 1L, 2L, 1L, NA_integer_)
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+
+  x <- c(NA, TRUE, TRUE, NA, TRUE)
+  y <- c(NA, TRUE, FALSE, TRUE, NA)
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+
+  x <- c(NA_character_, 'a', 'a', NA_character_, 'a')
+  y <- c(NA_character_, 'a', 'b', 'a', NA_character_)
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+
+  a <- as.POSIXct('1900-01-01', tz = "America/New_York")
+  b <- as.POSIXct('1900-01-01', tz = "UTC")
+  na <- as.POSIXct(NA)
+  x <- c(na, a, a, na, a)
+  y <- c(na, a, b, a, na)
+  expect_identical(not_equal(x, y, TRUE), 3:5)
+})