R/helpers.R

In tjtnew/grates: Grouped Date Classes

#' Date and POSIXct generators
#'
#' These functions allow the quick creation of Date and POSIXct objects
#'
#' @param x A double vector representing the number of days since the UNIX
#'   "epoch", 1970-01-01.
#' @param xx A double vector representing the number of seconds since the UNIX
#'   "epoch", 1970-01-01.
#' @param tzone A character vector representing the desired time zone.  Defaults
#'   to "" for the local time zone.  Possible values can be found with
#'   [OlsonNames()].
#'
#' @return
#' * `new_date`: a ([Date]) object.
#' * `new_posixct`: a ([POSIXct]) object.
#'
#' @examples
#' new_date(0)
#' new_posixct(0, tzone = "UTC")
#'
#' @keywords internal
#' @export
new_date <- function(x = double()) {
  class(x) <- "Date"
  x
}

#' @keywords internal
#' @rdname new_date
#' @export
new_posixct <- function(xx = double(), tzone = "") {
  class(xx) <- c("POSIXct", "POSIXt")
  attr(xx, "tzone") <- tzone
  xx
}
# -------------------------------------------------------------------------


# ------------------------------------------------------------------------- #
# ----------------------------- INTERNALS --------------------------------- #
# ------------------------------------------------------------------------- #


# check for suggested packages --------------------------------------------
check_suggests <- function(package) {
  if (!requireNamespace(package, quietly = TRUE)) {
    msg <- sprintf("Suggested package '%s' not present.", package)
    stop(msg, call. = FALSE)
  }
}
# -------------------------------------------------------------------------


# integer checking and conversion -----------------------------------------

# check if entries of a vector whole numbers
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) {
  abs(x - round(x)) < tol
}

# cast a vector to an integer
int_cast <- function(x) {
  if (!all(is.wholenumber(x) | is.na(x))) {
    msg <- paste(deparse1(substitute(x)), "must be a whole number")
    stop(msg, call. = FALSE)
  }
  as.integer(x)
}
# -------------------------------------------------------------------------

is.Date <- function(x) inherits(x, "Date")

tzone <- function(x) {
  tz <- attr(x, "tzone")
  if(is.null(tz)) "" else tz
}


# The following is based on a functions of Davis Vaughan in
# https://github.com/DavisVaughan/datea/blob/master/R/ymon-as.R.
# It is quicker than doing as.POSIXct.Date and will work with
# all date and grate objects.
as_utc_posixct_from_int <- function(x) {
  attributes(x) <- NULL
  x <- x * 86400 # multiply by seconds in day (24 * 60 * 60)
  structure(x, tzone = "UTC", class = c("POSIXct", "POSIXt"))
}

as_zoned_posixct_from_int <- function(x, tz) {
  attributes(x) <- NULL
  x <- as.character(new_date(x))
  as.POSIXct(x, tz = tz)
}

# The following is based on a functions of Davis Vaughan in
# https://github.com/DavisVaughan/datea/blob/master/R/ymon-as.R.
# It is quicker than doing as.POSIXlt.Date and will work with
# all date and grate objects.
as_utc_posixlt_from_int <- function(x) {
  attributes(x) <- NULL
  x <- x * 86400 # multiply by seconds in day (24 * 60 * 60)
  as.POSIXlt(x, tz = "UTC", origin = new_posixct(xx = 0, tzone = "UTC"))
}

as_zoned_posixlt_from_int <- function(x, tz) {
  attributes(x) <- NULL
  x <- as.character(new_date(x))
  as.POSIXlt(x, tz = tz)
}


# -------------------------------------------------------------------------


add_months <- function(x, n) {
  x <- as_utc_posixlt_from_int(x)
  x$mon <- x$mon + n
  x <- as.Date(x)
  new_yrmon(unclass(x))
}

add_quarters <- function(x, n) {
  x <- as_utc_posixlt_from_int(x)
  x$mon <- x$mon + (3 * n)
  x <- as.Date(x)
  new_yrqtr(unclass(x))
}

