Implement holiday/calendar API (#96)

* Implement holiday/calendar API

* NEWS bullet

NAMESPACE

@@ -1,14 +1,18 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,almanac_radjusted)
+S3method(print,almanac_rcalendar)
 S3method(print,almanac_rcustom)
+S3method(print,almanac_rholiday)
 S3method(print,almanac_rintersect)
 S3method(print,almanac_roffset)
 S3method(print,almanac_rrule)
 S3method(print,almanac_rsetdiff)
 S3method(print,almanac_runion)
 S3method(rschedule_events,almanac_radjusted)
+S3method(rschedule_events,almanac_rcalendar)
 S3method(rschedule_events,almanac_rcustom)
+S3method(rschedule_events,almanac_rholiday)
 S3method(rschedule_events,almanac_rintersect)
 S3method(rschedule_events,almanac_roffset)
 S3method(rschedule_events,almanac_rrule)
@@ -49,10 +53,40 @@ export(alma_seq)
 export(alma_step)
 export(almanac_since)
 export(almanac_until)
+export(cal_add)
+export(cal_events)
+export(cal_match)
+export(cal_names)
+export(cal_remove)
 export(daily)
+export(hol_christmas)
+export(hol_christmas_eve)
+export(hol_easter)
+export(hol_good_friday)
+export(hol_halloween)
+export(hol_new_years_day)
+export(hol_new_years_eve)
+export(hol_observe)
+export(hol_offset)
+export(hol_rename)
+export(hol_st_patricks_day)
+export(hol_us_election_day)
+export(hol_us_fathers_day)
+export(hol_us_independence_day)
+export(hol_us_indigenous_peoples_day)
+export(hol_us_juneteenth)
+export(hol_us_labor_day)
+export(hol_us_martin_luther_king_junior_day)
+export(hol_us_memorial_day)
+export(hol_us_mothers_day)
+export(hol_us_presidents_day)
+export(hol_us_thanksgiving)
+export(hol_us_veterans_day)
+export(hol_valentines_day)
 export(monthly)
 export(new_rschedule)
 export(radjusted)
+export(rcalendar)
 export(rcustom)
 export(recur_for_count)
 export(recur_on_day_of_month)
@@ -71,6 +105,7 @@ export(recur_on_yday)
 export(recur_on_ymonth)
 export(recur_on_yweek)
 export(recur_with_week_start)
+export(rholiday)
 export(rintersect)
 export(roffset)
 export(rschedule_events)

NEWS.md

@@ -1,5 +1,25 @@
 # almanac (development version)
 
+* New holiday and calendar API (#96):
+
+  * `rholiday()` creates a new holiday from a holiday name and a
+    rschedule that defines when the holiday occurs. There are a number of
+    pre-created holidays prefixed with `hol_*()`, such as `hol_christmas()`
+    and `hol_us_thanksgiving()`. Holidays are rschedules, so you can use all
+    of the `alma_*()` functions on them.
+
+  * `hol_observe()`, `hol_offset()`, and `hol_rename()` are three helpers for
+    the holiday API. In particular, `hol_observe()` tweaks a holiday's
+    _observance date_ to align with when your business actually celebrated that
+    holiday.
+
+  * `rcalendar()` bundles multiple holidays together into a calendar. Calendars
+    are similar to `runion()`s, so you can use all the `alma_*()` functions on
+    these, but they also come with their own specialized API of functions that
+    start with `cal_*()`, such as `cal_match()` to look up the holiday name a
+    date corresponds to, and `cal_events()` to filter for all of the holidays
+    within a particular year.
+
 * `recur_for_count()` no longer overrides `until` (#95).
 
 * New `almanac_since()` and `almanac_until()` helpers to access the default

R/cache-rcalendar.R

@@ -0,0 +1,118 @@
+cache_rcalendar <- R6::R6Class(
+  "cache_rcalendar",
+  cloneable = FALSE,
+
+  # ----------------------------------------------------------------------------
+  public = list(
+    initialize = function(names, rholidays)
+      cache_rcalendar__initialize(self, private, names, rholidays),
+
+    get_events = function(observed)
+      cache_rcalendar__get_events(self, private, observed),
+
+    get_events_frame = function(observed)
+      cache_rcalendar__get_events_frame(self, private, observed)
+  ),
+
+  # ----------------------------------------------------------------------------
+  private = list(
+    names = character(),
+    rholidays = list(),
+
+    observed = list(events = NULL, events_frame = NULL, built = FALSE),
+    unobserved = list(events = NULL, events_frame = NULL, built = FALSE),
+
+    cache_build = function(observed)
+      cache_rcalendar__cache_build(self, private, observed)
+  )
+)
+
+# ------------------------------------------------------------------------------
+
+cache_rcalendar__cache_build <- function(self, private, observed) {
+  names <- private$names
+  rholidays <- private$rholidays
+
+  # Which cache are we building?
+  if (observed) {
+    rholiday_rschedule <- rholiday_robserved
+  } else {
+    rholiday_rschedule <- rholiday_runobserved
+  }
+
+  # Get events for each rholidays
+  rschedules <- map(rholidays, rholiday_rschedule)
+  rschedules_events <- map(rschedules, rschedule_events)
+
+  # Build `events_frame` which holds all results, regardless of uniqueness,
+  # sorted by event date but ties go to the order in which they were added to
+  # the rcalendar
+  names <- vec_rep_each(names, times = list_sizes(rschedules_events))
+  events <- list_unchop(rschedules_events, ptype = new_date())
+
+  events_frame <- data_frame(name = names, date = events)
+  events_frame <- vec_slice(events_frame, vec_order(events))
+
+  # Now build `events`, which holds sorted unique results
+  events <- vec_unique(events_frame$date)
+
+  result <- list(
+    events = events,
+    events_frame = events_frame,
+    built = TRUE
+  )
+
+  if (observed) {
+    private$observed <- result
+  } else {
+    private$unobserved <- result
+  }
+
+  invisible(self)
+}
+
+# ------------------------------------------------------------------------------
+
+cache_rcalendar__get_events <- function(self, private, observed) {
+  if (observed) {
+    built <- private$observed$built
+  } else {
+    built <- private$unobserved$built
+  }
+
+  if (!built) {
+    private$cache_build(observed = observed)
+  }
+
+  if (observed) {
+    private$observed$events
+  } else {
+    private$unobserved$events
+  }
+}
+
+cache_rcalendar__get_events_frame <- function(self, private, observed) {
+  if (observed) {
+    built <- private$observed$built
+  } else {
+    built <- private$unobserved$built
+  }
+
+  if (!built) {
+    private$cache_build(observed = observed)
+  }
+
+  if (observed) {
+    private$observed$events_frame
+  } else {
+    private$unobserved$events_frame
+  }
+}
+
+# ------------------------------------------------------------------------------
+
+cache_rcalendar__initialize <- function(self, private, names, rholidays) {
+  private$names <- names
+  private$rholidays <- rholidays
+  self
+}