R/period.R

In marberts/ppd: Prices Production and Development

#' End points for calendar periods
#' @param x A vector of dates.
#' @param period One of 'month', 'quarter', or 'year'.
#' @param start.mon Starting month of a year, beginning at 1 for January.
#' @return A pair of POSIXlt that bound \code{x}.
#' @details This is a simple helper function to make a sequence of dates to cut \code{x}.
#' There is no argument checking, and it should probably not be called directly.

period_ends <- function(x, period, start.mon){
  m <- as.POSIXlt(c(min(x, na.rm = TRUE), max(x, na.rm = TRUE)), tz = 'UTC')
  m$mday <- 1
  m$mon <- m$mon - start.mon + 1L
  ends <- as.POSIXlt(cut(m, period), tz = 'UTC')
  ends$mon <- ends$mon + start.mon - 1L
  ends[2] <- seq(ends[2], length.out = 2, by = period)[2]
  ends
}

#' Calendar periods
#' @export
#' @description Create a function to turn dates into calendar periods.
#' @param period One of 'month' (default), 'quarter', or 'year'.
#' @param start.mon In which month does a year start (default is January)?
#' @return A function.
#' @seealso \code{\link[ppd]{year_month}} for an application.
#' @details This function creates a simple wrapper for \code{\link[base]{cut.POSIXt}}.
#' By default it turns a date into the first day in a given calendar period, essentially rounding down dates.
#' 
#' Non-standard calendar periods that do not start in January (e.g., fiscal years) can be constructed by choosing a different starting month for a year with \code{start.mon}.
#'
#' This function is an alternative to some useful features in \code{zoo}.
#' It is essentially creates a drop-in replacement for \code{as.Date(as.yearmon(as.Date))}.
#' When dates are clustered, as in most time-series application, performance is about the same as the \code{zoo} equivalent.
#' Performance can be much faster when working with microdata, and is usually slower when working with few dates that are spread out.

calendar_period <- function(period = c('month', 'quarter', 'year'), start.mon = month.name) {
  # match period and start.mon
  period <- match.arg(period)
  start.mon <- match(match.arg(start.mon), month.name)
  # return function
  function(x, shift = 0, frac = 0) {
    # frac and shift should be length 1 numbers
    stopifnot(
      length(frac) == 1L,
      length(shift) == 1L,
      is.finite(frac),
      is.finite(shift),
      is.atomic(x)
    )
    # x should be a date
    x <- as.Date(x)
    if (length(x) == 0L || all(is.na(x))) return(x)
    # make a sequence of calendar periods that spans x
    ends <- period_ends(x, period, start.mon)
    s <- seq.Date(as.Date(ends[1]), as.Date(ends[2]), period)
    # use this sequence to bin x
    loc <- cut.Date(x, s, FALSE)
    # shift sequence 
    ends$mon <- ends$mon + shift
    ends <- as.Date(ends)
    s0 <- seq.Date(ends[1], ends[2], period)
    # return calendar periods in a bin
    x0 <- s0[loc]
    if (identical(frac, 0)) return(x0)
    # if frac != 0 then calculate last day in a calendar period
    s1 <- seq.Date(ends[1], by = period, length.out = length(s0) + 1L)[-1] - 1
    x1 <- s1[loc]
    if (identical(frac, 1)) return(x1)
    # if frac != 1 take a combination of the first day and last day in a calendar period
    as.Date(frac*as.numeric(x1) + (1 - frac)*as.numeric(x0), origin = '1970-01-01')
  }
}

#' Year month/year quarter/year
#' @export
#' @description Turn dates into year months/year quarters/years.
#' @param x A date, or something that can be coerced into one.
#' @param shift Number of months to shift up/down dates in x (0 by default).
#' @param frac Should calendar periods be formatted as the first day in a period (0, the default), the last day (1), or some point in between?
#' @return A vector of dates.
#' @seealso See \code{\link[ppd]{complete_quarters}} for an application, and \code{\link[ppd]{calendar_period}} for non-standard calendar periods.
#' @examples
#' # Turn dates into year-months
#' x <- as.Date(c('2018-01-15', '2018-01-03', '2018-02-24'))
#' year_month(x)
#' 
#' # Turn year-months into year-quarters
#' x <- as.Date(c('2018-01-01', '2018-02-01', '2018-04-01'))
#' year_quarter(x)
#'
#' # Format as the last day in a quarter
#' year_quarter(x, frac = 1)
#'
#' \dontrun{
#' # This can also be done with zoo
#' library(zoo)
#' as.Date(as.yearqtr(x))
#' as.Date(as.yearqtr(x), frac = 1)
#' }
#'
#' # Find periods one month ago
#' match(year_month(x, -1), year_month(x))
year_month <- calendar_period('month')

#' @rdname year_month
#' @export
year_quarter <- calendar_period('quarter')

#' @rdname year_month
#' @export
year <- calendar_period('year')

