Add custom diff() method for time points and calendars

NAMESPACE

@@ -317,6 +317,13 @@ S3method(date_start,Date)
 S3method(date_start,POSIXt)
 S3method(date_zone,Date)
 S3method(date_zone,POSIXt)
+S3method(diff,clock_iso_year_week_day)
+S3method(diff,clock_time_point)
+S3method(diff,clock_year_day)
+S3method(diff,clock_year_month_day)
+S3method(diff,clock_year_month_weekday)
+S3method(diff,clock_year_quarter_day)
+S3method(diff,clock_year_week_day)
 S3method(format,clock_duration)
 S3method(format,clock_iso_year_week_day)
 S3method(format,clock_time_point)

NEWS.md

@@ -1,5 +1,8 @@
 # clock (development version)
 
+* Added a `diff()` method for time points and calendars to ensure that durations
+  are always returned, even in the empty result case (#364).
+
 # clock 0.7.1
 
 * Removed usage of non-API `STRING_PTR()` in favor of `STRING_PTR_RO()`.

R/calendar.R

@@ -1044,6 +1044,28 @@ calendar_check_minimum_precision <- function(
   cli::cli_abort(message, call = call)
 }
 
+calendar_check_maximum_precision <- function(
+  x,
+  precision,
+  ...,
+  arg = caller_arg(x),
+  call = caller_env()
+) {
+  x_precision <- calendar_precision_attribute(x)
+
+  if (x_precision <= precision) {
+    return(invisible(NULL))
+  }
+
+  message <- c(
+    "Can't perform this operation because of the precision of {.arg {arg}}.",
+    i = "The precision of {.arg {arg}} must be at most {.str {precision_to_string(precision)}}.",
+    i = "{.arg {arg}} has a precision of {.str {precision_to_string(x_precision)}}."
+  )
+
+  cli::cli_abort(message, call = call)
+}
+
 calendar_check_exact_precision <- function(
   x,
   precision,
@@ -1207,6 +1229,21 @@ arith_numeric_and_calendar <- function(op, x, y, ...) {
 
 # ------------------------------------------------------------------------------
 
+# Special support for when `lag * differences >= n`
+#
+# In vctrs, this forces a return value of `vec_slice(x, 0L)`, but this is
+# not correct for calendar types. See also, `diff.Date()` which exists for a
+# similar reason.
+calendar_diff_is_empty <- function(x, lag, differences) {
+  # Same errors as vctrs
+  stopifnot(length(lag) == 1L, lag >= 1L)
+  stopifnot(length(differences) == 1L, differences >= 1L)
+  n <- vec_size(x)
+  lag * differences >= n
+}
+
+# ------------------------------------------------------------------------------
+
 #' @export
 as_year_month_day.clock_calendar <- function(x, ...) {
   check_dots_empty0(...)

R/gregorian-year-day.R

@@ -737,6 +737,18 @@ year_day_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_year_day <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_YEAR)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to year-day
 #'
 #' `as_year_day()` converts a vector to the year-day calendar.

R/gregorian-year-month-day.R

@@ -1030,6 +1030,18 @@ year_month_day_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_year_month_day <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_MONTH)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to year-month-day
 #'
 #' `as_year_month_day()` converts a vector to the year-month-day calendar.

R/gregorian-year-month-weekday.R

@@ -942,6 +942,18 @@ year_month_weekday_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_year_month_weekday <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_MONTH)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to year-month-weekday
 #'
 #' `as_year_month_weekday()` converts a vector to the year-month-weekday

R/iso-year-week-day.R

@@ -796,6 +796,18 @@ iso_year_week_day_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_iso_year_week_day <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_YEAR)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to iso-year-week-day
 #'
 #' `as_iso_year_week_day()` converts a vector to the iso-year-week-day

R/quarterly-year-quarter-day.R

@@ -960,6 +960,18 @@ year_quarter_day_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_year_quarter_day <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_QUARTER)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to year-quarter-day
 #'
 #' @description

R/time-point.R

