R/helpers.R

In CFtime: Using CF-Compliant Calendars with Climate Projection Data

# Internal functions
#
# The functions in this source file are for internal use only.

# ==============================================================================
# Offsets and timestamp formatting

#' Validate offsets passed into a CFTime instance
#'
#' Tests the `offsets` values. Throws an error if the argument contains `NA` values.
#'
#' @param offsets The offsets to test
#'
#' @returns logical. `TRUE` if the offsets are valid, throws an error otherwise.
#' @noRd
.validOffsets <- function(offsets) {
  if (any(is.na(offsets))) stop("Offsets cannot contain `NA` values.", call. = FALSE)
  TRUE
}

#' Formatting of time strings from time elements
#'
#' This is an internal function that should not generally be used outside of
#' the CFtime package.
#'
#' @param t A `data.frame` representing timestamps.
#'
#' @returns A vector of character strings with a properly formatted time. If any
#' timestamp has a fractional second part, then all time strings will report
#' seconds at milli-second precision.
#' @noRd
.format_time <- function(t) {
  fsec <- t$second %% 1L
  if (any(fsec > 0L)) {
    paste0(sprintf("%02d:%02d:", t$hour, t$minute), ifelse(t$second < 10, "0", ""), sprintf("%.3f", t$second))
  } else {
    sprintf("%02d:%02d:%02d", t$hour, t$minute, t$second)
  }
}

#' Do the time elements have time-of-day information?
#'
#' If any time information > 0, then `TRUE` otherwise `FALSE`.
#'
#' This is an internal function that should not generally be used outside of
#' the CFtime package.
#'
#' @param t A `data.frame` representing timestamps.
#'
#' @returns `TRUE` if any timestamp has time-of-day information, `FALSE` otherwise.
#' @noRd
.has_time <- function(t) {
  any(t$hour > 0) || any(t$minute > 0) || any(t$second > 0)
}

#' Do formatting of timestamps with format specifiers
#'
#' @param ts `data.frame` of decomposed offsets.
#' @param tz Time zone character string.
#' @param format A character string with the format specifiers, or
#' "date" or "timestamp".
#' @returns Character vector of formatted timestamps.
#' @noRd
.format_format <- function(ts, tz, format) {
  if (format == "") format <- "timestamp"
  if (format == "timestamp" && sum(ts$hour, ts$minute, ts$second) == 0)
    format <- "date"

  if (format == "date") return(sprintf("%04d-%02d-%02d", ts$year, ts$month, ts$day))
  else if (format == "timestamp") return(sprintf("%04d-%02d-%02dT%s", ts$year, ts$month, ts$day, .format_time(ts)))

  # Expand any composite specifiers
  format <- stringr::str_replace_all(format, c("%F" = "%Y-%m-%d", "%R" = "%H:%M", "%T" = "%H:%M:%S"))

  # Splice in timestamp values for specifiers
  # nocov start
  if (grepl("%b|%h", format[1])) {
    mon <- strftime(ISOdatetime(2024, 1:12, 1, 0, 0, 0), "%b")
    format <- stringr::str_replace_all(format, "%b|%h", mon[ts$month])
  }
  if (grepl("%B", format[1])) {
    mon <- strftime(ISOdatetime(2024, 1:12, 1, 0, 0, 0), "%B")
    format <- stringr::str_replace_all(format, "%B", mon[ts$month])
  }
  # nocov end
  format <- stringr::str_replace_all(format, "%[O]?d", sprintf("%02d", ts$day))
  format <- stringr::str_replace_all(format, "%e", sprintf("%2d", ts$day))
  format <- stringr::str_replace_all(format, "%[O]?H", sprintf("%02d", ts$hour))
  format <- stringr::str_replace_all(format, "%[O]?I", sprintf("%02d", ts$hour %% 12))
  format <- stringr::str_replace_all(format, "%[O]?m", sprintf("%02d", ts$month))
  format <- stringr::str_replace_all(format, "%[O]?M", sprintf("%02d", ts$minute))
  format <- stringr::str_replace_all(format, "%p", ifelse(ts$hour < 12, "AM", "PM"))
  format <- stringr::str_replace_all(format, "%S", sprintf("%02d", as.integer(ts$second)))
  format <- stringr::str_replace_all(format, "%[E]?Y", sprintf("%04d", ts$year))
  format <- stringr::str_replace_all(format, "%z", tz)
  format <- stringr::str_replace_all(format, "%%", "%")
  format
}