#' Complete periods
#' @export
#' @description Create a function to identify which elements in a vector of dates correspond to complete calendar periods.
#' @param period One of 'quarter' (default) or 'year'.
#' @param by One of 'month' (default) or 'quarter'.
#' @param start.mon In which month does a year start (default is January)?
#' @return A function.
#' @seealso \code{\link[ppd]{complete_quarters}} for an application.

complete_periods <- function(period = c('quarter', 'year'), 
                            by = c('month', 'quarter'), 
                            start.mon = month.name) {
  # match arguments
  period <- match.arg(period)
  by <- match.arg(by)
  mon <- match(match.arg(start.mon), month.name)
  # count for each period
  k <- switch(period, quarter = 1L, year = 4L) * switch(by, month = 3L, quarter = 1L)
  # return value
  function(x, f) {
    stopifnot(
      is.atomic(x), 
      missing(f) || is.atomic(f), 
      missing(f) || length(x) == length(f)
    )
    # function to find complete periods
    cp <- function(x) {
      # x should be a vector of dates
      x <- as.Date(x)
      if (length(x) == 0L) {
        return(logical(0))
      } else if (all(is.na(x))) {
        return(rep(NA, length(x)))
      }
      # do nothing if period == by
      if (period == by) return(rep(TRUE, length(x)))
      # turn x into calendar periods
      xb <- calendar_period(by, start.mon)(x, 1L - mon)
      # which periods are complete?
      tab <- tabulate(cut.Date(unique(xb), period, FALSE)) == k
      # output
      out <- cut.Date(xb, period, FALSE) %in% which(tab)
      out[is.na(x)] <- NA
      out
    }
    if (missing(f)) {
      # apply cp to x if f is missing
      cp(x)
    } else {
      # turn f into a factor and use it to split x, then apply cp
      f <- as.factor(f)
      out <- vector(length = length(x))
      split(out, f) <- lapply(split(x, f), cp)
      out[is.na(f)] <- NA
      out
    }
  }
}

#' Complete quarters/years
#' @export
#' @description Identify which elements in a vector of dates correspond to complete quarter/years.
#' @param x A vector of dates, or something that can be coerced into one.
#' @param f A factor the same length as \code{x}, or an atomic vector to be turned into a factor, that is used to group \code{x}.
#' @return A logical vector.
#' @details
#' This function counts the unique year-month/year-quarters in \code{x} and returns which elements of \code{x} belong to a year-quarter/year with the appropriate number of year-month/year-quarters.
#' For example, \code{complete_quarters} returns TRUE for an element of \code{x} if there are three distinct year-months in the corresponding year-quarter to which this element of \code{x} belongs.
#' NAs return NA.
#' 
#' If \code{f} is given then \code{x} is split according to \code{f} before finding complete quarters/years in \code{x}.
#' @seealso \code{\link[ppd]{complete_periods}} for checking completeness of non-standard calendar periods.
#' @examples
#' # Which elements in a monthly series form complete quarters?
#' x <- seq(as.Date('2018-01-01'), as.Date('2019-04-01'), 'month')
#' x[complete_quarters(x)]
#' x[complete_quarters(x, c(rep('a', 10), rep('b', 6)))]
#'
#' \dontrun{
#' # Can be done manually with zoo
#' library(zoo)
#' x <- unique(as.yearmon(x))
#' f <- factor(as.yearqtr(x))
#' x[as.character(as.yearqtr(x)) %in% levels(f)[tabulate(f) == 3]]
#' }
#'
#' # Which elements in a monthly series form complete years?
#' x[complete_years_m(x)]
#'
#' # Which elements in a quarterly series form complete years?
#' y <- seq(as.Date('2018-01-01'), as.Date('2019-04-01'), 'quarter')
#' y[complete_years_q(y)]
complete_quarters <- complete_periods('quarter', 'month')

#' @rdname complete_quarters
#' @export
complete_years_m <- complete_periods('year', 'month')

#' @rdname complete_quarters
#' @export
complete_years_q <- complete_periods('year', 'quarter')


# encode_period <- function(period = c('month', 'quarter', 'year'), start.mon = month.name){
#   period <- match.arg(period)
#   start.mon <- match(match.arg(start.mon), month.name)
#   function(...) {
#     args <- lapply(list(...), as.Date)
#     x <- structure(unlist(args, use.names = FALSE), class = 'Date')
#     if (length(x) == 0L || all(is.na(x))) return(x)
#     ends <- as.Date(period_ends(x, period, start.mon))
#     s <- seq.Date(ends[1], ends[2], period)
#     f <- unlist(lapply(seq_along(args), function(z) rep(z, length(args[[z]]))))
#     out <- split(cut.Date(x, s, FALSE), factor(f, levels = seq_along(args)))
#     names(out) <- names(args)
#     structure(out, ref = ends[1])
#   }
# }