Merge pull request #242 from r-lib/feature/date-start-end

Implement start/end functions

Author: DavisVaughan

NAMESPACE

@@ -171,6 +171,12 @@ S3method(as_zoned_time,clock_naive_time)
 S3method(as_zoned_time,clock_sys_time)
 S3method(as_zoned_time,clock_zoned_time)
 S3method(as_zoned_time,default)
+S3method(calendar_end,clock_calendar)
+S3method(calendar_end,clock_iso_year_week_day)
+S3method(calendar_end,clock_year_day)
+S3method(calendar_end,clock_year_month_day)
+S3method(calendar_end,clock_year_month_weekday)
+S3method(calendar_end,clock_year_quarter_day)
 S3method(calendar_group,clock_calendar)
 S3method(calendar_group,clock_iso_year_week_day)
 S3method(calendar_group,clock_year_day)
@@ -201,6 +207,12 @@ S3method(calendar_narrow,clock_year_month_day)
 S3method(calendar_narrow,clock_year_month_weekday)
 S3method(calendar_narrow,clock_year_quarter_day)
 S3method(calendar_precision,clock_calendar)
+S3method(calendar_start,clock_calendar)
+S3method(calendar_start,clock_iso_year_week_day)
+S3method(calendar_start,clock_year_day)
+S3method(calendar_start,clock_year_month_day)
+S3method(calendar_start,clock_year_month_weekday)
+S3method(calendar_start,clock_year_quarter_day)
 S3method(calendar_widen,clock_calendar)
 S3method(calendar_widen,clock_iso_year_week_day)
 S3method(calendar_widen,clock_year_day)
@@ -209,6 +221,8 @@ S3method(calendar_widen,clock_year_month_weekday)
 S3method(calendar_widen,clock_year_quarter_day)
 S3method(date_ceiling,Date)
 S3method(date_ceiling,POSIXt)
+S3method(date_end,Date)
+S3method(date_end,POSIXt)
 S3method(date_floor,Date)
 S3method(date_floor,POSIXt)
 S3method(date_format,Date)
@@ -227,6 +241,8 @@ S3method(date_set_zone,Date)
 S3method(date_set_zone,POSIXt)
 S3method(date_shift,Date)
 S3method(date_shift,POSIXt)
+S3method(date_start,Date)
+S3method(date_start,POSIXt)
 S3method(date_weekday_factor,Date)
 S3method(date_weekday_factor,POSIXt)
 S3method(date_zone,Date)
@@ -562,18 +578,21 @@ export(as_year_month_day)
 export(as_year_month_weekday)
 export(as_year_quarter_day)
 export(as_zoned_time)
+export(calendar_end)
 export(calendar_group)
 export(calendar_leap_year)
 export(calendar_month_factor)
 export(calendar_narrow)
 export(calendar_precision)
+export(calendar_start)
 export(calendar_widen)
 export(clock_labels)
 export(clock_labels_languages)
 export(clock_labels_lookup)
 export(clock_locale)
 export(date_build)
 export(date_ceiling)
+export(date_end)
 export(date_floor)
 export(date_format)
 export(date_group)
@@ -585,6 +604,7 @@ export(date_round)
 export(date_seq)
 export(date_set_zone)
 export(date_shift)
+export(date_start)
 export(date_time_build)
 export(date_time_parse)
 export(date_time_parse_abbrev)

NEWS.md

@@ -1,5 +1,11 @@
 # clock (development version)
 
