Implement calendar_start() and calendar_end()

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)
@@ -562,11 +574,13 @@ 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)

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/gregorian-year-day.R

@@ -857,6 +857,64 @@ calendar_widen.clock_year_day <- function(x, precision) {
 
 # ------------------------------------------------------------------------------
 
+#' Boundaries: year-day
+#'
+#' This is a year-day method for the [calendar_start()] and
+#' [calendar_end()] generics. They adjust components of a calendar to the
+#' start or end of a specified `precision`.
+#'
+#' @inheritParams year-day-group
+#'
+#' @return `x` at the same precision, but with some components altered to be
+#'   at the boundary value.
+#'
+#' @name year-day-boundary
+#'
+#' @examples
+#' # Day precision
+#' x <- year_day(2019:2020, 5)
+#' x
+#'
+#' # Compute the last day of the year
+#' calendar_end(x, "year")
+NULL
+
+#' @rdname year-day-boundary
+#' @export
+calendar_start.clock_year_day <- function(x, precision) {
+  x_precision <- calendar_precision_attribute(x)
+  precision <- validate_precision_string(precision)
+
+  calendar_start_end_checks(x, x_precision, precision, "start")
+
+  if (precision <= PRECISION_YEAR && x_precision > PRECISION_YEAR) {
+    x <- set_day(x, 1L)
+  }
+
+  x <- calendar_start_time(x, x_precision, precision)
+
+  x
+}
+
+#' @rdname year-day-boundary
+#' @export
+calendar_end.clock_year_day <- function(x, precision) {
+  x_precision <- calendar_precision_attribute(x)
+  precision <- validate_precision_string(precision)
+
+  calendar_start_end_checks(x, x_precision, precision, "end")
+
+  if (precision <= PRECISION_YEAR && x_precision > PRECISION_YEAR) {
+    x <- set_day(x, "last")
+  }
+
+  x <- calendar_end_time(x, x_precision, precision)
+
+  x
+}
+
+# ------------------------------------------------------------------------------
+
 #' Sequences: year-day
 #'
 #' @description

R/gregorian-year-month-day.R

@@ -1136,6 +1136,81 @@ calendar_widen.clock_year_month_day <- function(x, precision) {
 
 # ------------------------------------------------------------------------------
 
+#' Boundaries: year-month-day
+#'
+#' This is a year-month-day method for the [calendar_start()] and
+#' [calendar_end()] generics. They adjust components of a calendar to the
+#' start or end of a specified `precision`.
+#'
+#' @inheritParams year-month-day-group
+#'
+#' @return `x` at the same precision, but with some components altered to be
+#'   at the boundary value.
+#'
+#' @name year-month-day-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")
+#'
+#' # Compare that with just setting the day of the month to `"last"`, which
+#' # doesn't adjust any other components
+#' set_day(x, "last")
+#'
+#' # You can't compute the start / end at a more precise precision than
+#' # the input is at
+#' try(calendar_start(x, "second"))
+NULL
+
+#' @rdname year-month-day-boundary
+#' @export
+calendar_start.clock_year_month_day <- function(x, precision) {
+  x_precision <- calendar_precision_attribute(x)
+  precision <- validate_precision_string(precision)
+
+  calendar_start_end_checks(x, x_precision, precision, "start")
+
+  if (precision <= PRECISION_YEAR && x_precision > PRECISION_YEAR) {
+    x <- set_month(x, 1L)
+  }
+  if (precision <= PRECISION_MONTH && x_precision > PRECISION_MONTH) {
+    x <- set_day(x, 1L)
+  }
+
+  x <- calendar_start_time(x, x_precision, precision)
+
+  x
+}
+
+#' @rdname year-month-day-boundary
+#' @export
+calendar_end.clock_year_month_day <- function(x, precision) {
+  x_precision <- calendar_precision_attribute(x)
+  precision <- validate_precision_string(precision)
+
+  calendar_start_end_checks(x, x_precision, precision, "end")
+
+  if (precision <= PRECISION_YEAR && x_precision > PRECISION_YEAR) {
+    x <- set_month(x, 12L)
+  }
+  if (precision <= PRECISION_MONTH && x_precision > PRECISION_MONTH) {
+    x <- set_day(x, "last")
+  }
+
+  x <- calendar_end_time(x, x_precision, precision)
+
+  x
+}
+
+# ------------------------------------------------------------------------------
+
 #' Sequences: year-month-day
 #'
 #' @description