@@ -533,6 +533,17 @@ add_months.clock_time_point <- function(x, n, ...) {
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_time_point <- function(x, lag = 1L, differences = 1L, ...) {
+  # Special care to ensure that when `lag * differences >= n`, we still
+  # return a duration type rather than `vec_slice(x, 0L)` which vctrs does by
+  # default. It is always valid to diff the duration in place of the time point.
+  x <- as_duration(x)
+  diff(x, lag = lag, differences = differences, ...)
+}
+
+# ------------------------------------------------------------------------------
+
 #' @export
 as_duration.clock_time_point <- function(x, ...) {
   check_dots_empty0(...)

R/week-year-week-day.R

@@ -905,6 +905,18 @@ year_week_day_plus_duration <- function(
 
 # ------------------------------------------------------------------------------
 
+#' @export
+diff.clock_year_week_day <- function(x, lag = 1L, differences = 1L, ...) {
+  calendar_check_maximum_precision(x, PRECISION_YEAR)
+  if (calendar_diff_is_empty(x, lag, differences)) {
+    duration_helper(integer(), calendar_precision_attribute(x))
+  } else {
+    NextMethod()
+  }
+}
+
+# ------------------------------------------------------------------------------
+
 #' Convert to year-week-day
 #'
 #' `as_year_week_day()` converts a vector to the year-week-day

tests/testthat/_snaps/gregorian-year-day.md

@@ -474,6 +474,16 @@
       ! Invalid date found at location 1.
       i Resolve invalid date issues by specifying the `invalid` argument.
 
+# errors on invalid precisions
+
+    Code
+      diff(year_day(2019, 1))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "year".
+      i `x` has a precision of "day".
+
 # minimums are right
 
     Code

tests/testthat/_snaps/gregorian-year-month-day.md

@@ -612,6 +612,16 @@
       ! Invalid date found at location 1.
       i Resolve invalid date issues by specifying the `invalid` argument.
 
+# errors on invalid precisions
+
+    Code
+      diff(year_month_day(2019, 1, 2))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "month".
+      i `x` has a precision of "day".
+
 # minimums are right
 
     Code

tests/testthat/_snaps/gregorian-year-month-weekday.md

@@ -574,6 +574,16 @@
       ! Invalid date found at location 1.
       i Resolve invalid date issues by specifying the `invalid` argument.
 
+# errors on invalid precisions
+
+    Code
+      diff(year_month_weekday(2019, 1, 1, index = 2))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "month".
+      i `x` has a precision of "day".
+
 # minimums are right
 
     Code

tests/testthat/_snaps/iso-year-week-day.md

@@ -486,6 +486,16 @@
       ! Invalid date found at location 1.
       i Resolve invalid date issues by specifying the `invalid` argument.
 
+# errors on invalid precisions
+
+    Code
+      diff(iso_year_week_day(2019, 1))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "year".
+      i `x` has a precision of "week".
+
 # minimums are right
 
     Code

tests/testthat/_snaps/quarterly-year-quarter-day.md

@@ -613,3 +613,13 @@
       Error in `add_years()`:
       ! Can't recycle `x` (size 2) to match `n` (size 3).
 
+# errors on invalid precisions
+
+    Code
+      diff(year_quarter_day(2019, 1, 1))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "quarter".
+      i `x` has a precision of "day".
+

tests/testthat/_snaps/week-year-week-day.md

@@ -609,3 +609,13 @@
       Error in `add_years()`:
       ! Can't recycle `x` (size 2) to match `n` (size 3).
 
+# errors on invalid precisions
+
+    Code
+      diff(year_week_day(2019, 1))
+    Condition
+      Error in `diff()`:
+      ! Can't perform this operation because of the precision of `x`.
+      i The precision of `x` must be at most "year".
+      i `x` has a precision of "week".
+

tests/testthat/test-gregorian-year-day.R

@@ -770,6 +770,41 @@ test_that("is.infinite() works", {
   expect_identical(is.infinite(x), c(FALSE, FALSE))
 })
 
+# ------------------------------------------------------------------------------
+# diff()
+
+test_that("works with `lag` and `differences`", {
+  x <- year_day(2019:2026)
+  expect_identical(diff(x), rep(duration_years(1), 7))
+  expect_identical(diff(x, lag = 2), rep(duration_years(2), 6))
+  expect_identical(diff(x, differences = 2), rep(duration_years(0), 6))
+  expect_identical(
+    diff(x, lag = 3, differences = 2),
+    rep(duration_years(0), 2)
+  )
+})
+
+test_that("works with `lag` and `differences` that force an empty result (#364)", {
+  expect_identical(diff(year_day(integer())), duration_years())
+  expect_identical(diff(year_day(1)), duration_years())
+  expect_identical(
+    diff(year_day(1:8), lag = 4, differences = 3),
+    duration_years()
+  )
+})
+
+test_that("errors on invalid precisions", {
+  expect_snapshot(error = TRUE, {
+    diff(year_day(2019, 1))
+  })
+})
+
+test_that("errors on invalid lag/differences", {
+  # These are base R errors we don't control
+  expect_error(diff(year_day(2019), lag = 1:2))
+  expect_error(diff(year_day(2019), differences = 1:2))
+})
+
 # ------------------------------------------------------------------------------
 # clock_minimum() / clock_maximum()
 

tests/testthat/test-gregorian-year-month-day.R

@@ -1180,6 +1180,49 @@ test_that("is.infinite() works", {
   expect_identical(is.infinite(x), c(FALSE, FALSE))
 })
 
+# ------------------------------------------------------------------------------
+# diff()
+
+test_that("works with `lag` and `differences`", {
+  x <- year_month_day(2019, 1:8)
+  expect_identical(diff(x), rep(duration_months(1), 7))
+  expect_identical(diff(x, lag = 2), rep(duration_months(2), 6))
+  expect_identical(diff(x, differences = 2), rep(duration_months(0), 6))
+  expect_identical(
+    diff(x, lag = 3, differences = 2),
+    rep(duration_months(0), 2)
+  )
+})
+
+test_that("works with `lag` and `differences` that force an empty result (#364)", {
+  expect_identical(diff(year_month_day(integer())), duration_years())
+  expect_identical(diff(year_month_day(integer(), integer())), duration_months())
+
+  expect_identical(diff(year_month_day(1)), duration_years())
+  expect_identical(diff(year_month_day(1, 1)), duration_months())
+
+  expect_identical(
+    diff(year_month_day(1:8), lag = 4, differences = 3),
+    duration_years()
+  )
+  expect_identical(
+    diff(year_month_day(1:8, 1), lag = 4, differences = 3),
+    duration_months()
+  )
+})
+
+test_that("errors on invalid precisions", {
+  expect_snapshot(error = TRUE, {
+    diff(year_month_day(2019, 1, 2))
+  })
+})
+
+test_that("errors on invalid lag/differences", {
+  # These are base R errors we don't control
+  expect_error(diff(year_month_day(2019, 1), lag = 1:2))
+  expect_error(diff(year_month_day(2019, 1), differences = 1:2))
+})
+
 # ------------------------------------------------------------------------------
 # clock_minimum() / clock_maximum()