# ==============================================================================
# Other internal functions

#' Calculate time units in factors
#'
#' @param f factor. Factor as generated by `CFfactor()`.
#' @param cal `CFCalendar` instance of the `CFTime` instance.
#' @param upd numeric. Number of units per day, from the `CFt` environment.
#' @returns A vector as long as the number of levels in the factor.
#' @noRd
.factor_units <- function(f, cal, upd) {
  period <- attr(f, "period")
  cal_class <- class(cal)[1L]

  res <- if (period == "day")
    rep(1L, nlevels(f))
  else if (cal_class == "CFCalendar360") {
    rep(c(360L, 90L, 90L, 30L, 10L, 1L)[which(CFt$factor_periods == period)], nlevels(f))
  } else {
    if (attr(f, "era") > 0L) {
      if (cal_class == "CFCalendar366") {
        switch(period,
               "year"    = rep(366L, nlevels(f)),
               "season"  = c(91L, 92L, 92L, 91L)[as.integer(substr(levels(f), 2, 2))],
               "quarter" = c(91L, 91L, 92L, 92L)[as.integer(levels(f))],
               "month"   = c(31L, 29L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[as.integer(levels(f))],
               "dekad"   = {
                 dk <- as.integer(substr(levels(f), 2L, 3L))
                 ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
                        ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L, 9L))
               }
        )
      } else {
        switch(period,
               "year"    = rep(365L, nlevels(f)),
               "season"  = c(90L, 92L, 92L, 91L)[as.integer(substr(levels(f), 2, 2))],
               "quarter" = c(90L, 91L, 92L, 92L)[as.integer(substr(levels(f), 2, 2))],
               "month"   = c(31L, 28L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[as.integer(levels(f))],
               "dekad"   = {
                 dk <- as.integer(substr(levels(f), 2L, 3L))
                 ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
                        ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L, 8L))
               }
        )
      }
    } else {  # not an era factor
      switch(period,
             "year"    = ifelse(cal$leap_year(as.integer(levels(f))), 366L, 365L),
             "season"  = {
               year <- as.integer(substr(levels(f), 1L, 4L))
               season <- as.integer(substr(levels(f), 6L, 6L))
               ifelse(cal$leap_year(year), c(91L, 92L, 92L, 91L)[season], c(90L, 92L, 92L, 91L)[season])
             },
             "quarter" = {
               year <- as.integer(substr(levels(f), 1L, 4L))
               qtr  <- as.integer(substr(levels(f), 6L, 6L))
               ifelse(cal$leap_year(year), c(91L, 91L, 92L, 92L)[qtr], c(90L, 91L, 92L, 92L)[qtr])
             },
             "month"   = {
               year  <- as.integer(substr(levels(f), 1L, 4L))
               month <- as.integer(substr(levels(f), 6L, 7L))
               ifelse(cal$leap_year(year), c(31L, 29L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[month],
                      c(31L, 28L, 31L, 30L, 31L, 30L, 31L, 31L, 30L, 31L, 30L, 31L)[month])
             },
             "dekad"   = {
               year  <- as.integer(substr(levels(f), 1L, 4L))
               dk <- as.integer(substr(levels(f), 6L, 7L))
               ifelse(dk %% 3L > 0L | dk %in% c(12L, 18L, 27L, 33L), 10L,
                      ifelse(dk %in% c(3L, 9L, 15L, 21L, 24L, 30L, 36L), 11L,
                             ifelse(cal$leap_year(year), 9L, 8L)))
             }
      )
    }
  }
  res * upd
}