+* New `date_start()` and `date_end()` for computing the date at the start or
+  end of a particular `precision`, such as the "end of the month" or
+  the "start of the year". These are powered by `calendar_start()` and
+  `calendar_end()`, which allow for even more flexible calendar-specific
+  boundary generation, such as the "last moment in the fiscal quarter" (#232).
+
 * New `invalid_remove()` for removing invalid dates. This is just a wrapper
   around `x[!invalid_detect(x)]`, but works nicely with the pipe (#229).
 

R/calendar.R

@@ -556,6 +556,161 @@ calendar_widen_time <- function(x, x_precision, precision) {
 
 # ------------------------------------------------------------------------------
 
+#' Boundaries: calendars
+#'
+#' @description
+#' - `calendar_start()` computes the start of a calendar at a particular
+#'   `precision`, such as the "start of the quarter".
+#'
+#' - `calendar_end()` computes the end of a calendar at a particular
+#'   `precision`, such as the "end of the month".
+#'
+#' For both `calendar_start()` and `calendar_end()`, the precision of `x` is
+#' always retained.
+#'
+#' Each calendar has its own help page describing the precisions that you
+#' can compute a boundary at:
+#'
+#' - [year-month-day][year-month-day-boundary]
+#'
+#' - [year-month-weekday][year-month-weekday-boundary]
+#'
+#' - [iso-year-week-day][iso-year-week-day-boundary]
+#'
+#' - [year-quarter-day][year-quarter-day-boundary]
+#'
+#' - [year-day][year-day-boundary]
+#'
+#' @inheritParams calendar_group
+#'
+#' @return `x` at the same precision, but with some components altered to be
+#'   at the boundary value.
+#'
+#' @name calendar-boundary
+#' @examples
+#' # Hour precision
+#' x <- year_month_day(2019, 2:4, 5, 6)
+#' x
+#'
+#' # Compute the start of the month
+#' calendar_start(x, "month")
+#'
+#' # Or the end of the month, notice that the hour value is adjusted as well
+#' calendar_end(x, "month")
+NULL
+
+
+#' @rdname calendar-boundary
+#' @export
+calendar_start <- function(x, precision) {
+  UseMethod("calendar_start")
+}
+
+#' @export
+calendar_start.clock_calendar <- function(x, precision) {
+  stop_clock_unsupported_calendar_op("calendar_start")
+}
+
+
+#' @rdname calendar-boundary
+#' @export
+calendar_end <- function(x, precision) {
+  UseMethod("calendar_end")
+}
+
+#' @export
+calendar_end.clock_calendar <- function(x, precision) {
+  stop_clock_unsupported_calendar_op("calendar_end")
+}
+
+
+calendar_start_end_checks <- function(x, x_precision, precision, which) {
+  if (!calendar_is_valid_precision(x, precision)) {
+    message <- paste0(
+      "`precision` must be a valid precision for a '", calendar_name(x), "'."
+    )
+    abort(message)
+  }
+
+  if (x_precision < precision) {
+    precision <- precision_to_string(precision)
+    x_precision <- precision_to_string(x_precision)
+
+    message <- paste0(
+      "Can't compute the ", which, " of `x` (", x_precision, ") ",
+      "at a more precise precision (", precision, ")."
+    )
+    abort(message)
+  }
+
+  if (precision > PRECISION_SECOND && x_precision != precision) {
+    # Computing the start/end of nanosecond precision at millisecond precision
+    # would be inconsistent with our general philosophy that you "lock in"
+    # the subsecond precision.
+    precision <- precision_to_string(precision)
+    x_precision <- precision_to_string(x_precision)
+
+    message <- paste0(
+      "Can't compute the ", which, " of a subsecond precision `x` (", x_precision, ") ",
+      "at another subsecond precision (", precision, ")."
+    )
+    abort(message)
+  }
+
+  invisible(x)
+}
+
+calendar_start_time <- function(x, x_precision, precision) {
+  values <- list(
+    hour = 0L,
+    minute = 0L,
+    second = 0L,
+    millisecond = 0L,
+    microsecond = 0L,
+    nanosecond = 0L
+  )
+
+  calendar_start_end_time(x, x_precision, precision, values)
+}
+
+calendar_end_time <- function(x, x_precision, precision) {
+  values <- list(
+    hour = 23L,
+    minute = 59L,
+    second = 59L,
+    millisecond = 999L,
+    microsecond = 999999L,
+    nanosecond = 999999999L
+  )
+
+  calendar_start_end_time(x, x_precision, precision, values)
+}
+
+calendar_start_end_time <- function(x, x_precision, precision, values) {
+  if (precision <= PRECISION_DAY && x_precision > PRECISION_DAY) {
+    x <- set_hour(x, values$hour)
+  }
+  if (precision <= PRECISION_HOUR && x_precision > PRECISION_HOUR) {
+    x <- set_minute(x, values$minute)
+  }
+  if (precision <= PRECISION_MINUTE && x_precision > PRECISION_MINUTE) {
+    x <- set_second(x, values$second)
+  }
+  if (precision <= PRECISION_SECOND && x_precision > PRECISION_SECOND) {
+    if (x_precision == PRECISION_MILLISECOND) {
+      x <- set_millisecond(x, values$millisecond)
+    } else if (x_precision == PRECISION_MICROSECOND) {
+      x <- set_microsecond(x, values$microsecond)
+    } else if (x_precision == PRECISION_NANOSECOND) {
+      x <- set_nanosecond(x, values$nanosecond)
+    }
+  }
+
+  x
+}
+
+# ------------------------------------------------------------------------------
+
 #' Precision: calendar
 #'
 #' `calendar_precision()` extracts the precision from a calendar object. It

R/date.R

@@ -1229,6 +1229,122 @@ date_today <- function(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, ...) {
+  UseMethod("date_start")
+}
+
+#' @rdname date-and-date-time-boundary
+#' @export
+date_end <- function(x, precision, ...) {
+  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_empty()
+  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_empty()
+  x <- as_year_month_day(x)
+  x <- calendar_end(x, precision)
+  as.Date(x, invalid = invalid)
+}
+
+# ------------------------------------------------------------------------------
+
 #' Sequences: date and date-time
 #'
 #' @description