diff --git a/NAMESPACE b/NAMESPACE index 30154d93..311c0149 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index b0d62e8c..3363a1a6 100644 --- a/NEWS.md +++ b/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()`. diff --git a/R/calendar.R b/R/calendar.R index 2da07ff9..ec33e2a8 100644 --- a/R/calendar.R +++ b/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(...) diff --git a/R/gregorian-year-day.R b/R/gregorian-year-day.R index b38d1688..147f942a 100644 --- a/R/gregorian-year-day.R +++ b/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. diff --git a/R/gregorian-year-month-day.R b/R/gregorian-year-month-day.R index 7838d1a8..23a7ae08 100644 --- a/R/gregorian-year-month-day.R +++ b/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. diff --git a/R/gregorian-year-month-weekday.R b/R/gregorian-year-month-weekday.R index 46765ee6..35df76b6 100644 --- a/R/gregorian-year-month-weekday.R +++ b/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 diff --git a/R/iso-year-week-day.R b/R/iso-year-week-day.R index 1524a8f4..f1a052d7 100644 --- a/R/iso-year-week-day.R +++ b/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 diff --git a/R/quarterly-year-quarter-day.R b/R/quarterly-year-quarter-day.R index 27feb679..a40d8094 100644 --- a/R/quarterly-year-quarter-day.R +++ b/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 diff --git a/R/time-point.R b/R/time-point.R index 095277ff..20c3d18d 100644 --- a/R/time-point.R +++ b/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(...) diff --git a/R/week-year-week-day.R b/R/week-year-week-day.R index 6e4f4c62..dcb977a1 100644 --- a/R/week-year-week-day.R +++ b/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 diff --git a/tests/testthat/_snaps/gregorian-year-day.md b/tests/testthat/_snaps/gregorian-year-day.md index 923406ea..43ebc67f 100644 --- a/tests/testthat/_snaps/gregorian-year-day.md +++ b/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 diff --git a/tests/testthat/_snaps/gregorian-year-month-day.md b/tests/testthat/_snaps/gregorian-year-month-day.md index c6788e27..9232270a 100644 --- a/tests/testthat/_snaps/gregorian-year-month-day.md +++ b/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 diff --git a/tests/testthat/_snaps/gregorian-year-month-weekday.md b/tests/testthat/_snaps/gregorian-year-month-weekday.md index e8e5d0a4..77aa6945 100644 --- a/tests/testthat/_snaps/gregorian-year-month-weekday.md +++ b/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 diff --git a/tests/testthat/_snaps/iso-year-week-day.md b/tests/testthat/_snaps/iso-year-week-day.md index 459739ce..be66c978 100644 --- a/tests/testthat/_snaps/iso-year-week-day.md +++ b/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 diff --git a/tests/testthat/_snaps/quarterly-year-quarter-day.md b/tests/testthat/_snaps/quarterly-year-quarter-day.md index a3f88560..e7b8f3b8 100644 --- a/tests/testthat/_snaps/quarterly-year-quarter-day.md +++ b/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". + diff --git a/tests/testthat/_snaps/week-year-week-day.md b/tests/testthat/_snaps/week-year-week-day.md index 1179fa78..3e74a3f0 100644 --- a/tests/testthat/_snaps/week-year-week-day.md +++ b/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". + diff --git a/tests/testthat/test-gregorian-year-day.R b/tests/testthat/test-gregorian-year-day.R index 10aaf388..97f31be4 100644 --- a/tests/testthat/test-gregorian-year-day.R +++ b/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() diff --git a/tests/testthat/test-gregorian-year-month-day.R b/tests/testthat/test-gregorian-year-month-day.R index 4907d95a..e3cf436b 100644 --- a/tests/testthat/test-gregorian-year-month-day.R +++ b/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() diff --git a/tests/testthat/test-gregorian-year-month-weekday.R b/tests/testthat/test-gregorian-year-month-weekday.R index dc77e9f3..400cf2c9 100644 --- a/tests/testthat/test-gregorian-year-month-weekday.R +++ b/tests/testthat/test-gregorian-year-month-weekday.R @@ -897,6 +897,41 @@ test_that("is.infinite() works", { expect_identical(is.infinite(x), c(FALSE, FALSE)) }) +# ------------------------------------------------------------------------------ +# diff() + +test_that("works with `lag` and `differences`", { + x <- year_month_weekday(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_weekday(integer())), duration_years()) + expect_identical(diff(year_month_weekday(1)), duration_years()) + expect_identical( + diff(year_month_weekday(1:8), lag = 4, differences = 3), + duration_years() + ) +}) + +test_that("errors on invalid precisions", { + expect_snapshot(error = TRUE, { + diff(year_month_weekday(2019, 1, 1, index = 2)) + }) +}) + +test_that("errors on invalid lag/differences", { + # These are base R errors we don't control + expect_error(diff(year_month_weekday(2019), lag = 1:2)) + expect_error(diff(year_month_weekday(2019), differences = 1:2)) +}) + # ------------------------------------------------------------------------------ # clock_minimum() / clock_maximum() diff --git a/tests/testthat/test-iso-year-week-day.R b/tests/testthat/test-iso-year-week-day.R index 0128af7f..980466de 100644 --- a/tests/testthat/test-iso-year-week-day.R +++ b/tests/testthat/test-iso-year-week-day.R @@ -772,6 +772,41 @@ test_that("is.infinite() works", { expect_identical(is.infinite(x), c(FALSE, FALSE)) }) +# ------------------------------------------------------------------------------ +# diff() + +test_that("works with `lag` and `differences`", { + x <- iso_year_week_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(iso_year_week_day(integer())), duration_years()) + expect_identical(diff(iso_year_week_day(1)), duration_years()) + expect_identical( + diff(iso_year_week_day(1:8), lag = 4, differences = 3), + duration_years() + ) +}) + +test_that("errors on invalid precisions", { + expect_snapshot(error = TRUE, { + diff(iso_year_week_day(2019, 1)) + }) +}) + +test_that("errors on invalid lag/differences", { + # These are base R errors we don't control + expect_error(diff(iso_year_week_day(2019), lag = 1:2)) + expect_error(diff(iso_year_week_day(2019), differences = 1:2)) +}) + # ------------------------------------------------------------------------------ # clock_minimum() / clock_maximum() diff --git a/tests/testthat/test-quarterly-year-quarter-day.R b/tests/testthat/test-quarterly-year-quarter-day.R index f82fdca8..345a81b4 100644 --- a/tests/testthat/test-quarterly-year-quarter-day.R +++ b/tests/testthat/test-quarterly-year-quarter-day.R @@ -1004,3 +1004,34 @@ test_that("`start` value is retained", { year_quarter_day(2020, 2, 1, start = 2) ) }) + +# ------------------------------------------------------------------------------ +# diff() + +test_that("works with `lag` and `differences`", { + x <- year_quarter_day(2019, 1:4) + expect_identical(diff(x), rep(duration_quarters(1), 3)) + expect_identical(diff(x, lag = 2), rep(duration_quarters(2), 2)) + expect_identical(diff(x, differences = 2), rep(duration_quarters(0), 2)) +}) + +test_that("works with `lag` and `differences` that force an empty result (#364)", { + expect_identical(diff(year_quarter_day(integer())), duration_years()) + expect_identical(diff(year_quarter_day(1)), duration_years()) + expect_identical( + diff(year_quarter_day(1:8), lag = 4, differences = 3), + duration_years() + ) +}) + +test_that("errors on invalid precisions", { + expect_snapshot(error = TRUE, { + diff(year_quarter_day(2019, 1, 1)) + }) +}) + +test_that("errors on invalid lag/differences", { + # These are base R errors we don't control + expect_error(diff(year_quarter_day(2019), lag = 1:2)) + expect_error(diff(year_quarter_day(2019), differences = 1:2)) +}) diff --git a/tests/testthat/test-time-point.R b/tests/testthat/test-time-point.R index 5b80bf8a..9a669823 100644 --- a/tests/testthat/test-time-point.R +++ b/tests/testthat/test-time-point.R @@ -490,6 +490,39 @@ test_that("unsupported time point addition throws good error", { }) }) +# ------------------------------------------------------------------------------ +# diff() + +test_that("works with `lag` and `differences`", { + x <- naive_seconds(1:8) + expect_identical(diff(x), rep(duration_seconds(1), 7)) + expect_identical(diff(x, lag = 2), rep(duration_seconds(2), 6)) + expect_identical(diff(x, differences = 2), rep(duration_seconds(0), 6)) + expect_identical( + diff(x, lag = 3, differences = 2), + rep(duration_seconds(0), 2) + ) + + x <- sys_seconds(1:8) + expect_identical(diff(x), rep(duration_seconds(1), 7)) + expect_identical(diff(x, lag = 2), rep(duration_seconds(2), 6)) + expect_identical(diff(x, differences = 2), rep(duration_seconds(0), 6)) + expect_identical( + diff(x, lag = 3, differences = 2), + rep(duration_seconds(0), 2) + ) +}) + +test_that("works with `lag` and `differences` that force an empty result (#364)", { + expect_identical(diff(naive_seconds()), duration_seconds()) + expect_identical(diff(naive_seconds(1)), duration_seconds()) + expect_identical(diff(naive_seconds(1:2)), duration_seconds(1)) + expect_identical( + diff(naive_seconds(1:8), lag = 4, differences = 3), + duration_seconds() + ) +}) + # ------------------------------------------------------------------------------ # clock_minimum() / clock_maximum() diff --git a/tests/testthat/test-week-year-week-day.R b/tests/testthat/test-week-year-week-day.R index 6cdbbebb..0769a9b8 100644 --- a/tests/testthat/test-week-year-week-day.R +++ b/tests/testthat/test-week-year-week-day.R @@ -945,3 +945,34 @@ test_that("`start` value is retained", { year_week_day(2024, 1, 1, start = 2) ) }) + +# ------------------------------------------------------------------------------ +# diff() + +test_that("works with `lag` and `differences`", { + x <- year_week_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)) +}) + +test_that("works with `lag` and `differences` that force an empty result (#364)", { + expect_identical(diff(year_week_day(integer())), duration_years()) + expect_identical(diff(year_week_day(1)), duration_years()) + expect_identical( + diff(year_week_day(1:8), lag = 4, differences = 3), + duration_years() + ) +}) + +test_that("errors on invalid precisions", { + expect_snapshot(error = TRUE, { + diff(year_week_day(2019, 1)) + }) +}) + +test_that("errors on invalid lag/differences", { + # These are base R errors we don't control + expect_error(diff(year_week_day(2019), lag = 1:2)) + expect_error(diff(year_week_day(2019), differences = 1:2)) +})