Nothing
#' @export
as_sys_time.Date <- function(x, ...) {
check_dots_empty0(...)
names <- names(x)
x <- unstructure(x)
if (is.double(x)) {
x <- floor(x)
}
x <- duration_days(x)
new_sys_time_from_fields(x, PRECISION_DAY, names)
}
#' @export
as_naive_time.Date <- function(x, ...) {
check_dots_empty0(...)
as_naive_time(as_sys_time(x))
}
#' Convert to a zoned-time from a date
#'
#' @description
#' This is a Date method for the [as_zoned_time()] generic.
#'
#' clock assumes that Dates are _naive_ date-time types. Like naive-times, they
#' have a yet-to-be-specified time zone. This method allows you to specify that
#' time zone, keeping the printed time. If possible, the time will be set to
#' midnight (see Details for the rare case in which this is not possible).
#'
#' @details
#' In the rare instance that the specified time zone does not contain a
#' date-time at midnight due to daylight saving time, `nonexistent` can be used
#' to resolve the issue. Similarly, if there are two possible midnight times due
#' to a daylight saving time fallback, `ambiguous` can be used.
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams as-zoned-time-naive-time
#'
#' @param x `[Date]`
#'
#' A Date.
#'
#' @return A zoned-time.
#'
#' @name as-zoned-time-Date
#' @export
#' @examples
#' x <- as.Date("2019-01-01")
#'
#' # The resulting zoned-times have the same printed time, but are in
#' # different time zones
#' as_zoned_time(x, "UTC")
#' as_zoned_time(x, "America/New_York")
#'
#' # Converting Date -> zoned-time is the same as naive-time -> zoned-time
#' x <- as_naive_time(year_month_day(2019, 1, 1))
#' as_zoned_time(x, "America/New_York")
#'
#' # In Asia/Beirut, there was a DST gap from
#' # 2021-03-27 23:59:59 -> 2021-03-28 01:00:00,
#' # skipping the 0th hour entirely. This means there is no midnight value.
#' x <- as.Date("2021-03-28")
#' try(as_zoned_time(x, "Asia/Beirut"))
#'
#' # To resolve this, set a `nonexistent` time resolution strategy
#' as_zoned_time(x, "Asia/Beirut", nonexistent = "roll-forward")
as_zoned_time.Date <- function(x,
zone,
...,
nonexistent = NULL,
ambiguous = NULL) {
check_dots_empty0(...)
x <- as_naive_time(x)
as_zoned_time(x, zone = zone, nonexistent = nonexistent, ambiguous = ambiguous)
}
#' @export
as_year_month_day.Date <- function(x, ...) {
check_dots_empty0(...)
as_year_month_day(as_naive_time(x))
}
#' @export
as_year_month_weekday.Date <- function(x, ...) {
check_dots_empty0(...)
as_year_month_weekday(as_naive_time(x))
}
#' @export
as_year_quarter_day.Date <- function(x, ..., start = NULL) {
check_dots_empty0(...)
as_year_quarter_day(as_naive_time(x), start = start)
}
#' @export
as_year_week_day.Date <- function(x, ..., start = NULL) {
check_dots_empty0(...)
as_year_week_day(as_naive_time(x), start = start)
}
#' @export
as_iso_year_week_day.Date <- function(x, ...) {
check_dots_empty0(...)
as_iso_year_week_day(as_naive_time(x))
}
#' @export
as_year_day.Date <- function(x, ...) {
check_dots_empty0(...)
as_year_day(as_naive_time(x))
}
#' @export
as_weekday.Date <- function(x, ...) {
check_dots_empty0(...)
as_weekday(as_naive_time(x))
}
# ------------------------------------------------------------------------------
# Not using `check_dots_empty()` because that might
# be too aggressive with base generics
#' @export
as.Date.clock_calendar <- function(x, ...) {
as.Date(as_naive_time(x))
}
#' @export
as.Date.clock_time_point <- function(x, ...) {
names <- clock_rcrd_names(x)
x <- time_point_floor(x, "day")
x <- as_duration(x)
x <- as.double(x)
names(x) <- names
new_date(x)
}
#' @export
as.Date.clock_zoned_time <- function(x, ...) {
as.Date(as_naive_time(x))
}
# ------------------------------------------------------------------------------
#' Convert to a date
#'
#' @description
#' `as_date()` is a generic function that converts its input to a date (Date).
#'
#' There are methods for converting date-times (POSIXct), calendars,
#' time points, and zoned-times to dates.
#'
#' For converting to a date-time, see [as_date_time()].
#'
#' @details
#' Note that clock always assumes that R's Date class is naive, so converting
#' a POSIXct to a Date will always retain the printed year, month, and day
#' value.
#'
#' This is not a drop-in replacement for `as.Date()`, as it only converts a
#' limited set of types to Date. For parsing characters as dates, see
#' [date_parse()]. For converting numerics to dates, see [vctrs::new_date()] or
#' continue to use `as.Date()`.
#'
#' @inheritParams rlang::args_dots_empty
#'
#' @param x `[vector]`
#'
#' A vector.
#'
#' @return A date with the same length as `x`.
#'
#' @export
#' @examples
#' x <- date_time_parse("2019-01-01 23:02:03", "America/New_York")
#'
#' # R's `as.Date.POSIXct()` method defaults to changing the printed time
#' # to UTC before converting, which can result in odd conversions like this:
#' as.Date(x)
#'
#' # `as_date()` will never change the printed time before converting
#' as_date(x)
#'
#' # Can also convert from other clock types
#' as_date(year_month_day(2019, 2, 5))
as_date <- function(x, ...) {
UseMethod("as_date")
}
#' @rdname as_date
#' @export
as_date.Date <- function(x, ...) {
check_dots_empty0(...)
date_standardize(x)
}
#' @rdname as_date
#' @export
as_date.POSIXt <- function(x, ...) {
check_dots_empty0(...)
as.Date(as_naive_time(x))
}
#' @rdname as_date
#' @export
as_date.clock_calendar <- function(x, ...) {
check_dots_empty0(...)
as.Date(x)
}
#' @rdname as_date
#' @export
as_date.clock_time_point <- function(x, ...) {
check_dots_empty0(...)
as.Date(x)
}
#' @rdname as_date
#' @export
as_date.clock_zoned_time <- function(x, ...) {
check_dots_empty0(...)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Getters: date
#'
#' @description
#' These are Date methods for the [getter generics][clock-getters].
#'
#' - `get_year()` returns the Gregorian year.
#'
#' - `get_month()` returns the month of the year.
#'
#' - `get_day()` returns the day of the month.
#'
#' For more advanced component extraction, convert to the calendar type
#' that you are interested in.
#'
#' @param x `[Date]`
#'
#' A Date to get the component from.
#'
#' @return The component.
#'
#' @name Date-getters
#' @examples
#' x <- as.Date("2019-01-01") + 0:5
#' get_day(x)
NULL
#' @rdname Date-getters
#' @export
get_year.Date <- function(x) {
get_date_field_year_month_day(x, get_year)
}
#' @rdname Date-getters
#' @export
get_month.Date <- function(x) {
get_date_field_year_month_day(x, get_month)
}
#' @rdname Date-getters
#' @export
get_day.Date <- function(x) {
get_date_field_year_month_day(x, get_day)
}
get_date_field_year_month_day <- function(x, get_fn) {
x <- as_year_month_day(x)
get_fn(x)
}
# ------------------------------------------------------------------------------
#' Setters: date
#'
#' @description
#' These are Date methods for the [setter generics][clock-setters].
#'
#' - `set_year()` sets the year.
#'
#' - `set_month()` sets the month of the year. Valid values are in the range
#' of `[1, 12]`.
#'
#' - `set_day()` sets the day of the month. Valid values are in the range
#' of `[1, 31]`.
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams invalid_resolve
#'
#' @param x `[Date]`
#'
#' A Date vector.
#'
#' @param value `[integer / "last"]`
#'
#' The value to set the component to.
#'
#' For `set_day()`, this can also be `"last"` to set the day to the
#' last day of the month.
#'
#' @return `x` with the component set.
#'
#' @name Date-setters
#' @examples
#' x <- as.Date("2019-02-01")
#'
#' # Set the day
#' set_day(x, 12:14)
#'
#' # Set to the "last" day of the month
#' set_day(x, "last")
#'
#' # You cannot set a Date to an invalid day like you can with
#' # a year-month-day. Instead, the default strategy is to error.
#' try(set_day(x, 31))
#' set_day(as_year_month_day(x), 31)
#'
#' # You can resolve these issues while setting the day by specifying
#' # an invalid date resolution strategy with `invalid`
#' set_day(x, 31, invalid = "previous")
NULL
#' @rdname Date-setters
#' @export
set_year.Date <- function(x, value, ..., invalid = NULL) {
check_dots_empty0(...)
set_date_field_year_month_day(x, value, invalid, set_year)
}
#' @rdname Date-setters
#' @export
set_month.Date <- function(x, value, ..., invalid = NULL) {
check_dots_empty0(...)
set_date_field_year_month_day(x, value, invalid, set_month)
}
#' @rdname Date-setters
#' @export
set_day.Date <- function(x, value, ..., invalid = NULL) {
check_dots_empty0(...)
set_date_field_year_month_day(x, value, invalid, set_day)
}
set_date_field_year_month_day <- function(x, value, invalid, set_fn) {
x <- as_year_month_day(x)
x <- set_fn(x, value)
x <- invalid_resolve(x, invalid = invalid)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' @method vec_arith.Date clock_duration
#' @export
vec_arith.Date.clock_duration <- function(op, x, y, ...) {
arith_date_and_duration(op, x, y, ...)
}
#' @method vec_arith.clock_duration Date
#' @export
vec_arith.clock_duration.Date <- function(op, x, y, ...) {
arith_duration_and_date(op, x, y, ...)
}
arith_date_and_duration <- function(op, x, y, ...) {
switch(
op,
"+" = add_duration(x, y),
"-" = add_duration(x, -y),
stop_incompatible_op(op, x, y, ...)
)
}
arith_duration_and_date <- function(op, x, y, ...) {
switch(
op,
"+" = add_duration(y, x, swapped = TRUE),
"-" = stop_incompatible_op(op, x, y, details = "Can't subtract a Date from a duration.", ...),
stop_incompatible_op(op, x, y, ...)
)
}
# ------------------------------------------------------------------------------
# @export - .onLoad()
slider_plus.Date.clock_duration <- function(x, y) {
vec_arith("+", x, y)
}
# @export - .onLoad()
slider_minus.Date.clock_duration <- function(x, y) {
vec_arith("-", x, y)
}
# ------------------------------------------------------------------------------
#' Arithmetic: date
#'
#' @description
#' These are Date methods for the
#' [arithmetic generics][clock-arithmetic].
#'
#' Calendrical based arithmetic:
#'
#' These functions convert to a year-month-day calendar, perform
#' the arithmetic, then convert back to a Date.
#'
#' - `add_years()`
#'
#' - `add_quarters()`
#'
#' - `add_months()`
#'
#' Time point based arithmetic:
#'
#' These functions convert to a time point, perform the arithmetic, then
#' convert back to a Date.
#'
#' - `add_weeks()`
#'
#' - `add_days()`
#'
#' @details
#' Adding a single quarter with `add_quarters()` is equivalent to adding
#' 3 months.
#'
#' `x` and `n` are recycled against each other using
#' [tidyverse recycling rules][vctrs::vector_recycling_rules].
#'
#' Only calendrical based arithmetic has the potential to generate invalid
#' dates. Time point based arithmetic, like adding days, will always generate
#' a valid date.
#'
#' @inheritParams clock-arithmetic
#' @inheritParams invalid_resolve
#'
#' @param x `[Date]`
#'
#' A Date vector.
#'
#' @return `x` after performing the arithmetic.
#'
#' @name Date-arithmetic
#'
#' @examples
#' x <- as.Date("2019-01-01")
#'
#' add_years(x, 1:5)
#'
#' y <- as.Date("2019-01-31")
#'
#' # Adding 1 month to `y` generates an invalid date. Unlike year-month-day
#' # types, R's native Date type cannot handle invalid dates, so you must
#' # resolve them immediately. If you don't you get an error:
#' try(add_months(y, 1:2))
#' add_months(as_year_month_day(y), 1:2)
#'
#' # Resolve invalid dates by specifying an invalid date resolution strategy
#' # with the `invalid` argument. Using `"previous"` here sets the date to
#' # the previous valid date - i.e. the end of the month.
#' add_months(y, 1:2, invalid = "previous")
NULL
#' @rdname Date-arithmetic
#' @export
add_years.Date <- function(x, n, ..., invalid = NULL) {
check_dots_empty0(...)
add_date_duration_year_month_day(x, n, invalid, add_years)
}
#' @rdname Date-arithmetic
#' @export
add_quarters.Date <- function(x, n, ..., invalid = NULL) {
check_dots_empty0(...)
add_date_duration_year_month_day(x, n, invalid, add_quarters)
}
#' @rdname Date-arithmetic
#' @export
add_months.Date <- function(x, n, ..., invalid = NULL) {
check_dots_empty0(...)
add_date_duration_year_month_day(x, n, invalid, add_months)
}
add_date_duration_year_month_day <- function(x, n, invalid, add_fn) {
x <- as_year_month_day(x)
x <- add_fn(x, n)
x <- invalid_resolve(x, invalid = invalid)
as.Date(x)
}
#' @rdname Date-arithmetic
#' @export
add_weeks.Date <- function(x, n, ...) {
check_dots_empty0(...)
add_date_duration_time_point(x, n, add_weeks)
}
#' @rdname Date-arithmetic
#' @export
add_days.Date <- function(x, n, ...) {
check_dots_empty0(...)
add_date_duration_time_point(x, n, add_days)
}
add_date_duration_time_point <- function(x, n, add_fn) {
x <- as_naive_time(x)
x <- add_fn(x, n)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Group date and date-time components
#'
#' @description
#' `date_group()` groups by a single component of a date-time, such as month
#' of the year, or day of the month.
#'
#' There are separate help pages for grouping dates and date-times:
#'
#' - [dates (Date)][date-group]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-group]
#'
#' @inheritParams calendar_group
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @param precision `[character(1)]`
#'
#' A precision. Allowed precisions are dependent on the input used.
#'
#' @return `x`, grouped at `precision`.
#'
#' @export
#' @examples
#' # See type specific documentation for more examples
#' date_group(as.Date("2019-01-01") + 0:5, "day", n = 2)
date_group <- function(x, precision, ..., n = 1L) {
check_date_or_date_time(x)
UseMethod("date_group")
}
#' Group date components
#'
#' @description
#' This is a Date method for the [date_group()] generic.
#'
#' `date_group()` groups by a single component of a Date, such as month
#' of the year, or day of the month.
#'
#' If you need to group by more complex components, like ISO weeks, or quarters,
#' convert to a calendar type that contains the component you are interested
#' in grouping by.
#'
#' @inheritParams date_group
#' @inheritParams invalid_resolve
#'
#' @param x `[Date]`
#'
#' A date vector.
#'
#' @param precision `[character(1)]`
#'
#' One of:
#'
#' - `"year"`
#'
#' - `"month"`
#'
#' - `"day"`
#'
#' @return `x`, grouped at `precision`.
#'
#' @name date-group
#'
#' @export
#' @examples
#' x <- as.Date("2019-01-01") + -3:5
#' x
#'
#' # Group by 2 days of the current month.
#' # Note that this resets at the beginning of the month, creating day groups
#' # of [29, 30] [31] [01, 02] [03, 04].
#' date_group(x, "day", n = 2)
#'
#' # Group by month
#' date_group(x, "month")
date_group.Date <- function(x, precision, ..., n = 1L, invalid = NULL) {
check_dots_empty0(...)
x <- as_year_month_day(x)
x <- calendar_group(x, precision, n = n)
x <- calendar_widen(x, "day")
as.Date(x, invalid = invalid)
}
# ------------------------------------------------------------------------------
#' Is the year a leap year?
#'
#' `date_leap_year()` detects if the year is a leap year.
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time to detect leap years in.
#'
#' @return A logical vector the same size as `x`. Returns `TRUE` if in a leap
#' year, `FALSE` if not in a leap year, and `NA` if `x` is `NA`.
#'
#' @examples
#' x <- as.Date("2019-01-01")
#' x <- add_years(x, 0:5)
#' date_leap_year(x)
#'
#' y <- as.POSIXct("2019-01-01", "America/New_York")
#' y <- add_years(y, 0:5)
#' date_leap_year(y)
#' @export
date_leap_year <- function(x) {
check_date_or_date_time(x)
UseMethod("date_leap_year")
}
#' @export
date_leap_year.Date <- function(x) {
x <- as_year_month_day(x)
calendar_leap_year(x)
}
# ------------------------------------------------------------------------------
#' Date and date-time rounding
#'
#' @description
#' - `date_floor()` rounds a date or date-time down to a multiple of
#' the specified `precision`.
#'
#' - `date_ceiling()` rounds a date or date-time up to a multiple of
#' the specified `precision`.
#'
#' - `date_round()` rounds up or down depending on what is closer,
#' rounding up on ties.
#'
#' There are separate help pages for rounding dates and date-times:
#'
#' - [dates (Date)][date-rounding]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-rounding]
#'
#' These functions round the underlying duration itself, relative to an
#' `origin`. For example, rounding to 15 hours will construct groups of
#' 15 hours, starting from `origin`, which defaults to a naive time of
#' 1970-01-01 00:00:00.
#'
#' If you want to group by components, such as "day of the month", see
#' [date_group()].
#'
#' @inheritParams date_group
#'
#' @param origin `[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]`
#'
#' An origin to start counting from. The default `origin` is
#' midnight on 1970-01-01 in the time zone of `x`.
#'
#' @return `x` rounded to the specified `precision`.
#'
#' @name date-and-date-time-rounding
#'
#' @examples
#' # See the type specific documentation for more examples
#'
#' x <- as.Date("2019-03-31") + 0:5
#' x
#'
#' # Flooring by 2 days, note that this is not tied to the current month,
#' # and instead counts from the specified `origin`.
#' date_floor(x, "day", n = 2)
NULL
#' @rdname date-and-date-time-rounding
#' @export
date_floor <- function(x, precision, ..., n = 1L, origin = NULL) {
check_date_or_date_time(x)
UseMethod("date_floor")
}
#' @rdname date-and-date-time-rounding
#' @export
date_ceiling <- function(x, precision, ..., n = 1L, origin = NULL) {
check_date_or_date_time(x)
UseMethod("date_ceiling")
}
#' @rdname date-and-date-time-rounding
#' @export
date_round <- function(x, precision, ..., n = 1L, origin = NULL) {
check_date_or_date_time(x)
UseMethod("date_round")
}
#' Rounding: date
#'
#' @description
#' These are Date methods for the
#' [rounding generics][date-and-date-time-rounding].
#'
#' - `date_floor()` rounds a date down to a multiple of
#' the specified `precision`.
#'
#' - `date_ceiling()` rounds a date up to a multiple of
#' the specified `precision`.
#'
#' - `date_round()` rounds up or down depending on what is closer,
#' rounding up on ties.
#'
#' The only supported rounding `precision`s for Dates are `"day"` and `"week"`.
#' You can group by irregular periods such as `"month"` or `"year"` by using
#' [date_group()].
#'
#' @details
#' When rounding by `"week"`, remember that the `origin` determines the "week
#' start". By default, 1970-01-01 is the implicit origin, which is a
#' Thursday. If you would like to round by weeks with a different week start,
#' just supply an origin on the weekday you are interested in.
#'
#' @inheritParams date_floor
#'
#' @param x `[Date]`
#'
#' A date vector.
#'
#' @param precision `[character(1)]`
#'
#' One of:
#'
#' - `"week"`
#'
#' - `"day"`
#'
#' `"week"` is an alias for `"day"` with `n * 7`.
#'
#' @param origin `[Date(1) / NULL]`
#'
#' An origin to start counting from. The default `origin` is
#' 1970-01-01.
#'
#' @return `x` rounded to the specified `precision`.
#'
#' @name date-rounding
#'
#' @examples
#' x <- as.Date("2019-03-31") + 0:5
#' x
#'
#' # Flooring by 2 days, note that this is not tied to the current month,
#' # and instead counts from the specified `origin`, so groups can cross
#' # the month boundary
#' date_floor(x, "day", n = 2)
#'
#' # Compare to `date_group()`, which groups by the day of the month
#' date_group(x, "day", n = 2)
#'
#' y <- as.Date("2019-01-01") + 0:20
#' y
#'
#' # Flooring by week uses an implicit `origin` of 1970-01-01, which
#' # is a Thursday
#' date_floor(y, "week")
#' as_weekday(date_floor(y, "week"))
#'
#' # If you want to round by weeks with a different week start, supply an
#' # `origin` that falls on the weekday you care about. This uses a Monday.
#' origin <- as.Date("1970-01-05")
#' as_weekday(origin)
#'
#' date_floor(y, "week", origin = origin)
#' as_weekday(date_floor(y, "week", origin = origin))
NULL
#' @rdname date-rounding
#' @export
date_floor.Date <- function(x, precision, ..., n = 1L, origin = NULL) {
check_dots_empty0(...)
date_rounder(x, precision, n, origin, time_point_floor)
}
#' @rdname date-rounding
#' @export
date_ceiling.Date <- function(x, precision, ..., n = 1L, origin = NULL) {
check_dots_empty0(...)
date_rounder(x, precision, n, origin, time_point_ceiling)
}
#' @rdname date-rounding
#' @export
date_round.Date <- function(x, precision, ..., n = 1L, origin = NULL) {
check_dots_empty0(...)
date_rounder(x, precision, n, origin, time_point_round)
}
date_rounder <- function(x,
precision,
n,
origin,
time_point_rounder,
...,
error_call = caller_env()) {
check_dots_empty0(...)
result <- tweak_date_rounder_precision(precision, n)
precision <- result$precision
n <- result$n
x <- as_naive_time(x)
if (!is_null(origin)) {
origin <- collect_date_rounder_origin(origin, error_call = error_call)
}
x <- time_point_rounder(x, precision, n = n, origin = origin)
as.Date(x)
}
# Note:
# For Date and POSIXct, which are always day and second precision, we can
# allow a special "week" precision for the rounding functions. This isn't
# normally allowed for time points, as there is no week precision time point,
# and instead you'd do `day`,` `n = n * 7`. This makes that a little easier.
tweak_date_rounder_precision <- function(precision, n) {
if (identical(precision, "week")) {
precision <- "day"
n <- n * 7L
}
list(precision = precision, n = n)
}
collect_date_rounder_origin <- function(origin, error_call) {
check_date(origin, call = error_call)
vec_check_size(origin, 1L, call = error_call)
check_no_missing(origin, call = error_call)
if (is.infinite(origin)) {
cli::cli_abort("{.arg origin} can't be an infinite date.", call = error_call)
}
origin <- as_naive_time(origin)
origin
}
# ------------------------------------------------------------------------------
#' Convert a date or date-time to a weekday factor
#'
#' `date_weekday_factor()` converts a date or date-time to an ordered factor
#' with levels representing the weekday. This can be useful in combination with
#' ggplot2, or for modeling.
#'
#' @inheritParams weekday_factor
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @return An ordered factor representing the weekdays.
#'
#' @export
#' @examples
#' x <- as.Date("2019-01-01") + 0:6
#'
#' # Default to Sunday -> Saturday
#' date_weekday_factor(x)
#'
#' # ISO encoding is Monday -> Sunday
#' date_weekday_factor(x, encoding = "iso")
#'
#' # With full names
#' date_weekday_factor(x, abbreviate = FALSE)
#'
#' # Or a different language
#' date_weekday_factor(x, labels = "fr")
date_weekday_factor <- function(x,
...,
labels = "en",
abbreviate = TRUE,
encoding = "western") {
check_dots_empty0(...)
check_date_or_date_time(x)
x <- as_weekday(x)
weekday_factor(x, labels = labels, abbreviate = abbreviate, encoding = encoding)
}
# ------------------------------------------------------------------------------
#' Convert a date or date-time to an ordered factor of month names
#'
#' @description
#' `date_month_factor()` extracts the month values from a date or date-time and
#' converts them to an ordered factor of month names. This can be useful in
#' combination with ggplot2, or for modeling.
#'
#' @inheritParams calendar_month_factor
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @return An ordered factor representing the months.
#'
#' @export
#' @examples
#' x <- add_months(as.Date("2019-01-01"), 0:11)
#'
#' date_month_factor(x)
#' date_month_factor(x, abbreviate = TRUE)
#' date_month_factor(x, labels = "fr")
date_month_factor <- function(x,
...,
labels = "en",
abbreviate = FALSE) {
check_dots_empty0(...)
check_date_or_date_time(x)
x <- as_year_month_day(x)
calendar_month_factor(x, labels = labels, abbreviate = abbreviate)
}
# ------------------------------------------------------------------------------
#' Formatting: date and date-time
#'
#' @description
#' `date_format()` formats a date (Date) or date-time (POSIXct/POSIXlt) using
#' a `format` string.
#'
#' There are separate help pages for formatting dates and date-times:
#'
#' - [dates (Date)][date-formatting]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-formatting]
#'
#' @inheritParams rlang::args_dots_empty
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @return A character vector of the formatted input.
#'
#' @export
#' @examples
#' # See method specific documentation for more examples
#'
#' x <- as.Date("2019-01-01")
#' date_format(x, format = "year: %Y, month: %m, day: %d")
date_format <- function(x, ...) {
check_date_or_date_time(x)
UseMethod("date_format")
}
#' Formatting: date
#'
#' @description
#' This is a Date method for the [date_format()] generic.
#'
#' `date_format()` formats a date (Date) using a `format` string.
#'
#' If `format` is `NULL`, a default format of `"%Y-%m-%d"` is used.
#'
#' @details
#' Because a Date is considered to be a _naive_ type in clock, meaning that
#' it currently has no implied time zone, using the `%z` or `%Z` format commands
#' is not allowed and will result in `NA`.
#'
#' @inheritParams rlang::args_dots_empty
#' @inheritParams format.clock_zoned_time
#'
#' @param x `[Date]`
#'
#' A date vector.
#'
#' @return A character vector of the formatted input.
#'
#' @name date-formatting
#'
#' @export
#' @examples
#' x <- as.Date("2019-01-01")
#'
#' # Default
#' date_format(x)
#'
#' date_format(x, format = "year: %Y, month: %m, day: %d")
#'
#' # With different locales
#' date_format(x, format = "%A, %B %d, %Y")
#' date_format(x, format = "%A, %B %d, %Y", locale = clock_locale("fr"))
date_format.Date <- function(x,
...,
format = NULL,
locale = clock_locale()) {
check_dots_empty0(...)
x <- as_naive_time(x)
format(x, format = format, locale = locale)
}
# ------------------------------------------------------------------------------
#' Parsing: date
#'
#' @description
#' `date_parse()` parses strings into a Date.
#'
#' The default `format` used is `"%Y-%m-%d"`. This matches the default
#' result from calling `print()` or `format()` on a Date.
#'
#' @details
#' _`date_parse()` ignores both the `%z` and `%Z` commands,_ as clock treats
#' Date as a _naive_ type, with a yet-to-be-specified time zone.
#'
#' Parsing strings with sub-daily components, such as hours, minutes, or
#' seconds, should generally be done with [date_time_parse()]. If you only
#' need the date components from a string with sub-daily components, choose
#' one of the following:
#'
#' - If the date components are at the front of the string, and you don't want
#' the time components to affect the date in any way, you can use
#' [date_parse()] to parse only the date components. For example,
#' `date_parse("2019-01-05 00:01:02", format = "%Y-%m-%d")` will parse
#' through `05` and then stop.
#'
#' - If you want the time components to influence the date, then parse the full
#' string with [date_time_parse()], round to day precision with a
#' rounding function like [date_round()], and cast to date with [as_date()].
#'
#' Attempting to directly parse all components of a sub-daily string into a
#' Date is ambiguous and undefined, and is unlikely to work as you might expect.
#' For example, `date_parse("2019-01-05 00:01:02", format =
#' "%Y-%m-%d %H:%M:%S")` is not officially supported, even if it works in
#' some cases.
#'
#' @inheritParams zoned-parsing
#'
#' @return A Date.
#'
#' @export
#' @examples
#' date_parse("2020-01-01")
#'
#' date_parse(
#' "January 5, 2020",
#' format = "%B %d, %Y"
#' )
#'
#' # With a different locale
#' date_parse(
#' "janvier 5, 2020",
#' format = "%B %d, %Y",
#' locale = clock_locale("fr")
#' )
#'
#' # A neat feature of `date_parse()` is the ability to parse
#' # the ISO year-week-day format
#' date_parse("2020-W01-2", format = "%G-W%V-%u")
#'
#' # ---------------------------------------------------------------------------
#' # Sub-daily components
#'
#' # If you have a string with sub-daily components, but only require the date,
#' # first parse them as date-times to fully parse the sub-daily components,
#' # then round using whatever convention is required for your use case before
#' # converting to date.
#' x <- c("2019-01-01 11", "2019-01-01 12")
#'
#' x <- date_time_parse(x, zone = "UTC", format = "%Y-%m-%d %H")
#' x
#'
#' date_floor(x, "day")
#' date_round(x, "day")
#'
#' as_date(date_round(x, "day"))
date_parse <- function(x, ..., format = NULL, locale = clock_locale()) {
check_dots_empty0(...)
x <- naive_time_parse(x, format = format, precision = "day", locale = locale)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Shifting: date and date-time
#'
#' @description
#' `date_shift()` shifts `x` to the `target` weekday. You can shift to the next
#' or previous weekday. If `x` is currently on the `target` weekday, you can
#' choose to leave it alone or advance it to the next instance of the `target`.
#'
#' There are separate help pages for shifting dates and date-times:
#'
#' - [dates (Date)][date-shifting]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-shifting]
#'
#' @inheritParams time_point_shift
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @return `x` shifted to the `target` weekday.
#'
#' @name date-and-date-time-shifting
#'
#' @export
#' @examples
#' # See the type specific documentation for more examples
#'
#' x <- as.Date("2019-01-01") + 0:1
#'
#' # A Tuesday and Wednesday
#' as_weekday(x)
#'
#' monday <- weekday(clock_weekdays$monday)
#'
#' # Shift to the next Monday
#' date_shift(x, monday)
date_shift <- function(x,
target,
...,
which = "next",
boundary = "keep") {
check_date_or_date_time(x)
UseMethod("date_shift")
}
#' Shifting: date
#'
#' @description
#' `date_shift()` shifts `x` to the `target` weekday. You can shift to the next
#' or previous weekday. If `x` is currently on the `target` weekday, you can
#' choose to leave it alone or advance it to the next instance of the `target`.
#'
#' Weekday shifting is one of the easiest ways to floor by week while
#' controlling what is considered the first day of the week. You can also
#' accomplish this with the `origin` argument of [date_floor()], but this is
#' slightly easier.
#'
#' @inheritParams time_point_shift
#'
#' @param x `[Date]`
#'
#' A date vector.
#'
#' @return `x` shifted to the `target` weekday.
#'
#' @name date-shifting
#'
#' @export
#' @examples
#' x <- as.Date("2019-01-01") + 0:1
#'
#' # A Tuesday and Wednesday
#' as_weekday(x)
#'
#' monday <- weekday(clock_weekdays$monday)
#'
#' # Shift to the next Monday
#' date_shift(x, monday)
#'
#' # Shift to the previous Monday
#' # This is an easy way to "floor by week" with a target weekday in mind
#' date_shift(x, monday, which = "previous")
#'
#' # What about Tuesday?
#' tuesday <- weekday(clock_weekdays$tuesday)
#'
#' # Notice that the day that was currently on a Tuesday was not shifted
#' date_shift(x, tuesday)
#'
#' # You can force it to `"advance"`
#' date_shift(x, tuesday, boundary = "advance")
date_shift.Date <- function(x,
target,
...,
which = "next",
boundary = "keep") {
check_dots_empty0(...)
x <- as_naive_time(x)
x <- time_point_shift(x, target, which = which, boundary = boundary)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Building: date
#'
#' @description
#' `date_build()` builds a Date from it's individual components.
#'
#' @details
#' Components are recycled against each other using
#' [tidyverse recycling rules][vctrs::vector_recycling_rules].
#'
#' @inheritParams invalid_resolve
#'
#' @param year `[integer]`
#'
#' The year. Values `[-32767, 32767]` are generally allowed.
#'
#' @param month `[integer]`
#'
#' The month. Values `[1, 12]` are allowed.
#'
#' @param day `[integer / "last"]`
#'
#' The day of the month. Values `[1, 31]` are allowed.
#'
#' If `"last"`, then the last day of the month is returned.
#'
#' @return A Date.
#'
#' @export
#' @examples
#' date_build(2019)
#' date_build(2019, 1:3)
#'
#' # Generating invalid dates will trigger an error
#' try(date_build(2019, 1:12, 31))
#'
#' # You can resolve this with `invalid`
#' date_build(2019, 1:12, 31, invalid = "previous")
#'
#' # But this particular case (the last day of the month) is better
#' # specified as:
#' date_build(2019, 1:12, "last")
date_build <- function(year, month = 1L, day = 1L, ..., invalid = NULL) {
check_dots_empty0(...)
x <- year_month_day(year, month, day)
x <- invalid_resolve(x, invalid = invalid)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Current date and date-time
#'
#' @description
#' - `date_today()` returns the current date in the specified `zone` as a Date.
#'
#' - `date_now()` returns the current date-time in the specified `zone` as a
#' POSIXct.
#'
#' @details
#' clock assumes that Date is a _naive_ type, like naive-time. This means that
#' `date_today()` first looks up the current date-time in the specified `zone`,
#' then converts that to a Date, retaining the printed time while dropping any
#' information about that time zone.
#'
#' @inheritParams zoned_time_now
#'
#' @return
#' - `date_today()` a single Date.
#'
#' - `date_now()` a single POSIXct.
#'
#' @name date-today
#'
#' @examples
#' # Current date in the local time zone
#' date_today("")
#'
#' # Current date in a specified time zone
#' date_today("Europe/London")
#'
#' # Current date-time in that same time zone
#' date_now("Europe/London")
NULL
#' @rdname date-today
#' @export
date_today <- function(zone) {
as.Date(zoned_time_now(zone))
}
# ------------------------------------------------------------------------------
#' Boundaries: date and date-time
#'
#' @description
#' - `date_start()` computes the date at the start of a particular
#' `precision`, such as the "start of the year".
#'
#' - `date_end()` computes the date at the end of a particular
#' `precision`, such as the "end of the month".
#'
#' There are separate help pages for computing boundaries for dates and
#' date-times:
#'
#' - [dates (Date)][date-boundary]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-boundary]
#'
#' @inheritParams date_group
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @param precision `[character(1)]`
#'
#' A precision. Allowed precisions are dependent on the input used.
#'
#' @return `x` but with some components altered to be at the boundary value.
#'
#' @name date-and-date-time-boundary
#'
#' @examples
#' # See type specific documentation for more examples
#'
#' x <- date_build(2019, 2:4)
#'
#' date_end(x, "month")
#'
#' x <- date_time_build(2019, 2:4, 3:5, 4, 5, zone = "America/New_York")
#'
#' # Note that the hour, minute, and second components are also adjusted
#' date_end(x, "month")
NULL
#' @rdname date-and-date-time-boundary
#' @export
date_start <- function(x, precision, ...) {
check_date_or_date_time(x)
UseMethod("date_start")
}
#' @rdname date-and-date-time-boundary
#' @export
date_end <- function(x, precision, ...) {
check_date_or_date_time(x)
UseMethod("date_end")
}
#' Boundaries: date
#'
#' @description
#' This is a Date method for the [date_start()] and [date_end()] generics.
#'
#' @inheritParams date_group
#' @inheritParams invalid_resolve
#'
#' @param x `[Date]`
#'
#' A date vector.
#'
#' @param precision `[character(1)]`
#'
#' One of:
#'
#' - `"year"`
#'
#' - `"month"`
#'
#' - `"day"`
#'
#' @return `x` but with some components altered to be at the boundary value.
#'
#' @name date-boundary
#'
#' @examples
#' x <- date_build(2019:2021, 2:4, 3:5)
#' x
#'
#' # Last day of the month
#' date_end(x, "month")
#'
#' # Last day of the year
#' date_end(x, "year")
#'
#' # First day of the year
#' date_start(x, "year")
NULL
#' @rdname date-boundary
#' @export
date_start.Date <- function(x, precision, ..., invalid = NULL) {
check_dots_empty0(...)
x <- as_year_month_day(x)
x <- calendar_start(x, precision)
as.Date(x, invalid = invalid)
}
#' @rdname date-boundary
#' @export
date_end.Date <- function(x, precision, ..., invalid = NULL) {
check_dots_empty0(...)
x <- as_year_month_day(x)
x <- calendar_end(x, precision)
as.Date(x, invalid = invalid)
}
# ------------------------------------------------------------------------------
#' Sequences: date and date-time
#'
#' @description
#' `date_seq()` generates a date (Date) or date-time (POSIXct/POSIXlt) sequence.
#'
#' There are separate help pages for generating sequences for dates and
#' date-times:
#'
#' - [dates (Date)][date-sequence]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-sequence]
#'
#' @inheritParams rlang::args_dots_empty
#'
#' @param from `[Date(1) / POSIXct(1) / POSIXlt(1)]`
#'
#' A date or date-time to start the sequence from.
#'
#' @param to `[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]`
#'
#' A date or date-time to stop the sequence at.
#'
#' `to` is only included in the result if the resulting sequence divides
#' the distance between `from` and `to` exactly.
#'
#' @param by `[integer(1) / clock_duration(1) / NULL]`
#'
#' The unit to increment the sequence by.
#'
#' @param total_size `[positive integer(1) / NULL]`
#'
#' The size of the resulting sequence.
#'
#' If specified alongside `to`, this must generate a non-fractional sequence
#' between `from` and `to`.
#'
#' @return A date or date-time vector.
#'
#' @export
#' @examples
#' # See method specific documentation for more examples
#'
#' x <- as.Date("2019-01-01")
#' date_seq(x, by = duration_months(2), total_size = 20)
date_seq <- function(from,
...,
to = NULL,
by = NULL,
total_size = NULL) {
check_date_or_date_time(from)
UseMethod("date_seq")
}
#' Sequences: date
#'
#' @description
#' This is a Date method for the [date_seq()] generic.
#'
#' `date_seq()` generates a date (Date) sequence.
#'
#' When calling `date_seq()`, exactly two of the following must be specified:
#' - `to`
#' - `by`
#' - `total_size`
#'
#' @inheritParams date_seq
#' @inheritParams invalid_resolve
#'
#' @param from `[Date(1)]`
#'
#' A date to start the sequence from.
#'
#' @param to `[Date(1) / NULL]`
#'
#' A date to stop the sequence at.
#'
#' `to` is only included in the result if the resulting sequence divides
#' the distance between `from` and `to` exactly.
#'
#' If `to` is supplied along with `by`, all components of `to` more precise
#' than the precision of `by` must match `from` exactly. For example, if `by =
#' duration_months(1)`, the day component of `to` must match the day component
#' of `from`. This ensures that the generated sequence is, at a minimum, a
#' weakly monotonic sequence of dates.
#'
#' @param by `[integer(1) / clock_duration(1) / NULL]`
#'
#' The unit to increment the sequence by.
#'
#' If `by` is an integer, it is equivalent to `duration_days(by)`.
#'
#' If `by` is a duration, it is allowed to have a precision of:
#' - year
#' - quarter
#' - month
#' - week
#' - day
#'
#' @return A date vector.
#'
#' @name date-sequence
#'
#' @export
#' @examples
#' from <- date_build(2019, 1)
#' to <- date_build(2019, 4)
#'
#' # Defaults to daily sequence
#' date_seq(from, to = to, by = 7)
#'
#' # Use durations to change to monthly or yearly sequences
#' date_seq(from, to = to, by = duration_months(1))
#' date_seq(from, by = duration_years(-2), total_size = 3)
#'
#' # Note that components of `to` more precise than the precision of `by`
#' # must match `from` exactly. For example, this is not well defined:
#' from <- date_build(2019, 5, 2)
#' to <- date_build(2025, 7, 5)
#' try(date_seq(from, to = to, by = duration_years(1)))
#'
#' # The month and day components of `to` must match `from`
#' to <- date_build(2025, 5, 2)
#' date_seq(from, to = to, by = duration_years(1))
#'
#' # ---------------------------------------------------------------------------
#'
#' # Invalid dates must be resolved with the `invalid` argument
#' from <- date_build(2019, 1, 31)
#' to <- date_build(2019, 12, 31)
#'
#' try(date_seq(from, to = to, by = duration_months(1)))
#' date_seq(from, to = to, by = duration_months(1), invalid = "previous")
#'
#' # Compare this to the base R result, which is often a source of confusion
#' seq(from, to = to, by = "1 month")
#'
#' # This is equivalent to the overflow invalid resolution strategy
#' date_seq(from, to = to, by = duration_months(1), invalid = "overflow")
#'
#' # ---------------------------------------------------------------------------
#'
#' # Usage of `to` and `total_size` must generate a non-fractional sequence
#' # between `from` and `to`
#' from <- date_build(2019, 1, 1)
#' to <- date_build(2019, 1, 4)
#'
#' # These are fine
#' date_seq(from, to = to, total_size = 2)
#' date_seq(from, to = to, total_size = 4)
#'
#' # But this is not!
#' try(date_seq(from, to = to, total_size = 3))
date_seq.Date <- function(from,
...,
to = NULL,
by = NULL,
total_size = NULL,
invalid = NULL) {
check_dots_empty0(...)
check_number_of_supplied_optional_arguments(to, by, total_size)
check_date(to, allow_null = TRUE)
if (!is_null(total_size)) {
total_size <- check_length_out(total_size)
}
if (is_null(by)) {
precision <- "day"
} else if (is_duration(by)) {
precision <- duration_precision(by)
} else {
precision <- "day"
by <- duration_helper(by, PRECISION_DAY)
}
check_precision(precision)
precision_int <- precision_to_integer(precision)
if (precision_int == PRECISION_QUARTER) {
by <- duration_cast(by, "month")
precision <- "month"
precision_int <- PRECISION_MONTH
}
if (precision_int == PRECISION_WEEK) {
by <- duration_cast(by, "day")
precision <- "day"
precision_int <- PRECISION_DAY
}
if (precision_int %in% c(PRECISION_YEAR, PRECISION_MONTH)) {
out <- date_seq_year_month(from, to, by, total_size, precision)
out <- invalid_resolve(out, invalid = invalid)
out <- as.Date(out)
return(out)
}
if (precision_int == PRECISION_DAY) {
out <- date_seq_day(from, to, by, total_size, precision)
out <- as.Date(out)
return(out)
}
precisions <- c("year", "quarter", "month", "week", "day")
by_precision <- duration_precision(by)
cli::cli_abort("`by` must have a precision of {.or {.str {precisions}}}, not {.str {by_precision}}.")
}
date_seq_year_month <- function(from,
to,
by,
total_size,
precision,
...,
error_call = caller_env()) {
check_dots_empty0(...)
has_time <- is_POSIXt(from)
from <- as_year_month_day(from)
original_from <- from
from <- calendar_narrow(from, precision)
if (!is_null(to)) {
to <- as_year_month_day(to)
check_from_to_component_equivalence(
from = original_from,
to = to,
precision = precision,
has_time = has_time,
error_call = error_call
)
to <- calendar_narrow(to, precision)
}
out <- seq(from, to = to, by = by, length.out = total_size)
out <- reset_original_components(out, original_from, precision, has_time)
out
}
date_seq_day <- function(from, to, by, total_size, precision, ..., error_call = caller_env()) {
check_dots_empty0(...)
date_seq_day_hour_minute_second(from, to, by, total_size, precision, error_call, as_naive_time)
}
date_seq_hour_minute_second <- function(from, to, by, total_size, precision, ..., error_call = caller_env()) {
check_dots_empty0(...)
date_seq_day_hour_minute_second(from, to, by, total_size, precision, error_call, as_sys_time)
}
date_seq_day_hour_minute_second <- function(from, to, by, total_size, precision, error_call, as_time_point_fn) {
has_time <- is_POSIXt(from)
from <- as_time_point_fn(from)
original_from <- from
from <- time_point_floor(from, precision)
if (!is_null(to)) {
to <- as_time_point_fn(to)
check_from_to_component_equivalence(
from = as_year_month_day(original_from),
to = as_year_month_day(to),
precision = precision,
has_time = has_time,
error_call = error_call
)
to <- time_point_floor(to, precision)
}
out <- seq(from, to = to, by = by, length.out = total_size)
original_time <- original_from - from
out <- out + original_time
out
}
check_from_to_component_equivalence <- function(from,
to,
precision,
has_time,
error_call) {
ok <- TRUE
check_precision(precision, call = error_call)
precision_int <- precision_to_integer(precision)
if (precision_int < PRECISION_MONTH) {
ok <- ok && is_true(get_month(from) == get_month(to))
}
if (precision_int < PRECISION_DAY) {
ok <- ok && is_true(get_day(from) == get_day(to))
}
if (has_time) {
if (precision_int < PRECISION_HOUR) {
ok <- ok && is_true(get_hour(from) == get_hour(to))
}
if (precision_int < PRECISION_MINUTE) {
ok <- ok && is_true(get_minute(from) == get_minute(to))
}
if (precision_int < PRECISION_SECOND) {
ok <- ok && is_true(get_second(from) == get_second(to))
}
}
if (!ok) {
message <- c(
"All components of {.arg from} and {.arg to} more precise than {.str {precision}} must match.",
i = "{.arg from} is {.str {format(from)}}.",
i = "{.arg to} is {.str {format(to)}}."
)
cli::cli_abort(message, call = error_call)
}
invisible()
}
reset_original_components <- function(out, from, precision, has_time) {
check_precision(precision)
precision_int <- precision_to_integer(precision)
if (precision_int < PRECISION_MONTH) {
out <- set_month(out, get_month(from))
}
if (precision_int < PRECISION_DAY) {
out <- set_day(out, get_day(from))
}
if (has_time) {
if (precision_int < PRECISION_HOUR) {
out <- set_hour(out, get_hour(from))
}
if (precision_int < PRECISION_MINUTE) {
out <- set_minute(out, get_minute(from))
}
if (precision_int < PRECISION_SECOND) {
out <- set_second(out, get_second(from))
}
}
out
}
check_number_of_supplied_optional_arguments <- function(to,
by,
total_size,
...,
error_call = caller_env()) {
check_dots_empty0(...)
has_to <- !is_null(to)
has_by <- !is_null(by)
has_ts <- !is_null(total_size)
n_has <- sum(has_to, has_by, has_ts)
if (n_has != 2L) {
header <- "Must specify exactly two of:"
bullets <- cli::format_bullets_raw(c(
"*" = cli::format_inline("{.arg to}"),
"*" = cli::format_inline("{.arg by}"),
"*" = cli::format_inline("{.arg total_size}")
))
message <- c(header, bullets)
cli::cli_abort(message, call = error_call)
}
invisible()
}
# ------------------------------------------------------------------------------
#' Spanning sequence: date and date-time
#'
#' @description
#' `date_spanning_seq()` generates a regular sequence along the span of
#' `x`, i.e. along `[min(x), max(x)]`. For dates, this generates a day precision
#' sequence, and for date-times it generates a second precision sequence.
#'
#' @details
#' Missing and infinite values are automatically removed before the sequence is
#' generated.
#'
#' For date-times, sys-time based sequences are generated, consistent with
#' [`date_seq()`][posixt-sequence] when using a second precision `by` value.
#'
#' If you need more precise sequence generation, call [range()] and [date_seq()]
#' directly.
#'
#' @param x `[Date / POSIXct / POSIXlt]`
#'
#' A date or date-time vector.
#'
#' @return A sequence along `[min(x), max(x)]`.
#'
#' @export
#' @examples
#' x <- date_build(2020, c(1, 2, 1), c(10, 5, 12))
#' date_spanning_seq(x)
#'
#' # Missing and infinite dates are removed before the sequence is generated
#' x <- c(x, NA, Inf, -Inf)
#' x
#'
#' date_spanning_seq(x)
#'
#' # For date-times, sequences are generated at second precision
#' x <- date_time_build(
#' 2020, 1, 2, 3, c(5, 4, 5), c(10, 48, 12),
#' zone = "America/New_York"
#' )
#' x
#'
#' date_spanning_seq(x)
date_spanning_seq <- function(x) {
check_date_or_date_time(x)
UseMethod("date_spanning_seq")
}
#' @export
date_spanning_seq.Date <- function(x) {
x <- vec_drop_infinite(x)
x <- as_sys_time(x)
x <- time_point_spanning_seq(x)
as.Date(x)
}
# ------------------------------------------------------------------------------
#' Counting: date and date-time
#'
#' @description
#' `date_count_between()` counts the number of `precision` units between
#' `start` and `end` (i.e., the number of years or months or hours). This count
#' corresponds to the _whole number_ of units, and will never return a
#' fractional value.
#'
#' This is suitable for, say, computing the whole number of years or months
#' between two dates, accounting for the day and time of day.
#'
#' There are separate help pages for counting for dates and date-times:
#'
#' - [dates (Date)][date-count-between]
#'
#' - [date-times (POSIXct/POSIXlt)][posixt-count-between]
#'
#' @inheritSection calendar_count_between Comparison Direction
#'
#' @inheritParams calendar_count_between
#'
#' @param start,end `[Date / POSIXct / POSIXlt]`
#'
#' A pair of date or date-time vectors. These will be recycled to their common
#' size.
#'
#' @inherit calendar_count_between return
#'
#' @export
#' @examples
#' # See method specific documentation for more examples
#'
#' start <- date_parse("2000-05-05")
#' end <- date_parse(c("2020-05-04", "2020-05-06"))
#'
#' # Age in years
#' date_count_between(start, end, "year")
#'
#' # Number of "whole" months between these dates
#' date_count_between(start, end, "month")
date_count_between <- function(start, end, precision, ..., n = 1L) {
check_date_or_date_time(start)
UseMethod("date_count_between")
}
#' Counting: date
#'
#' @description
#' This is a Date method for the [date_count_between()] generic.
#'
#' `date_count_between()` counts the number of `precision` units between
#' `start` and `end` (i.e., the number of years or months). This count
#' corresponds to the _whole number_ of units, and will never return a
#' fractional value.
#'
#' This is suitable for, say, computing the whole number of years or months
#' between two dates, accounting for the day of the month.
#'
#' _Calendrical based counting:_
#'
#' These precisions convert to a year-month-day calendar and count while in that
#' type.
#'
#' - `"year"`
#'
#' - `"quarter"`
#'
#' - `"month"`
#'
#' _Time point based counting:_
#'
#' These precisions convert to a time point and count while in that type.
#'
#' - `"week"`
#'
#' - `"day"`
#'
#' For dates, whether a calendar or time point is used is not all that
#' important, but is is fairly important for date-times.
#'
#' @details
#' `"quarter"` is equivalent to `"month"` precision with `n` set to `n * 3L`.
#'
#' @inheritSection calendar_count_between Comparison Direction
#'
#' @inheritParams date_count_between
#'
#' @param start,end `[Date]`
#'
#' A pair of date vectors. These will be recycled to their common
#' size.
#'
#' @param precision `[character(1)]`
#'
#' One of:
#'
#' - `"year"`
#' - `"quarter"`
#' - `"month"`
#' - `"week"`
#' - `"day"`
#'
#' @inherit date_count_between return
#'
#' @name date-count-between
#'
#' @export
#' @examples
#' start <- date_parse("2000-05-05")
#' end <- date_parse(c("2020-05-04", "2020-05-06"))
#'
#' # Age in years
#' date_count_between(start, end, "year")
#'
#' # Number of "whole" months between these dates. i.e.
#' # `2000-05-05 -> 2020-04-05` is 239 months
#' # `2000-05-05 -> 2020-05-05` is 240 months
#' # Since 2020-05-04 occurs before the 5th of that month,
#' # it gets a count of 239
#' date_count_between(start, end, "month")
#'
#' # Number of "whole" quarters between (same as `"month"` with `n * 3`)
#' date_count_between(start, end, "quarter")
#' date_count_between(start, end, "month", n = 3)
#'
#' # Number of days between
#' date_count_between(start, end, "day")
#'
#' # Number of full 3 day periods between these two dates
#' date_count_between(start, end, "day", n = 3)
#'
#' # Essentially the truncated value of this
#' date_count_between(start, end, "day") / 3
#'
#' # ---------------------------------------------------------------------------
#'
#' # Breakdown into full years, months, and days between
#' x <- start
#'
#' years <- date_count_between(x, end, "year")
#' x <- add_years(x, years)
#'
#' months <- date_count_between(x, end, "month")
#' x <- add_months(x, months)
#'
#' days <- date_count_between(x, end, "day")
#' x <- add_days(x, days)
#'
#' data.frame(
#' start = start,
#' end = end,
#' years = years,
#' months = months,
#' days = days
#' )
#'
#' # Note that when breaking down a date like that, you may need to
#' # set `invalid` during intermediate calculations
#' start <- date_build(2019, c(3, 3, 4), c(30, 31, 1))
#' end <- date_build(2019, 5, 05)
#'
#' # These are 1 month apart (plus a few days)
#' months <- date_count_between(start, end, "month")
#'
#' # But adding that 1 month to `start` results in an invalid date
#' try(add_months(start, months))
#'
#' # You can choose various ways to resolve this
#' start_previous <- add_months(start, months, invalid = "previous")
#' start_next <- add_months(start, months, invalid = "next")
#'
#' days_previous <- date_count_between(start_previous, end, "day")
#' days_next <- date_count_between(start_next, end, "day")
#'
#' # Resulting in slightly different day values.
#' # No result is "perfect". Choosing "previous" or "next" both result
#' # in multiple `start` dates having the same month/day breakdown values.
#' data.frame(
#' start = start,
#' end = end,
#' months = months,
#' days_previous = days_previous,
#' days_next = days_next
#' )
date_count_between.Date <- function(start, end, precision, ..., n = 1L) {
check_dots_empty0(...)
check_date(end)
# Designed to match `add_*()` functions to guarantee that
# if `start <= end`, then `start + <count> <= end`
allowed_precisions_calendar <- c(
PRECISION_YEAR, PRECISION_QUARTER, PRECISION_MONTH
)
allowed_precisions_naive_time <- c(
PRECISION_WEEK, PRECISION_DAY
)
allowed_precisions_sys_time <- c(
)
date_count_between_impl(
start = start,
end = end,
precision = precision,
n = n,
allowed_precisions_calendar = allowed_precisions_calendar,
allowed_precisions_naive_time = allowed_precisions_naive_time,
allowed_precisions_sys_time = allowed_precisions_sys_time
)
}
date_count_between_impl <- function(start,
end,
precision,
n,
allowed_precisions_calendar,
allowed_precisions_naive_time,
allowed_precisions_sys_time,
...,
error_call = caller_env()) {
check_precision(precision, call = error_call)
precision_int <- precision_to_integer(precision)
if (precision_int %in% allowed_precisions_calendar) {
start <- as_year_month_day(start)
end <- as_year_month_day(end)
out <- calendar_count_between(start, end, precision, n = n)
return(out)
}
if (precision_int %in% allowed_precisions_naive_time) {
start <- as_naive_time(start)
end <- as_naive_time(end)
out <- time_point_count_between(start, end, precision, n = n)
return(out)
}
if (precision_int %in% allowed_precisions_sys_time) {
start <- as_sys_time(start)
end <- as_sys_time(end)
out <- time_point_count_between(start, end, precision, n = n)
return(out)
}
precisions <- c(
allowed_precisions_calendar,
allowed_precisions_naive_time,
allowed_precisions_sys_time
)
precisions <- vapply(precisions, precision_to_string, character(1))
cli::cli_abort(
"{.arg precision} must be {.or {.str {precisions}}}, not {.str {precision}}.",
call = error_call
)
}
# ------------------------------------------------------------------------------
is_date <- function(x) {
inherits(x, "Date")
}
check_date <- function(x,
...,
allow_null = FALSE,
arg = caller_arg(x),
call = caller_env()) {
check_inherits(
x = x,
what = "Date",
allow_null = allow_null,
arg = arg,
call = call
)
}
check_date_or_date_time <- function(x,
...,
allow_null = FALSE,
arg = caller_arg(x),
call = caller_env()) {
if (!missing(x)) {
if (is_date(x) || is_POSIXt(x)) {
return(invisible(NULL))
}
if (allow_null && is_null(x)) {
return(invisible(NULL))
}
}
stop_input_type(
x = x,
what = cli::format_inline("a {.cls Date} or {.cls POSIXt}"),
allow_null = allow_null,
arg = arg,
call = call
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.