Nothing
## time_util_fun.R | ds4psy
## hn | uni.kn | 2023 09 13
## ------------------------
## (0) Utility functions for date and time data and objects. ------
## (A) Class of date/time object: ------
# is_Date: -----
is_Date <- function(date){
inherits(date, "Date")
}
# is_POSIXt: -----
is_POSIXt <- function(time){
inherits(time, "POSIXt")
}
# is_POSIXct: -----
is_POSIXct <- function(time){
inherits(time, "POSIXct")
}
# is_POSIXlt: -----
is_POSIXlt <- function(time){
inherits(time, "POSIXlt")
}
# is_difftime: -----
is_difftime <- function(time){
inherits(time, "difftime")
}
# is_time: -----
is_time <- function(t){
is_POSIXt(t) | is_difftime(t)
}
# is_date_time: -----
is_date_time <- function(dt){
is_Date(dt) | is_time(dt)
}
# ## Check:
# d <- Sys.Date()
# t <- Sys.time()
#
# is_Date(d)
# is_Date(t)
#
# is_POSIXt(d)
# is_POSIXt(t)
#
# is_POSIXct(d)
# is_POSIXct(t)
#
# is_POSIXlt(d)
# is_POSIXlt(t)
# is_POSIXlt(as.POSIXlt(t))
#
# is_difftime(d)
# is_difftime(t)
# is_difftime((t + 1) - t)
#
# is_time(d)
# is_time(t)
# is_time(as.POSIXlt(t))
# is_time((t + 1) - t)
#
# is_date_time(d)
# is_date_time(t)
# is_date_time(as.POSIXlt(t))
# is_date_time((t + 1) - t)
## (B) Parsing "Date" from non-dates: ------
# date_frms_*: Standard date formats: ------
sps <- c("", "-", "/", ".", " ") # separators
# Ymd:
df_Ym <- paste0("%Y", sps, "%m", sps, "%d")
df_Yb <- paste0("%Y", sps, "%b", sps, "%d")
df_YB <- paste0("%Y", sps, "%B", sps, "%d")
# ymd:
df_ym <- paste0("%y", sps, "%m", sps, "%d")
df_yb <- paste0("%y", sps, "%b", sps, "%d")
df_yB <- paste0("%y", sps, "%B", sps, "%d")
# dmY:
df_mY <- paste0("%d", sps, "%m", sps, "%Y")
df_bY <- paste0("%d", sps, "%b", sps, "%Y")
df_BY <- paste0("%d", sps, "%B", sps, "%Y")
# dmy:
df_my <- paste0("%d", sps, "%m", sps, "%y")
df_by <- paste0("%d", sps, "%b", sps, "%y")
df_By <- paste0("%d", sps, "%B", sps, "%y")
# combine:
date_frms_Ymd <- c(df_Ym, df_Yb, df_YB)
date_frms_ymd <- c(df_ym, df_yb, df_yB)
date_frms_dmY <- c(df_mY, df_bY, df_BY)
date_frms_dmy <- c(df_my, df_by, df_By)
# date_from_string: Parse a string into "Date": ------
date_from_string <- function(x, tz = "", ...){
# 0. Initialize:
dt <- NA
# 1. Prepare: ----
if (is_Date(x)){ return(x) } # fast exit
if (!is.character(x)){
# message("date_from_string: Coercing x into a character string.")
x <- as.character(x)
}
# 2. Aim to identify date format: ----
x_1 <- x[1] # Heuristic: Check 1st item: Position of 4-digit year (yyyy)?
if (grepl(x = x_1, pattern = "^(\\d\\d\\d\\d)")){ # yyyy first:
date_frms <- date_frms_Ymd
} else if (grepl(x = x_1, pattern = "(\\d\\d\\d\\d)$")){ # yyyy at end:
date_frms <- date_frms_dmY
} else { # year is yy:
date_frms <- c(date_frms_ymd, date_frms_dmy) # => prefer yy first.
}
# 3. Main: Parse x as.Date(x) using date_frms: ----
dt <- as.Date(x, tz = tz, tryFormats = date_frms, ...)
# 4. Output:
return(dt)
} # date_from_string end.
# ## Check:
# date_from_string("2010-08-12")
# date_from_string("12.08.2010")
# date_from_string("12 Aug 2010")
# date_from_string("12 August 2010")
#
# # Note preference for year first:
# date_from_string("10-8-12") # "2010-08-12"
# date_from_string("12-8-10") # "2012-08-10"
#
# # Note some flexibility:
# date_from_string(Sys.Date()) # dates are returned as is
# date_from_string("20100812") # no separators (Y first)
# date_from_string(20100812) # coercing numbers into strings
# date_from_string(Sys.time()) # times are returned as dates
#
# # for vectors:
# date_from_string(c("10-8-12", "12-8-10"))
# date_from_string(c(20100812, 20120810))
#
# # fame data (with format string):
# date_from_string(fame$DOB, format = "%B %d, %Y")
#
# # (!) NOT accounted for:
# date_from_string("August 10, 2010") # BdY
# # but works with format string:
# date_from_string("August 10, 2010", format = "%B %d, %Y")
#
# date_from_string("12.8") # no year
# # but providing formats works (adding default year):
# date_from_string("12.8", format = "%d.%m")
# date_from_string("12.8", format = "%m.%d")
#
# date_from_string(c("12-8-2010", "12-Aug-10")) # mix of formats
# date_from_string(c("2010-8-12", "12-8-2010")) # mix of orders
# date_from_noDate: Parse non-Date into "Date" object(s): ------
date_from_noDate <- function(x, tz = "", ...){
# 0. Initialize:
dt <- NA
# 1. Prepare: ----
if (is_Date(x)){ return(x) } # fast exit
# Coerce numeric x that are NOT date-time objects into character strings:
if (!is_date_time(x) & is.numeric(x)){
# message('date_from_noDate: Coercing x from "number" into "character".')
x <- as.character(x)
}
# 2. Main: Coerce non-Date objects into "Date" objects: ----
# A. Aim to coerce character string inputs x into "Date":
if (is.character(x)){
# message('date_from_noDate: Aiming to parse x from "character" as "Date".')
dt <- date_from_string(x, tz = tz, ...)
}
# B. Coerce "POSIXt" inputs into "Date":
if (is_POSIXt(x)){
# message('date_from_noDate: Coercing x from "POSIXt" into "Date".')
dt <- as.Date(x, tz = tz, ...)
}
# 3. Verify "Date": ----
if (!is_Date(dt)){
message('date_from_noDate: Failed to parse x as "Date".')
}
# 4. Output:
return(dt)
} # date_from_noDate end.
# ## Check:
# date_from_noDate(20100612) # number
# date_from_noDate("20100612") # string
#
# # Note effect of time zones:
# # (a) calendar times (POSIXct):
# date_from_noDate(as.POSIXct("2020-01-01 08:00:00", tz = "Pacific/Auckland")) # is interpreted as
# date_from_noDate(as.POSIXct("2020-01-01 08:00:00", tz = "Pacific/Auckland"), tz = "") # NZ time in current time zone!
# date_from_noDate(as.POSIXct("2020-01-01 08:00:00", tz = "Pacific/Auckland"), tz = "Pacific/Auckland") # NZ time in NZ time zone.
# # (b) local times (POSIXlt):
# date_from_noDate(as.POSIXlt("2020-01-01 08:00:00", tz = "Pacific/Auckland"))
#
# # Former problem/error now resolved:
# date_from_noDate(as.POSIXct("2020-07-01 01:29:06")) # was "2020-06-30" - WHY???
# date_from_noDate(as.POSIXct("2020-07-01 01:29:06"), tz = "") # now "2020-07-01"
# Solution: Add default argument tz = "".
# # fame data (with format string):
# date_from_noDate(fame$DOB, format = "%B %d, %Y")
#
# # Note errors for:
# date_from_noDate(123)
# date_from_noDate("ABC")
# time_from_string: Parse a string into "POSIXt" (without tz): ------
time_from_string <- function(x, tz = "", ...){
# 0. Initialize:
t <- NA
# 1. Prepare: ----
if (is_POSIXt(x)){ return(x) } # fast exit
if (!is.character(x)){
# message("time_from_string: Coercing x into a character string.")
x <- as.character(x)
}
# 2. Main: Convert x into POSIXct: ----
t <- as.POSIXct(x,
tz = tz, # Note: tz = "" by default.
tryFormats = c(# format strings:
# y: yy
"%y%m%d%H%M%OS",
"%y-%m-%d %H:%M:%OS",
"%y/%m/%d %H:%M:%OS",
"%y-%m-%d %H.%M.%OS",
"%y/%m/%d %H.%M.%OS",
"%y%m%d%H%M",
"%y-%m-%d %H:%M",
"%y/%m/%d %H:%M",
"%y-%m-%d %H.%M",
"%y/%m/%d %H.%M",
"%y%m%d",
"%y-%m-%d",
"%y/%m/%d",
# Y: yyyy
"%Y%m%d%H%M%OS",
"%Y-%m-%d %H:%M:%OS",
"%Y/%m/%d %H:%M:%OS",
"%Y-%m-%d %H.%M.%OS",
"%Y/%m/%d %H.%M.%OS",
"%Y%m%d%H%M",
"%Y-%m-%d %H:%M",
"%Y/%m/%d %H:%M",
"%Y-%m-%d %H.%M",
"%Y/%m/%d %H.%M",
"%Y%m%d",
"%Y-%m-%d",
"%Y/%m/%d",
# no date:
"%H%M%OS",
"%H:%M:%OS",
"%H.%M.%OS",
"%H%M",
"%H:%M",
"%H.%M"),
optional = FALSE,
...)
# 3. Output:
return(t)
} # time_from_string end.
# ## Check:
# # from character:
# time_from_string(c("2020-01-01 10:30:45", "2020-06-30 22:30:50"))
# time_from_string(c("2020/01/01 10.30.45", "2020/06/30 22.30.50"))
# time_from_string(c("20-01-01 10:30", "20-06-30 22:30"))
#
# # # from numeric:
# time_from_string(201005103045) # date-time
# time_from_string(201005) # date
# time_from_string(1030) # time (today)
#
# # with format:
# time_from_string(c("6|8|10 10<30<45"), format = "%m|%d|%y %H<%M<%S")
# time_from_string(c("June 8, 2010, 10-30"), format = "%B %d, %Y, %H-%M")
#
# # with tz:
# time_from_string(c("20-01-01 10:30:45", "20-06-30 22:30:50"), tz = "Pacific/Auckland")
# time_from_noPOSIXt: Parse non-time into "POSIXt" (typically POSIXct) object(s): ------
time_from_noPOSIXt <- function(x, tz = "", ...){
# 0. Initialize:
t <- NA
# 1. Prepare: ----
if (is_POSIXt(x)){ return(x) } # fast exit
# Coerce numeric x that are NOT date-time objects into character strings:
if (!is_date_time(x) & is.numeric(x)){
# message('time_from_noPOSIXt: Coercing x from "number" into "character".')
x <- as.character(x)
}
# 2. Main: Coerce non-time objects into "POSIXct" objects: ----
# A. Aim to coerce character string inputs x into "POSIXct":
if (is.character(x)){
# message('time_from_noPOSIXt: Aiming to parse x from "character" as "POSIXct".')
t <- time_from_string(x, tz = tz, ...) # Note: tz = "" by default.
}
# B. Coerce "Date" inputs into "POSIXct" objects:
if (is_Date(x)){
# message('time_from_noPOSIXt: Coercing x from "Date" into "POSIXct".')
t <- as.POSIXct(x, tz = tz, ...) # Note: tz = "" by default.
}
# 3. Verify "POSIXct": ----
if (!is_POSIXct(t)){
message('time_from_noPOSIXt: Failed to parse x as "POSIXct".')
}
# # +. Convert from POSIXct to POSIXlt with tz:
# t <- as.POSIXlt(t, tz = tz, ...) # Note: tz = "" by default.
# 4. Output:
return(t)
} # time_from_noPOSIXt end.
# ## Check:
# # Any POSIXt returned as is:
# is_POSIXct(time_from_noPOSIXt(Sys.time() + 0:2))
# is_POSIXlt(time_from_noPOSIXt(as.POSIXlt(Sys.time() + 0:2)))
#
# # from "Date":
# time_from_noPOSIXt(Sys.Date() + seq(0, 720, by = 180)) # note tz changes
#
# # from character:
# time_from_noPOSIXt(c("2020-01-01 10:30:45", "2020-06-30 22:30:50"))
# time_from_noPOSIXt(c("2020/01/01 10.30.45", "2020/06/30 22.30.50"))
# time_from_noPOSIXt(c("20-01-01 10:30", "20-06-30 22:30"))
#
# # # from numeric:
# time_from_noPOSIXt(201005103045) # date-time
# time_from_noPOSIXt(201005) # date
# time_from_noPOSIXt(1030) # time (today)
#
# # with format:
# time_from_noPOSIXt(c("6|8|10 10<30<45"), format = "%m|%d|%y %H<%M<%S")
# time_from_noPOSIXt(c("June 8, 2010, 10-30"), format = "%B %d, %Y, %H-%M")
#
# # with tz:
# time_from_noPOSIXt(c("20-01-01 10:30:45", "20-06-30 22:30:50"), tz = "Pacific/Auckland")
## (C) Temporal idiosyncracies: ------
# diff_tz: Difference between 2 time zones (in "HH:MM" format or as nr. of minutes): ------
#' Get the time zone difference between two times.
#'
#' \code{diff_tz} computes the time difference
#' between two times \code{t1} and \code{t2}
#' that is exclusively due to both times being in
#' different time zones.
#'
#' \code{diff_tz} ignores all differences in nominal times,
#' but allows adjusting time-based computations
#' for time shifts that are due to time zone differences
#' (e.g., different locations, or
#' changes to/from daylight saving time, DST),
#' rather than differences in actual times.
#'
#' Internally, \code{diff_tz} determines and contrasts the POSIX
#' conversion specifications "%Z" and "%z" for both times
#' (in numeric form).
#'
#' If the lengths of \code{t1} and \code{t2} differ,
#' the shorter vector is recycled to the length of the longer one.
#'
#' @param t1 First time (required, as "POSIXt" time point/moment).
#'
#' @param t2 Second time (required, as "POSIXt" time point/moment).
#'
#' @param in_min Return time-zone based time
#' difference in minutes (Boolean)?
#' Default: \code{in_min = FALSE}.
#'
#' @return A character (in "HH:MM" format) or
#' numeric vector (number of minutes).
#'
#' @examples
#' # Time zones differences:
#' tm <- "2020-01-01 01:00:00" # nominal time
#' t1 <- as.POSIXct(tm, tz = "Pacific/Auckland")
#' t2 <- as.POSIXct(tm, tz = "Europe/Berlin")
#' t3 <- as.POSIXct(tm, tz = "Pacific/Honolulu")
#'
#' # as character (in "HH:MM"):
#' diff_tz(t1, t2)
#' diff_tz(t2, t3)
#' diff_tz(t1, t3)
#'
#' # as numeric (in minutes):
#' diff_tz(t1, t3, in_min = TRUE)
#'
#' # Compare local times (POSIXlt):
#' t4 <- as.POSIXlt(Sys.time(), tz = "Pacific/Auckland")
#' t5 <- as.POSIXlt(Sys.time(), tz = "Europe/Berlin")
#' diff_tz(t4, t5)
#' diff_tz(t4, t5, in_min = TRUE)
#'
#' # DSL shift: Spring ahead (on 2020-03-29: 02:00:00 > 03:00:00):
#' s6 <- "2020-03-29 01:00:00 CET" # before DSL switch
#' s7 <- "2020-03-29 03:00:00 CEST" # after DSL switch
#' t6 <- as.POSIXct(s6, tz = "Europe/Berlin") # CET
#' t7 <- as.POSIXct(s7, tz = "Europe/Berlin") # CEST
#'
#' diff_tz(t6, t7) # 1 hour forward
#' diff_tz(t6, t7, in_min = TRUE)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{days_in_month}} for the number of days in given months;
#' \code{\link{is_leap_year}} to check for leap years.
#'
#' @export
diff_tz <- function(t1, t2, in_min = FALSE){
# 0. Initialize:
n <- length(t1)
hm_diff <- rep(NA, n)
hr_diff <- rep(NA, n)
mi_diff <- rep(NA, n)
# 1. Handle inputs: ----
if (!is_POSIXct(t1)){
t1 <- time_from_noPOSIXt(t1)
}
if (!is_POSIXct(t2)){
t2 <- time_from_noPOSIXt(t2)
}
# Recycle shorter time argument to length of longer one: ----
aligned_v <- align_vec_pair(v1 = t1, v2 = t2)
t1 <- aligned_v[[1]]
t2 <- aligned_v[[2]]
# # WAS: Recycle or truncate t2 argument based on t1:
# t2 <- align_vector_length(v_fixed = t1, v_change = t2)
# message(paste0("t2 = ", t2, collapse = " ")) # debugging
# 2. Main: ----
# Query t1 and t2:
tz_1 <- format(t1, "%Z") # time zone label
tz_2 <- format(t2, "%Z")
td_1 <- format(t1, "%z") # difference from UTC
td_2 <- format(t2, "%z")
# Compute difference for different tz:
# # (a) If tz differ:
# if ((tz_1 != tz_2) | (td_1 != td_2)){
#
# # message("Time zones differ. Computing difference t2 - t1:")
#
# hr_diff <- num_as_char(as.numeric(substr(td_2, 1, 3)) - as.numeric(substr(td_1, 1, 3)), n_pre_dec = 2, n_dec = 0)
# mi_diff <- num_as_char(as.numeric(substr(td_2, 4, 5)) - as.numeric(substr(td_1, 4, 5)), n_pre_dec = 2, n_dec = 0)
#
# }
# (b) Vectorized solution:
ix_diff <- ((tz_1 != tz_2) | (td_1 != td_2)) # identify cases with tz differences
hr_diff[ix_diff] <- as.numeric(substr(td_2[ix_diff], 1, 3)) - as.numeric(substr(td_1[ix_diff], 1, 3))
mi_diff[ix_diff] <- as.numeric(substr(td_2[ix_diff], 4, 5)) - as.numeric(substr(td_1[ix_diff], 4, 5))
hr_diff[!ix_diff] <- 0
mi_diff[!ix_diff] <- 0
# 3. Prepare output: ----
if (in_min){
hm_diff <- (hr_diff * 60) + mi_diff
} else { # return as character (in HH:MM format):
hr_diff <- num_as_char(hr_diff, n_pre_dec = 2, n_dec = 0)
mi_diff <- num_as_char(mi_diff, n_pre_dec = 2, n_dec = 0)
hm_diff <- paste0(hr_diff, ":", mi_diff)
}
# 4. Output:
return(hm_diff)
} # diff_tz end.
# ## Check:
#
## 1. Time zones differences:
# tm <- "2020-01-01 01:00:00" # nominal time
# t1 <- as.POSIXct(tm, tz = "Pacific/Auckland")
# t2 <- as.POSIXct(tm, tz = "Europe/Berlin")
# t3 <- as.POSIXct(tm, tz = "Pacific/Honolulu")
#
# # as character (in "HH:MM"):
# diff_tz(t1, t2)
# diff_tz(t2, t3)
# diff_tz(t1, t3)
#
# # as numeric (in minutes):
# diff_tz(t1, t2, in_min = TRUE)
# diff_tz(t2, t3, in_min = TRUE)
# diff_tz(t1, t3, in_min = TRUE)
#
# ## 2. Compare local times (POSIXlt):
# t4 <- as.POSIXlt(Sys.time(), tz = "Pacific/Auckland")
# t5 <- as.POSIXlt(Sys.time(), tz = "Europe/Berlin")
# diff_tz(t4, t5)
#
# ## 3. DSL shift: Spring ahead (on 2020-03-29: 02:00:00 > 03:00:00):
# s6 <- "2020-03-29 01:00:00 CET" # before DSL switch
# s7 <- "2020-03-29 03:00:00 CEST" # after DSL switch
# t6 <- as.POSIXct(s6, tz = "Europe/Berlin") # CET
# t7 <- as.POSIXct(s7, tz = "Europe/Berlin") # CEST
# # format(t6, "%F %T %Z %z")
# # format(t7, "%F %T %Z %z")
#
# diff_tz(t6, t7)
# diff_tz(t6, t7, in_min = TRUE)
#
# # (b) Fall back (on 2020-10-25: 03:00:00 > 02:00:00):
# s8 <- "2020-10-25 01:00:00 CEST" # before DSL switch
# s9 <- "2020-10-25 03:00:00 CET" # after DSL switch
# t8 <- as.POSIXct(s8, tz = "Europe/Berlin") # CEST
# t9 <- as.POSIXct(s9, tz = "Europe/Berlin") # CET
# # format(t8, "%F %T %Z %z")
# # format(t9, "%F %T %Z %z")
#
# diff_tz(t8, t9)
# diff_tz(t8, t9, in_min = TRUE)
#
# # No differences:
# diff_tz(t6, t9) # both CET
# diff_tz(t7, t8) # both CEST
# diff_tz(t6, t9, in_min = TRUE)
# diff_tz(t7, t8, in_min = TRUE)
#
# # 4. With vectors:
# ta <- as.POSIXct("2020-01-01 01:00:00", tz = "Europe/Berlin")
# tb <- as.POSIXct("2020-06-01 02:22:22", tz = "Pacific/Auckland")
# tc <- as.POSIXct("2020-01-01 05:55:55", tz = "")
#
# c(ta, tb, tc) # Note: CET vs. CEST, NZ is dropped!
# diff_tz(c(ta, tb, tc), tc) # Note: only tz/DSL matters
# diff_tz(c(ta, tb, tc), tc, in_min = TRUE)
#
# # 5. Recycle 1st argument to length of 2nd:
# diff_tz(tc, c(ta, tb, tc))
# is_leap_year: ------
#' Is some year a so-called leap year?
#'
#' \code{is_leap_year} checks whether a given year
#' (provided as a date or time \code{dt},
#' or number/string denoting a 4-digit year)
#' lies in a so-called leap year (i.e., a year containing a date of Feb-29).
#'
#' When \code{dt} is not recognized as "Date" or "POSIXt" object(s),
#' \code{is_leap_year} aims to parse a string \code{dt}
#' as describing year(s) in a "dddd" (4-digit year) format,
#' as a valid "Date" string (to retrieve the 4-digit year "\%Y"),
#' or a numeric \code{dt} as 4-digit integer(s).
#'
#' \code{is_leap_year} then solves the task
#' by verifying the numeric definition of a "leap year"
#' (see \url{https://en.wikipedia.org/wiki/Leap_year}).
#'
#' An alternative solution that tried using
#' \code{as.Date()} for defining a "Date" of Feb-29
#' in the corresponding year(s) was removed,
#' as it evaluated \code{NA} values as \code{FALSE}.
#'
#' @param dt Date or time (scalar or vector).
#' Numbers or strings with dates are parsed into
#' 4-digit numbers denoting the year.
#'
#' @return Boolean vector.
#'
#' @examples
#' is_leap_year(2020)
#' (days_this_year <- 365 + is_leap_year(Sys.Date()))
#'
#' # from dates:
#' is_leap_year(Sys.Date())
#' is_leap_year(as.Date("2022-02-28"))
#'
#' # from times:
#' is_leap_year(Sys.time())
#' is_leap_year(as.POSIXct("2022-10-11 10:11:12"))
#' is_leap_year(as.POSIXlt("2022-10-11 10:11:12"))
#'
#' # from non-integers:
#' is_leap_year(2019.5)
#'
#' # For vectors:
#' is_leap_year(2020:2028)
#'
#' # with dt as strings:
#' is_leap_year(c("2020", "2021"))
#' is_leap_year(c("2020-02-29 01:02:03", "2021-02-28 01:02"))
#'
#' # Note: Invalid date string yields error:
#' # is_leap_year("2021-02-29")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{days_in_month}} for the number of days in given months;
#' \code{\link{diff_tz}} for time zone-based time differences;
#' \code{leap_year} function of the \strong{lubridate} package.
#'
#' @source
#' See \url{https://en.wikipedia.org/wiki/Leap_year} for definition.
#'
#' @export
is_leap_year <- function(dt){
# 0. Initialize:
y <- NA
out <- NA
alt <- NA
# 1. Handle input: Determine y (as integer): ----
if (is_Date(dt) | is_POSIXct(dt) | is_POSIXlt(dt)){
y <- as.numeric(format(dt, format = "%Y"))
} else if (is.character(dt)){
if (all(grepl(x = dt, pattern = "^\\d\\d\\d\\d$"))) {
# message('is_leap_year: Parsing string dt as "yyyy").')
y <- as.numeric(dt)
} else {
message('is_leap_year: Coercing string dt into "Date" (to get "%Y").')
y <- as.numeric(format(as.Date(dt), format = "%Y"))
}
} else if (is.numeric(dt)){
if (all(is_wholenumber(dt))){
y <- dt
} else {
message('is_leap_year: Rounding numeric dt to nearest integer.')
y <- round(dt, 0)
}} else {
message('is_leap_year: Failed to parse dt into year.')
}
if (any(is.na(y))){
message('is_leap_year: Some year values are NA.') # notify user
}
# 2. Main: ----
# A. Using definition from <https://en.wikipedia.org/wiki/Leap_year>:
out <- (y %% 4 == 0) & ((y %% 100 != 0) | (y %% 400 == 0))
# print(out) # debugging
# # B. Try defining Feb-29 as "Date" (NA if non-existent):
# ToDo: Remove NAs and do the following only for non-NA entries:
# feb_29 <- paste(y, "02", "29", sep = "-")
# alt <- !is.na(as.Date(feb_29, format = "%Y-%m-%d")) # ERROR: y = NA and FALSE both become TRUE
# # print(alt) # debugging
# if (!all.equal(out, alt)){ # Warn of discrepancy:
# warning("is_leap_year: Two solutions yield different results. Using 1st.")
# }
# 3. Output:
return(out)
} # is_leap_year end.
# ## Check:
# is_leap_year(2020)
# (days_this_year <- 365 + is_leap_year(Sys.Date()))
#
# is_leap_year(Sys.Date())
# is_leap_year(as.Date("2022-10-11"))
#
# is_leap_year(Sys.time())
# is_leap_year(as.POSIXct("2022-10-11 10:11:12"))
# is_leap_year(as.POSIXlt("2022-10-11 10:11:12"))
#
# is_leap_year(2019.5)
#
# # For vectors:
# v <- 2020:2028
# is_leap_year(v)
#
# # with dt as strings:
# is_leap_year("2000")
# is_leap_year(c("2020", "2021"))
# is_leap_year(c("2020-02-29 01:02:03", "2021-02-28 01:02"))
# # Note: Invalid date string would yield error
# is_leap_year("2021-02-29")
# MONTH_DAYS: Define a CONSTANT for days in TYPICAL month (no leap year): ------
MONTH_DAYS <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
# sum(MONTH_DAYS) # 365 (no leap year)
names(MONTH_DAYS) <- base::month.abb
# days_in_month: Get number of days in a given month (based on date): ------
# Note: Requires "Date" (rather than only month name/nr.) to check for leap years.
#' How many days are in a month (of given date)?
#'
#' \code{days_in_month} computes the number of days in the months of
#' given dates (provided as a date or time \code{dt},
#' or number/string denoting a 4-digit year).
#'
#' The function requires \code{dt} as "Dates",
#' rather than month names or numbers,
#' to check for leap years (in which February has 29 days).
#'
#' @param dt Date or time (scalar or vector).
#' Default: \code{dt = Sys.Date()}.
#' Numbers or strings with dates are parsed into
#' 4-digit numbers denoting the year.
#'
#' @param ... Other parameters (passed to \code{as.Date()}).
#'
#' @return A named (numeric) vector.
#'
#' @examples
#' days_in_month()
#'
#' # Robustness:
#' days_in_month(Sys.Date()) # Date
#' days_in_month(Sys.time()) # POSIXct
#' days_in_month("2020-07-01") # string
#' days_in_month(20200901) # number
#' days_in_month(c("2020-02-10 01:02:03", "2021-02-11", "2024-02-12")) # vectors of strings
#'
#' # For leap years:
#' ds <- as.Date("2020-02-20") + (365 * 0:4)
#' days_in_month(ds) # (2020/2024 are leap years)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{is_leap_year}} to check for leap years;
#' \code{\link{diff_tz}} for time zone-based time differences;
#' \code{days_in_month} function of the \strong{lubridate} package.
#'
#' @export
days_in_month <- function(dt = Sys.Date(), ...){
# 0. Initialize:
nr_days <- NA
# 1. Handle inputs:
if (!is_Date(dt)){ dt <- date_from_noDate(dt, ...) }
# 2. Main: Look up days, accounting for leap years ----
month_nr <- as.numeric(format(dt, format = "%m"))
# message(paste(month_nr, collapse = " "))
nr_days <- MONTH_DAYS[month_nr] # look up days in constant
# message(paste(nr_days, collapse = " "))
# Special case: Feb. of leap year has 29 days:
nr_days[(month_nr == 2) & (is_leap_year(dt))] <- 29
# 3. Output:
return(nr_days)
} # days_in_month end.
# ## Check:
# days_in_month(Sys.Date()) # Date
# days_in_month(Sys.time()) # POSIXct
# days_in_month("2020-07-01") # string
# days_in_month(20200901) # number
# days_in_month(c("2020-02-10 01:02:03", "2021-02-11", "2024-02-12")) # vectors of strings
#
# # # leap years:
# ds <- as.Date("2020-02-20") + (365 * 0:4) # 2020 and 2024 are leap years
# ds
# days_in_month(ds)
# days_last_month: Get number of days in a PRECEDING month (based on date): ------
days_last_month <- function(dt, ...){
nr <- NA # initialize
# 1. Handle inputs:
if (!is_Date(dt)){ dt <- date_from_noDate(dt, ...) }
# 2. Get dt elements:
year_nr <- as.numeric(format(dt, format = "%Y"))
month_nr <- as.numeric(format(dt, format = "%m"))
# 3. Main processing: ----
last_month_nr <- (month_nr - 1) # reduce month_nr by 1
# Handle special case: Dec becomes Jan of preceding year:
last_month_nr[last_month_nr == 0] <- 12 # Dec <- Jan
year_nr[last_month_nr == 12] <- (year_nr[last_month_nr == 12] - 1) # preceding year!
# Express as valid date:
# Heuristic: A 15. day exists for all months, but cannot be mistaken for month_nr:
mid_last_month <- paste(year_nr, last_month_nr, "15", sep = "-")
dt_last_month <- as.Date(mid_last_month, format = "%Y-%m-%d")
# message(paste(dt_last_month, collapse = " ")) # debugging
# Get days_in_month() for dates of dt_last_month:
nr <- days_in_month(dt_last_month)
# 4. Output:
return(nr)
} # days_last_month end.
## Check:
# days_last_month(as.Date("2020-01-10"))
#
# (dts <- as.Date("2020-01-15") + 30 * 0:12)
# days_in_month(dts)
# days_last_month(dts)
#
# days_last_month(c("2020-01-10", "2020-02-11", "2020-03-12")) # vectors of strings
# bday_eq_last_month: Get closest equivalent to bday in last month: ------
# Helper function bday_eq_last_month(to_date, bday):
# Get closest equivalent to bday in last month (e.g.,
# - 28.02. if bday on 30.03 and no leap year,
# - 30.11 for bday on 31.12, etc.)
# bday_eq_last_month <- function(dt, bday, ...){
#
# # (a) Handle inputs:
# if (!is_Date(dt)){ dt <- date_from_noDate(dt, ...) }
#
# if (length(dt) > length(bday)){
#
# bday <- rep(bday, length.out = length(dt)) # recycle bday
#
# }
#
# # (b) Get dt elements:
# year_nr <- as.numeric(format(dt, format = "%Y"))
# month_nr <- as.numeric(format(dt, format = "%m"))
#
# # (c) Main processing:
# last_month_nr <- (month_nr - 1) # reduce month_nr by 1
#
# # Handle special case: Dec becomes Jan of preceding year:
# last_month_nr[last_month_nr == 0] <- 12 # Dec <- Jan!
# year_nr[last_month_nr == 12] <- (year_nr[last_month_nr == 12] - 1) # preceding year!
#
# # How many days were there last month?
# max_day_last_month <- days_last_month(dt)
#
# day_nr <- rep(NA, length(dt))
#
# # Distinguish 2 cases:
# day_nr[max_day_last_month >= bday] <- bday[max_day_last_month >= bday] # 1. bday exists in last month; OR
# day_nr[max_day_last_month < bday] <- max_day_last_month[max_day_last_month < bday] # 2. take max_day_last_month instead.
#
# # Construct as date:
# bd_last_month <- paste(year_nr, last_month_nr, day_nr, sep = "-")
# dt_last_month <- as.Date(bd_last_month, format = "%Y-%m-%d")
#
# # message(dt_last_month) # debugging
#
# # (d) Output:
# return(dt_last_month)
#
# } # bday_eq_last_month end.
## Check:
# bday_eq_last_month("2020-01-01", bday = 31)
# bday_eq_last_month("2020-12-01", bday = 31)
#
# bday_eq_last_month("2020-03-01", bday = 29) # 2020 is leap year
# bday_eq_last_month("2020-03-01", bday = 30)
# bday_eq_last_month("2020-03-01", bday = 31)
#
# bday_eq_last_month("2021-03-01", bday = 29) # 2021 is NO leap year
# bday_eq_last_month("2021-03-01", bday = 30)
# bday_eq_last_month("2021-03-01", bday = 31)
#
# # For vectors:
# (ds <- paste("2021", 1:12, 15, sep = "-")) # 2021 is NO leap year
# bday_eq_last_month(ds, bday = 20)
# bday_eq_last_month(ds, bday = 29)
# bday_eq_last_month(ds, bday = 30)
# bday_eq_last_month(ds, bday = 31)
# dt_last_monthly_bd: Get the date of last full-month bday: ------
# Question: On which day of last/previous month would one's monthly bday fall?
# Problem: Some days (e.g., 29, 30, 31) do not exist in last month.
# Solution: Use the last/final day of previous month in those cases.
dt_last_monthly_bd <- function(dob, to_date, ...){
# (a) Handle inputs: ----
if (!is_Date(dob)){ dob <- date_from_noDate(dob, ...) }
if (!is_Date(to_date)){
# message(paste0("1. to_date = ", to_date)) # debugging
to_date <- date_from_noDate(to_date, ...)
# message(paste0("2. to_date = ", to_date)) # debugging
}
# Recycle shorter date argument to length of longer one: ----
aligned_v <- align_vec_pair(v1 = dob, v2 = to_date)
dob <- aligned_v[[1]]
to_date <- aligned_v[[2]]
# # WAS: Recycle or truncate to_date argument based on dob:
# to_date <- align_vector_length(v_fixed = dob, v_change = to_date)
# (b) Get dt elements:
dob_y <- as.numeric(format(dob, format = "%Y"))
dob_m <- as.numeric(format(dob, format = "%m"))
dob_d <- as.numeric(format(dob, format = "%d"))
tod_y <- as.numeric(format(to_date, format = "%Y"))
tod_m <- as.numeric(format(to_date, format = "%m"))
tod_d <- as.numeric(format(to_date, format = "%d"))
# (c) Main processing: ----
bd_this_month <- tod_d >= dob_d # flag
dt_y <- tod_y
dt_m <- rep(NA, length(dob))
# # Distinguish 2 cases:
# dt_m[bd_this_month] <- tod_m[bd_this_month] # 1. bd_this_month
# dt_m[!bd_this_month] <- tod_m[!bd_this_month] - 1 # 2. !bd_this_month
# Combine cases:
dt_m <- tod_m - (1 * !bd_this_month)
# Handle special case: Dec becomes Jan of preceding year:
dt_m[dt_m == 0] <- 12 # Dec <- Jan!
ix_1 <- (dt_m == 12) & (!bd_this_month)
dt_y[ix_1] <- dt_y[ix_1] - 1 # preceding year!
# Construct as date:
dt_string <- paste(dt_y, dt_m, dob_d, sep = "-")
dt <- as.Date(dt_string, format = "%Y-%m-%d")
# Handle special case:
# Problem: dt is NA for non-existent dates (e.g., Feb 30, June 31, ...)
# # Solution 1: Get LAST day of PRECEDING month:
# ix <- is.na(dt)
# dob_d[ix] <- days_last_month(dt = to_date[ix]) # using days_last_month() helper!
# dt_string[ix] <- paste(dt_y[ix], dt_m[ix], dob_d[ix], sep = "-")
# dt[ix] <- as.Date(dt_string[ix], format = "%Y-%m-%d")
# Solution 2: Get FIRST day of CURRENT month, then subtract 1 day:
ix_2 <- is.na(dt)
# dob_d[ix] <- days_last_month(dt = to_date[ix])
dt_string[ix_2] <- paste(dt_y[ix_2], tod_m[ix_2], "01", sep = "-")
dt[ix_2] <- as.Date(dt_string[ix_2], format = "%Y-%m-%d") - 1
# Note: One could also argue for 1st of current month for these cases???
# (d) Output:
return(dt)
} # dt_last_monthly_bd end.
# ## Check:
# (bd <- as.Date("2020-01-28") + 0:4)
# dt_last_monthly_bd(bd, as.Date("2020-03-10"))
# dt_last_monthly_bd(bd, "2021-03-31")
# dt_last_monthly_bd(bd, "2021-03-01")
# #
# # # Birthday on Feb. 29 of leap year:
# dt_last_monthly_bd("2020-02-29", "2021-03-01")
#
# # Recycling length of 2nd argument:
# dt_last_monthly_bd(c("2020-02-28", "2020-02-29", "2020-03-01"), "2021-03-01")
#
# # Case with errors:
# (bd <- as.Date(fame$DOB[35], format = "%B %d, %Y"))
# (dd <- as.Date(fame$DOD[35], format = "%B %d, %Y"))
# dt_last_monthly_bd(bd, dd) # seems ok.
#
# # Special cases:
# dt_last_monthly_bd(dob = "2020-12-31", "2020-01-01") # dob > to_date
# dt_last_monthly_bd(dob = "2020-03-31", "2020-03-01") # dob > to_date
# dt_last_monthly_bd(dob = "2020-03-31", "2020-03-31") # dob = to_date
#
# # Former problem/error now resolved:
# t1 <- "2020-05-31 05:41:27"
# t2 <- "2020-07-01 01:29:06"
# dt_last_monthly_bd(t1, t2) # now: "2020-06-30"
# dt_last_monthly_bd(t1, t2, tz = "") # now: "2020-06-30"
## Done: ----------
# - Moved time utility/helper functions into separate file.
## ToDo: ----------
# ad (0):
# - consider making class test functions is_Date / is_POSIXt available to users by export.
# - consider making date and time parser functions (date_from_noDate/time_from_noPOSIX) available to users by export.
## eof. ----------------------
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.