Nothing
R/time_fun.R
In ds4psy: Data Science for Psychologists
Defines functions
zodiac
diff_times
diff_dates
diff_days
change_tz
change_time
what_year
what_month
what_week
what_wday
what_date
what_time
cur_time
cur_date
Documented in
change_time
change_tz
cur_date
cur_time
diff_dates
diff_times
what_date
what_month
what_time
what_wday
what_week
what_year
zodiac
## time_fun.R | ds4psy
## hn | uni.kn | 2023 09 15
## ------------------------
## Main functions for date and time objects.
## (0) Note utility functions for date and time data objects in time_util_fun.R! ------
## (1) cur_ functions: ----------
# 90% of all use cases are covered by 2 functions that ask for the _current_ date or time:
# - `cur_date()`: in 2 different orders (optional sep)
# - `cur_time()`: with or without seconds (optional sep)
# cur_date: A relaxed version of Sys.time() ------
#' Current date (in yyyy-mm-dd or dd-mm-yyyy format).
#'
#' \code{cur_date} provides a relaxed version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{cur_date} returns \code{Sys.Date}
#' as a character string (using current system settings and
#' \code{sep} for formatting).
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' Alternatively, consider using \code{Sys.Date}
#' or \code{Sys.time()} to obtain the "%Y-%m-%d" (or "%F")
#' format according to the ISO 8601 standard.
#'
#' For more options, see the documentations of the
#' \code{date} and \code{Sys.Date} functions of \strong{base} R
#' and the formatting options for \code{Sys.time()}.
#'
#' @param rev Boolean: Reverse from "yyyy-mm-dd" to "dd-mm-yyyy" format?
#' Default: \code{rev = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = "-"}.
#'
#' @return A character string or object of class "Date".
#'
#' @examples
#' cur_date()
#' cur_date(sep = "/")
#' cur_date(rev = TRUE)
#' cur_date(rev = TRUE, sep = ".")
#'
#' # return a "Date" object:
#' from <- cur_date(as_string = FALSE)
#' class(from)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_date()} function to print dates with more options;
#' \code{date()} and \code{today()} functions of the \strong{lubridate} package;
#' \code{date()}, \code{Sys.Date()}, and \code{Sys.time()} functions of \strong{base} R.
#'
#' @export
cur_date <- function(rev = FALSE, as_string = TRUE, sep = "-"){
# 0. Initialize:
d <- NA
# 1. Get system date:
# d <- Sys.time() # current time (optimizing options)
d <- Sys.Date() # current date (satisficing solution)
# 2. Format instruction string:
if (rev){
fmt <- paste("%d", "%m", "%Y", sep = sep, collapse = "") # using sep
} else {
fmt <- paste("%Y", "%m", "%d", sep = sep, collapse = "") # using sep
}
# 3. Output:
# ## Side effect and invisible return:
# # Print formatted d (as side effect):
# print(format(d, fmt)) # as string
# # cat(format(d, fmt)) # no string
#
# # Return Date object:
# invisible(d)
if (as_string){
return(format(d, format = fmt)) # formatted string
# return(print(format(d, fmt))) # print string
# return(cat(format(d, fmt))) # no string
} else {
return(d) # as Date
}
} # cur_date().
# ## Check:
# cur_date()
# cur_date(sep = "/")
# cur_date(rev = TRUE)
# cur_date(rev = TRUE, sep = ".")
# cur_time: A satisficing version of Sys.time() ------
#' Current time (in hh:mm or hh:mm:ss format).
#'
#' \code{cur_time} provides a satisficing version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{cur_time} returns a
#' \code{Sys.time()} as a character string
#' (in "%H:%M" or "%H:%M:%S" format)
#' using current system settings.
#' If \code{as_string = FALSE}, a "POSIXct"
#' (calendar time) object is returned.
#'
#' For a time zone argument,
#' see the \code{\link{what_time}} function,
#' or the \code{now()} function of
#' the \strong{lubridate} package.
#'
#' @param seconds Boolean: Show time with seconds?
#' Default: \code{seconds = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "POSIXct" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = ":"}.
#'
#' @return A character string or object of class "POSIXct".
#'
#' @examples
#' cur_time()
#' cur_time(seconds = TRUE)
#' cur_time(sep = ".")
#'
#' # return a "POSIXct" object:
#' t <- cur_time(as_string = FALSE)
#' format(t, "%T %Z")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_time()} function to print times with more options;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
cur_time <- function(seconds = FALSE, as_string = TRUE, sep = ":"){
# 0. Initialize:
t <- NA
# 1. Current time:
t <- Sys.time()
# 2. Format instruction string:
if (seconds) {
fmt <- paste("%H", "%M", "%S", sep = sep, collapse = "") # %S and using sep
} else {
fmt <- paste("%H", "%M", sep = sep, collapse = "") # no %S, using sep
}
# 3. Output:
# ## Side effect and invisible return:
# # Print formatted t (as side effect):
# print(format(t, fmt)) # as string
# # cat(format(t, fmt)) # no string
#
# # Return POSIXct object:
# invisible(t)
if (as_string){
return(format(t, format = fmt)) # formatted string
# return(print(format(t, fmt))) # print string
# return(cat(format(t, fmt))) # no string
} else {
return(t) # as POSIXct
}
} # cur_time().
## Check:
# cur_time()
# cur_time(seconds = TRUE)
# cur_time(sep = ".")
# cur_date_time: Combining cur_date and cur_time: ------
# ToDo? Or just call cur_date() AND cur_time()?
## (2) what_ functions: ----------
# Motivation: The R base function date()
# returns date as "Wed Aug 21 19:43:22 2019",
# which is more than we usually want.
# Some simpler variants following a simple heuristic:
# What is it that we _usually_ want to hear as `x` when asking
# "What `x` is it today?" or "What `x` is it right now?"
# About 5% are covered by 4 additional functions that ask `what_` questions
# about the position of some temporal unit in some larger continuum of time:
#
# - `what_time()`: more versatile version of cur_time() (accepting a when argument)
# - `what_date()`: more versatile version of cur_date() (accepting a when argument)
# - `what_wday()` : as name (weekday, abbr or full), OR as number (in units of week, month, or year; as char or as integer)
# - `what_week()` : only as number (in units of month, or year); return as char or as integer
# - `what_month()`: as name (abbr or full) OR as number (as char or as integer)
# - `what_year()` : only as number (abbr or full), return as char or as integer
#
# All of these functions
# - take some "point in time" time as input (as a "when" argument),
# which defaults to now (i.e., Sys.time()) but can also be a vector.
# - return a character string (which can easily be converted into a number), unless specifically asking for numeric output
# what_time: More versatile version of cur_time(), allowing for a when vector: ------
#' What time is it?
#'
#' \code{what_time} provides a satisficing version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{what_time} prints a simple version of
#' \code{when} or \code{Sys.time()}
#' as a character string (in "%H:%M" or "%H:%M:%S" format)
#' using current default system settings.
#' If \code{as_string = FALSE}, a "POSIXct"
#' (calendar time) object is returned.
#'
#' The \code{tz} argument allows specifying time zones
#' (see \code{Sys.timezone()} for current setting
#' and \code{OlsonNames()} for options.)
#'
#' However, \code{tz} is merely used to represent the
#' times provided to the \code{when} argument.
#' Thus, there currently is no active conversion
#' of times into other time zones
#' (see the \code{now} function of \strong{lubridate} package).
#'
#' @param when Time (as a scalar or vector).
#' Default: \code{when = NA}.
#' Returning \code{Sys.time()}, if \code{when = NA}.
#'
#' @param seconds Boolean: Show time with seconds?
#' Default: \code{seconds = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "POSIXct" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = ":"}.
#'
#' @param tz Time zone.
#' Default: \code{tz = ""} (i.e., current system time zone,
#' see \code{Sys.timezone()}).
#' Use \code{tz = "UTC"} for Coordinated Universal Time.
#'
#' @return A character string or object of class "POSIXct".
#'
#' @examples
#' what_time()
#'
#' # with vector (of "POSIXct" objects):
#' tm <- c("2020-02-29 01:02:03", "2020-12-31 14:15:16")
#' what_time(tm)
#'
#' # with time zone:
#' ts <- ISOdate(2020, 12, 24, c(0, 12)) # midnight and midday UTC
#' t1 <- what_time(when = ts, tz = "Pacific/Honolulu")
#' t1 # time display changed, due to tz
#'
#' # return "POSIXct" object(s):
#' # Same time in differen tz:
#' t2 <- what_time(as.POSIXct("2020-02-29 10:00:00"), as_string = FALSE, tz = "Pacific/Honolulu")
#' format(t2, "%F %T %Z (UTF %z)")
#' # from string:
#' t3 <- what_time("2020-02-29 10:00:00", as_string = FALSE, tz = "Pacific/Honolulu")
#' format(t3, "%F %T %Z (UTF %z)")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_time <- function(when = NA, seconds = FALSE, as_string = TRUE, sep = ":", tz = ""){
# 0. Initialize:
t <- NA
# 1. Check when argument:
if (all(is.na(when))){
t <- Sys.time() # use current time
} else { # interpret when:
if (!is_POSIXct(when)){
t <- time_from_noPOSIXt(when)
# # same time display in different tz (i.e., different time):
# t <- time_from_noPOSIXt(when, tz = tz)
} else {
t <- when # copy
}
}
# 2. Verify class:
if (!is_POSIXt(t)){
message(paste0('what_time: "t" is not of class "POSIXt".'))
# return(t)
}
# 3. Change time display into time zone tz:
if (tz != ""){
message("Changing tz (but keeping original time).")
t <- change_tz(t, tz = tz)
}
# 4. Format output:
if (seconds) {
fmt <- paste("%H", "%M", "%S", sep = sep, collapse = "") # %S and using sep
} else {
fmt <- paste("%H", "%M", sep = sep, collapse = "") # no %S, using sep
}
# ## Side effect and invisible return:
# # Print formatted t (as side effect):
# print(format(t, fmt)) # as string
# # cat(format(t, fmt)) # no string
#
# # Return POSIXct object:
# invisible(t)
# 5. Output:
if (as_string){
return(format(t, format = fmt)) # formatted string
# return(print(format(t, fmt))) # print string
# return(cat(format(t, fmt))) # no string
} else {
return(t) # as POSIXt
}
} # what_time().
# # Check:
# what_time()
#
# # with vector (of POSIXct objects):
# ts <- c("2020-02-29 01:02:03", "2020-12-31 14:15:16")
# what_time(ts)
#
# # with time zone:
# t1 <- what_time(ts, seconds = TRUE, sep = "_", tz = "UTC")
# t1
#
# # returns POSIXct objects:
# t2 <- what_time("2020-02-29 12:30:45", tz = "America/Los_Angeles")
# format(t2, "%T %Z")
# what_date: More versatile version of cur_date(), allowing for a when vector: ------
#' What date is it?
#'
#' \code{what_date} provides a satisficing version of
#' \code{Sys.Date()} that is sufficient for most purposes.
#'
#' By default, \code{what_date} returns either
#' \code{Sys.Date()} or the dates provided by \code{when}
#' as a character string (using current system settings and
#' \code{sep} for formatting).
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' The \code{tz} argument allows specifying time zones
#' (see \code{Sys.timezone()} for current setting
#' and \code{OlsonNames()} for options.)
#'
#' However, \code{tz} is merely used to represent the
#' dates provided to the \code{when} argument.
#' Thus, there currently is no active conversion
#' of dates into other time zones
#' (see the \code{today} function of \strong{lubridate} package).
#'
#' @param when Date(s) (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param rev Boolean: Reverse date (to %d-%m-%Y)?
#' Default: \code{rev = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = "-"}.
#'
#' @param month_form Character: Month format.
#' Default: \code{month_form = "m"} for numeric month (01-12).
#' Use \code{month_form = "b"} for short month name
#' and \code{month_form = "B"} for full month name (in current locale).
#'
#' @param tz Time zone.
#' Default: \code{tz = ""} (i.e., current system time zone,
#' see \code{Sys.timezone()}).
#' Use \code{tz = "UTC"} for Coordinated Universal Time.
#'
#' @return A character string or object of class "Date".
#'
#' @examples
#' what_date()
#' what_date(sep = "/")
#' what_date(rev = TRUE)
#' what_date(rev = TRUE, sep = ".")
#' what_date(rev = TRUE, sep = " ", month_form = "B")
#'
#' # with "POSIXct" times:
#' what_date(when = Sys.time())
#'
#' # with time vector (of "POSIXct" objects):
#' ts <- c("1969-07-13 13:53 CET", "2020-12-31 23:59:59")
#' what_date(ts)
#' what_date(ts, rev = TRUE, sep = ".")
#' what_date(ts, rev = TRUE, month_form = "b")
#'
#' # return a "Date" object:
#' dt <- what_date(as_string = FALSE)
#' class(dt)
#'
#' # with time zone:
#' ts <- ISOdate(2020, 12, 24, c(0, 12)) # midnight and midday UTC
#' what_date(when = ts, tz = "Pacific/Honolulu", as_string = FALSE)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_wday()} function to obtain (week)days;
#' \code{what_time()} function to obtain times;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_date <- function(when = NA, rev = FALSE, as_string = TRUE,
sep = "-", month_form = "m", tz = ""){
# 0. Initialize:
d <- NA
# 1. Check when argument:
if (all(is.na(when))){
# d <- Sys.time() # current time (optimizing options)
d <- Sys.Date() # current date (satisficing solution)
} else {
# interpret when:
if (!is_Date(when)){
# message('what_date: Aiming to parse "when" as "Date".')
d <- date_from_noDate(when, tz = tz)
} else {
d <- as.Date(when, tz = tz) # as Date (with passive tz)
}
}
# 2. Verify class:
if (!is_Date(d)){
message(paste0('what_date: "d" is not of class "Date".'))
# return(d)
}
# 3. Convert into time zone tz:
if (tz != ""){
message("Converting date(s) into tz.")
d <- change_tz(d, tz = tz)
}
# 4. Format output:
if (substr(month_form, 1, 1) != "%") {
month_form <- paste0("%", month_form) # add % prefix
}
if (rev){
fmt <- paste("%d", month_form, "%Y", sep = sep, collapse = "") # using sep
} else {
fmt <- paste("%Y", month_form, "%d", sep = sep, collapse = "") # using sep
}
# ## Side effect and invisible return:
# # Print formatted d (as side effect):
# print(format(d, fmt)) # as string
# # cat(format(d, fmt)) # no string
#
# # Return Date object:
# invisible(d)
# 5. Output:
if (as_string){
return(format(d, format = fmt)) # formatted string
# return(print(format(d, fmt))) # print string
# return(cat(format(d, fmt))) # no string
} else {
return(d) # as Date
}
} # what_date().
# ## Check:
# what_date()
# what_date(as_string = FALSE)
#
# what_date(sep = "/")
# what_date(rev = TRUE)
# what_date(rev = TRUE, sep = ".")
# what_date(rev = TRUE, sep = " ", month_form = "B")
#
# what_date(c("2020-01-01", "2020-12-31"), tz = "Australia/Sydney", as_string = FALSE)
# ds <- c("2020-01-15 01:02:03 NZ", "2020-12-31 14:15:16") # POSIXct
# what_date(ds, tz = "Pacific/Auckland", as_string = FALSE)
# what_date(ds, rev = TRUE, sep = ".")
# what_date(ds, rev = TRUE, month_form = "b")
## what_day_alt: What day is it? (OLD/ORG version: name or number) ------
## what_day_alt: as name (weekday, abbr or full), OR as number (in units of week, month, or year; as char or as integer)
# What day is it? (alternative OLD/ORG version)
#
# \code{what_day_alt} provides a satisficing version of
# to determine the day corresponding to a given date.
#
# \code{what_day_alt} returns the day
# of \code{when} or \code{Sys.Date()}
# (as a name or number).
#
# @param when Date (as a scalar or vector).
# Default: \code{when = NA}.
# Using \code{as.Date(when)} to convert strings into dates,
# and \code{Sys.Date()}, if \code{when = NA}.
#
# @param unit Character: Unit of day?
# Possible values are \code{"week", "month", "year"}.
# Default: \code{unit = "week"} (for day within week).
#
# @param abbr Boolean: Return abbreviated?
# Default: \code{abbr = FALSE}.
#
# @param as_integer Boolean: Return as integer?
# Default: \code{as_integer = FALSE}.
#
# @examples
# what_day_alt()
# what_day_alt(abbr = TRUE)
# what_day_alt(as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_day_alt(when = ds)
# what_day_alt(when = ds, unit = "month", as_integer = TRUE)
# what_day_alt(when = ds, unit = "year", as_integer = TRUE)
#
#
# @family date and time functions
#
# @seealso
# \code{what_day()} for a simpler version (only weekdays);
# \code{what_date()} function to obtain dates;
# \code{what_time()} function to obtain times;
# \code{cur_time()} function to print the current time;
# \code{cur_date()} function to print the current date;
# \code{Sys.time()} function of \strong{base} R.
#
# @export
# what_day_alt <- function(when = Sys.time(), unit = "week", abbr = FALSE, as_integer = FALSE){
#
# # Robustness:
# unit <- substr(tolower(unit), 1, 1) # use only 1st letter of string
#
# # Convert when into objects of class "Date" representing calendar dates:
# if ( any(class(when) != "Date") & !("POSIXct" %in% class(when)) ) {
# message(paste0("what_day_alt: Using as.Date() to convert 'when' into class 'Date'."))
# when <- as.Date(when)
# }
#
# # Verify date/time input:
# if ( any(class(when) != "Date") & !("POSIXct" %in% class(when)) ) {
# message(paste0("what_day_alt: when must be of class 'Date' or 'POSIXct'."))
# message(paste0("Currently, class(when) = ", class(when), "."))
# return(when)
# }
#
# # initialize:
# d <- as.character(NA)
#
# # get day d (as char):
# if (unit == "w"){ # unit "week":
#
# if (as_integer){
#
# # Weekday as a decimal number (1–7, Mon=1):
# d <- format(when, "%u") # WARN: r-devel-linux-x86_64-debian-clang!
#
# } else {
#
# if (abbr){
# d <- format(when, "%a") # Abbreviated weekday name in the current locale on this platform.
# } else {
# d <- format(when, "%A") # Full weekday name in the current locale.
# }
#
# }
#
# } else if (unit == "m") { # unit "month":
#
# # Day of the month as decimal number (01–31):
# d <- format(when, "%d") # WARN: r-devel-linux-x86_64-debian-clang!
#
#
# } else if (unit == "y") { # unit "year":
#
# # Day of year as decimal number (001–366):
# d <- format(when, "%j") # WARN: r-devel-linux-x86_64-debian-clang!
#
# } else { # some other unit:
#
# message("Unknown unit. Using unit = 'month':")
#
# # Day of the month as decimal number (01–31):
# d <- format(when, "%d") # WARN: r-devel-linux-x86_64-debian-clang!
#
# }
#
# # as char or integer:
# if (as_integer) {
# as.integer(d)
# } else {
# d
# }
#
# } # what_day_alt().
# ## Check:
# what_day_alt()
# what_day_alt(abbr = TRUE)
# what_day_alt(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_day_alt(when = d1)
# what_day_alt(when = d1, unit = "month", as_integer = TRUE)
# what_day_alt(when = d1, unit = "year", as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_day_alt(when = ds)
# what_day_alt(when = ds, unit = "month", as_integer = TRUE)
# what_day_alt(when = ds, unit = "year", as_integer = TRUE)
#
# # Note: Errors
# what_day_alt(when = d1, unit = "asdf")
# what_day_alt(when = "now")
# what_day_alt(when = 123)
### Simplified version: Providing only the weekday (as a name):
# what_wday: What day is it? (name, NOT number) ------
# what_wday: as name (weekday, abbr or full), NOT as number (in units of week, month, or year; as char or as integer)
#' What day of the week is it?
#'
#' \code{what_wday} provides a satisficing version of
#' to determine the day of the week
#' corresponding to a given date.
#'
#' \code{what_wday} returns the name of the weekday
#' of \code{when} or of \code{Sys.Date()}
#' (as a character string).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = Sys.Date()}.
#' Aiming to convert \code{when} into "Date"
#' if a different object class is provided.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @examples
#' what_wday()
#' what_wday(abbr = TRUE)
#'
#' what_wday(Sys.Date() + -1:1) # Date (as vector)
#' what_wday(Sys.time()) # POSIXct
#' what_wday("2020-02-29") # string (of valid date)
#' what_wday(20200229) # number (of valid date)
#'
#' # date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_wday(when = ds)
#' what_wday(when = ds, abbr = TRUE)
#'
#' # time vector (strings of POSIXct times):
#' ts <- c("1969-07-13 13:53 CET", "2020-12-31 23:59:59")
#' what_wday(ts)
#'
#' # fame data:
#' greta_dob <- as.Date(fame[grep(fame$name, pattern = "Greta") , ]$DOB, "%B %d, %Y")
#' what_wday(greta_dob) # Friday, of course.
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_date()} function to obtain dates;
#' \code{what_time()} function to obtain times;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_wday <- function(when = Sys.Date(), abbr = FALSE){
# 0. Initialize:
d <- as.character(NA)
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: weekday d (as char):
# if (unit == "w"){ # unit "week":
# if (as_integer){
# d <- format(when, "%u") # Weekday as a decimal number (1–7, Monday is 1).
# } else {
if (abbr){
d <- format(when, format = "%a") # Abbreviated weekday name in the current locale on this platform.
} else {
d <- format(when, format = "%A") # Full weekday name in the current locale.
}
#}
# } else if (unit == "m") { # unit "month":
# d <- format(when, "%d") # Day of the month as decimal number (01–31).
# } else if (unit == "y") { # unit "year":
# d <- format(when, "%j") # Day of year as decimal number (001–366).
# } else { # some other unit:
# message("Unknown unit. Using unit = 'month':")
# d <- format(when, "%d") # Day of the month as decimal number (01–31).
# }
# 3. Output:
## as char or integer:
# if (as_integer) {
# as.integer(d)
# } else {
d
# }
} # what_wday().
# ## Check:
# what_wday()
# what_wday(abbr = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_wday(when = d1)
# what_wday(when = d1, abbr = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_wday(when = ds)
# what_wday(when = ds, abbr = TRUE)
#
# # Note: Errors
# what_wday(when = "now")
# what_wday(when = 123)
#
# Bday of Greta Thunberg?
# greta_dob <- as.Date(fame[grep(fame$name, pattern = "Greta") , ]$DOB, "%B %d, %Y")
# what_wday(greta_dob) # Friday, of course.
# what_week: What week is it? (number only) ------
#' What week is it?
#'
#' \code{what_week} provides a satisficing version of
#' to determine the week corresponding to a given date.
#'
#' \code{what_week} returns the week
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = Sys.Date()}.
#' Using \code{as.Date(when)} to convert strings into dates
#' if a different \code{when} is provided.
#'
#' @param unit Character: Unit of week?
#' Possible values are \code{"month", "year"}.
#' Default: \code{unit = "year"} (for week within year).
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_week()
#' what_week(as_integer = TRUE)
#'
#' # Other dates/times:
#' d1 <- as.Date("2020-12-24")
#' what_week(when = d1, unit = "year")
#' what_week(when = d1, unit = "month")
#'
#' what_week(Sys.time()) # with POSIXct time
#'
#' # with date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_week(when = ds)
#' what_week(when = ds, unit = "month", as_integer = TRUE)
#' what_week(when = ds, unit = "year", as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-12-25 10:11:12 CET", "2020-12-31 23:59:59")
#' what_week(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_wday()} function to obtain (week)days;
#' \code{what_date()} function to obtain dates;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_week <- function(when = Sys.Date(), unit = "year", as_integer = FALSE){
# 0. Initialize:
w <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# Robustness:
unit <- substr(tolower(unit), 1, 1) # use only 1st letter of string
# 2. Main: Get week w (as char):
if (unit == "m"){ # unit "month":
# Searching nr. of week corresponding to current time in current month?
# Sources: Adapted from a discussion at
# <https://stackoverflow.com/questions/25199851/r-how-to-get-the-week-number-of-the-month>
# desired date:
d_des <- as.Date(when)
wk_2 <- as.numeric(format(d_des, "%V")) # corresponding week (01--53) as defined in ISO 8601 (week starts Monday)
# date of 1st day in corresponding month:
d_1st <- as.Date(cut(d_des, "month")) # date of 1st day in corresponding month
wk_1 <- as.numeric(format(d_1st, "%V")) # corresponding week (01--53) as defined in ISO 8601 (week starts on Monday)
# difference:
w <- (wk_2 - wk_1) + 1 # as number
w <- as.character(w) # as character
} else if (unit == "y") { # unit "year":
w <- format(when, format = "%V") # %V: week of the year as decimal number (01--53) as defined in ISO 8601 (week starts on Monday)
} else { # some other unit:
message("Unknown unit. Using unit = 'year':")
w <- format(when, format = "%V") # %V: week of the year as decimal number (01--53) as defined in ISO 8601 (week starts on Monday)
}
# 3. Output (as char or integer):
if (as_integer) {
return(as.integer(w))
} else {
return(w)
}
} # what_week().
# ## Check:
# what_week()
# what_week(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2019-08-23")
# what_week(when = d1, unit = "year")
# what_week(when = d1, unit = "month")
#
# # Week nr. (in month):
# d2 <- as.Date("2019-06-23") # Sunday of 4th week in June 2019.
# what_week(when = d2, unit = "month")
# d3 <- as.Date("2019-06-24") # Monday of 5th week in June 2019.
# what_week(when = d3, unit = "month")
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_week(when = ds)
# what_week(when = ds, unit = "month", as_integer = TRUE)
# what_week(when = ds, unit = "year", as_integer = TRUE)
#
# ## Note: Errors
# # what_week(when = d1, unit = "asdf")
# # what_week(when = "now")
# # what_week(when = 123)
# what_month: What month is it? (name or number) ------
# - `what_month()`: as name (abbr or full) OR as number (as char or as integer)
#' What month is it?
#'
#' \code{what_month} provides a satisficing version of
#' to determine the month corresponding to a given date.
#'
#' \code{what_month} returns the month
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_month()
#' what_month(abbr = TRUE)
#' what_month(as_integer = TRUE)
#'
#' # with date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_month(when = ds)
#' what_month(when = ds, abbr = TRUE, as_integer = FALSE)
#' what_month(when = ds, abbr = TRUE, as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-02-29 10:11:12 CET", "2020-12-31 23:59:59")
#' what_month(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_week()} function to obtain weeks;
#' \code{what_date()} function to obtain dates;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_month <- function(when = Sys.Date(), abbr = FALSE, as_integer = FALSE){
# 0. Initialize:
m <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: Get month m (as char):
if (as_integer) {
m <- format(when, format = "%m")
m <- as.integer(m)
} else { # month name (as character):
if (abbr){
m <- format(when, format = "%b") # Abbreviated month name in the current locale on this platform.
} else {
m <- format(when, format = "%B") # Full month name in the current locale.
}
}
# 3. Output (as char or integer):
return(m)
} # what_month().
# ## Check:
# what_month()
# what_month(abbr = TRUE)
# what_month(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_month(when = d1)
# what_month(when = d1, abbr = TRUE)
# what_month(when = d1, as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_month(when = ds)
# what_month(when = ds, abbr = TRUE, as_integer = FALSE)
# what_month(when = ds, abbr = TRUE, as_integer = TRUE)
#
# ## Note: Errors
# # what_month(when = "now")
# # what_month(when = 123)
# what_year: What year is it? ------
#' What year is it?
#'
#' \code{what_year} provides a satisficing version of
#' to determine the year corresponding to a given date.
#'
#' \code{what_year} returns the year
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_year()
#' what_year(abbr = TRUE)
#' what_year(as_integer = TRUE)
#'
#' # with date vectors (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_year(when = ds)
#' what_year(when = ds, abbr = TRUE, as_integer = FALSE)
#' what_year(when = ds, abbr = TRUE, as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-02-29 10:11:12 CET", "2020-12-31 23:59:59")
#' what_year(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_week()} function to obtain weeks;
#' \code{what_month()} function to obtain months;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_year <- function(when = Sys.Date(), abbr = FALSE, as_integer = FALSE){
# 0. Initialize:
y <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: Get year y:
if (abbr){
y <- format(when, format = "%y")
} else {
y <- format(when, format = "%Y")
}
# 3. Output (as char or integer):
if (as_integer) {
return(as.integer(y))
} else {
return(y)
}
} # what_year().
# ## Check:
# what_year()
# what_year(abbr = TRUE)
# what_year(as_integer = TRUE)
#
# # other dates/times:
# dt <- as.Date("1987-07-13")
# what_year(when = dt, abbr = TRUE, as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_year(when = ds)
# what_year(when = ds, abbr = TRUE, as_integer = FALSE)
# what_year(when = ds, abbr = TRUE, as_integer = TRUE)
#
# # Note: Errors
# what_year("2020-01-01")
# what_year(2020-01-01)
## (3) Time conversions: ----------
# change_time: ------
# Task 2: Change time zone AND actual time, without changing represented time (i.e., time display):
#' Change time and time zone (without changing time display).
#'
#' \code{change_time} changes the time and time zone
#' without changing the time display.
#'
#' \code{change_time} expects inputs to \code{time}
#' to be local time(s) (of the "POSIXlt" class)
#' and a valid time zone argument \code{tz} (as a string)
#' and returns the same time display (but different actual times)
#' as calendar time(s) (of the "POSIXct" class).
#'
#' @param time Time (as a scalar or vector).
#' If \code{time} is not a local time (of the "POSIXlt" class)
#' the function first tries coercing \code{time} into "POSIXlt"
#' without changing the time display.
#'
#' @param tz Time zone (as character string).
#' Default: \code{tz = ""}
#' (i.e., current system time zone, \code{Sys.timezone()}).
#' See \code{OlsonNames()} for valid options.
#'
#' @return A calendar time of class "POSIXct".
#'
#' @examples
#' change_time(as.POSIXlt(Sys.time()), tz = "UTC")
#'
#' # from "POSIXlt" time:
#' t1 <- as.POSIXlt("2020-01-01 10:20:30", tz = "Europe/Berlin")
#' change_time(t1, "Pacific/Auckland")
#' change_time(t1, "America/Los_Angeles")
#'
#' # from "POSIXct" time:
#' tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC")
#' change_time(tc, "Pacific/Auckland")
#'
#' # from "Date":
#' dt <- as.Date("2020-12-31", tz = "Pacific/Honolulu")
#' change_time(dt, tz = "Pacific/Auckland")
#'
#' # from time "string":
#' ts <- "2020-12-31 20:30:45"
#' change_time(ts, tz = "America/Los_Angeles")
#'
#' # from other "string" times:
#' tx <- "7:30:45"
#' change_time(tx, tz = "Asia/Calcutta")
#' ty <- "1:30"
#' change_time(ty, tz = "Europe/London")
#'
#' # convert into local times:
#' (l1 <- as.POSIXlt("2020-06-01 10:11:12"))
#' change_tz(change_time(l1, "Pacific/Auckland"), tz = "UTC")
#' change_tz(change_time(l1, "Europe/Berlin"), tz = "UTC")
#' change_tz(change_time(l1, "America/New_York"), tz = "UTC")
#'
#' # with vector of "POSIXlt" times:
#' (l2 <- as.POSIXlt("2020-12-31 23:59:55", tz = "America/Los_Angeles"))
#' (tv <- c(l1, l2)) # uses tz of l1
#' change_time(tv, "America/Los_Angeles") # change time and tz
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{change_tz}} function which preserves time but changes time display;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
change_time <- function(time, tz = ""){
# 0. Initialize:
ct <- NA
t_display <- NA
# 1. Need local time "POSIXlt" input:
# If NOT:
# A. Parse time to get t_display:
# B. Convert t_display into "POSIXlt"
if (!is_POSIXlt(time)){
# message('change_time: Coercing time to "POSIXlt" with SAME time display.')
# A: Get t_display from various date-time objects:
if (is_POSIXct(time)){
# message('change_time: Parsing time from "POSIXct" as "%Y-%m-%d %H:%M:%S".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M:%S")
} else if (is_Date(time)){
# message('change_time: Parsing time from "Date" as "%Y-%m-%d".')
t_display <- strptime(time, format = "%Y-%m-%d")
} else if (is.character(time)){
# Get t_display by parsing date-time string (using standard formats):
if (grepl(x = time, pattern = ".*(-).*( ).*(:).*(:).*")) { # date + full time:
# message('change_time: Parsing date-time from string as "%Y-%m-%d %H:%M:%S".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M:%S")
} else if (grepl(x = time, pattern = ".*(-).*( ).*(:).*")) { # date + H:M time:
# message('change_time: Parsing date-time from string as "%Y-%m-%d %H:%M".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M")
} else if (grepl(x = time, pattern = ".*(:).*(:).*")) { # H:M:S time:
# message('change_time: Parsing time (with default date) from string as "%H:%M:%S".')
t_display <- strptime(time, format = "%H:%M:%S")
} else if (grepl(x = time, pattern = ".*(:).*")) { # H:M time:
# message('change_time: Parsing time (with default date) from string as "%H:%M".')
t_display <- strptime(time, format = "%H:%M")
} else {
message('change_time: Failed to parse time string.')
}
} else {
message('change_time: Cannot parse time display.')
} # various time classes end.
# B. Convert t_display into POSIXlt:
# print(paste0("t_display = ", t_display)) # debugging
time <- as.POSIXlt(t_display, tz = tz) # Note: tz = "" by default.
} # if (!is_POSIXlt(time)) end.
# 2. Main: Convert time from POSIXlt to POSIXct with tz:
ct <- as.POSIXct(time, tz = tz) # Note: tz = "" by default.
# 3. Output:
return(ct)
} # change_time().
# ## Check:
# change_time(as.POSIXlt(Sys.time()), tz = "Pacific/Auckland")
# #
# # # from "POSIXlt" time:
# (t1 <- as.POSIXlt("2020-01-10 10:20:30", tz = "Europe/Berlin"))
# change_time(t1, "Pacific/Auckland")
# change_time(t1, "Europe/Berlin")
# change_time(t1, "America/New_York")
#
# from "Date":
# dt <- as.Date("2020-12-31", tz = "Pacific/Honolulu")
# format(dt, "%F %T %Z") # Note: tz ignored.
# change_time(dt, tz = "Pacific/Auckland")
#
# # from time "string":
# ts <- "2020-12-31 20:30:45"
# change_time(ts, tz = "America/Los_Angeles")
#
# # from other "string" times:
# tx <- "7:30:45"
# change_time(tx, tz = "Asia/Calcutta")
# ty <- "1:30"
# change_time(ty, tz = "Europe/London")
#
# # convert into local times:
# change_tz(change_time(t1, "Pacific/Auckland"), tz = "UTC")
# change_tz(change_time(t1, "Europe/Berlin"), tz = "UTC")
# change_tz(change_time(t1, "America/New_York"), tz = "UTC")
#
# # from "POSIXct" time:
# (tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC"))
# change_time(tc, "Pacific/Auckland")
#
# # with vector of "POSIXlt" times:
# t2 <- as.POSIXlt("2020-12-31 23:59:55", tz = "America/Los_Angeles")
# tv <- c(t1, t2)
# tv # uses tz of t1
# change_time(tv, "America/Los_Angeles")
# change_tz: ------
# Task 1: Change nominal time to time zone, without changing actual time.
#' Change time zone (without changing represented time).
#'
#' \code{change_tz} changes the nominal time zone (i.e., the time display)
#' without changing the actual time.
#'
#' \code{change_tz} expects inputs to \code{time}
#' to be calendar time(s) (of the "POSIXct" class)
#' and a valid time zone argument \code{tz} (as a string)
#' and returns the same time(s) as local time(s)
#' (of the "POSIXlt" class).
#'
#' @param time Time (as a scalar or vector).
#' If \code{time} is not a calendar time (of the "POSIXct" class)
#' the function first tries coercing \code{time} into "POSIXct"
#' without changing the denoted time.
#'
#' @param tz Time zone (as character string).
#' Default: \code{tz = ""}
#' (i.e., current system time zone, \code{Sys.timezone()}).
#' See \code{OlsonNames()} for valid options.
#'
#' @return A local time of class "POSIXlt".
#'
#' @examples
#' change_tz(Sys.time(), tz = "Pacific/Auckland")
#' change_tz(Sys.time(), tz = "Pacific/Honolulu")
#'
#' # from "POSIXct" time:
#' tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC")
#' change_tz(tc, "Australia/Melbourne")
#' change_tz(tc, "Europe/Berlin")
#' change_tz(tc, "America/Los_Angeles")
#'
#' # from "POSIXlt" time:
#' tl <- as.POSIXlt("2020-07-01 12:00:00", tz = "UTC")
#' change_tz(tl, "Australia/Melbourne")
#' change_tz(tl, "Europe/Berlin")
#' change_tz(tl, "America/Los_Angeles")
#'
#' # from "Date":
#' dt <- as.Date("2020-12-31")
#' change_tz(dt, "Pacific/Auckland")
#' change_tz(dt, "Pacific/Honolulu") # Note different date!
#'
#' # with a vector of "POSIXct" times:
#' t2 <- as.POSIXct("2020-12-31 23:59:55", tz = "America/Los_Angeles")
#' tv <- c(tc, t2)
#' tv # Note: Both times in tz of tc
#' change_tz(tv, "America/Los_Angeles")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{change_time}} function which preserves time display but changes time;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
change_tz <- function(time, tz = ""){
# 0. Initialize:
out <- NA
# 1. Parse time:
if (!is_POSIXct(time)){
# message('change_tz: Coercing time to "POSIXct" without changing represented time.')
time <- as.POSIXct(time) # Note: tz = "" by default.
}
# print(paste0("change_tz: time = ", format(time, "%F %T %Z"))) # debugging
# 2. Main: Convert nominal time (to POSIXlt):
out <- as.POSIXlt(time, tz = tz) # Note: tz = "" by default.
# 3. Output:
return(out)
} # change_tz().
# # Check:
# change_tz(Sys.time(), tz = "Pacific/Auckland")
# change_tz(Sys.time(), tz = "Pacific/Honolulu")
#
# # from "POSIXct" time:
# tc <- as.POSIXct("2020-07-01 12:30:00", tz = "UTC")
# change_tz(tc, "Pacific/Auckland") # Note: Date effect!
# change_tz(tc, "Australia/Melbourne")
# change_tz(tc, "Europe/Berlin")
# change_tz(tc, "America/Los_Angeles")
#
# # from "POSIXlt" time:
# tl <- as.POSIXlt("2020-07-01 12:30:00", tz = "UTC")
# change_tz(tl, "Pacific/Auckland") # Note: Date effect!
# change_tz(tl, "Australia/Melbourne")
# change_tz(tl, "Europe/Berlin")
# change_tz(tl, "America/Los_Angeles")
#
# # from "Date":
# dt <- as.Date("2020-12-31")
# change_tz(dt, "Pacific/Auckland")
# change_tz(dt, "Pacific/Honolulu") # Note different date!
# # Compare:
# lubridate::with_tz(dt, tzone = "Pacific/Auckland") # same result
# lubridate::with_tz(dt, tzone = "Pacific/Honolulu") # same result
#
# # with a vector of "POSIXct" times:
# (t2 <- as.POSIXct("2020-12-31 23:59:55", tz = "America/Los_Angeles"))
# (tv <- c(tc, t2)) # Note: Both times in tz of tc
# change_tz(tv, "America/Los_Angeles")
# # Compare:
# lubridate::with_tz(tv, tzone = "America/Los_Angeles") # same results
## (4) Compute differences between 2 dates/times (in human time units/periods): ------
# diff_days: Difference between two dates (in days, with optional decimals): ------
diff_days <- function(from_date, to_date = Sys.Date(), units = "days", as_Date = TRUE, ...){
# 0. Initialize:
n_days <- NA
# 1. Handle inputs: Assume/convert times into 2 "Date" objects
if (as_Date) { # Convert non-Date (e.g., POSIXt) into "Date" objects:
if (!is_Date(from_date)) { from_date <- date_from_noDate(from_date, ...) }
if (!is_Date(to_date)) { to_date <- date_from_noDate(to_date, ...) }
}
# 2. Main: Use difftime:
t_diff <- base::difftime(to_date, from_date, units = units, ...) # default: units = "days"
# 3. Output:
n_days <- as.numeric(t_diff)
return(n_days)
} # diff_days().
# ## Check:
# ds <- Sys.Date() + -2:+2
# diff_days(ds)
#
# one_year_ago <- Sys.Date() - (365 + is_leap_year(Sys.Date()))
# diff_days(one_year_ago)
#
# ## Note: "Date" objects with DECIMALS are possible:
# (d1 <- Sys.Date())
# (d2 <- Sys.Date() + 1.75)
# diff_days(d1, d2)
#
# ## Note: Date vs. time differences:
# t0 <- as.POSIXct("2020-07-10 00:00:01", tz = "UTC") # start of day
# t1 <- as.POSIXct("2020-07-10 23:59:59", tz = "UTC") # end of day
# t2 <- t1 + 2 # 2 seconds after t1 (but next date)
#
# # By default, only Dates are considered:
# diff_days(t0, t1)
# diff_days(t1, t2)
# diff_days(t0, t2)
#
# # Other units: as_Date must be FALSE:
# diff_days(t0, t1, units = "secs", as_Date = FALSE)
# diff_days(t1, t2, units = "secs", as_Date = FALSE)
# diff_days(t0, t2, units = "secs", as_Date = FALSE)
#
# diff_days(t0, t1, units = "weeks", as_Date = FALSE)
# diff_days(t1, t2, units = "hours", as_Date = FALSE)
# diff_days(t0, t2, units = "mins", as_Date = FALSE)
#
# # Exact time differences (with decimals):
# diff_days(t0, t1, as_Date = FALSE)
# diff_days(t1, t2, as_Date = FALSE)
# diff_days(t0, t2, as_Date = FALSE)
# diff_dates: Compute date difference (i.e., age) in human units: ------
#' Get the difference between two dates (in human units).
#'
#' \code{diff_dates} computes the difference between two dates
#' (i.e., from some \code{from_date} to some \code{to_date})
#' in human measurement units (periods).
#'
#' \code{diff_dates} answers questions like
#' "How much time has elapsed between two dates?"
#' or "How old are you?" in human time periods
#' of (full) years, months, and days.
#'
#' Key characteristics:
#'
#' \itemize{
#'
#' \item If \code{to_date} or \code{from_date} are not "Date" objects,
#' \code{diff_dates} aims to coerce them into "Date" objects.
#'
#' \item If \code{to_date} is missing (i.e., \code{NA}),
#' \code{to_date} is set to today's date (i.e., \code{Sys.Date()}).
#'
#' \item If \code{to_date} is specified, any intermittent missing values
#' (i.e., \code{NA}) are set to today's date (i.e., \code{Sys.Date()}).
#' Thus, dead people (with both birth dates and death dates specified)
#' do not age any further, but people still alive (with \code{is.na(to_date)},
#' are measured to today's date (i.e., \code{Sys.Date()}).
#'
#' \item If \code{to_date} precedes \code{from_date} (i.e., \code{from_date > to_date})
#' computations are performed on swapped days and
#' the result is marked as negative (by a character \code{"-"}) in the output.
#'
#' \item If the lengths of \code{from_date} and \code{to_date} differ,
#' the shorter vector is recycled to the length of the longer one.
#'
#' }
#'
#' By default, \code{diff_dates} provides output as (signed) character strings.
#' For numeric outputs, use \code{as_character = FALSE}.
#'
#' @param from_date From date (required, scalar or vector, as "Date").
#' Date of birth (DOB), assumed to be of class "Date",
#' and coerced into "Date" when of class "POSIXt".
#'
#' @param to_date To date (optional, scalar or vector, as "Date").
#' Default: \code{to_date = Sys.Date()}.
#' Maximum date/date of death (DOD), assumed to be of class "Date",
#' and coerced into "Date" when of class "POSIXt".
#'
#' @param unit Largest measurement unit for representing results.
#' Units represent human time periods, rather than
#' chronological time differences.
#' Default: \code{unit = "years"} for completed years, months, and days.
#' Options available:
#' \enumerate{
#'
#' \item \code{unit = "years"}: completed years, months, and days (default)
#'
#' \item \code{unit = "months"}: completed months, and days
#'
#' \item \code{unit = "days"}: completed days
#'
#' }
#' Units may be abbreviated.
#'
#' @param as_character Boolean: Return output as character?
#' Default: \code{as_character = TRUE}.
#' If \code{as_character = FALSE}, results are returned
#' as columns of a data frame
#' and include \code{from_date} and \code{to_date}.
#'
#' @return A character vector or data frame
#' (with dates, sign, and numeric columns for units).
#'
#' @examples
#' y_100 <- Sys.Date() - (100 * 365.25) + -1:1
#' diff_dates(y_100)
#'
#' # with "to_date" argument:
#' y_050 <- Sys.Date() - (50 * 365.25) + -1:1
#' diff_dates(y_100, y_050)
#' diff_dates(y_100, y_050, unit = "d") # days (with decimals)
#'
#' # Time unit and output format:
#' ds_from <- as.Date("2010-01-01") + 0:2
#' ds_to <- as.Date("2020-03-01") # (2020 is leap year)
#' diff_dates(ds_from, ds_to, unit = "y", as_character = FALSE) # years
#' diff_dates(ds_from, ds_to, unit = "m", as_character = FALSE) # months
#' diff_dates(ds_from, ds_to, unit = "d", as_character = FALSE) # days
#'
#' # Robustness:
#' days_cur_year <- 365 + is_leap_year(Sys.Date())
#' diff_dates(Sys.time() - (1 * (60 * 60 * 24) * days_cur_year)) # for POSIXt times
#' diff_dates("10-08-11", "20-08-10") # for strings
#' diff_dates(20200228, 20200301) # for numbers (2020 is leap year)
#'
#' # Recycling "to_date" to length of "from_date":
#' y_050_2 <- Sys.Date() - (50 * 365.25)
#' diff_dates(y_100, y_050_2)
#'
#' # Note maxima and minima:
#' diff_dates("0000-01-01", "9999-12-31") # max. d + m + y
#' diff_dates("1000-06-01", "1000-06-01") # min. d + m + y
#'
#' # If from_date == to_date:
#' diff_dates("2000-01-01", "2000-01-01")
#'
#' # If from_date > to_date:
#' diff_dates("2000-01-02", "2000-01-01") # Note negation "-"
#' diff_dates("2000-02-01", "2000-01-01", as_character = TRUE)
#' diff_dates("2001-02-02", "2000-02-02", as_character = FALSE)
#'
#' # Test random date samples:
#' f_d <- sample_date(size = 10)
#' t_d <- sample_date(size = 10)
#' diff_dates(f_d, t_d, as_character = TRUE)
#'
#' # Using 'fame' data:
#' dob <- as.Date(fame$DOB, format = "%B %d, %Y")
#' dod <- as.Date(fame$DOD, format = "%B %d, %Y")
#' head(diff_dates(dob, dod)) # Note: Deceased people do not age further.
#' head(diff_dates(dob, dod, as_character = FALSE)) # numeric outputs
#'
#' @family date and time functions
#'
#' @seealso
#' Time spans (\code{interval} \code{as.period}) in the \strong{lubridate} package.
#'
#' @export
diff_dates <- function(from_date, to_date = Sys.Date(),
unit = "years", as_character = TRUE){
# 0. Initialize:
today <- Sys.Date() # (do only once)
age <- NA
# 1. Handle inputs: ------
# (a) NA inputs: ----
if (any(is.na(from_date))){
message('diff_dates: "from_date" must not be NA.')
return(NA)
}
if (all(is.na(to_date))){
message('diff_dates: Changing "to_date" from NA to "Sys.Date()".')
to_date <- today
}
# (b) Turn non-Date inputs into "Date" objects: ----
if (!is_Date(from_date)){
# message('diff_dates: Aiming to parse "from_date" as "Date".')
from_date <- date_from_noDate(from_date)
}
if (!is_Date(to_date)){
# message('diff_dates: Aiming to parse "to_date" as "Date".')
to_date <- date_from_noDate(to_date)
}
# (c) Recycle shorter date vector to length of longer one: ----
aligned_v <- align_vec_pair(v1 = from_date, v2 = to_date)
from_date <- aligned_v[[1]]
to_date <- aligned_v[[2]]
## WAS:
# (c) Recycle or truncate to_date argument based on from_date:
# to_date <- align_vec(v_mod = to_date, v_fix = from_date)
# Note: from_date and to_date now have the same length:
n_dates <- length(from_date)
# (d) Replace intermittent NA values in to_date by current date: ----
# Axiom: Dead people do not age any further, but
# if to_date = NA, we want to measure until today:
set_to_date_NA_to_NOW <- TRUE # if FALSE: Occasional to_date = NA values yield NA result.
if (set_to_date_NA_to_NOW){
if (!all(is.na(to_date))){ # only SOME to_date values are missing:
to_date[is.na(to_date)] <- today # replace those NA values by today = Sys.Date()
}
}
# (e) Verify that from_date and to_date are "Date" objects: ----
if (!is_Date(from_date)){
message('diff_dates: "from_date" should be of class "Date".')
# print(from_date) # debugging
}
if (!is_Date(to_date)){
message('diff_dates: "to_date" should be of class "Date".')
# print(to_date) # debugging
}
# (f) For cases of (from_date > to_date): Swap dates and negate sign:
from_date_org <- from_date # store original orders
to_date_org <- to_date # (to list in outputs)
ix_swap <- (from_date > to_date) # ix of cases to swap
from_date_temp <- from_date[ix_swap] # temporary storage
from_date[ix_swap] <- to_date[ix_swap] # from_date by to_date
to_date[ix_swap] <- from_date_temp # to_date by from_date
sign <- rep("", n_dates) # initialize (as character)
sign[ix_swap] <- "-" # negate sign (character)
# message(sign) # debugging
# (g) Unit: ----
unit <- substr(tolower(unit), 1, 1) # robustness: use only 1st letter: y/m/d
if (!unit %in% c("y", "m", "d")){
message('diff_dates: unit must be "year", "month", or "day". Using "year".')
unit <- "y"
}
# 2. Main function: ------
# (a) initialize other variables:
full_y <- NA
full_m <- NA
full_d <- NA
full_d_1 <- NA
full_d_2 <- NA
# (b) Special case: unit == "d" ----
if (unit == "d"){
# Use diff_days() helper/utility function:
full_d <- diff_days(from_date = from_date, to_date = to_date)
if (as_character){
age <- paste0(sign, full_d, "d")
} else { # return a data frame:
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"d" = full_d,
row.names = 1:n_dates)
}
return(age)
}
# (c) All other units (y/m): Get date elements ----
# from_date elements (DOB):
bd_y <- as.numeric(format(from_date, "%Y"))
bd_m <- as.numeric(format(from_date, "%m"))
bd_d <- as.numeric(format(from_date, "%d"))
# to_date elements (DOD, max. date):
to_y <- as.numeric(format(to_date, "%Y"))
to_m <- as.numeric(format(to_date, "%m"))
to_d <- as.numeric(format(to_date, "%d"))
# (c1) Completed years:
# bday this year? (as Boolean):
bd_ty <- ifelse((to_m > bd_m) | ((to_m == bd_m) & (to_d >= bd_d)), TRUE, FALSE)
# print(bd_ty)
full_y <- (to_y - bd_y) - (1 * !bd_ty)
# (c2) Completed months:
# bday this month? (as Boolean):
bd_tm <- ifelse((to_d >= bd_d), TRUE, FALSE)
# print(bd_tm)
## Distinguish 2 cases:
# full_m[bd_ty] <- (to_m[bd_ty] - bd_m[bd_ty]) - !bd_tm[bd_ty] # 1: bd_ty
# full_m[!bd_ty] <- (12 + to_m[!bd_ty] - bd_m[!bd_ty]) - !bd_tm[!bd_ty] # 2: !bd_ty
## Combine both cases:
full_m <- (to_m - bd_m) + (12 * !bd_ty) - (1 * !bd_tm)
if (unit == "m"){
full_m <- (12 * full_y) + full_m # express years in months
}
# (c3) Completed days:
## bday today? (as Boolean):
# bd_td <- ifelse((to_d == bd_d), TRUE, FALSE)
# Use 2 solutions:
# s_1: LOCAL solution: Determine the number N of days in last month.
# Then use this number to compute difference from bd_d to to_d
## Distinguish 2 cases:
# full_d_1[bd_tm] <- to_d[bd_tm] - bd_d[bd_tm] # 1: bd_tm: days since bd_tm
# full_d_1[!bd_tm] <- to_d[!bd_tm] - bd_d[!bd_tm] + days_last_month(to_date[!bd_tm]) # 2: !bd_tm
## Combine cases:
dlm_to <- days_last_month(to_date)
# full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) # ERROR: See diverging cases below.
## Bug FIX: If bday would have been after the maximum day of last month:
ix_2_fix <- !bd_tm & (bd_d > dlm_to) # ix of cases to fix:
# full_d_1[ix_2_fix] <- to_d[ix_2_fix] # full_d <- to_d for these cases
## ALL-in-ONE:
full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) + ((bd_d - dlm_to) * ix_2_fix)
# message(paste(full_d, collapse = " ")) # debugging
# s_2: GLOBAL solution: Start from total number of days and
# subtract all days of full years and months already accounted for.
# Use diff_days() helper function to compute exact number of days between two dates:
# full_d_2 <- total_days - accounted_days
# = diff_days(DOB, to_date) - diff_days(DOB, to_date = dt_bday_last_month(to_date))
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_date, to_date = to_date)
# Use dt_bday_last_month() helper/utility function (Note: may return decimals):
dt_bday_last_month <- dt_last_monthly_bd(dob = from_date, to_date = to_date)
accounted_days <- diff_days(from_date = from_date, to_date = dt_bday_last_month)
unaccounted_days <- (total_days - accounted_days) # may contain decimals!
# Only consider completed/full days (as integers):
full_d_2 <- floor(unaccounted_days)
# message(paste("total_days = ", total_days, collapse = ", ")) # debugging
# message(paste("accounted_days = ", accounted_days, collapse = ", ")) # debugging
# message(paste("full_d_2 = ", full_d_2, collapse = ", ")) # debugging
# s+3: Verify equality of both solutions: ----
verify_equality <- TRUE
if (verify_equality & (!all(full_d_1 == full_d_2))){
message('diff_dates: 2 methods for full days yield different results (d_1 vs. d_2):')
# Diagnostic info (for debugging):
ix_diff <- (full_d_1 != full_d_2)
if (n_dates > 1){
message(paste(which(ix_diff), collapse = ", "))
message(paste(from_date[ix_diff], collapse = ", "))
message(paste(to_date[ix_diff], collapse = ", "))
}
message(paste("y:", full_y[ix_diff], collapse = ", "))
message(paste("m:", full_m[ix_diff], collapse = ", "))
message(paste("d 1:", full_d_1[ix_diff], collapse = ", "))
message(paste("d_2:", full_d_2[ix_diff], collapse = ", "))
}
# Decision: Use full_d_1
full_d <- full_d_1
# 3. Output: ------
if (as_character){
if (unit == "y"){
age <- paste0(sign, full_y, "y ", full_m, "m ", full_d, "d")
} else if (unit == "m"){
age <- paste0(sign, full_m, "m ", full_d, "d")
}
} else { # return a data frame:
if (unit == "y"){
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"y" = full_y,
"m" = full_m,
"d" = full_d,
row.names = 1:n_dates)
} else if (unit == "m"){
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"m" = full_m,
"d" = full_d,
row.names = 1:n_dates)
}
}
return(age)
} # diff_dates().
# ## Check:
# # Days:
# (ds_from <- as.Date("2010-01-02") + -1:1)
# (ds_to <- as.Date("2020-03-01")) # Note: 2020 is leap year.
# diff_dates(from_date = ds_from, to_date = ds_to)
# diff_dates(from_date = ds_from, to_date = ds_to, unit = "m")
# diff_dates(from_date = ds_from, to_date = ds_to, unit = "d")
#
# # Months:
# ms <- Sys.Date() - 366 + seq(from = -100, to = +100, by = 50)
# ms
# diff_dates(ms)
#
# y_100 <- Sys.Date() - (100 * 365.25) + -1:1
# y_100
# diff_dates(y_100)
#
# # with "to_date" argument:
# y_050 <- Sys.Date() - (50 * 365.25) + -1:1
# y_050
# diff_dates(y_100, y_050)
#
# Recycling vector lengths:
# # # (a) recycling "to_date" to length of "from_date":
# y_050_2 <- Sys.Date() - (50 * 365.25)
# y_050_2
# diff_dates(y_100, y_050_2, as_character = FALSE)
#
# # (b) recycling "from_date" to length of "to_date":
# to_dates <- paste("2020", 1:12, "15", sep = "-")
# diff_dates(from_date = "2000-01-01", to_dates, as_character = FALSE)
#
# # Using 'fame' data:
# (dob <- as.Date(fame$DOB, format = "%B %d, %Y"))
# (dod <- as.Date(fame$DOD, format = "%B %d, %Y"))
# diff_dates(dob, dod, as_character = TRUE)
# diff_dates(dob, dod, unit = "m")
# diff_dates(dob, dod, unit = "d")
#
# # Extreme cases:
# # (a) from_date == to_date:
# diff_dates("1000-01-01", "2000-12-31") # max. d + m
# diff_dates("1000-06-01", "1000-06-01") # min. d + m + y
#
# # (b) from_date > to_date:
# # Reverse result and add negation sign ("-"):
# diff_dates("2000-01-02", "2000-01-03")
# diff_dates("2000-02-01", "2000-01-01", as_character = TRUE)
# diff_dates("2001-02-02", "2000-02-02", as_character = FALSE)
#
# ## Check consistency (of 2 solutions):
#
# ## Test with random date samples:
# from <- sample_date(size = 100) - 0.11
# to <- sample_date(size = 100) + 0.22
# diff_dates(from, to, unit = "y", as_character = FALSE)
# diff_dates(from, to, unit = "d", as_character = TRUE)
#
# ## Test with random TIME samples:
# from <- sample_time(size = 100) - .25
# to <- sample_time(size = 100) + .25
# diff_dates(from, to, unit = "y", as_character = TRUE)
# diff_dates(from, to, unit = "d", as_character = TRUE)
#
## Test with date strings:
# from <- "2000-01-01"
# to <- paste("2020", 1:12, "11", sep = "-")
# diff_dates(from, to, unit = "y", as_character = FALSE)
#
#
# # Verify possibly diverging cases:
#
# # 1:
# dob <- as.Date("1981-05-31")
# dod <- as.Date("1992-05-08")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 2:
# dob <- as.Date("1983-07-30")
# dod <- as.Date("1994-03-03")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 3:
# dob <- as.Date("1973-10-31")
# dod <- as.Date("1982-12-29")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 4:
# dob <- as.Date("1979-07-31")
# dod <- as.Date("1998-07-18")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 5:
# dob <- as.Date("1999-05-31")
# dod <- as.Date("1999-10-07")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# ## Analyze: Compare results to other methods:
#
# ## (a) lubridate time spans (interval, periods):
# lubridate::as.period(dob %--% dod, unit = "years")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
# diff_dates(dob, dod, unit = "years")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "months")
# diff_dates(dob, dod, unit = "months")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "days")
# diff_dates(dob, dod, unit = "days")
#
# ## (b) base::difftime():
# all.equal(as.numeric(dod - dob), diff_days(dob, dod))
# all.equal(as.numeric(difftime(dod, dob)), diff_days(dob, dod))
# difftime(dod, dob, units = "weeks") # Note: No "weeks" in diff_dates().
#
# # from strings:
# diff_dates("2000-12-31")
# diff_dates("90-01-02", to_date = "10-01-01")
#
# # from numbers:
# diff_dates(20001231) # turned into character > Date
# diff_dates(19900711, to_date = 20100710)
#
# # NAs:
# diff_dates(from_date = y_100, to_date = NA)
# diff_dates(from_date = NA, to_date = NA)
## ToDo:
# - add n_decimals argument? (default of 0).
#
# - Add exercise to Chapter 10:
# Explore the diff_dates() function that computes
# the difference between two dates (in human measurement units).
# - Use result to compute age in years (as a number) and months (as a number).
# - Use result to compute age in full weeks (as a number).
# - Use result to add a week entry "Xw" between month m and day d.
# diff_times: Compute time difference (i.e., age) in human units: ------
#' Get the difference between two times (in human units).
#'
#' \code{diff_times} computes the difference between two times
#' (i.e., from some \code{from_time} to some \code{to_time})
#' in human measurement units (periods).
#'
#' \code{diff_times} answers questions like
#' "How much time has elapsed between two dates?"
#' or "How old are you?" in human time periods
#' of (full) years, months, and days.
#'
#' Key characteristics:
#'
#' \itemize{
#'
#' \item If \code{to_time} or \code{from_time} are not "POSIXct" objects,
#' \code{diff_times} aims to coerce them into "POSIXct" objects.
#'
#' \item If \code{to_time} is missing (i.e., \code{NA}),
#' \code{to_time} is set to the current time (i.e., \code{Sys.time()}).
#'
#' \item If \code{to_time} is specified, any intermittent missing values
#' (i.e., \code{NA}) are set to the current time (i.e., \code{Sys.time()}).
#'
#' \item If \code{to_time} precedes \code{from_time} (i.e., \code{from_time > to_time})
#' computations are performed on swapped times and the result is marked
#' as negative (by a character \code{"-"}) in the output.
#'
#' \item If the lengths of \code{from_time} and \code{to_time} differ,
#' the shorter vector is recycled to the length of the longer one.
#'
#' }
#'
#' By default, \code{diff_times} provides output as (signed) character strings.
#' For numeric outputs, use \code{as_character = FALSE}.
#'
#' @param from_time From time (required, scalar or vector, as "POSIXct").
#' Origin time, assumed to be of class "POSIXct",
#' and coerced into "POSIXct" when of class "Date" or "POSIXlt.
#'
#' @param to_time To time (optional, scalar or vector, as "POSIXct").
#' Default: \code{to_time = Sys.time()}.
#' Maximum time, assumed to be of class "POSIXct",
#' and coerced into "POSIXct" when of class "Date" or "POSIXlt".
#'
#' @param unit Largest measurement unit for representing results.
#' Units represent human time periods, rather than
#' chronological time differences.
#' Default: \code{unit = "days"} for completed days, hours, minutes, and seconds.
#' Options available:
#' \enumerate{
#'
#' \item \code{unit = "years"}: completed years, months, and days (default)
#'
#' \item \code{unit = "months"}: completed months, and days
#'
#' \item \code{unit = "days"}: completed days
#'
#' \item \code{unit = "hours"}: completed hours
#'
#' \item \code{unit = "minutes"}: completed minutes
#'
#' \item \code{unit = "seconds"}: completed seconds
#'
#' }
#' Units may be abbreviated.
#'
#' @param as_character Boolean: Return output as character?
#' Default: \code{as_character = TRUE}.
#' If \code{as_character = FALSE}, results are returned
#' as columns of a data frame
#' and include \code{from_date} and \code{to_date}.
#'
#' @return A character vector or data frame
#' (with times, sign, and numeric columns for units).
#'
#' @examples
#' t1 <- as.POSIXct("1969-07-13 13:53 CET") # (before UNIX epoch)
#' diff_times(t1, unit = "years", as_character = TRUE)
#' diff_times(t1, unit = "secs", as_character = TRUE)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{diff_dates}} for date differences;
#' time spans (an \code{interval} \code{as.period}) in the \strong{lubridate} package.
#'
#' @export
diff_times <- function(from_time, to_time = Sys.time(),
unit = "days", as_character = TRUE){
# 0. Initialize:
now <- Sys.time() # (do only once)
age <- NA
# 1. Handle inputs: ------
# (a) NA inputs:
if (any(is.na(from_time))){
message('diff_times: "from_time" must not be NA.')
return(NA)
}
if (all(is.na(to_time))){
message('diff_times: Changing "to_time" from NA to "Sys.time()".')
to_time <- now
}
# (b) Turn non-Date inputs into "Date" objects
if (!is_POSIXct(from_time)){
# message('diff_times: Aiming to parse "from_time" as "POSIXct".')
from_time <- time_from_noPOSIXt(from_time)
}
if (!is_POSIXct(to_time)){
# message('diff_times: Aiming to parse "to_time" as "POSIXct".')
to_time <- time_from_noPOSIXt(to_time)
}
# (c) Recycle shorter time vector to length of longer one: ----
aligned_v <- align_vec_pair(v1 = from_time, v2 = to_time)
from_time <- aligned_v[[1]]
to_time <- aligned_v[[2]]
## WAS: (c) Recycle or truncate to_time argument based on from_time:
# to_time <- align_vec(v_mod = to_time, v_fix = from_time)
# Note: from_time and to_time now have the same length:
n_times <- length(from_time)
# (d) Replace intermittent NA values in to_time by current time:
# Axiom: Entities with a given to_time do not age any further, but
# if to_time = NA, we want to measure until now:
set_to_time_NA_to_NOW <- TRUE # if FALSE: Occasional to_time = NA values yield NA result.
if (set_to_time_NA_to_NOW){
if (!all(is.na(to_time))){ # only SOME to_time values are missing:
to_time[is.na(to_time)] <- now # replace those NA values by now = Sys.time()
}
}
# (e) Verify that from_time and to_time are "POSIXct" objects:
if (!is_POSIXct(from_time)){
message('diff_times: "from_time" should be of class "POSIXct".')
# print(from_time) # debugging
}
if (!is_POSIXct(to_time)){
message('diff_times: "to_time" should be of class "POSIXct".')
# print(to_time) # debugging
}
# (f) If from_time > to_time: Swap dates and negate sign:
from_time_org <- from_time # store original orders
to_time_org <- to_time # (to list in outputs)
ix_swap <- (from_time > to_time) # ix of cases to swap
from_time_temp <- from_time[ix_swap] # temporary storage
from_time[ix_swap] <- to_time[ix_swap] # from_time by to_time
to_time[ix_swap] <- from_time_temp # to_time by from_time
sign <- rep("", n_times) # initialize (as character)
sign[ix_swap] <- "-" # negate sign (character)
# message(sign) # debugging
# (g) Unit:
unit <- substr(tolower(unit), 1, 2) # robustness: use only 1st letter: y/m/d
if (!unit %in% c("ye", "mo", "da", "ho", "mi", "se")){
message('diff_times: unit must be "year", "month", "day", "hour", "min", "sec". Using "day".')
unit <- "da"
}
# 2. Main function: ------
# (a) initialize other variables:
full_y <- NA
full_m <- NA
full_d <- NA
full_d_1 <- NA
full_d_2 <- NA
full_H <- NA
full_M <- NA
full_S <- NA
# (b) total time (in sec):
total_time_sec <- diff_days(from_date = from_time, to_date = to_time, units = "sec", as_Date = FALSE)
# (c) Special case: unit == "sec" ----
if (unit == "se"){
# Use diff_days() helper/utility function:
full_S <- total_time_sec
if (as_character){
age <- paste0(sign, full_S, "S")
} else { # return a data frame:
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"S" = full_S,
row.names = 1:n_times)
}
return(age)
}
# (d) All other units (year/month/day/hour/min): Get date elements ----
# from_time elements (DOB):
bd_y <- as.numeric(format(from_time, "%Y"))
bd_m <- as.numeric(format(from_time, "%m"))
bd_d <- as.numeric(format(from_time, "%d"))
bd_H <- as.numeric(format(from_time, "%H"))
bd_M <- as.numeric(format(from_time, "%M"))
bd_S <- as.numeric(format(from_time, "%S"))
# to_time elements (DOD, max. time):
to_y <- as.numeric(format(to_time, "%Y"))
to_m <- as.numeric(format(to_time, "%m"))
to_d <- as.numeric(format(to_time, "%d"))
to_H <- as.numeric(format(to_time, "%H"))
to_M <- as.numeric(format(to_time, "%M"))
to_S <- as.numeric(format(to_time, "%S"))
# (+) Special case: Consider possible time difference due to different time zones:
tz_diff_mins <- diff_tz(t1 = from_time, t2 = to_time, in_min = TRUE)
tz_diff_days <- tz_diff_mins / (60 * 24) # in days
# (e) Case: largest unit year/month: ----
if (unit == "ye" || unit == "mo"){
# (e1) Completed years:
# bday this year? (as Boolean):
bd_ty <- ifelse(( (to_m > bd_m) | ((to_m == bd_m) & (to_d > bd_d)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H > bd_H)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H == bd_H) & (to_M > bd_M)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S))), TRUE, FALSE)
# print(bd_ty)
full_y <- (to_y - bd_y) - (1 * !bd_ty)
# (e2) Completed months:
# bday this month? (as Boolean):
bd_tm <- ifelse(((to_d > bd_d) | ((to_d == bd_d) & (to_H > bd_H)) |
((to_d == bd_d) & (to_H == bd_H) & (to_M > bd_M)) |
((to_d == bd_d) & (to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S))), TRUE, FALSE)
# print(bd_tm)
## Distinguish 2 cases:
# full_m[bd_ty] <- (to_m[bd_ty] - bd_m[bd_ty]) - !bd_tm[bd_ty] # 1: bd_ty
# full_m[!bd_ty] <- (12 + to_m[!bd_ty] - bd_m[!bd_ty]) - !bd_tm[!bd_ty] # 2: !bd_ty
## Combine both cases:
full_m <- (to_m - bd_m) + (12 * !bd_ty) - (1 * !bd_tm)
# Special case:
if (unit == "mo"){
full_m <- (12 * full_y) + full_m # express years in months
full_y <- 0 # reset years
}
# (e3) Completed days:
## Reached bday-time today? (as Boolean):
bd_td <- ifelse((to_H > bd_H) |
((to_H == bd_H) & (to_M > bd_M)) |
((to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S)), TRUE, FALSE)
# Use 2 solutions:
# s_1: LOCAL solution: Determine the number N of days in last month.
# Then use this number to compute difference from bd_d to to_d
## Distinguish 2 cases:
# full_d_1[bd_tm] <- to_d[bd_tm] - bd_d[bd_tm] # 1: bd_tm: days since bd_tm
# full_d_1[!bd_tm] <- to_d[!bd_tm] - bd_d[!bd_tm] + days_last_month(to_date[!bd_tm]) # 2: !bd_tm
## Combine cases:
dlm_to <- days_last_month(to_time)
# full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) # ERROR: See diverging cases below.
## Bug FIX: If bday would have been after the maximum day of last month:
ix_2_fix <- !bd_tm & (bd_d > dlm_to) # ix of cases to fix:
# full_d_1[ix_2_fix] <- to_d[ix_2_fix] # full_d <- to_d for these cases
## ALL-in-ONE:
full_d_1 <- (to_d - bd_d) + (dlm_to * !bd_tm) + ((bd_d - dlm_to) * ix_2_fix) - (1 * !bd_td)
# s_2: GLOBAL solution: Start from total number of days and
# subtract all days of full years and months already accounted for.
# Use diff_days() helper function to compute exact number of days between two dates:
# full_d_2 <- total_days - accounted_days
# = diff_days(DOB, to_date) - diff_days(DOB, to_date = dt_bday_last_month(to_date))
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_time, to_date = to_time, units = "days", as_Date = FALSE)
# Use dt_bday_last_month() helper/utility function (Note: may return decimals):
dt_bday_last_month <- dt_last_monthly_bd(dob = from_time, to_date = to_time) # tz = "" is NO LONGER necessary!!
accounted_days_ym2 <- diff_days(from_date = from_time, to_date = dt_bday_last_month)
unaccounted_days <- (total_days - accounted_days_ym2) # may contain decimals!
# Correction: If tz_diff_mins differ from zero:
ix_tz_diff <- (tz_diff_mins != 0)
unaccounted_days[ix_tz_diff] <- unaccounted_days[ix_tz_diff] + tz_diff_days[ix_tz_diff]
# Only consider completed/full days (as integers):
full_d_2 <- floor(unaccounted_days)
## Correction: Add 1 day if bd_td is TRUE:
# full_d_2[bd_td] <- full_d_2[bd_td] + 1 # Problem: Too general (lots of error cases).
debugging_feedback <- FALSE # TRUE = debugging info
if (debugging_feedback){
message('diff_times debugging info (computing full_d_1 vs. full_d_2):')
# above:
message(paste("full_y = ", full_y, collapse = ", ")) # debugging
message(paste("full_m = ", full_m, collapse = ", ")) # debugging
message(paste("full_d_1 = ", full_d_1, collapse = ", ")) # debugging
# new:
message(paste("total_days = ", total_days, collapse = ", ")) # debugging
message(paste("dt_bday_last_month = ", dt_bday_last_month, collapse = ", ")) # debugging
message(paste("accounted_days_ym2 = ", accounted_days_ym2, collapse = ", ")) # debugging
message(paste("unaccounted_days = ", unaccounted_days, collapse = ", ")) # debugging
message(paste("tz_diff_mins = ", tz_diff_mins, collapse = ", ")) # debugging
message(paste("tz_diff_days = ", tz_diff_days, collapse = ", ")) # debugging
message(paste("full_d_2 = ", full_d_2, collapse = ", ")) # debugging
}
# +++ here now +++
# s+3: Verify equality of both solutions: ----
verify_equality <- TRUE
if (verify_equality & (!all(full_d_1 == full_d_2))){
message('diff_times: 2 methods for full days yield different results (d_1 vs. d_2):')
# Diagnostic info (for debugging):
ix_diff <- (full_d_1 != full_d_2)
if (n_times > 1){
message(paste("ix_diff:", which(ix_diff), collapse = ", "))
message(paste("from_time:", from_time[ix_diff], collapse = ", "))
message(paste("to_time:", to_time[ix_diff], collapse = ", "))
}
message(paste("y:", full_y[ix_diff], collapse = ", "))
message(paste("m:", full_m[ix_diff], collapse = ", "))
message(paste("d_1:", full_d_1[ix_diff], collapse = ", "))
message(paste("d_2:", full_d_2[ix_diff], collapse = ", "))
}
# # Decision 1: Use full_d_1:
# full_d <- full_d_1
# Problem: We need accounted_days_ym2 for computing accounted_time_sec!
# Decision 2: Use full_d_2.
full_d <- full_d_2
## Special case: full_d_2 is negative:
if (any(full_d_2 < 0)){
# message('diff_times: Incrementing month count for negative full day count.')
ix_neg_days <- (full_d_2 < 0)
full_m[ix_neg_days] <- full_m[ix_neg_days] + 1 # increment month count
}
# Store accounted time (in sec):
accounted_time_sec <- (accounted_days_ym2 * (24 * 60 * 60)) + (full_d * (24 * 60 * 60))
} # if (unit == "ye" | unit == "mo").
# (f) Case: largest unit day: ----
if (unit == "da"){
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_time, to_date = to_time, units = "days", as_Date = FALSE)
# Only consider completed/full days (as integers):
full_d <- floor(total_days)
# accounted_days_d <- full_d
# unaccounted_days <- total_days - accounted_days_d # may contain decimals!
# Store accounted time (in sec):
accounted_time_sec <- (full_d * (24 * 60 * 60))
} # if (unit == "da").
# (g) Case: largest unit hour/min:
if (unit == "ho" | unit == "mi"){
accounted_time_sec <- 0
}
# (c4) Remaining time units: ----
# Global approach: Determine total time (in sec) and subtract accounted time (in sec):
unaccounted_time_sec <- (total_time_sec - accounted_time_sec)
# Special case: Account for possible tz difference:
unaccounted_time_sec <- unaccounted_time_sec + (tz_diff_mins * 60)
full_H <- unaccounted_time_sec %/% (60 * 60)
full_M <- (unaccounted_time_sec - (full_H * (60 * 60))) %/% 60
full_S <- (unaccounted_time_sec - (full_H * (60 * 60)) - (full_M * 60))
# Special case:
if (unit == "mi"){
full_M <- (60 * full_H) + full_M # express hours in minutes
full_H <- 0 # reset hours
}
# 3. Output: ------
if (as_character){
if (unit == "ye"){
age <- paste0(sign, full_y, "y ", full_m, "m ", full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "mo"){
age <- paste0(sign, full_m, "m ", full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "da"){
age <- paste0(sign, full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "ho"){
age <- paste0(sign, full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "mi"){
age <- paste0(sign, full_M, "M ", full_S, "S")
}
} else { # return a data frame:
if (unit == "ye"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"y" = full_y,
"m" = full_m,
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "mo"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"m" = full_m,
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "da"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "ho"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "mi"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
}
}
return(age)
} # diff_times().
# ## Check:
#
# t1 <- as.POSIXct("1969-07-13 13:53 CET")
# t2 <- Sys.time()
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# diff_times(t1, t2, unit = "month", as_character = TRUE)
# diff_times(t1, t2, unit = "day", as_character = TRUE)
# diff_times(t1, t2, unit = "hour", as_character = TRUE)
# diff_times(t1, t2, unit = "min", as_character = TRUE)
# diff_times(t1, t2, unit = "sec", as_character = TRUE)
#
# # Test with random TIME samples:
# from <- sample_time(size = 100, from = "2020-01-01")
# to <- sample_time(size = 100, from = "2020-04-01")
#
# # "year":
# diff_times(from, to, unit = "year", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "years")
# Note differences in hour counts (due to DST).
# But: diff_times more consistent (see results for unit = "days")!
#
# # "month":
# diff_times(from, to, unit = "month", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "months")
# # Note differences in hour counts (due to DST).
# # But: diff_times more consistent (see results for unit = "days")!
#
# # "day":
# diff_times(from, to, unit = "day", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "day")
#
# # "hour":
# diff_times(from, to, unit = "hour", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "hour")
#
# # "min":
# diff_times(from, to, unit = "min", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "min")
#
# # "sec":
# diff_times(from, to, unit = "sec", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "sec")
# ## Former problems/error cases:
#
# # A. now resolved:
#
# # (a)
# t1 <- "2020-05-31 05:41:27"
# t2 <- "2020-07-01 01:29:06"
# diff_times(t1, t2, unit = "year", as_character = FALSE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Bug fix: Add default argument tz = "" to date_from_noDate() and date_from_string() functions:
# dt_last_monthly_bd(t1, t2) # "2020-06-30" is correct.
#
# # (b)
# t1 <- "2020-06-07 01:08:48"
# t2 <- "2020-07-09 22:49:20"
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # (c) DST switch (a: spring ahead):
# t1 <- "2020-03-28 12:00:00" # before DST switch
# t2 <- "2020-03-29 12:00:00" # after DST switch (on 2020-03-29: 02:00:00 > 03:00:00)
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Solved by using new utility/helper function:
# diff_tz(t1, t2, in_min = TRUE)
#
# # (d) DST switch (b: fall back):
# t1 <- "2020-10-24 12:00:00" # before DST switch
# t2 <- "2020-10-25 12:00:00" # after DST switch (on 2020-10-25: 03:00:00 > 02:00:00)
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Solved by using new utility/helper function:
# diff_tz(t1, t2, in_min = TRUE)
#
# # (e) Differences between diff_times() and lubridate solution:
# t1 <- "2020-03-26 23:26:38"
# t2 <- "2020-05-02 19:13:20"
# diff_times(t1, t2, unit = "days", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "days")
#
# t1 <- "2020-03-05 05:18:25"
# t2 <- "2020-05-24 07:27:05"
# diff_times(t1, t2, unit = "days", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "days")
# # B. NOT resolved YET:
#
# (x) Error/discrepancy case:
# t1 <- "2020-04-23 16:15:22"
# t2 <- "2020-06-23 04:14:54"
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# dt_last_monthly_bd(t1, t2) # "2020-06-23" is correct.
#
# (y) Differences between diff_times() and lubridate solution:
# t1 <- "2020-06-04 08:39:07"
# t2 <- "2020-04-19 09:32:36"
# diff_times(t1, t2, unit = "years", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
## ToDo:
# - add n_decimals argument? (default of 0).
## (5) Get zodiac name/symbol for given date(s): ------
#' Get zodiac (corresponding to date x).
#'
#' \code{zodiac} provides the tropical zodiac sign or symbol
#' for given date(s) \code{x}.
#'
#' \code{zodiac} is flexible by providing different
#' output formats (in Latin/English, German, or Unicode/HTML,
#' see \code{out}) and allowing to adjust the calendar dates
#' on which a new zodiac is assigned (via \code{zodiac_swap_mmdd}).
#'
#' @param x Date (as a scalar or vector, required).
#' If \code{x} is not a date (of class "Date"),
#' the function tries to coerce \code{x} into a "Date".
#'
#' @param out Output format (as character).
#' Available output formats are:
#' English/Latin (\code{out = "en"}, by default),
#' German/Deutsch (\code{out = "de"}),
#' HTML (\code{out = "html"}), or
#' Unicode (\code{out = "Unicode"}) symbols.
#'
#' @param zodiac_swap_mmdd Monthly dates on which
#' the 12 zodiac signs switch (in \code{mmdd} format,
#' ordered chronologically within a calendar year).
#' Default: \code{zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
#' 0723, 0823, 0923, 1023, 1123, 1222)}.
#'
#' @return Zodiac label or symbol (as a factor).
#'
#' @examples
#' zodiac(Sys.Date())
#'
#' # Works with vectors:
#' dt <- sample_date(size = 10)
#' zodiac(dt)
#' levels(zodiac(dt))
#'
#' # Alternative outputs:
#' zodiac(dt, out = "de") # German/deutsch
#' zodiac(dt, out = "Unicode") # Unicode
#' zodiac(dt, out = "HTML") # HTML
#'
#' # Alternative date breaks:
#' zodiac("2000-08-23") # 0823 is "Virgo" by default
#' zodiac("2000-08-23", # change to 0824 (i.e., August 24):
#' zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
#' 0723, 0824, 0923, 1023, 1123, 1222))
#'
#' @source See
#' \url{https://en.wikipedia.org/wiki/Zodiac} or
#' \url{https://de.wikipedia.org/wiki/Tierkreiszeichen}
#' for alternative date ranges.
#'
#' @family date and time functions
#'
#' @seealso
#' \code{Zodiac()} function of the \strong{DescTools} package.
#'
#' @export
zodiac <- function(x,
out = "en",
zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
0723, 0823, 0923, 1023, 1123, 1222)
){
# 0. Initialize:
date <- NA
zod <- NA
# 1. Handle inputs: ------
# (a) NA inputs: ----
if (any(is.na(x))){
message('zodiac: "date" must not be NA.')
return(NA)
}
# (b) Turn non-Date inputs into "Date" objects: ----
if (!is_Date(x)){
# message('zodiac: Aiming to parse "x" as "Date".')
date <- date_from_noDate(x)
} else {
date <- x
}
# 2. Determine month and days:
mm <- as.numeric(format(date, "%m"))
dd <- as.numeric(format(date, "%d"))
mm <- num_as_char(mm, n_pre_dec = 2, n_dec = 0)
dd <- num_as_char(dd, n_pre_dec = 2, n_dec = 0)
mmdd <- as.numeric(paste0(mm, dd)) # as number (from 101 to 1231)
# 3. Get zodiac sign/symbol for date: -----
# Data: Date breaks and labels:
# Aries: Mar 21 – Apr 20: Widder
# Taurus: Apr 21 – May 20: Stier
# Gemini: May 21 – Jun 20: Zwillinge
# Cancer: Jun 21 – Jul 22: Krebs
# Leo: Jul 23 – Aug 22: Loewe
# Virgo: Aug 23 – Sep 22: Jungfrau
# Libra: Sep 23 – Oct 22: Waage
# Scorpio: Oct 23 – Nov 22: Skorpion
# Sagittarius: Nov 23 – Dec 21: Schuetze
# Capricorn: Dec 22 – Jan 19: Steinbock
# Aquarius: Jan 20 – Feb 18: Wassermann
# Pisces: Feb 19 – Mar 20: Fische
# Latin/en:
labels_en <- c("Aries", "Taurus", "Gemini", "Cancer", "Leo", "Virgo",
"Libra", "Scorpio", "Sagittarius", "Capricorn", "Aquarius", "Pisces")
# German/de:
labels_de <- c("Widder", "Stier", "Zwillinge", "Krebs", "L\u00F6we", "Jungfrau",
"Waage", "Skorpion", "Sch\u00FCtze", "Steinbock", "Wassermann", "Fische")
# Unicode:
labels_unicode <- c("\u2648", "\u2649", "\u264A", "\u264B", "\u264C", "\u264D", "\u264E", "\u264F",
"\u2650", "\u2651", "\u2652", "\u2653")
# HTML:
labels_html <- c("♈", "♉", "♊", "♋", "♌", "♍",
"♎", "♏", "♐", "♑", "♒", "♓")
year_cats <- c(10:12, 1:10) # sequence of zodiac sign categories (arranged in calendar year)
# Output formats: ----
out <- substr(tolower(out), 1, 2) # 4robustness
if (out == "de" | out == "ge"){ # deutsch/German:
labels_year <- labels_de[year_cats] # 13 Namen (out == "de"/"ge")
} else if (out == "un" | out == "uc"){ # Unicode symbols:
labels_year <- labels_unicode[year_cats] # 13 Unicodes (out == "uc"/"un")
} else if (out == "ht"){ # HTML symbols:
labels_year <- labels_html[year_cats] # 13 HTML codes (out == "ht"/"HTML")
} else { # default (out == "English/Latin"):
labels_year <- labels_en[year_cats] # 13 labels (mapped to calendar year)
}
# 4. Main: Determine zodiac by numeric date breaks (in numeric mmdd format):
date_breaks <- c(-Inf, zodiac_swap_mmdd, +Inf)
zod <- cut(x = mmdd, breaks = date_breaks, labels = labels_year,
include.lowest = TRUE, right = FALSE)
# 5. Recode levels of zod as factor (from 1 = Aries to 12 = Pisces):
zod_cats <- c(4:12, 1:3) # re-order zodiac signs
zod <- factor(zod, levels = levels(zod)[zod_cats]) # re-order factor levels
# 6. Output:
# zod <- paste0(mm, "-", dd, ": ", mmdd, " = ", zod, "") # 4debugging
return(zod)
} # zodiac().
# ## Check:
# zodiac(Sys.Date())
# (dt <- sample_date(size = 10))
# zodiac(dt)
#
# # Verify date range borders:
# dt_brd <- c("2000-01-19", "2000-01-20",
# "2000-02-18", "2000-02-19",
# "2000-03-20", "2000-03-21",
# "2000-04-20", "2000-04-21",
# "2000-05-20", "2000-05-21",
# "2000-06-20", "2000-06-21",
# "2000-07-22", "2000-07-23",
# "2000-08-22", "2000-08-23",
# "2000-09-22", "2000-09-23",
# "2000-10-22", "2000-10-23",
# "2000-11-22", "2000-11-23",
# "2000-12-21", "2000-12-22")
# zodiac(dt_brd)
# levels(zodiac(dt_brd))
# is.ordered(zodiac(dt_brd))
#
# # Alternative outputs:
# zodiac(dt_brd, out = "de")
# zodiac(dt_brd, out = "unicode")
# zodiac(dt_brd, out = "HTML")
#
# # Set alternative date breaks:
# zodiac("2000-08-23")
# zodiac("2000-08-23",
# zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
# 0723, 0824, 0923, 1023, 1123, 1222))
## Done: ----------
# - Provided all what_ functions with a "when" argument that is set to Sys.Date()
# or Sys.time() by default, allowing for other dates/times for which question
# is answered (e.g., On what day was my birthday?)
# - change_tz() and change_time() function(s)
# for converting time display (in "POSIXct") into local times (in "POSIXlt"),
# and vice versa (changing times, but not time display).
# - Moved time utility/helper functions into separate file.
## ToDo: ----------
# Add a zodiac() function (that works for vectors of dates):
#
# Input: Dates or times (as vector)
# Output: As factor (levels 1-12) OR character OR Unicode/HTML symbols,
# with labels in Latin/en/de
# See: <https://en.wikipedia.org/wiki/Zodiac> and
# See: <https://de.wikipedia.org/wiki/Tierkreiszeichen> for ranges and symbols.
#
# Note: The DescTools package also contains a Zodiac() function.
# ad (1) and (2):
# - update cur_ and what_ functions to use new helpers
# - re-consider what_day() to return NUMERIC day in week/month/year.
# - fix ToDo in what_date() (Actively convert time?)
# - Return dates/times either as strings (if as_string = TRUE) or
# as dates/times (of class "Date"/"POSIXct") in all what_() functions
# ad (4): Differences between dates/times:
# - finish and clean up diff_dates (or date_diff) function.
# - consider adding diff_times function (analog to diff_dates, but for date-times, including H:M:S)
## eof. ----------------------
Try the ds4psy package in your browser
Any scripts or data that you put into this service are public.
ds4psy documentation built on Sept. 15, 2023, 9:08 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions zodiac diff_times diff_dates diff_days change_tz change_time what_year what_month what_week what_wday what_date what_time cur_time cur_date
Documented in change_time change_tz cur_date cur_time diff_dates diff_times what_date what_month what_time what_wday what_week what_year zodiac
## time_fun.R | ds4psy
## hn | uni.kn | 2023 09 15
## ------------------------
## Main functions for date and time objects.
## (0) Note utility functions for date and time data objects in time_util_fun.R! ------
## (1) cur_ functions: ----------
# 90% of all use cases are covered by 2 functions that ask for the _current_ date or time:
# - `cur_date()`: in 2 different orders (optional sep)
# - `cur_time()`: with or without seconds (optional sep)
# cur_date: A relaxed version of Sys.time() ------
#' Current date (in yyyy-mm-dd or dd-mm-yyyy format).
#'
#' \code{cur_date} provides a relaxed version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{cur_date} returns \code{Sys.Date}
#' as a character string (using current system settings and
#' \code{sep} for formatting).
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' Alternatively, consider using \code{Sys.Date}
#' or \code{Sys.time()} to obtain the "%Y-%m-%d" (or "%F")
#' format according to the ISO 8601 standard.
#'
#' For more options, see the documentations of the
#' \code{date} and \code{Sys.Date} functions of \strong{base} R
#' and the formatting options for \code{Sys.time()}.
#'
#' @param rev Boolean: Reverse from "yyyy-mm-dd" to "dd-mm-yyyy" format?
#' Default: \code{rev = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = "-"}.
#'
#' @return A character string or object of class "Date".
#'
#' @examples
#' cur_date()
#' cur_date(sep = "/")
#' cur_date(rev = TRUE)
#' cur_date(rev = TRUE, sep = ".")
#'
#' # return a "Date" object:
#' from <- cur_date(as_string = FALSE)
#' class(from)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_date()} function to print dates with more options;
#' \code{date()} and \code{today()} functions of the \strong{lubridate} package;
#' \code{date()}, \code{Sys.Date()}, and \code{Sys.time()} functions of \strong{base} R.
#'
#' @export
cur_date <- function(rev = FALSE, as_string = TRUE, sep = "-"){
# 0. Initialize:
d <- NA
# 1. Get system date:
# d <- Sys.time() # current time (optimizing options)
d <- Sys.Date() # current date (satisficing solution)
# 2. Format instruction string:
if (rev){
fmt <- paste("%d", "%m", "%Y", sep = sep, collapse = "") # using sep
} else {
fmt <- paste("%Y", "%m", "%d", sep = sep, collapse = "") # using sep
}
# 3. Output:
# ## Side effect and invisible return:
# # Print formatted d (as side effect):
# print(format(d, fmt)) # as string
# # cat(format(d, fmt)) # no string
#
# # Return Date object:
# invisible(d)
if (as_string){
return(format(d, format = fmt)) # formatted string
# return(print(format(d, fmt))) # print string
# return(cat(format(d, fmt))) # no string
} else {
return(d) # as Date
}
} # cur_date().
# ## Check:
# cur_date()
# cur_date(sep = "/")
# cur_date(rev = TRUE)
# cur_date(rev = TRUE, sep = ".")
# cur_time: A satisficing version of Sys.time() ------
#' Current time (in hh:mm or hh:mm:ss format).
#'
#' \code{cur_time} provides a satisficing version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{cur_time} returns a
#' \code{Sys.time()} as a character string
#' (in "%H:%M" or "%H:%M:%S" format)
#' using current system settings.
#' If \code{as_string = FALSE}, a "POSIXct"
#' (calendar time) object is returned.
#'
#' For a time zone argument,
#' see the \code{\link{what_time}} function,
#' or the \code{now()} function of
#' the \strong{lubridate} package.
#'
#' @param seconds Boolean: Show time with seconds?
#' Default: \code{seconds = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "POSIXct" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = ":"}.
#'
#' @return A character string or object of class "POSIXct".
#'
#' @examples
#' cur_time()
#' cur_time(seconds = TRUE)
#' cur_time(sep = ".")
#'
#' # return a "POSIXct" object:
#' t <- cur_time(as_string = FALSE)
#' format(t, "%T %Z")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_time()} function to print times with more options;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
cur_time <- function(seconds = FALSE, as_string = TRUE, sep = ":"){
# 0. Initialize:
t <- NA
# 1. Current time:
t <- Sys.time()
# 2. Format instruction string:
if (seconds) {
fmt <- paste("%H", "%M", "%S", sep = sep, collapse = "") # %S and using sep
} else {
fmt <- paste("%H", "%M", sep = sep, collapse = "") # no %S, using sep
}
# 3. Output:
# ## Side effect and invisible return:
# # Print formatted t (as side effect):
# print(format(t, fmt)) # as string
# # cat(format(t, fmt)) # no string
#
# # Return POSIXct object:
# invisible(t)
if (as_string){
return(format(t, format = fmt)) # formatted string
# return(print(format(t, fmt))) # print string
# return(cat(format(t, fmt))) # no string
} else {
return(t) # as POSIXct
}
} # cur_time().
## Check:
# cur_time()
# cur_time(seconds = TRUE)
# cur_time(sep = ".")
# cur_date_time: Combining cur_date and cur_time: ------
# ToDo? Or just call cur_date() AND cur_time()?
## (2) what_ functions: ----------
# Motivation: The R base function date()
# returns date as "Wed Aug 21 19:43:22 2019",
# which is more than we usually want.
# Some simpler variants following a simple heuristic:
# What is it that we _usually_ want to hear as `x` when asking
# "What `x` is it today?" or "What `x` is it right now?"
# About 5% are covered by 4 additional functions that ask `what_` questions
# about the position of some temporal unit in some larger continuum of time:
#
# - `what_time()`: more versatile version of cur_time() (accepting a when argument)
# - `what_date()`: more versatile version of cur_date() (accepting a when argument)
# - `what_wday()` : as name (weekday, abbr or full), OR as number (in units of week, month, or year; as char or as integer)
# - `what_week()` : only as number (in units of month, or year); return as char or as integer
# - `what_month()`: as name (abbr or full) OR as number (as char or as integer)
# - `what_year()` : only as number (abbr or full), return as char or as integer
#
# All of these functions
# - take some "point in time" time as input (as a "when" argument),
# which defaults to now (i.e., Sys.time()) but can also be a vector.
# - return a character string (which can easily be converted into a number), unless specifically asking for numeric output
# what_time: More versatile version of cur_time(), allowing for a when vector: ------
#' What time is it?
#'
#' \code{what_time} provides a satisficing version of
#' \code{Sys.time()} that is sufficient for most purposes.
#'
#' By default, \code{what_time} prints a simple version of
#' \code{when} or \code{Sys.time()}
#' as a character string (in "%H:%M" or "%H:%M:%S" format)
#' using current default system settings.
#' If \code{as_string = FALSE}, a "POSIXct"
#' (calendar time) object is returned.
#'
#' The \code{tz} argument allows specifying time zones
#' (see \code{Sys.timezone()} for current setting
#' and \code{OlsonNames()} for options.)
#'
#' However, \code{tz} is merely used to represent the
#' times provided to the \code{when} argument.
#' Thus, there currently is no active conversion
#' of times into other time zones
#' (see the \code{now} function of \strong{lubridate} package).
#'
#' @param when Time (as a scalar or vector).
#' Default: \code{when = NA}.
#' Returning \code{Sys.time()}, if \code{when = NA}.
#'
#' @param seconds Boolean: Show time with seconds?
#' Default: \code{seconds = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "POSIXct" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = ":"}.
#'
#' @param tz Time zone.
#' Default: \code{tz = ""} (i.e., current system time zone,
#' see \code{Sys.timezone()}).
#' Use \code{tz = "UTC"} for Coordinated Universal Time.
#'
#' @return A character string or object of class "POSIXct".
#'
#' @examples
#' what_time()
#'
#' # with vector (of "POSIXct" objects):
#' tm <- c("2020-02-29 01:02:03", "2020-12-31 14:15:16")
#' what_time(tm)
#'
#' # with time zone:
#' ts <- ISOdate(2020, 12, 24, c(0, 12)) # midnight and midday UTC
#' t1 <- what_time(when = ts, tz = "Pacific/Honolulu")
#' t1 # time display changed, due to tz
#'
#' # return "POSIXct" object(s):
#' # Same time in differen tz:
#' t2 <- what_time(as.POSIXct("2020-02-29 10:00:00"), as_string = FALSE, tz = "Pacific/Honolulu")
#' format(t2, "%F %T %Z (UTF %z)")
#' # from string:
#' t3 <- what_time("2020-02-29 10:00:00", as_string = FALSE, tz = "Pacific/Honolulu")
#' format(t3, "%F %T %Z (UTF %z)")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_time <- function(when = NA, seconds = FALSE, as_string = TRUE, sep = ":", tz = ""){
# 0. Initialize:
t <- NA
# 1. Check when argument:
if (all(is.na(when))){
t <- Sys.time() # use current time
} else { # interpret when:
if (!is_POSIXct(when)){
t <- time_from_noPOSIXt(when)
# # same time display in different tz (i.e., different time):
# t <- time_from_noPOSIXt(when, tz = tz)
} else {
t <- when # copy
}
}
# 2. Verify class:
if (!is_POSIXt(t)){
message(paste0('what_time: "t" is not of class "POSIXt".'))
# return(t)
}
# 3. Change time display into time zone tz:
if (tz != ""){
message("Changing tz (but keeping original time).")
t <- change_tz(t, tz = tz)
}
# 4. Format output:
if (seconds) {
fmt <- paste("%H", "%M", "%S", sep = sep, collapse = "") # %S and using sep
} else {
fmt <- paste("%H", "%M", sep = sep, collapse = "") # no %S, using sep
}
# ## Side effect and invisible return:
# # Print formatted t (as side effect):
# print(format(t, fmt)) # as string
# # cat(format(t, fmt)) # no string
#
# # Return POSIXct object:
# invisible(t)
# 5. Output:
if (as_string){
return(format(t, format = fmt)) # formatted string
# return(print(format(t, fmt))) # print string
# return(cat(format(t, fmt))) # no string
} else {
return(t) # as POSIXt
}
} # what_time().
# # Check:
# what_time()
#
# # with vector (of POSIXct objects):
# ts <- c("2020-02-29 01:02:03", "2020-12-31 14:15:16")
# what_time(ts)
#
# # with time zone:
# t1 <- what_time(ts, seconds = TRUE, sep = "_", tz = "UTC")
# t1
#
# # returns POSIXct objects:
# t2 <- what_time("2020-02-29 12:30:45", tz = "America/Los_Angeles")
# format(t2, "%T %Z")
# what_date: More versatile version of cur_date(), allowing for a when vector: ------
#' What date is it?
#'
#' \code{what_date} provides a satisficing version of
#' \code{Sys.Date()} that is sufficient for most purposes.
#'
#' By default, \code{what_date} returns either
#' \code{Sys.Date()} or the dates provided by \code{when}
#' as a character string (using current system settings and
#' \code{sep} for formatting).
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' The \code{tz} argument allows specifying time zones
#' (see \code{Sys.timezone()} for current setting
#' and \code{OlsonNames()} for options.)
#'
#' However, \code{tz} is merely used to represent the
#' dates provided to the \code{when} argument.
#' Thus, there currently is no active conversion
#' of dates into other time zones
#' (see the \code{today} function of \strong{lubridate} package).
#'
#' @param when Date(s) (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param rev Boolean: Reverse date (to %d-%m-%Y)?
#' Default: \code{rev = FALSE}.
#'
#' @param as_string Boolean: Return as character string?
#' Default: \code{as_string = TRUE}.
#' If \code{as_string = FALSE}, a "Date" object is returned.
#'
#' @param sep Character: Separator to use.
#' Default: \code{sep = "-"}.
#'
#' @param month_form Character: Month format.
#' Default: \code{month_form = "m"} for numeric month (01-12).
#' Use \code{month_form = "b"} for short month name
#' and \code{month_form = "B"} for full month name (in current locale).
#'
#' @param tz Time zone.
#' Default: \code{tz = ""} (i.e., current system time zone,
#' see \code{Sys.timezone()}).
#' Use \code{tz = "UTC"} for Coordinated Universal Time.
#'
#' @return A character string or object of class "Date".
#'
#' @examples
#' what_date()
#' what_date(sep = "/")
#' what_date(rev = TRUE)
#' what_date(rev = TRUE, sep = ".")
#' what_date(rev = TRUE, sep = " ", month_form = "B")
#'
#' # with "POSIXct" times:
#' what_date(when = Sys.time())
#'
#' # with time vector (of "POSIXct" objects):
#' ts <- c("1969-07-13 13:53 CET", "2020-12-31 23:59:59")
#' what_date(ts)
#' what_date(ts, rev = TRUE, sep = ".")
#' what_date(ts, rev = TRUE, month_form = "b")
#'
#' # return a "Date" object:
#' dt <- what_date(as_string = FALSE)
#' class(dt)
#'
#' # with time zone:
#' ts <- ISOdate(2020, 12, 24, c(0, 12)) # midnight and midday UTC
#' what_date(when = ts, tz = "Pacific/Honolulu", as_string = FALSE)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_wday()} function to obtain (week)days;
#' \code{what_time()} function to obtain times;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_date <- function(when = NA, rev = FALSE, as_string = TRUE,
sep = "-", month_form = "m", tz = ""){
# 0. Initialize:
d <- NA
# 1. Check when argument:
if (all(is.na(when))){
# d <- Sys.time() # current time (optimizing options)
d <- Sys.Date() # current date (satisficing solution)
} else {
# interpret when:
if (!is_Date(when)){
# message('what_date: Aiming to parse "when" as "Date".')
d <- date_from_noDate(when, tz = tz)
} else {
d <- as.Date(when, tz = tz) # as Date (with passive tz)
}
}
# 2. Verify class:
if (!is_Date(d)){
message(paste0('what_date: "d" is not of class "Date".'))
# return(d)
}
# 3. Convert into time zone tz:
if (tz != ""){
message("Converting date(s) into tz.")
d <- change_tz(d, tz = tz)
}
# 4. Format output:
if (substr(month_form, 1, 1) != "%") {
month_form <- paste0("%", month_form) # add % prefix
}
if (rev){
fmt <- paste("%d", month_form, "%Y", sep = sep, collapse = "") # using sep
} else {
fmt <- paste("%Y", month_form, "%d", sep = sep, collapse = "") # using sep
}
# ## Side effect and invisible return:
# # Print formatted d (as side effect):
# print(format(d, fmt)) # as string
# # cat(format(d, fmt)) # no string
#
# # Return Date object:
# invisible(d)
# 5. Output:
if (as_string){
return(format(d, format = fmt)) # formatted string
# return(print(format(d, fmt))) # print string
# return(cat(format(d, fmt))) # no string
} else {
return(d) # as Date
}
} # what_date().
# ## Check:
# what_date()
# what_date(as_string = FALSE)
#
# what_date(sep = "/")
# what_date(rev = TRUE)
# what_date(rev = TRUE, sep = ".")
# what_date(rev = TRUE, sep = " ", month_form = "B")
#
# what_date(c("2020-01-01", "2020-12-31"), tz = "Australia/Sydney", as_string = FALSE)
# ds <- c("2020-01-15 01:02:03 NZ", "2020-12-31 14:15:16") # POSIXct
# what_date(ds, tz = "Pacific/Auckland", as_string = FALSE)
# what_date(ds, rev = TRUE, sep = ".")
# what_date(ds, rev = TRUE, month_form = "b")
## what_day_alt: What day is it? (OLD/ORG version: name or number) ------
## what_day_alt: as name (weekday, abbr or full), OR as number (in units of week, month, or year; as char or as integer)
# What day is it? (alternative OLD/ORG version)
#
# \code{what_day_alt} provides a satisficing version of
# to determine the day corresponding to a given date.
#
# \code{what_day_alt} returns the day
# of \code{when} or \code{Sys.Date()}
# (as a name or number).
#
# @param when Date (as a scalar or vector).
# Default: \code{when = NA}.
# Using \code{as.Date(when)} to convert strings into dates,
# and \code{Sys.Date()}, if \code{when = NA}.
#
# @param unit Character: Unit of day?
# Possible values are \code{"week", "month", "year"}.
# Default: \code{unit = "week"} (for day within week).
#
# @param abbr Boolean: Return abbreviated?
# Default: \code{abbr = FALSE}.
#
# @param as_integer Boolean: Return as integer?
# Default: \code{as_integer = FALSE}.
#
# @examples
# what_day_alt()
# what_day_alt(abbr = TRUE)
# what_day_alt(as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_day_alt(when = ds)
# what_day_alt(when = ds, unit = "month", as_integer = TRUE)
# what_day_alt(when = ds, unit = "year", as_integer = TRUE)
#
#
# @family date and time functions
#
# @seealso
# \code{what_day()} for a simpler version (only weekdays);
# \code{what_date()} function to obtain dates;
# \code{what_time()} function to obtain times;
# \code{cur_time()} function to print the current time;
# \code{cur_date()} function to print the current date;
# \code{Sys.time()} function of \strong{base} R.
#
# @export
# what_day_alt <- function(when = Sys.time(), unit = "week", abbr = FALSE, as_integer = FALSE){
#
# # Robustness:
# unit <- substr(tolower(unit), 1, 1) # use only 1st letter of string
#
# # Convert when into objects of class "Date" representing calendar dates:
# if ( any(class(when) != "Date") & !("POSIXct" %in% class(when)) ) {
# message(paste0("what_day_alt: Using as.Date() to convert 'when' into class 'Date'."))
# when <- as.Date(when)
# }
#
# # Verify date/time input:
# if ( any(class(when) != "Date") & !("POSIXct" %in% class(when)) ) {
# message(paste0("what_day_alt: when must be of class 'Date' or 'POSIXct'."))
# message(paste0("Currently, class(when) = ", class(when), "."))
# return(when)
# }
#
# # initialize:
# d <- as.character(NA)
#
# # get day d (as char):
# if (unit == "w"){ # unit "week":
#
# if (as_integer){
#
# # Weekday as a decimal number (1–7, Mon=1):
# d <- format(when, "%u") # WARN: r-devel-linux-x86_64-debian-clang!
#
# } else {
#
# if (abbr){
# d <- format(when, "%a") # Abbreviated weekday name in the current locale on this platform.
# } else {
# d <- format(when, "%A") # Full weekday name in the current locale.
# }
#
# }
#
# } else if (unit == "m") { # unit "month":
#
# # Day of the month as decimal number (01–31):
# d <- format(when, "%d") # WARN: r-devel-linux-x86_64-debian-clang!
#
#
# } else if (unit == "y") { # unit "year":
#
# # Day of year as decimal number (001–366):
# d <- format(when, "%j") # WARN: r-devel-linux-x86_64-debian-clang!
#
# } else { # some other unit:
#
# message("Unknown unit. Using unit = 'month':")
#
# # Day of the month as decimal number (01–31):
# d <- format(when, "%d") # WARN: r-devel-linux-x86_64-debian-clang!
#
# }
#
# # as char or integer:
# if (as_integer) {
# as.integer(d)
# } else {
# d
# }
#
# } # what_day_alt().
# ## Check:
# what_day_alt()
# what_day_alt(abbr = TRUE)
# what_day_alt(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_day_alt(when = d1)
# what_day_alt(when = d1, unit = "month", as_integer = TRUE)
# what_day_alt(when = d1, unit = "year", as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_day_alt(when = ds)
# what_day_alt(when = ds, unit = "month", as_integer = TRUE)
# what_day_alt(when = ds, unit = "year", as_integer = TRUE)
#
# # Note: Errors
# what_day_alt(when = d1, unit = "asdf")
# what_day_alt(when = "now")
# what_day_alt(when = 123)
### Simplified version: Providing only the weekday (as a name):
# what_wday: What day is it? (name, NOT number) ------
# what_wday: as name (weekday, abbr or full), NOT as number (in units of week, month, or year; as char or as integer)
#' What day of the week is it?
#'
#' \code{what_wday} provides a satisficing version of
#' to determine the day of the week
#' corresponding to a given date.
#'
#' \code{what_wday} returns the name of the weekday
#' of \code{when} or of \code{Sys.Date()}
#' (as a character string).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = Sys.Date()}.
#' Aiming to convert \code{when} into "Date"
#' if a different object class is provided.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @examples
#' what_wday()
#' what_wday(abbr = TRUE)
#'
#' what_wday(Sys.Date() + -1:1) # Date (as vector)
#' what_wday(Sys.time()) # POSIXct
#' what_wday("2020-02-29") # string (of valid date)
#' what_wday(20200229) # number (of valid date)
#'
#' # date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_wday(when = ds)
#' what_wday(when = ds, abbr = TRUE)
#'
#' # time vector (strings of POSIXct times):
#' ts <- c("1969-07-13 13:53 CET", "2020-12-31 23:59:59")
#' what_wday(ts)
#'
#' # fame data:
#' greta_dob <- as.Date(fame[grep(fame$name, pattern = "Greta") , ]$DOB, "%B %d, %Y")
#' what_wday(greta_dob) # Friday, of course.
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_date()} function to obtain dates;
#' \code{what_time()} function to obtain times;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_wday <- function(when = Sys.Date(), abbr = FALSE){
# 0. Initialize:
d <- as.character(NA)
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: weekday d (as char):
# if (unit == "w"){ # unit "week":
# if (as_integer){
# d <- format(when, "%u") # Weekday as a decimal number (1–7, Monday is 1).
# } else {
if (abbr){
d <- format(when, format = "%a") # Abbreviated weekday name in the current locale on this platform.
} else {
d <- format(when, format = "%A") # Full weekday name in the current locale.
}
#}
# } else if (unit == "m") { # unit "month":
# d <- format(when, "%d") # Day of the month as decimal number (01–31).
# } else if (unit == "y") { # unit "year":
# d <- format(when, "%j") # Day of year as decimal number (001–366).
# } else { # some other unit:
# message("Unknown unit. Using unit = 'month':")
# d <- format(when, "%d") # Day of the month as decimal number (01–31).
# }
# 3. Output:
## as char or integer:
# if (as_integer) {
# as.integer(d)
# } else {
d
# }
} # what_wday().
# ## Check:
# what_wday()
# what_wday(abbr = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_wday(when = d1)
# what_wday(when = d1, abbr = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_wday(when = ds)
# what_wday(when = ds, abbr = TRUE)
#
# # Note: Errors
# what_wday(when = "now")
# what_wday(when = 123)
#
# Bday of Greta Thunberg?
# greta_dob <- as.Date(fame[grep(fame$name, pattern = "Greta") , ]$DOB, "%B %d, %Y")
# what_wday(greta_dob) # Friday, of course.
# what_week: What week is it? (number only) ------
#' What week is it?
#'
#' \code{what_week} provides a satisficing version of
#' to determine the week corresponding to a given date.
#'
#' \code{what_week} returns the week
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = Sys.Date()}.
#' Using \code{as.Date(when)} to convert strings into dates
#' if a different \code{when} is provided.
#'
#' @param unit Character: Unit of week?
#' Possible values are \code{"month", "year"}.
#' Default: \code{unit = "year"} (for week within year).
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_week()
#' what_week(as_integer = TRUE)
#'
#' # Other dates/times:
#' d1 <- as.Date("2020-12-24")
#' what_week(when = d1, unit = "year")
#' what_week(when = d1, unit = "month")
#'
#' what_week(Sys.time()) # with POSIXct time
#'
#' # with date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_week(when = ds)
#' what_week(when = ds, unit = "month", as_integer = TRUE)
#' what_week(when = ds, unit = "year", as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-12-25 10:11:12 CET", "2020-12-31 23:59:59")
#' what_week(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_wday()} function to obtain (week)days;
#' \code{what_date()} function to obtain dates;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_week <- function(when = Sys.Date(), unit = "year", as_integer = FALSE){
# 0. Initialize:
w <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# Robustness:
unit <- substr(tolower(unit), 1, 1) # use only 1st letter of string
# 2. Main: Get week w (as char):
if (unit == "m"){ # unit "month":
# Searching nr. of week corresponding to current time in current month?
# Sources: Adapted from a discussion at
# <https://stackoverflow.com/questions/25199851/r-how-to-get-the-week-number-of-the-month>
# desired date:
d_des <- as.Date(when)
wk_2 <- as.numeric(format(d_des, "%V")) # corresponding week (01--53) as defined in ISO 8601 (week starts Monday)
# date of 1st day in corresponding month:
d_1st <- as.Date(cut(d_des, "month")) # date of 1st day in corresponding month
wk_1 <- as.numeric(format(d_1st, "%V")) # corresponding week (01--53) as defined in ISO 8601 (week starts on Monday)
# difference:
w <- (wk_2 - wk_1) + 1 # as number
w <- as.character(w) # as character
} else if (unit == "y") { # unit "year":
w <- format(when, format = "%V") # %V: week of the year as decimal number (01--53) as defined in ISO 8601 (week starts on Monday)
} else { # some other unit:
message("Unknown unit. Using unit = 'year':")
w <- format(when, format = "%V") # %V: week of the year as decimal number (01--53) as defined in ISO 8601 (week starts on Monday)
}
# 3. Output (as char or integer):
if (as_integer) {
return(as.integer(w))
} else {
return(w)
}
} # what_week().
# ## Check:
# what_week()
# what_week(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2019-08-23")
# what_week(when = d1, unit = "year")
# what_week(when = d1, unit = "month")
#
# # Week nr. (in month):
# d2 <- as.Date("2019-06-23") # Sunday of 4th week in June 2019.
# what_week(when = d2, unit = "month")
# d3 <- as.Date("2019-06-24") # Monday of 5th week in June 2019.
# what_week(when = d3, unit = "month")
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_week(when = ds)
# what_week(when = ds, unit = "month", as_integer = TRUE)
# what_week(when = ds, unit = "year", as_integer = TRUE)
#
# ## Note: Errors
# # what_week(when = d1, unit = "asdf")
# # what_week(when = "now")
# # what_week(when = 123)
# what_month: What month is it? (name or number) ------
# - `what_month()`: as name (abbr or full) OR as number (as char or as integer)
#' What month is it?
#'
#' \code{what_month} provides a satisficing version of
#' to determine the month corresponding to a given date.
#'
#' \code{what_month} returns the month
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_month()
#' what_month(abbr = TRUE)
#' what_month(as_integer = TRUE)
#'
#' # with date vector (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_month(when = ds)
#' what_month(when = ds, abbr = TRUE, as_integer = FALSE)
#' what_month(when = ds, abbr = TRUE, as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-02-29 10:11:12 CET", "2020-12-31 23:59:59")
#' what_month(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_week()} function to obtain weeks;
#' \code{what_date()} function to obtain dates;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_month <- function(when = Sys.Date(), abbr = FALSE, as_integer = FALSE){
# 0. Initialize:
m <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: Get month m (as char):
if (as_integer) {
m <- format(when, format = "%m")
m <- as.integer(m)
} else { # month name (as character):
if (abbr){
m <- format(when, format = "%b") # Abbreviated month name in the current locale on this platform.
} else {
m <- format(when, format = "%B") # Full month name in the current locale.
}
}
# 3. Output (as char or integer):
return(m)
} # what_month().
# ## Check:
# what_month()
# what_month(abbr = TRUE)
# what_month(as_integer = TRUE)
#
# # Other dates/times:
# d1 <- as.Date("2020-02-29")
# what_month(when = d1)
# what_month(when = d1, abbr = TRUE)
# what_month(when = d1, as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_month(when = ds)
# what_month(when = ds, abbr = TRUE, as_integer = FALSE)
# what_month(when = ds, abbr = TRUE, as_integer = TRUE)
#
# ## Note: Errors
# # what_month(when = "now")
# # what_month(when = 123)
# what_year: What year is it? ------
#' What year is it?
#'
#' \code{what_year} provides a satisficing version of
#' to determine the year corresponding to a given date.
#'
#' \code{what_year} returns the year
#' of \code{when} or \code{Sys.Date()}
#' (as a name or number).
#'
#' @param when Date (as a scalar or vector).
#' Default: \code{when = NA}.
#' Using \code{as.Date(when)} to convert strings into dates,
#' and \code{Sys.Date()}, if \code{when = NA}.
#'
#' @param abbr Boolean: Return abbreviated?
#' Default: \code{abbr = FALSE}.
#'
#' @param as_integer Boolean: Return as integer?
#' Default: \code{as_integer = FALSE}.
#'
#' @examples
#' what_year()
#' what_year(abbr = TRUE)
#' what_year(as_integer = TRUE)
#'
#' # with date vectors (as characters):
#' ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
#' what_year(when = ds)
#' what_year(when = ds, abbr = TRUE, as_integer = FALSE)
#' what_year(when = ds, abbr = TRUE, as_integer = TRUE)
#'
#' # with time vector (strings of POSIXct times):
#' ts <- c("2020-02-29 10:11:12 CET", "2020-12-31 23:59:59")
#' what_year(ts)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{what_week()} function to obtain weeks;
#' \code{what_month()} function to obtain months;
#' \code{cur_time()} function to print the current time;
#' \code{cur_date()} function to print the current date;
#' \code{now()} function of the \strong{lubridate} package;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
what_year <- function(when = Sys.Date(), abbr = FALSE, as_integer = FALSE){
# 0. Initialize:
y <- NA
# 1. Handle inputs:
if (!is_Date(when)){
# message('what_wday: Aiming to parse "when" as "Date".')
when <- date_from_noDate(when)
}
if (!is_Date(when)){
message(paste0('what_wday: "when" must be of class "Date".'))
return(when)
}
# 2. Main: Get year y:
if (abbr){
y <- format(when, format = "%y")
} else {
y <- format(when, format = "%Y")
}
# 3. Output (as char or integer):
if (as_integer) {
return(as.integer(y))
} else {
return(y)
}
} # what_year().
# ## Check:
# what_year()
# what_year(abbr = TRUE)
# what_year(as_integer = TRUE)
#
# # other dates/times:
# dt <- as.Date("1987-07-13")
# what_year(when = dt, abbr = TRUE, as_integer = TRUE)
#
# # Work with vectors (when as characters):
# ds <- c("2020-01-01", "2020-02-29", "2020-12-24", "2020-12-31")
# what_year(when = ds)
# what_year(when = ds, abbr = TRUE, as_integer = FALSE)
# what_year(when = ds, abbr = TRUE, as_integer = TRUE)
#
# # Note: Errors
# what_year("2020-01-01")
# what_year(2020-01-01)
## (3) Time conversions: ----------
# change_time: ------
# Task 2: Change time zone AND actual time, without changing represented time (i.e., time display):
#' Change time and time zone (without changing time display).
#'
#' \code{change_time} changes the time and time zone
#' without changing the time display.
#'
#' \code{change_time} expects inputs to \code{time}
#' to be local time(s) (of the "POSIXlt" class)
#' and a valid time zone argument \code{tz} (as a string)
#' and returns the same time display (but different actual times)
#' as calendar time(s) (of the "POSIXct" class).
#'
#' @param time Time (as a scalar or vector).
#' If \code{time} is not a local time (of the "POSIXlt" class)
#' the function first tries coercing \code{time} into "POSIXlt"
#' without changing the time display.
#'
#' @param tz Time zone (as character string).
#' Default: \code{tz = ""}
#' (i.e., current system time zone, \code{Sys.timezone()}).
#' See \code{OlsonNames()} for valid options.
#'
#' @return A calendar time of class "POSIXct".
#'
#' @examples
#' change_time(as.POSIXlt(Sys.time()), tz = "UTC")
#'
#' # from "POSIXlt" time:
#' t1 <- as.POSIXlt("2020-01-01 10:20:30", tz = "Europe/Berlin")
#' change_time(t1, "Pacific/Auckland")
#' change_time(t1, "America/Los_Angeles")
#'
#' # from "POSIXct" time:
#' tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC")
#' change_time(tc, "Pacific/Auckland")
#'
#' # from "Date":
#' dt <- as.Date("2020-12-31", tz = "Pacific/Honolulu")
#' change_time(dt, tz = "Pacific/Auckland")
#'
#' # from time "string":
#' ts <- "2020-12-31 20:30:45"
#' change_time(ts, tz = "America/Los_Angeles")
#'
#' # from other "string" times:
#' tx <- "7:30:45"
#' change_time(tx, tz = "Asia/Calcutta")
#' ty <- "1:30"
#' change_time(ty, tz = "Europe/London")
#'
#' # convert into local times:
#' (l1 <- as.POSIXlt("2020-06-01 10:11:12"))
#' change_tz(change_time(l1, "Pacific/Auckland"), tz = "UTC")
#' change_tz(change_time(l1, "Europe/Berlin"), tz = "UTC")
#' change_tz(change_time(l1, "America/New_York"), tz = "UTC")
#'
#' # with vector of "POSIXlt" times:
#' (l2 <- as.POSIXlt("2020-12-31 23:59:55", tz = "America/Los_Angeles"))
#' (tv <- c(l1, l2)) # uses tz of l1
#' change_time(tv, "America/Los_Angeles") # change time and tz
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{change_tz}} function which preserves time but changes time display;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
change_time <- function(time, tz = ""){
# 0. Initialize:
ct <- NA
t_display <- NA
# 1. Need local time "POSIXlt" input:
# If NOT:
# A. Parse time to get t_display:
# B. Convert t_display into "POSIXlt"
if (!is_POSIXlt(time)){
# message('change_time: Coercing time to "POSIXlt" with SAME time display.')
# A: Get t_display from various date-time objects:
if (is_POSIXct(time)){
# message('change_time: Parsing time from "POSIXct" as "%Y-%m-%d %H:%M:%S".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M:%S")
} else if (is_Date(time)){
# message('change_time: Parsing time from "Date" as "%Y-%m-%d".')
t_display <- strptime(time, format = "%Y-%m-%d")
} else if (is.character(time)){
# Get t_display by parsing date-time string (using standard formats):
if (grepl(x = time, pattern = ".*(-).*( ).*(:).*(:).*")) { # date + full time:
# message('change_time: Parsing date-time from string as "%Y-%m-%d %H:%M:%S".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M:%S")
} else if (grepl(x = time, pattern = ".*(-).*( ).*(:).*")) { # date + H:M time:
# message('change_time: Parsing date-time from string as "%Y-%m-%d %H:%M".')
t_display <- strptime(time, format = "%Y-%m-%d %H:%M")
} else if (grepl(x = time, pattern = ".*(:).*(:).*")) { # H:M:S time:
# message('change_time: Parsing time (with default date) from string as "%H:%M:%S".')
t_display <- strptime(time, format = "%H:%M:%S")
} else if (grepl(x = time, pattern = ".*(:).*")) { # H:M time:
# message('change_time: Parsing time (with default date) from string as "%H:%M".')
t_display <- strptime(time, format = "%H:%M")
} else {
message('change_time: Failed to parse time string.')
}
} else {
message('change_time: Cannot parse time display.')
} # various time classes end.
# B. Convert t_display into POSIXlt:
# print(paste0("t_display = ", t_display)) # debugging
time <- as.POSIXlt(t_display, tz = tz) # Note: tz = "" by default.
} # if (!is_POSIXlt(time)) end.
# 2. Main: Convert time from POSIXlt to POSIXct with tz:
ct <- as.POSIXct(time, tz = tz) # Note: tz = "" by default.
# 3. Output:
return(ct)
} # change_time().
# ## Check:
# change_time(as.POSIXlt(Sys.time()), tz = "Pacific/Auckland")
# #
# # # from "POSIXlt" time:
# (t1 <- as.POSIXlt("2020-01-10 10:20:30", tz = "Europe/Berlin"))
# change_time(t1, "Pacific/Auckland")
# change_time(t1, "Europe/Berlin")
# change_time(t1, "America/New_York")
#
# from "Date":
# dt <- as.Date("2020-12-31", tz = "Pacific/Honolulu")
# format(dt, "%F %T %Z") # Note: tz ignored.
# change_time(dt, tz = "Pacific/Auckland")
#
# # from time "string":
# ts <- "2020-12-31 20:30:45"
# change_time(ts, tz = "America/Los_Angeles")
#
# # from other "string" times:
# tx <- "7:30:45"
# change_time(tx, tz = "Asia/Calcutta")
# ty <- "1:30"
# change_time(ty, tz = "Europe/London")
#
# # convert into local times:
# change_tz(change_time(t1, "Pacific/Auckland"), tz = "UTC")
# change_tz(change_time(t1, "Europe/Berlin"), tz = "UTC")
# change_tz(change_time(t1, "America/New_York"), tz = "UTC")
#
# # from "POSIXct" time:
# (tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC"))
# change_time(tc, "Pacific/Auckland")
#
# # with vector of "POSIXlt" times:
# t2 <- as.POSIXlt("2020-12-31 23:59:55", tz = "America/Los_Angeles")
# tv <- c(t1, t2)
# tv # uses tz of t1
# change_time(tv, "America/Los_Angeles")
# change_tz: ------
# Task 1: Change nominal time to time zone, without changing actual time.
#' Change time zone (without changing represented time).
#'
#' \code{change_tz} changes the nominal time zone (i.e., the time display)
#' without changing the actual time.
#'
#' \code{change_tz} expects inputs to \code{time}
#' to be calendar time(s) (of the "POSIXct" class)
#' and a valid time zone argument \code{tz} (as a string)
#' and returns the same time(s) as local time(s)
#' (of the "POSIXlt" class).
#'
#' @param time Time (as a scalar or vector).
#' If \code{time} is not a calendar time (of the "POSIXct" class)
#' the function first tries coercing \code{time} into "POSIXct"
#' without changing the denoted time.
#'
#' @param tz Time zone (as character string).
#' Default: \code{tz = ""}
#' (i.e., current system time zone, \code{Sys.timezone()}).
#' See \code{OlsonNames()} for valid options.
#'
#' @return A local time of class "POSIXlt".
#'
#' @examples
#' change_tz(Sys.time(), tz = "Pacific/Auckland")
#' change_tz(Sys.time(), tz = "Pacific/Honolulu")
#'
#' # from "POSIXct" time:
#' tc <- as.POSIXct("2020-07-01 12:00:00", tz = "UTC")
#' change_tz(tc, "Australia/Melbourne")
#' change_tz(tc, "Europe/Berlin")
#' change_tz(tc, "America/Los_Angeles")
#'
#' # from "POSIXlt" time:
#' tl <- as.POSIXlt("2020-07-01 12:00:00", tz = "UTC")
#' change_tz(tl, "Australia/Melbourne")
#' change_tz(tl, "Europe/Berlin")
#' change_tz(tl, "America/Los_Angeles")
#'
#' # from "Date":
#' dt <- as.Date("2020-12-31")
#' change_tz(dt, "Pacific/Auckland")
#' change_tz(dt, "Pacific/Honolulu") # Note different date!
#'
#' # with a vector of "POSIXct" times:
#' t2 <- as.POSIXct("2020-12-31 23:59:55", tz = "America/Los_Angeles")
#' tv <- c(tc, t2)
#' tv # Note: Both times in tz of tc
#' change_tz(tv, "America/Los_Angeles")
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{change_time}} function which preserves time display but changes time;
#' \code{Sys.time()} function of \strong{base} R.
#'
#' @export
change_tz <- function(time, tz = ""){
# 0. Initialize:
out <- NA
# 1. Parse time:
if (!is_POSIXct(time)){
# message('change_tz: Coercing time to "POSIXct" without changing represented time.')
time <- as.POSIXct(time) # Note: tz = "" by default.
}
# print(paste0("change_tz: time = ", format(time, "%F %T %Z"))) # debugging
# 2. Main: Convert nominal time (to POSIXlt):
out <- as.POSIXlt(time, tz = tz) # Note: tz = "" by default.
# 3. Output:
return(out)
} # change_tz().
# # Check:
# change_tz(Sys.time(), tz = "Pacific/Auckland")
# change_tz(Sys.time(), tz = "Pacific/Honolulu")
#
# # from "POSIXct" time:
# tc <- as.POSIXct("2020-07-01 12:30:00", tz = "UTC")
# change_tz(tc, "Pacific/Auckland") # Note: Date effect!
# change_tz(tc, "Australia/Melbourne")
# change_tz(tc, "Europe/Berlin")
# change_tz(tc, "America/Los_Angeles")
#
# # from "POSIXlt" time:
# tl <- as.POSIXlt("2020-07-01 12:30:00", tz = "UTC")
# change_tz(tl, "Pacific/Auckland") # Note: Date effect!
# change_tz(tl, "Australia/Melbourne")
# change_tz(tl, "Europe/Berlin")
# change_tz(tl, "America/Los_Angeles")
#
# # from "Date":
# dt <- as.Date("2020-12-31")
# change_tz(dt, "Pacific/Auckland")
# change_tz(dt, "Pacific/Honolulu") # Note different date!
# # Compare:
# lubridate::with_tz(dt, tzone = "Pacific/Auckland") # same result
# lubridate::with_tz(dt, tzone = "Pacific/Honolulu") # same result
#
# # with a vector of "POSIXct" times:
# (t2 <- as.POSIXct("2020-12-31 23:59:55", tz = "America/Los_Angeles"))
# (tv <- c(tc, t2)) # Note: Both times in tz of tc
# change_tz(tv, "America/Los_Angeles")
# # Compare:
# lubridate::with_tz(tv, tzone = "America/Los_Angeles") # same results
## (4) Compute differences between 2 dates/times (in human time units/periods): ------
# diff_days: Difference between two dates (in days, with optional decimals): ------
diff_days <- function(from_date, to_date = Sys.Date(), units = "days", as_Date = TRUE, ...){
# 0. Initialize:
n_days <- NA
# 1. Handle inputs: Assume/convert times into 2 "Date" objects
if (as_Date) { # Convert non-Date (e.g., POSIXt) into "Date" objects:
if (!is_Date(from_date)) { from_date <- date_from_noDate(from_date, ...) }
if (!is_Date(to_date)) { to_date <- date_from_noDate(to_date, ...) }
}
# 2. Main: Use difftime:
t_diff <- base::difftime(to_date, from_date, units = units, ...) # default: units = "days"
# 3. Output:
n_days <- as.numeric(t_diff)
return(n_days)
} # diff_days().
# ## Check:
# ds <- Sys.Date() + -2:+2
# diff_days(ds)
#
# one_year_ago <- Sys.Date() - (365 + is_leap_year(Sys.Date()))
# diff_days(one_year_ago)
#
# ## Note: "Date" objects with DECIMALS are possible:
# (d1 <- Sys.Date())
# (d2 <- Sys.Date() + 1.75)
# diff_days(d1, d2)
#
# ## Note: Date vs. time differences:
# t0 <- as.POSIXct("2020-07-10 00:00:01", tz = "UTC") # start of day
# t1 <- as.POSIXct("2020-07-10 23:59:59", tz = "UTC") # end of day
# t2 <- t1 + 2 # 2 seconds after t1 (but next date)
#
# # By default, only Dates are considered:
# diff_days(t0, t1)
# diff_days(t1, t2)
# diff_days(t0, t2)
#
# # Other units: as_Date must be FALSE:
# diff_days(t0, t1, units = "secs", as_Date = FALSE)
# diff_days(t1, t2, units = "secs", as_Date = FALSE)
# diff_days(t0, t2, units = "secs", as_Date = FALSE)
#
# diff_days(t0, t1, units = "weeks", as_Date = FALSE)
# diff_days(t1, t2, units = "hours", as_Date = FALSE)
# diff_days(t0, t2, units = "mins", as_Date = FALSE)
#
# # Exact time differences (with decimals):
# diff_days(t0, t1, as_Date = FALSE)
# diff_days(t1, t2, as_Date = FALSE)
# diff_days(t0, t2, as_Date = FALSE)
# diff_dates: Compute date difference (i.e., age) in human units: ------
#' Get the difference between two dates (in human units).
#'
#' \code{diff_dates} computes the difference between two dates
#' (i.e., from some \code{from_date} to some \code{to_date})
#' in human measurement units (periods).
#'
#' \code{diff_dates} answers questions like
#' "How much time has elapsed between two dates?"
#' or "How old are you?" in human time periods
#' of (full) years, months, and days.
#'
#' Key characteristics:
#'
#' \itemize{
#'
#' \item If \code{to_date} or \code{from_date} are not "Date" objects,
#' \code{diff_dates} aims to coerce them into "Date" objects.
#'
#' \item If \code{to_date} is missing (i.e., \code{NA}),
#' \code{to_date} is set to today's date (i.e., \code{Sys.Date()}).
#'
#' \item If \code{to_date} is specified, any intermittent missing values
#' (i.e., \code{NA}) are set to today's date (i.e., \code{Sys.Date()}).
#' Thus, dead people (with both birth dates and death dates specified)
#' do not age any further, but people still alive (with \code{is.na(to_date)},
#' are measured to today's date (i.e., \code{Sys.Date()}).
#'
#' \item If \code{to_date} precedes \code{from_date} (i.e., \code{from_date > to_date})
#' computations are performed on swapped days and
#' the result is marked as negative (by a character \code{"-"}) in the output.
#'
#' \item If the lengths of \code{from_date} and \code{to_date} differ,
#' the shorter vector is recycled to the length of the longer one.
#'
#' }
#'
#' By default, \code{diff_dates} provides output as (signed) character strings.
#' For numeric outputs, use \code{as_character = FALSE}.
#'
#' @param from_date From date (required, scalar or vector, as "Date").
#' Date of birth (DOB), assumed to be of class "Date",
#' and coerced into "Date" when of class "POSIXt".
#'
#' @param to_date To date (optional, scalar or vector, as "Date").
#' Default: \code{to_date = Sys.Date()}.
#' Maximum date/date of death (DOD), assumed to be of class "Date",
#' and coerced into "Date" when of class "POSIXt".
#'
#' @param unit Largest measurement unit for representing results.
#' Units represent human time periods, rather than
#' chronological time differences.
#' Default: \code{unit = "years"} for completed years, months, and days.
#' Options available:
#' \enumerate{
#'
#' \item \code{unit = "years"}: completed years, months, and days (default)
#'
#' \item \code{unit = "months"}: completed months, and days
#'
#' \item \code{unit = "days"}: completed days
#'
#' }
#' Units may be abbreviated.
#'
#' @param as_character Boolean: Return output as character?
#' Default: \code{as_character = TRUE}.
#' If \code{as_character = FALSE}, results are returned
#' as columns of a data frame
#' and include \code{from_date} and \code{to_date}.
#'
#' @return A character vector or data frame
#' (with dates, sign, and numeric columns for units).
#'
#' @examples
#' y_100 <- Sys.Date() - (100 * 365.25) + -1:1
#' diff_dates(y_100)
#'
#' # with "to_date" argument:
#' y_050 <- Sys.Date() - (50 * 365.25) + -1:1
#' diff_dates(y_100, y_050)
#' diff_dates(y_100, y_050, unit = "d") # days (with decimals)
#'
#' # Time unit and output format:
#' ds_from <- as.Date("2010-01-01") + 0:2
#' ds_to <- as.Date("2020-03-01") # (2020 is leap year)
#' diff_dates(ds_from, ds_to, unit = "y", as_character = FALSE) # years
#' diff_dates(ds_from, ds_to, unit = "m", as_character = FALSE) # months
#' diff_dates(ds_from, ds_to, unit = "d", as_character = FALSE) # days
#'
#' # Robustness:
#' days_cur_year <- 365 + is_leap_year(Sys.Date())
#' diff_dates(Sys.time() - (1 * (60 * 60 * 24) * days_cur_year)) # for POSIXt times
#' diff_dates("10-08-11", "20-08-10") # for strings
#' diff_dates(20200228, 20200301) # for numbers (2020 is leap year)
#'
#' # Recycling "to_date" to length of "from_date":
#' y_050_2 <- Sys.Date() - (50 * 365.25)
#' diff_dates(y_100, y_050_2)
#'
#' # Note maxima and minima:
#' diff_dates("0000-01-01", "9999-12-31") # max. d + m + y
#' diff_dates("1000-06-01", "1000-06-01") # min. d + m + y
#'
#' # If from_date == to_date:
#' diff_dates("2000-01-01", "2000-01-01")
#'
#' # If from_date > to_date:
#' diff_dates("2000-01-02", "2000-01-01") # Note negation "-"
#' diff_dates("2000-02-01", "2000-01-01", as_character = TRUE)
#' diff_dates("2001-02-02", "2000-02-02", as_character = FALSE)
#'
#' # Test random date samples:
#' f_d <- sample_date(size = 10)
#' t_d <- sample_date(size = 10)
#' diff_dates(f_d, t_d, as_character = TRUE)
#'
#' # Using 'fame' data:
#' dob <- as.Date(fame$DOB, format = "%B %d, %Y")
#' dod <- as.Date(fame$DOD, format = "%B %d, %Y")
#' head(diff_dates(dob, dod)) # Note: Deceased people do not age further.
#' head(diff_dates(dob, dod, as_character = FALSE)) # numeric outputs
#'
#' @family date and time functions
#'
#' @seealso
#' Time spans (\code{interval} \code{as.period}) in the \strong{lubridate} package.
#'
#' @export
diff_dates <- function(from_date, to_date = Sys.Date(),
unit = "years", as_character = TRUE){
# 0. Initialize:
today <- Sys.Date() # (do only once)
age <- NA
# 1. Handle inputs: ------
# (a) NA inputs: ----
if (any(is.na(from_date))){
message('diff_dates: "from_date" must not be NA.')
return(NA)
}
if (all(is.na(to_date))){
message('diff_dates: Changing "to_date" from NA to "Sys.Date()".')
to_date <- today
}
# (b) Turn non-Date inputs into "Date" objects: ----
if (!is_Date(from_date)){
# message('diff_dates: Aiming to parse "from_date" as "Date".')
from_date <- date_from_noDate(from_date)
}
if (!is_Date(to_date)){
# message('diff_dates: Aiming to parse "to_date" as "Date".')
to_date <- date_from_noDate(to_date)
}
# (c) Recycle shorter date vector to length of longer one: ----
aligned_v <- align_vec_pair(v1 = from_date, v2 = to_date)
from_date <- aligned_v[[1]]
to_date <- aligned_v[[2]]
## WAS:
# (c) Recycle or truncate to_date argument based on from_date:
# to_date <- align_vec(v_mod = to_date, v_fix = from_date)
# Note: from_date and to_date now have the same length:
n_dates <- length(from_date)
# (d) Replace intermittent NA values in to_date by current date: ----
# Axiom: Dead people do not age any further, but
# if to_date = NA, we want to measure until today:
set_to_date_NA_to_NOW <- TRUE # if FALSE: Occasional to_date = NA values yield NA result.
if (set_to_date_NA_to_NOW){
if (!all(is.na(to_date))){ # only SOME to_date values are missing:
to_date[is.na(to_date)] <- today # replace those NA values by today = Sys.Date()
}
}
# (e) Verify that from_date and to_date are "Date" objects: ----
if (!is_Date(from_date)){
message('diff_dates: "from_date" should be of class "Date".')
# print(from_date) # debugging
}
if (!is_Date(to_date)){
message('diff_dates: "to_date" should be of class "Date".')
# print(to_date) # debugging
}
# (f) For cases of (from_date > to_date): Swap dates and negate sign:
from_date_org <- from_date # store original orders
to_date_org <- to_date # (to list in outputs)
ix_swap <- (from_date > to_date) # ix of cases to swap
from_date_temp <- from_date[ix_swap] # temporary storage
from_date[ix_swap] <- to_date[ix_swap] # from_date by to_date
to_date[ix_swap] <- from_date_temp # to_date by from_date
sign <- rep("", n_dates) # initialize (as character)
sign[ix_swap] <- "-" # negate sign (character)
# message(sign) # debugging
# (g) Unit: ----
unit <- substr(tolower(unit), 1, 1) # robustness: use only 1st letter: y/m/d
if (!unit %in% c("y", "m", "d")){
message('diff_dates: unit must be "year", "month", or "day". Using "year".')
unit <- "y"
}
# 2. Main function: ------
# (a) initialize other variables:
full_y <- NA
full_m <- NA
full_d <- NA
full_d_1 <- NA
full_d_2 <- NA
# (b) Special case: unit == "d" ----
if (unit == "d"){
# Use diff_days() helper/utility function:
full_d <- diff_days(from_date = from_date, to_date = to_date)
if (as_character){
age <- paste0(sign, full_d, "d")
} else { # return a data frame:
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"d" = full_d,
row.names = 1:n_dates)
}
return(age)
}
# (c) All other units (y/m): Get date elements ----
# from_date elements (DOB):
bd_y <- as.numeric(format(from_date, "%Y"))
bd_m <- as.numeric(format(from_date, "%m"))
bd_d <- as.numeric(format(from_date, "%d"))
# to_date elements (DOD, max. date):
to_y <- as.numeric(format(to_date, "%Y"))
to_m <- as.numeric(format(to_date, "%m"))
to_d <- as.numeric(format(to_date, "%d"))
# (c1) Completed years:
# bday this year? (as Boolean):
bd_ty <- ifelse((to_m > bd_m) | ((to_m == bd_m) & (to_d >= bd_d)), TRUE, FALSE)
# print(bd_ty)
full_y <- (to_y - bd_y) - (1 * !bd_ty)
# (c2) Completed months:
# bday this month? (as Boolean):
bd_tm <- ifelse((to_d >= bd_d), TRUE, FALSE)
# print(bd_tm)
## Distinguish 2 cases:
# full_m[bd_ty] <- (to_m[bd_ty] - bd_m[bd_ty]) - !bd_tm[bd_ty] # 1: bd_ty
# full_m[!bd_ty] <- (12 + to_m[!bd_ty] - bd_m[!bd_ty]) - !bd_tm[!bd_ty] # 2: !bd_ty
## Combine both cases:
full_m <- (to_m - bd_m) + (12 * !bd_ty) - (1 * !bd_tm)
if (unit == "m"){
full_m <- (12 * full_y) + full_m # express years in months
}
# (c3) Completed days:
## bday today? (as Boolean):
# bd_td <- ifelse((to_d == bd_d), TRUE, FALSE)
# Use 2 solutions:
# s_1: LOCAL solution: Determine the number N of days in last month.
# Then use this number to compute difference from bd_d to to_d
## Distinguish 2 cases:
# full_d_1[bd_tm] <- to_d[bd_tm] - bd_d[bd_tm] # 1: bd_tm: days since bd_tm
# full_d_1[!bd_tm] <- to_d[!bd_tm] - bd_d[!bd_tm] + days_last_month(to_date[!bd_tm]) # 2: !bd_tm
## Combine cases:
dlm_to <- days_last_month(to_date)
# full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) # ERROR: See diverging cases below.
## Bug FIX: If bday would have been after the maximum day of last month:
ix_2_fix <- !bd_tm & (bd_d > dlm_to) # ix of cases to fix:
# full_d_1[ix_2_fix] <- to_d[ix_2_fix] # full_d <- to_d for these cases
## ALL-in-ONE:
full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) + ((bd_d - dlm_to) * ix_2_fix)
# message(paste(full_d, collapse = " ")) # debugging
# s_2: GLOBAL solution: Start from total number of days and
# subtract all days of full years and months already accounted for.
# Use diff_days() helper function to compute exact number of days between two dates:
# full_d_2 <- total_days - accounted_days
# = diff_days(DOB, to_date) - diff_days(DOB, to_date = dt_bday_last_month(to_date))
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_date, to_date = to_date)
# Use dt_bday_last_month() helper/utility function (Note: may return decimals):
dt_bday_last_month <- dt_last_monthly_bd(dob = from_date, to_date = to_date)
accounted_days <- diff_days(from_date = from_date, to_date = dt_bday_last_month)
unaccounted_days <- (total_days - accounted_days) # may contain decimals!
# Only consider completed/full days (as integers):
full_d_2 <- floor(unaccounted_days)
# message(paste("total_days = ", total_days, collapse = ", ")) # debugging
# message(paste("accounted_days = ", accounted_days, collapse = ", ")) # debugging
# message(paste("full_d_2 = ", full_d_2, collapse = ", ")) # debugging
# s+3: Verify equality of both solutions: ----
verify_equality <- TRUE
if (verify_equality & (!all(full_d_1 == full_d_2))){
message('diff_dates: 2 methods for full days yield different results (d_1 vs. d_2):')
# Diagnostic info (for debugging):
ix_diff <- (full_d_1 != full_d_2)
if (n_dates > 1){
message(paste(which(ix_diff), collapse = ", "))
message(paste(from_date[ix_diff], collapse = ", "))
message(paste(to_date[ix_diff], collapse = ", "))
}
message(paste("y:", full_y[ix_diff], collapse = ", "))
message(paste("m:", full_m[ix_diff], collapse = ", "))
message(paste("d 1:", full_d_1[ix_diff], collapse = ", "))
message(paste("d_2:", full_d_2[ix_diff], collapse = ", "))
}
# Decision: Use full_d_1
full_d <- full_d_1
# 3. Output: ------
if (as_character){
if (unit == "y"){
age <- paste0(sign, full_y, "y ", full_m, "m ", full_d, "d")
} else if (unit == "m"){
age <- paste0(sign, full_m, "m ", full_d, "d")
}
} else { # return a data frame:
if (unit == "y"){
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"y" = full_y,
"m" = full_m,
"d" = full_d,
row.names = 1:n_dates)
} else if (unit == "m"){
age <- data.frame("from_date" = from_date_org,
"to_date" = to_date_org,
"neg" = sign, # negation sign?
"m" = full_m,
"d" = full_d,
row.names = 1:n_dates)
}
}
return(age)
} # diff_dates().
# ## Check:
# # Days:
# (ds_from <- as.Date("2010-01-02") + -1:1)
# (ds_to <- as.Date("2020-03-01")) # Note: 2020 is leap year.
# diff_dates(from_date = ds_from, to_date = ds_to)
# diff_dates(from_date = ds_from, to_date = ds_to, unit = "m")
# diff_dates(from_date = ds_from, to_date = ds_to, unit = "d")
#
# # Months:
# ms <- Sys.Date() - 366 + seq(from = -100, to = +100, by = 50)
# ms
# diff_dates(ms)
#
# y_100 <- Sys.Date() - (100 * 365.25) + -1:1
# y_100
# diff_dates(y_100)
#
# # with "to_date" argument:
# y_050 <- Sys.Date() - (50 * 365.25) + -1:1
# y_050
# diff_dates(y_100, y_050)
#
# Recycling vector lengths:
# # # (a) recycling "to_date" to length of "from_date":
# y_050_2 <- Sys.Date() - (50 * 365.25)
# y_050_2
# diff_dates(y_100, y_050_2, as_character = FALSE)
#
# # (b) recycling "from_date" to length of "to_date":
# to_dates <- paste("2020", 1:12, "15", sep = "-")
# diff_dates(from_date = "2000-01-01", to_dates, as_character = FALSE)
#
# # Using 'fame' data:
# (dob <- as.Date(fame$DOB, format = "%B %d, %Y"))
# (dod <- as.Date(fame$DOD, format = "%B %d, %Y"))
# diff_dates(dob, dod, as_character = TRUE)
# diff_dates(dob, dod, unit = "m")
# diff_dates(dob, dod, unit = "d")
#
# # Extreme cases:
# # (a) from_date == to_date:
# diff_dates("1000-01-01", "2000-12-31") # max. d + m
# diff_dates("1000-06-01", "1000-06-01") # min. d + m + y
#
# # (b) from_date > to_date:
# # Reverse result and add negation sign ("-"):
# diff_dates("2000-01-02", "2000-01-03")
# diff_dates("2000-02-01", "2000-01-01", as_character = TRUE)
# diff_dates("2001-02-02", "2000-02-02", as_character = FALSE)
#
# ## Check consistency (of 2 solutions):
#
# ## Test with random date samples:
# from <- sample_date(size = 100) - 0.11
# to <- sample_date(size = 100) + 0.22
# diff_dates(from, to, unit = "y", as_character = FALSE)
# diff_dates(from, to, unit = "d", as_character = TRUE)
#
# ## Test with random TIME samples:
# from <- sample_time(size = 100) - .25
# to <- sample_time(size = 100) + .25
# diff_dates(from, to, unit = "y", as_character = TRUE)
# diff_dates(from, to, unit = "d", as_character = TRUE)
#
## Test with date strings:
# from <- "2000-01-01"
# to <- paste("2020", 1:12, "11", sep = "-")
# diff_dates(from, to, unit = "y", as_character = FALSE)
#
#
# # Verify possibly diverging cases:
#
# # 1:
# dob <- as.Date("1981-05-31")
# dod <- as.Date("1992-05-08")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 2:
# dob <- as.Date("1983-07-30")
# dod <- as.Date("1994-03-03")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 3:
# dob <- as.Date("1973-10-31")
# dod <- as.Date("1982-12-29")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 4:
# dob <- as.Date("1979-07-31")
# dod <- as.Date("1998-07-18")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# # 5:
# dob <- as.Date("1999-05-31")
# dod <- as.Date("1999-10-07")
# diff_dates(dob, dod)
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
#
# ## Analyze: Compare results to other methods:
#
# ## (a) lubridate time spans (interval, periods):
# lubridate::as.period(dob %--% dod, unit = "years")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "years")
# diff_dates(dob, dod, unit = "years")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "months")
# diff_dates(dob, dod, unit = "months")
#
# lubridate::as.period(lubridate::interval(dob, dod), unit = "days")
# diff_dates(dob, dod, unit = "days")
#
# ## (b) base::difftime():
# all.equal(as.numeric(dod - dob), diff_days(dob, dod))
# all.equal(as.numeric(difftime(dod, dob)), diff_days(dob, dod))
# difftime(dod, dob, units = "weeks") # Note: No "weeks" in diff_dates().
#
# # from strings:
# diff_dates("2000-12-31")
# diff_dates("90-01-02", to_date = "10-01-01")
#
# # from numbers:
# diff_dates(20001231) # turned into character > Date
# diff_dates(19900711, to_date = 20100710)
#
# # NAs:
# diff_dates(from_date = y_100, to_date = NA)
# diff_dates(from_date = NA, to_date = NA)
## ToDo:
# - add n_decimals argument? (default of 0).
#
# - Add exercise to Chapter 10:
# Explore the diff_dates() function that computes
# the difference between two dates (in human measurement units).
# - Use result to compute age in years (as a number) and months (as a number).
# - Use result to compute age in full weeks (as a number).
# - Use result to add a week entry "Xw" between month m and day d.
# diff_times: Compute time difference (i.e., age) in human units: ------
#' Get the difference between two times (in human units).
#'
#' \code{diff_times} computes the difference between two times
#' (i.e., from some \code{from_time} to some \code{to_time})
#' in human measurement units (periods).
#'
#' \code{diff_times} answers questions like
#' "How much time has elapsed between two dates?"
#' or "How old are you?" in human time periods
#' of (full) years, months, and days.
#'
#' Key characteristics:
#'
#' \itemize{
#'
#' \item If \code{to_time} or \code{from_time} are not "POSIXct" objects,
#' \code{diff_times} aims to coerce them into "POSIXct" objects.
#'
#' \item If \code{to_time} is missing (i.e., \code{NA}),
#' \code{to_time} is set to the current time (i.e., \code{Sys.time()}).
#'
#' \item If \code{to_time} is specified, any intermittent missing values
#' (i.e., \code{NA}) are set to the current time (i.e., \code{Sys.time()}).
#'
#' \item If \code{to_time} precedes \code{from_time} (i.e., \code{from_time > to_time})
#' computations are performed on swapped times and the result is marked
#' as negative (by a character \code{"-"}) in the output.
#'
#' \item If the lengths of \code{from_time} and \code{to_time} differ,
#' the shorter vector is recycled to the length of the longer one.
#'
#' }
#'
#' By default, \code{diff_times} provides output as (signed) character strings.
#' For numeric outputs, use \code{as_character = FALSE}.
#'
#' @param from_time From time (required, scalar or vector, as "POSIXct").
#' Origin time, assumed to be of class "POSIXct",
#' and coerced into "POSIXct" when of class "Date" or "POSIXlt.
#'
#' @param to_time To time (optional, scalar or vector, as "POSIXct").
#' Default: \code{to_time = Sys.time()}.
#' Maximum time, assumed to be of class "POSIXct",
#' and coerced into "POSIXct" when of class "Date" or "POSIXlt".
#'
#' @param unit Largest measurement unit for representing results.
#' Units represent human time periods, rather than
#' chronological time differences.
#' Default: \code{unit = "days"} for completed days, hours, minutes, and seconds.
#' Options available:
#' \enumerate{
#'
#' \item \code{unit = "years"}: completed years, months, and days (default)
#'
#' \item \code{unit = "months"}: completed months, and days
#'
#' \item \code{unit = "days"}: completed days
#'
#' \item \code{unit = "hours"}: completed hours
#'
#' \item \code{unit = "minutes"}: completed minutes
#'
#' \item \code{unit = "seconds"}: completed seconds
#'
#' }
#' Units may be abbreviated.
#'
#' @param as_character Boolean: Return output as character?
#' Default: \code{as_character = TRUE}.
#' If \code{as_character = FALSE}, results are returned
#' as columns of a data frame
#' and include \code{from_date} and \code{to_date}.
#'
#' @return A character vector or data frame
#' (with times, sign, and numeric columns for units).
#'
#' @examples
#' t1 <- as.POSIXct("1969-07-13 13:53 CET") # (before UNIX epoch)
#' diff_times(t1, unit = "years", as_character = TRUE)
#' diff_times(t1, unit = "secs", as_character = TRUE)
#'
#' @family date and time functions
#'
#' @seealso
#' \code{\link{diff_dates}} for date differences;
#' time spans (an \code{interval} \code{as.period}) in the \strong{lubridate} package.
#'
#' @export
diff_times <- function(from_time, to_time = Sys.time(),
unit = "days", as_character = TRUE){
# 0. Initialize:
now <- Sys.time() # (do only once)
age <- NA
# 1. Handle inputs: ------
# (a) NA inputs:
if (any(is.na(from_time))){
message('diff_times: "from_time" must not be NA.')
return(NA)
}
if (all(is.na(to_time))){
message('diff_times: Changing "to_time" from NA to "Sys.time()".')
to_time <- now
}
# (b) Turn non-Date inputs into "Date" objects
if (!is_POSIXct(from_time)){
# message('diff_times: Aiming to parse "from_time" as "POSIXct".')
from_time <- time_from_noPOSIXt(from_time)
}
if (!is_POSIXct(to_time)){
# message('diff_times: Aiming to parse "to_time" as "POSIXct".')
to_time <- time_from_noPOSIXt(to_time)
}
# (c) Recycle shorter time vector to length of longer one: ----
aligned_v <- align_vec_pair(v1 = from_time, v2 = to_time)
from_time <- aligned_v[[1]]
to_time <- aligned_v[[2]]
## WAS: (c) Recycle or truncate to_time argument based on from_time:
# to_time <- align_vec(v_mod = to_time, v_fix = from_time)
# Note: from_time and to_time now have the same length:
n_times <- length(from_time)
# (d) Replace intermittent NA values in to_time by current time:
# Axiom: Entities with a given to_time do not age any further, but
# if to_time = NA, we want to measure until now:
set_to_time_NA_to_NOW <- TRUE # if FALSE: Occasional to_time = NA values yield NA result.
if (set_to_time_NA_to_NOW){
if (!all(is.na(to_time))){ # only SOME to_time values are missing:
to_time[is.na(to_time)] <- now # replace those NA values by now = Sys.time()
}
}
# (e) Verify that from_time and to_time are "POSIXct" objects:
if (!is_POSIXct(from_time)){
message('diff_times: "from_time" should be of class "POSIXct".')
# print(from_time) # debugging
}
if (!is_POSIXct(to_time)){
message('diff_times: "to_time" should be of class "POSIXct".')
# print(to_time) # debugging
}
# (f) If from_time > to_time: Swap dates and negate sign:
from_time_org <- from_time # store original orders
to_time_org <- to_time # (to list in outputs)
ix_swap <- (from_time > to_time) # ix of cases to swap
from_time_temp <- from_time[ix_swap] # temporary storage
from_time[ix_swap] <- to_time[ix_swap] # from_time by to_time
to_time[ix_swap] <- from_time_temp # to_time by from_time
sign <- rep("", n_times) # initialize (as character)
sign[ix_swap] <- "-" # negate sign (character)
# message(sign) # debugging
# (g) Unit:
unit <- substr(tolower(unit), 1, 2) # robustness: use only 1st letter: y/m/d
if (!unit %in% c("ye", "mo", "da", "ho", "mi", "se")){
message('diff_times: unit must be "year", "month", "day", "hour", "min", "sec". Using "day".')
unit <- "da"
}
# 2. Main function: ------
# (a) initialize other variables:
full_y <- NA
full_m <- NA
full_d <- NA
full_d_1 <- NA
full_d_2 <- NA
full_H <- NA
full_M <- NA
full_S <- NA
# (b) total time (in sec):
total_time_sec <- diff_days(from_date = from_time, to_date = to_time, units = "sec", as_Date = FALSE)
# (c) Special case: unit == "sec" ----
if (unit == "se"){
# Use diff_days() helper/utility function:
full_S <- total_time_sec
if (as_character){
age <- paste0(sign, full_S, "S")
} else { # return a data frame:
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"S" = full_S,
row.names = 1:n_times)
}
return(age)
}
# (d) All other units (year/month/day/hour/min): Get date elements ----
# from_time elements (DOB):
bd_y <- as.numeric(format(from_time, "%Y"))
bd_m <- as.numeric(format(from_time, "%m"))
bd_d <- as.numeric(format(from_time, "%d"))
bd_H <- as.numeric(format(from_time, "%H"))
bd_M <- as.numeric(format(from_time, "%M"))
bd_S <- as.numeric(format(from_time, "%S"))
# to_time elements (DOD, max. time):
to_y <- as.numeric(format(to_time, "%Y"))
to_m <- as.numeric(format(to_time, "%m"))
to_d <- as.numeric(format(to_time, "%d"))
to_H <- as.numeric(format(to_time, "%H"))
to_M <- as.numeric(format(to_time, "%M"))
to_S <- as.numeric(format(to_time, "%S"))
# (+) Special case: Consider possible time difference due to different time zones:
tz_diff_mins <- diff_tz(t1 = from_time, t2 = to_time, in_min = TRUE)
tz_diff_days <- tz_diff_mins / (60 * 24) # in days
# (e) Case: largest unit year/month: ----
if (unit == "ye" || unit == "mo"){
# (e1) Completed years:
# bday this year? (as Boolean):
bd_ty <- ifelse(( (to_m > bd_m) | ((to_m == bd_m) & (to_d > bd_d)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H > bd_H)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H == bd_H) & (to_M > bd_M)) |
((to_m == bd_m) & (to_d == bd_d) & (to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S))), TRUE, FALSE)
# print(bd_ty)
full_y <- (to_y - bd_y) - (1 * !bd_ty)
# (e2) Completed months:
# bday this month? (as Boolean):
bd_tm <- ifelse(((to_d > bd_d) | ((to_d == bd_d) & (to_H > bd_H)) |
((to_d == bd_d) & (to_H == bd_H) & (to_M > bd_M)) |
((to_d == bd_d) & (to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S))), TRUE, FALSE)
# print(bd_tm)
## Distinguish 2 cases:
# full_m[bd_ty] <- (to_m[bd_ty] - bd_m[bd_ty]) - !bd_tm[bd_ty] # 1: bd_ty
# full_m[!bd_ty] <- (12 + to_m[!bd_ty] - bd_m[!bd_ty]) - !bd_tm[!bd_ty] # 2: !bd_ty
## Combine both cases:
full_m <- (to_m - bd_m) + (12 * !bd_ty) - (1 * !bd_tm)
# Special case:
if (unit == "mo"){
full_m <- (12 * full_y) + full_m # express years in months
full_y <- 0 # reset years
}
# (e3) Completed days:
## Reached bday-time today? (as Boolean):
bd_td <- ifelse((to_H > bd_H) |
((to_H == bd_H) & (to_M > bd_M)) |
((to_H == bd_H) & (to_M == bd_M) & (to_S >= bd_S)), TRUE, FALSE)
# Use 2 solutions:
# s_1: LOCAL solution: Determine the number N of days in last month.
# Then use this number to compute difference from bd_d to to_d
## Distinguish 2 cases:
# full_d_1[bd_tm] <- to_d[bd_tm] - bd_d[bd_tm] # 1: bd_tm: days since bd_tm
# full_d_1[!bd_tm] <- to_d[!bd_tm] - bd_d[!bd_tm] + days_last_month(to_date[!bd_tm]) # 2: !bd_tm
## Combine cases:
dlm_to <- days_last_month(to_time)
# full_d_1 <- to_d - bd_d + (dlm_to * !bd_tm) # ERROR: See diverging cases below.
## Bug FIX: If bday would have been after the maximum day of last month:
ix_2_fix <- !bd_tm & (bd_d > dlm_to) # ix of cases to fix:
# full_d_1[ix_2_fix] <- to_d[ix_2_fix] # full_d <- to_d for these cases
## ALL-in-ONE:
full_d_1 <- (to_d - bd_d) + (dlm_to * !bd_tm) + ((bd_d - dlm_to) * ix_2_fix) - (1 * !bd_td)
# s_2: GLOBAL solution: Start from total number of days and
# subtract all days of full years and months already accounted for.
# Use diff_days() helper function to compute exact number of days between two dates:
# full_d_2 <- total_days - accounted_days
# = diff_days(DOB, to_date) - diff_days(DOB, to_date = dt_bday_last_month(to_date))
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_time, to_date = to_time, units = "days", as_Date = FALSE)
# Use dt_bday_last_month() helper/utility function (Note: may return decimals):
dt_bday_last_month <- dt_last_monthly_bd(dob = from_time, to_date = to_time) # tz = "" is NO LONGER necessary!!
accounted_days_ym2 <- diff_days(from_date = from_time, to_date = dt_bday_last_month)
unaccounted_days <- (total_days - accounted_days_ym2) # may contain decimals!
# Correction: If tz_diff_mins differ from zero:
ix_tz_diff <- (tz_diff_mins != 0)
unaccounted_days[ix_tz_diff] <- unaccounted_days[ix_tz_diff] + tz_diff_days[ix_tz_diff]
# Only consider completed/full days (as integers):
full_d_2 <- floor(unaccounted_days)
## Correction: Add 1 day if bd_td is TRUE:
# full_d_2[bd_td] <- full_d_2[bd_td] + 1 # Problem: Too general (lots of error cases).
debugging_feedback <- FALSE # TRUE = debugging info
if (debugging_feedback){
message('diff_times debugging info (computing full_d_1 vs. full_d_2):')
# above:
message(paste("full_y = ", full_y, collapse = ", ")) # debugging
message(paste("full_m = ", full_m, collapse = ", ")) # debugging
message(paste("full_d_1 = ", full_d_1, collapse = ", ")) # debugging
# new:
message(paste("total_days = ", total_days, collapse = ", ")) # debugging
message(paste("dt_bday_last_month = ", dt_bday_last_month, collapse = ", ")) # debugging
message(paste("accounted_days_ym2 = ", accounted_days_ym2, collapse = ", ")) # debugging
message(paste("unaccounted_days = ", unaccounted_days, collapse = ", ")) # debugging
message(paste("tz_diff_mins = ", tz_diff_mins, collapse = ", ")) # debugging
message(paste("tz_diff_days = ", tz_diff_days, collapse = ", ")) # debugging
message(paste("full_d_2 = ", full_d_2, collapse = ", ")) # debugging
}
# +++ here now +++
# s+3: Verify equality of both solutions: ----
verify_equality <- TRUE
if (verify_equality & (!all(full_d_1 == full_d_2))){
message('diff_times: 2 methods for full days yield different results (d_1 vs. d_2):')
# Diagnostic info (for debugging):
ix_diff <- (full_d_1 != full_d_2)
if (n_times > 1){
message(paste("ix_diff:", which(ix_diff), collapse = ", "))
message(paste("from_time:", from_time[ix_diff], collapse = ", "))
message(paste("to_time:", to_time[ix_diff], collapse = ", "))
}
message(paste("y:", full_y[ix_diff], collapse = ", "))
message(paste("m:", full_m[ix_diff], collapse = ", "))
message(paste("d_1:", full_d_1[ix_diff], collapse = ", "))
message(paste("d_2:", full_d_2[ix_diff], collapse = ", "))
}
# # Decision 1: Use full_d_1:
# full_d <- full_d_1
# Problem: We need accounted_days_ym2 for computing accounted_time_sec!
# Decision 2: Use full_d_2.
full_d <- full_d_2
## Special case: full_d_2 is negative:
if (any(full_d_2 < 0)){
# message('diff_times: Incrementing month count for negative full day count.')
ix_neg_days <- (full_d_2 < 0)
full_m[ix_neg_days] <- full_m[ix_neg_days] + 1 # increment month count
}
# Store accounted time (in sec):
accounted_time_sec <- (accounted_days_ym2 * (24 * 60 * 60)) + (full_d * (24 * 60 * 60))
} # if (unit == "ye" | unit == "mo").
# (f) Case: largest unit day: ----
if (unit == "da"){
# Use diff_days() helper/utility function:
total_days <- diff_days(from_date = from_time, to_date = to_time, units = "days", as_Date = FALSE)
# Only consider completed/full days (as integers):
full_d <- floor(total_days)
# accounted_days_d <- full_d
# unaccounted_days <- total_days - accounted_days_d # may contain decimals!
# Store accounted time (in sec):
accounted_time_sec <- (full_d * (24 * 60 * 60))
} # if (unit == "da").
# (g) Case: largest unit hour/min:
if (unit == "ho" | unit == "mi"){
accounted_time_sec <- 0
}
# (c4) Remaining time units: ----
# Global approach: Determine total time (in sec) and subtract accounted time (in sec):
unaccounted_time_sec <- (total_time_sec - accounted_time_sec)
# Special case: Account for possible tz difference:
unaccounted_time_sec <- unaccounted_time_sec + (tz_diff_mins * 60)
full_H <- unaccounted_time_sec %/% (60 * 60)
full_M <- (unaccounted_time_sec - (full_H * (60 * 60))) %/% 60
full_S <- (unaccounted_time_sec - (full_H * (60 * 60)) - (full_M * 60))
# Special case:
if (unit == "mi"){
full_M <- (60 * full_H) + full_M # express hours in minutes
full_H <- 0 # reset hours
}
# 3. Output: ------
if (as_character){
if (unit == "ye"){
age <- paste0(sign, full_y, "y ", full_m, "m ", full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "mo"){
age <- paste0(sign, full_m, "m ", full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "da"){
age <- paste0(sign, full_d, "d",
" ", full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "ho"){
age <- paste0(sign, full_H, "H ", full_M, "M ", full_S, "S")
} else if (unit == "mi"){
age <- paste0(sign, full_M, "M ", full_S, "S")
}
} else { # return a data frame:
if (unit == "ye"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"y" = full_y,
"m" = full_m,
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "mo"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"m" = full_m,
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "da"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"d" = full_d,
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "ho"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"H" = full_H,
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
} else if (unit == "mi"){
age <- data.frame("from_time" = from_time_org,
"to_time" = to_time_org,
"neg" = sign, # negation sign?
"M" = full_M,
"S" = full_S,
row.names = 1:n_times)
}
}
return(age)
} # diff_times().
# ## Check:
#
# t1 <- as.POSIXct("1969-07-13 13:53 CET")
# t2 <- Sys.time()
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# diff_times(t1, t2, unit = "month", as_character = TRUE)
# diff_times(t1, t2, unit = "day", as_character = TRUE)
# diff_times(t1, t2, unit = "hour", as_character = TRUE)
# diff_times(t1, t2, unit = "min", as_character = TRUE)
# diff_times(t1, t2, unit = "sec", as_character = TRUE)
#
# # Test with random TIME samples:
# from <- sample_time(size = 100, from = "2020-01-01")
# to <- sample_time(size = 100, from = "2020-04-01")
#
# # "year":
# diff_times(from, to, unit = "year", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "years")
# Note differences in hour counts (due to DST).
# But: diff_times more consistent (see results for unit = "days")!
#
# # "month":
# diff_times(from, to, unit = "month", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "months")
# # Note differences in hour counts (due to DST).
# # But: diff_times more consistent (see results for unit = "days")!
#
# # "day":
# diff_times(from, to, unit = "day", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "day")
#
# # "hour":
# diff_times(from, to, unit = "hour", as_character = FALSE)
# lubridate::as.period(lubridate::interval(from, to), unit = "hour")
#
# # "min":
# diff_times(from, to, unit = "min", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "min")
#
# # "sec":
# diff_times(from, to, unit = "sec", as_character = TRUE)
# lubridate::as.period(lubridate::interval(from, to), unit = "sec")
# ## Former problems/error cases:
#
# # A. now resolved:
#
# # (a)
# t1 <- "2020-05-31 05:41:27"
# t2 <- "2020-07-01 01:29:06"
# diff_times(t1, t2, unit = "year", as_character = FALSE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Bug fix: Add default argument tz = "" to date_from_noDate() and date_from_string() functions:
# dt_last_monthly_bd(t1, t2) # "2020-06-30" is correct.
#
# # (b)
# t1 <- "2020-06-07 01:08:48"
# t2 <- "2020-07-09 22:49:20"
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # (c) DST switch (a: spring ahead):
# t1 <- "2020-03-28 12:00:00" # before DST switch
# t2 <- "2020-03-29 12:00:00" # after DST switch (on 2020-03-29: 02:00:00 > 03:00:00)
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Solved by using new utility/helper function:
# diff_tz(t1, t2, in_min = TRUE)
#
# # (d) DST switch (b: fall back):
# t1 <- "2020-10-24 12:00:00" # before DST switch
# t2 <- "2020-10-25 12:00:00" # after DST switch (on 2020-10-25: 03:00:00 > 02:00:00)
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# # Solved by using new utility/helper function:
# diff_tz(t1, t2, in_min = TRUE)
#
# # (e) Differences between diff_times() and lubridate solution:
# t1 <- "2020-03-26 23:26:38"
# t2 <- "2020-05-02 19:13:20"
# diff_times(t1, t2, unit = "days", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "days")
#
# t1 <- "2020-03-05 05:18:25"
# t2 <- "2020-05-24 07:27:05"
# diff_times(t1, t2, unit = "days", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "days")
# # B. NOT resolved YET:
#
# (x) Error/discrepancy case:
# t1 <- "2020-04-23 16:15:22"
# t2 <- "2020-06-23 04:14:54"
# diff_times(t1, t2, unit = "year", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
#
# dt_last_monthly_bd(t1, t2) # "2020-06-23" is correct.
#
# (y) Differences between diff_times() and lubridate solution:
# t1 <- "2020-06-04 08:39:07"
# t2 <- "2020-04-19 09:32:36"
# diff_times(t1, t2, unit = "years", as_character = TRUE)
# lubridate::as.period(lubridate::interval(t1, t2), unit = "years")
## ToDo:
# - add n_decimals argument? (default of 0).
## (5) Get zodiac name/symbol for given date(s): ------
#' Get zodiac (corresponding to date x).
#'
#' \code{zodiac} provides the tropical zodiac sign or symbol
#' for given date(s) \code{x}.
#'
#' \code{zodiac} is flexible by providing different
#' output formats (in Latin/English, German, or Unicode/HTML,
#' see \code{out}) and allowing to adjust the calendar dates
#' on which a new zodiac is assigned (via \code{zodiac_swap_mmdd}).
#'
#' @param x Date (as a scalar or vector, required).
#' If \code{x} is not a date (of class "Date"),
#' the function tries to coerce \code{x} into a "Date".
#'
#' @param out Output format (as character).
#' Available output formats are:
#' English/Latin (\code{out = "en"}, by default),
#' German/Deutsch (\code{out = "de"}),
#' HTML (\code{out = "html"}), or
#' Unicode (\code{out = "Unicode"}) symbols.
#'
#' @param zodiac_swap_mmdd Monthly dates on which
#' the 12 zodiac signs switch (in \code{mmdd} format,
#' ordered chronologically within a calendar year).
#' Default: \code{zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
#' 0723, 0823, 0923, 1023, 1123, 1222)}.
#'
#' @return Zodiac label or symbol (as a factor).
#'
#' @examples
#' zodiac(Sys.Date())
#'
#' # Works with vectors:
#' dt <- sample_date(size = 10)
#' zodiac(dt)
#' levels(zodiac(dt))
#'
#' # Alternative outputs:
#' zodiac(dt, out = "de") # German/deutsch
#' zodiac(dt, out = "Unicode") # Unicode
#' zodiac(dt, out = "HTML") # HTML
#'
#' # Alternative date breaks:
#' zodiac("2000-08-23") # 0823 is "Virgo" by default
#' zodiac("2000-08-23", # change to 0824 (i.e., August 24):
#' zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
#' 0723, 0824, 0923, 1023, 1123, 1222))
#'
#' @source See
#' \url{https://en.wikipedia.org/wiki/Zodiac} or
#' \url{https://de.wikipedia.org/wiki/Tierkreiszeichen}
#' for alternative date ranges.
#'
#' @family date and time functions
#'
#' @seealso
#' \code{Zodiac()} function of the \strong{DescTools} package.
#'
#' @export
zodiac <- function(x,
out = "en",
zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
0723, 0823, 0923, 1023, 1123, 1222)
){
# 0. Initialize:
date <- NA
zod <- NA
# 1. Handle inputs: ------
# (a) NA inputs: ----
if (any(is.na(x))){
message('zodiac: "date" must not be NA.')
return(NA)
}
# (b) Turn non-Date inputs into "Date" objects: ----
if (!is_Date(x)){
# message('zodiac: Aiming to parse "x" as "Date".')
date <- date_from_noDate(x)
} else {
date <- x
}
# 2. Determine month and days:
mm <- as.numeric(format(date, "%m"))
dd <- as.numeric(format(date, "%d"))
mm <- num_as_char(mm, n_pre_dec = 2, n_dec = 0)
dd <- num_as_char(dd, n_pre_dec = 2, n_dec = 0)
mmdd <- as.numeric(paste0(mm, dd)) # as number (from 101 to 1231)
# 3. Get zodiac sign/symbol for date: -----
# Data: Date breaks and labels:
# Aries: Mar 21 – Apr 20: Widder
# Taurus: Apr 21 – May 20: Stier
# Gemini: May 21 – Jun 20: Zwillinge
# Cancer: Jun 21 – Jul 22: Krebs
# Leo: Jul 23 – Aug 22: Loewe
# Virgo: Aug 23 – Sep 22: Jungfrau
# Libra: Sep 23 – Oct 22: Waage
# Scorpio: Oct 23 – Nov 22: Skorpion
# Sagittarius: Nov 23 – Dec 21: Schuetze
# Capricorn: Dec 22 – Jan 19: Steinbock
# Aquarius: Jan 20 – Feb 18: Wassermann
# Pisces: Feb 19 – Mar 20: Fische
# Latin/en:
labels_en <- c("Aries", "Taurus", "Gemini", "Cancer", "Leo", "Virgo",
"Libra", "Scorpio", "Sagittarius", "Capricorn", "Aquarius", "Pisces")
# German/de:
labels_de <- c("Widder", "Stier", "Zwillinge", "Krebs", "L\u00F6we", "Jungfrau",
"Waage", "Skorpion", "Sch\u00FCtze", "Steinbock", "Wassermann", "Fische")
# Unicode:
labels_unicode <- c("\u2648", "\u2649", "\u264A", "\u264B", "\u264C", "\u264D", "\u264E", "\u264F",
"\u2650", "\u2651", "\u2652", "\u2653")
# HTML:
labels_html <- c("♈", "♉", "♊", "♋", "♌", "♍",
"♎", "♏", "♐", "♑", "♒", "♓")
year_cats <- c(10:12, 1:10) # sequence of zodiac sign categories (arranged in calendar year)
# Output formats: ----
out <- substr(tolower(out), 1, 2) # 4robustness
if (out == "de" | out == "ge"){ # deutsch/German:
labels_year <- labels_de[year_cats] # 13 Namen (out == "de"/"ge")
} else if (out == "un" | out == "uc"){ # Unicode symbols:
labels_year <- labels_unicode[year_cats] # 13 Unicodes (out == "uc"/"un")
} else if (out == "ht"){ # HTML symbols:
labels_year <- labels_html[year_cats] # 13 HTML codes (out == "ht"/"HTML")
} else { # default (out == "English/Latin"):
labels_year <- labels_en[year_cats] # 13 labels (mapped to calendar year)
}
# 4. Main: Determine zodiac by numeric date breaks (in numeric mmdd format):
date_breaks <- c(-Inf, zodiac_swap_mmdd, +Inf)
zod <- cut(x = mmdd, breaks = date_breaks, labels = labels_year,
include.lowest = TRUE, right = FALSE)
# 5. Recode levels of zod as factor (from 1 = Aries to 12 = Pisces):
zod_cats <- c(4:12, 1:3) # re-order zodiac signs
zod <- factor(zod, levels = levels(zod)[zod_cats]) # re-order factor levels
# 6. Output:
# zod <- paste0(mm, "-", dd, ": ", mmdd, " = ", zod, "") # 4debugging
return(zod)
} # zodiac().
# ## Check:
# zodiac(Sys.Date())
# (dt <- sample_date(size = 10))
# zodiac(dt)
#
# # Verify date range borders:
# dt_brd <- c("2000-01-19", "2000-01-20",
# "2000-02-18", "2000-02-19",
# "2000-03-20", "2000-03-21",
# "2000-04-20", "2000-04-21",
# "2000-05-20", "2000-05-21",
# "2000-06-20", "2000-06-21",
# "2000-07-22", "2000-07-23",
# "2000-08-22", "2000-08-23",
# "2000-09-22", "2000-09-23",
# "2000-10-22", "2000-10-23",
# "2000-11-22", "2000-11-23",
# "2000-12-21", "2000-12-22")
# zodiac(dt_brd)
# levels(zodiac(dt_brd))
# is.ordered(zodiac(dt_brd))
#
# # Alternative outputs:
# zodiac(dt_brd, out = "de")
# zodiac(dt_brd, out = "unicode")
# zodiac(dt_brd, out = "HTML")
#
# # Set alternative date breaks:
# zodiac("2000-08-23")
# zodiac("2000-08-23",
# zodiac_swap_mmdd = c(0120, 0219, 0321, 0421, 0521, 0621,
# 0723, 0824, 0923, 1023, 1123, 1222))
## Done: ----------
# - Provided all what_ functions with a "when" argument that is set to Sys.Date()
# or Sys.time() by default, allowing for other dates/times for which question
# is answered (e.g., On what day was my birthday?)
# - change_tz() and change_time() function(s)
# for converting time display (in "POSIXct") into local times (in "POSIXlt"),
# and vice versa (changing times, but not time display).
# - Moved time utility/helper functions into separate file.
## ToDo: ----------
# Add a zodiac() function (that works for vectors of dates):
#
# Input: Dates or times (as vector)
# Output: As factor (levels 1-12) OR character OR Unicode/HTML symbols,
# with labels in Latin/en/de
# See: <https://en.wikipedia.org/wiki/Zodiac> and
# See: <https://de.wikipedia.org/wiki/Tierkreiszeichen> for ranges and symbols.
#
# Note: The DescTools package also contains a Zodiac() function.
# ad (1) and (2):
# - update cur_ and what_ functions to use new helpers
# - re-consider what_day() to return NUMERIC day in week/month/year.
# - fix ToDo in what_date() (Actively convert time?)
# - Return dates/times either as strings (if as_string = TRUE) or
# as dates/times (of class "Date"/"POSIXct") in all what_() functions
# ad (4): Differences between dates/times:
# - finish and clean up diff_dates (or date_diff) function.
# - consider adding diff_times function (analog to diff_dates, but for date-times, including H:M:S)
## eof. ----------------------
Try the ds4psy package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.