in comparisons, print difference also for dates and times

Author: stibu81

R/expect-comparison.R

@@ -82,7 +82,22 @@ failure_compare <- function(act, exp, operator) {
       actual_op,
       exp$val
     )
-    msg_diff <- NULL
+
+    if (inherits(act$val, c("Date", "POSIXt"))) {
+      diff <- act$val - exp$val
+      if (is.na(diff)) {
+        msg_diff <- NULL
+      } else {
+        msg_diff <- sprintf(
+          "Difference: %s %s 0 %s",
+          dt_diff(diff),
+          actual_op,
+          attr(diff, "unit")
+        )
+      }
+    } else {
+      msg_diff <- NULL
+    }
   }
 
   c(msg_exp, msg_act, msg_diff)
@@ -186,3 +201,9 @@ digits <- function(x) {
     ceiling(round(scale, digits = 2))
   }
 }
+
+dt_diff <- function(x) {
+  val <- unclass(x)
+  digits <- digits(abs(val)) + 1
+  paste(num_exact(val, digits), attr(x, "unit"))
+}

tests/testthat/_snaps/expect-comparison.md

@@ -83,107 +83,28 @@
     Condition
       Error:
       ! Expected `time2` < `time`.
-      Actual comparison: "2020-01-01 01:00:01" >= "2020-01-01 01:00:00"
-
----
-
-    Code
-      expect_lte(time2, time)
-    Condition
-      Error:
-      ! Expected `time2` <= `time`.
-      Actual comparison: "2020-01-01 01:00:01" > "2020-01-01 01:00:00"
-
----
-
-    Code
-      expect_gt(time, time2)
-    Condition
-      Error:
-      ! Expected `time` > `time2`.
-      Actual comparison: "2020-01-01 01:00:00" <= "2020-01-01 01:00:01"
-
----
-
-    Code
-      expect_gte(time, time2)
-    Condition
-      Error:
-      ! Expected `time` >= `time2`.
-      Actual comparison: "2020-01-01 01:00:00" < "2020-01-01 01:00:01"
+      Actual comparison: "2020-01-01 01:00:01.5" >= "2020-01-01 01:00:00"
+      Difference: 1.5 secs >= 0 secs
 
 # comparisons with Date objects work
 
-    Code
-      expect_lt(date2, date)
-    Condition
-      Error:
-      ! Expected `date2` < `date`.
-      Actual comparison: "2020-01-02" >= "2020-01-01"
-
----
-
-    Code
-      expect_lte(date2, date)
-    Condition
-      Error:
-      ! Expected `date2` <= `date`.
-      Actual comparison: "2020-01-02" > "2020-01-01"
-
----
-
     Code
       expect_gt(date, date2)
     Condition
       Error:
       ! Expected `date` > `date2`.
       Actual comparison: "2020-01-01" <= "2020-01-02"
-
----
-
-    Code
-      expect_gte(date, date2)
-    Condition
-      Error:
-      ! Expected `date` >= `date2`.
-      Actual comparison: "2020-01-01" < "2020-01-02"
+      Difference: -1.0 days <= 0 days
 
 # comparisons with character objects work
 
-    Code
-      expect_lt("b", "a")
-    Condition
-      Error:
-      ! Expected "b" < "a".
-      Actual comparison: "b" >= "a"
-
----
-
     Code
       expect_lte("b", "a")
     Condition
       Error:
       ! Expected "b" <= "a".
       Actual comparison: "b" > "a"
 
----
-
-    Code
-      expect_gt("a", "b")
-    Condition
-      Error:
-      ! Expected "a" > "b".
-      Actual comparison: "a" <= "b"
-
----
-
-    Code
-      expect_gte("a", "b")
-    Condition
-      Error:
-      ! Expected "a" >= "b".
-      Actual comparison: "a" < "b"
-
 # comparison must yield a single logical
 
     Code

tests/testthat/test-expect-comparison.R

@@ -60,42 +60,25 @@ test_that("comparisons with NA work", {
 
 test_that("comparisons with POSIXct objects work", {
   time <- as.POSIXct("2020-01-01 01:00:00")
-  time2 <- time + 1
+  time2 <- time + 1.5
   expect_success(expect_lt(time, time2))
-  expect_success(expect_lte(time, time2))
-  expect_success(expect_gt(time2, time))
-  expect_success(expect_gte(time2, time))
 
   expect_snapshot_failure(expect_lt(time2, time))
-  expect_snapshot_failure(expect_lte(time2, time))
-  expect_snapshot_failure(expect_gt(time, time2))
-  expect_snapshot_failure(expect_gte(time, time2))
 })
 
 test_that("comparisons with Date objects work", {
   date <- as.Date("2020-01-01")
   date2 <- date + 1
-  expect_success(expect_lt(date, date2))
-  expect_success(expect_lte(date, date2))
   expect_success(expect_gt(date2, date))
   expect_success(expect_gte(date2, date))
 
-  expect_snapshot_failure(expect_lt(date2, date))
-  expect_snapshot_failure(expect_lte(date2, date))
   expect_snapshot_failure(expect_gt(date, date2))
-  expect_snapshot_failure(expect_gte(date, date2))
 })
 
 test_that("comparisons with character objects work", {
-  expect_success(expect_lt("a", "b"))
   expect_success(expect_lte("a", "b"))
-  expect_success(expect_gt("b", "a"))
-  expect_success(expect_gte("b", "a"))
 
-  expect_snapshot_failure(expect_lt("b", "a"))
   expect_snapshot_failure(expect_lte("b", "a"))
-  expect_snapshot_failure(expect_gt("a", "b"))
-  expect_snapshot_failure(expect_gte("a", "b"))
 })
 
 test_that("comparison must yield a single logical", {