add_periods <- function(x, n) {
  out <- unclass(x)
  d <- attr(x, "interval")
  if (is.integer(d)) {
    out <- out + (n * d)
  } else {
    dn <- get_interval_number(d) * n
    dt <- get_interval_type(d)
    by = paste(dn, dt)
    out <- vapply(
      new_date(out),
      function(x) seq.Date(x, by = by, length.out = 2)[2],
      double(1)
    )
  }

  start <- min(attr(x, "start"), min(x))
  new_period(out, interval = d, firstdate = start)
}

yrmon_difftime <- function(x, y) {
  x <- as_utc_posixlt_from_int(x)
  y <- as_utc_posixlt_from_int(y)
  12L * (x$year - y$year) + (x$mon - y$mon)
}


# other useful conversions ------------------------------------------------

last_week_in_year <- function(year = integer(), firstday = 1L) {
  x <- as.Date(sprintf("%d-12-28", year))
  wday <- strptime(sprintf("%d-12-28", year), format="%Y-%m-%d", tz = "UTC")$wday
  wday <- 1L + (wday + (7L - firstday)) %% 7L
  midweek <- x + (4L - wday)
  seven_day_week_in_year(date = midweek)
}

seven_day_week_in_year <- function(date) {
  xx <- as_utc_posixlt_from_int(date)
  yr <- xx$year + 1900L
  jan1 <- sprintf("%d-01-01", yr)
  jan1 <- as.Date(strptime(jan1, format = "%Y-%m-%d", tz = "UTC"))
  res <- 1 + (unclass(date) - unclass(jan1)) %/% 7
  attributes(res) <- NULL
  res
}

numeric_yrwk_to_date <- function(year = integer(), week = integer(), firstday = integer()) {
  jan4 <- strptime(sprintf("%d-01-04", year), format="%Y-%m-%d", tz = "UTC")
  wday <- jan4$wday
  out <- jan4 - ((wday + 7L - firstday) %% 7) * 86400
  out <- out + (week - 1) * 7L * 86400
  as.Date(out)
}


is_leap_year <- function(year) {
  ((((year) %% 4) == 0 & ((year) %% 100) != 0) | ((year) %% 400) == 0)
}

delayedAssign(
  "QUARTER_DAYS_IN_MONTH_BEFORE",
  c(0L, 31L, 59L, 0L, 30L, 61L, 0L, 31L, 62L, 0L, 31L, 61L)
)


quarter_days_before_month <- function(year, month) {
  QUARTER_DAYS_IN_MONTH_BEFORE[month] + ((month == 3) & is_leap_year(year))
}


delayedAssign(
  "DAYS_IN_MONTH",
  c(31L, 28L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)
)

days_in_month <- function(year, month) {
  DAYS_IN_MONTH[month] + ((month == 2) & is_leap_year(year))
}


delayedAssign(
  "DAYS_IN_QUARTER",
  c(90L, 91L, 92L, 92L)
)

days_in_quarter <- function(year, quarter) {
  DAYS_IN_QUARTER[quarter] + ((quarter == 1) & is_leap_year(year))
}

delayedAssign(
  "DAYS_BEFORE_MONTH",
  c(0L, 31L, 59L, 90L, 120L, 151L, 181L, 212L, 243L, 273L, 304L, 334L)
)

days_before_month <- function(year, month) {
  DAYS_BEFORE_MONTH[month] + ((month > 2) & is_leap_year(year))
}

month_to_days <- function(months) {
  year <- months %/% 12L + 1970L
  month <- months %% 12L + 1L
  days_before_year(year) + days_before_month(year, month) - 719162L
}

date_to_month <- function(x) {
  x <- as_utc_posixlt_from_int(x)
  yr <- x$year + 1900L
  mon <- x$mon
  mon <- (yr - 1970L) * 12L + mon
  mon
}

days_before_year <- function(year = integer()) {
  year <- year - 1L
  year*365 + (year %/% 4) - (year %/% 100) + (year %/% 400)
}