#' Pull time interval from a vector
#'
#' @description
#' `r lifecycle::badge('stable')`
#'
#' Assuming regularly spaced time, the `interval_pull()` returns a list of time
#' components as the "interval" class.
#'
#' @param x A vector of index-like class.
#'
#' @details Extend tsibble to support custom time indexes by defining S3 generics
#' `index_valid()` and `interval_pull()` for them.
#' @return An "interval" class (a list) includes "year",
#' "quarter", "month", "week", "day", "hour", "minute", "second", "millisecond",
#' "microsecond", "nanosecond", "unit".
#'
#' @rdname interval-pull
#' @export
#'
#' @examples
#' x <- seq(as.Date("2017-10-01"), as.Date("2017-10-31"), by = 3)
#' interval_pull(x)
interval_pull <- function(x) {
UseMethod("interval_pull")
}
#' @export
interval_pull.default <- function(x) {
dont_know(x, "interval_pull()")
}
#' @export
# Assume date is regularly spaced
interval_pull.POSIXt <- function(x) {
dttm <- as.double(x)
nhms <- gcd_interval(dttm)
period <- split_period(nhms)
new_interval(
hour = period$hour,
minute = period$minute,
second = period$second %/% 1,
millisecond = (period$second %% 1 * 1e3) %/% 1,
microsecond = (period$second %% 1 * 1e3) %% 1 * 1e3
)
}
#' @export
interval_pull.nanotime <- function(x) {
nano <- as.numeric(x)
int <- gcd_interval(nano) # num of nanoseconds
new_interval(nanosecond = int)
}
#' @export
interval_pull.difftime <- function(x) {
t_units <- units(x)
if (t_units == "weeks") {
nweeks <- gcd_interval(unclass(x))
new_interval(week = nweeks)
} else {
dttm <- as.double(x, units = "secs")
nhms <- gcd_interval(dttm)
period <- split_period(nhms)
new_interval(
day = period$day,
hour = period$hour,
minute = period$minute,
second = period$second
)
}
}
#' @export
interval_pull.hms <- function(x) { # for hms package
dttm <- as.double(x)
nhms <- gcd_interval(dttm)
period <- split_period(nhms)
new_interval(
hour = period$hour + period$day * 24,
minute = period$minute,
second = period$second %/% 1,
millisecond = period$second %% 1 %/% 1e-3,
microsecond = period$second %% 1 %/% 1e-6 %% 1e+3
)
}
#' @export
interval_pull.Period <- function(x) {
second_int <- gcd_interval(x$second)
new_interval(
year = gcd_interval(x$year),
month = gcd_interval(x$month),
day = gcd_interval(x$day),
hour = gcd_interval(x$hour),
minute = gcd_interval(x$minute),
second = second_int %/% 1,
millisecond = round(second_int %% 1 %/% 1e-3),
microsecond = round(second_int %% 1 %/% 1e-6 %% 1e+3)
)
}
#' @export
interval_pull.Date <- function(x) {
dttm <- as.numeric(x)
ndays <- gcd_interval(dttm) # num of seconds
new_interval(day = ndays)
}
#' @export
interval_pull.yearweek <- function(x) {
wk <- as.double(x)
nweeks <- gcd_interval(wk)
new_interval(week = nweeks)
}
#' @export
interval_pull.yearmonth <- function(x) {
mon <- as.double(x)
nmonths <- gcd_interval(mon)
new_interval(month = nmonths)
}
#' @export
interval_pull.yearquarter <- function(x) {
qtr <- as.double(x)
nqtrs <- gcd_interval(qtr)
new_interval(quarter = nqtrs)
}
#' @export
interval_pull.numeric <- function(x) {
nunits <- gcd_interval(x)
# "place our origin at 1582 if we are historically inclined or at 1900 if
# we are more financially motivated." (p98, the grammar of graphics v2)
if (is_empty(x)) {
new_interval(unit = nunits)
} else if (min0(x) > 1581 && max0(x) < 2500) {
new_interval(year = nunits)
} else {
new_interval(unit = nunits)
}
}
#' @export
interval_pull.ordered <- function(x) {
interval_pull(as.integer(x))
}
#' Interval constructor for a tsibble
#'
#' @description
#' `r lifecycle::badge('stable')`
#' * `new_interval()` creates an interval object.
#' * `gcd_interval()` computes the greatest common divisor for the difference
#' of numerics.
#' * `is_regular_interval()` checks if the interval is regular.
#'
#' @param ... A set of name-value pairs to specify default interval units: "year",
#' "quarter", "month", "week", "day", "hour", "minute", "second", "millisecond",
#' "microsecond", "nanosecond", "unit".
#' @param .regular Logical. `FALSE` gives an irregular interval, and will ignore
#' the `...` argument.
#' @param .others A list name-value pairs that are not included in the `...`,
#' to allow custom interval.
#' @param x A vector of numerics.
#'
#' @return an "interval" class
#' @rdname new-interval
#' @export
#' @examples
#' (x <- new_interval(hour = 1, minute = 30))
#' (y <- new_interval(.regular = FALSE)) # irregular interval
#' new_interval() # unknown interval
#' new_interval(.others = list(semester = 1)) # custom interval
new_interval <- function(..., .regular = TRUE, .others = list()) {
stopifnot(is.logical(.regular))
stopifnot(is.list(.others))
default <- list2(...)
names_default <- names(default)
names_unit <- fn_fmls_names(default_interval)
pidx <- pmatch(names_default, names_unit)
if (anyNA(pidx)) {
x_units <- paste(names_default[is.na(pidx)], collapse = ", ")
abort(sprintf("Invalid argument: %s.", x_units))
}
default <- eval_bare(call2("default_interval", !!!default))
out <- dots_list(!!!default, !!!.others, .homonyms = "error")
if (!(all(map_lgl(out, function(x) has_length(x, 1))))) {
abort("Only accepts one input for each argument, not empty or multiple.")
}
new_rcrd(fields = out, .regular = .regular, class = "interval")
}
#' @param x An interval.
#' @rdname new-interval
#' @export
#' @examples
#' is_regular_interval(x)
#' is_regular_interval(y)
is_regular_interval <- function(x) {
abort_not_interval(x)
x %@% ".regular"
}
default_interval <- function(year = 0, quarter = 0, month = 0, week = 0,
day = 0, hour = 0, minute = 0, second = 0,
millisecond = 0, microsecond = 0, nanosecond = 0,
unit = 0) {
list(
year = year, quarter = quarter, month = month, week = week,
day = day, hour = hour, minute = minute, second = second,
millisecond = millisecond, microsecond = microsecond,
nanosecond = nanosecond, unit = unit
)
}
irregular <- function() {
new_interval(.regular = FALSE)
}
unknown_interval <- function(x) {
is_regular_interval(x) && sum(vec_c(!!!vec_data(x))) == 0
}
#' @export
`[[.interval` <- function(x, i, ...) {
field(x, i)
}
#' @export
`$.interval` <- `[[.interval`
#' @export
format.interval <- function(x, ...) {
if (!is_regular_interval(x)) return("!")
if (unknown_interval(x)) return("?")
n <- n_fields(x)
micro <- ifelse(is_utf8_output(), "\U00B5s", "us")
defaults <- vec_c("Y", "Q", "M", "W", "D", "h", "m", "s", "ms", micro, "ns", "")
n_defaults <- vec_size(defaults)
misc <- if (n > n_defaults) vec_slice(fields(x), (n_defaults + 1):n) else NULL
fmt_names <- vec_c(defaults, misc)
val <- vec_c(!!!vec_data(x))
paste0(val[val != 0], fmt_names[val != 0], collapse = " ")
}
#' Time units from tsibble's "interval" class used for `seq(by = )`
#'
#' `r lifecycle::badge('experimental')`
#'
#' @param x An interval.
#' @export
#' @keywords internal
default_time_units <- function(x) {
abort_not_interval(x)
x <- vec_data(x)
x[["microsecond"]] <- x[["microsecond"]] * 1e-6
x[["millisecond"]] <- x[["millisecond"]] * 1e-3
x[["minute"]] <- x[["minute"]] * 60
x[["hour"]] <- x[["hour"]] * 3600
sum(vec_c(!!!x))
}
abort_not_interval <- function(x) {
if (is_false(inherits(x, "interval"))) {
abort("`x` must be class 'interval'.")
}
}
#' @rdname new-interval
#' @export
#' @examples
#' gcd_interval(c(1, 3, 5, 6))
# regular time interval is obtained from the greatest common divisor of positive
# time distances.
gcd_interval <- function(x) {
if (length(x) < 2) { # only one time index
0
} else {
unique_x <- vec_unique(round(abs(diff(x)), digits = 6))
gcd_vector(unique_x)
}
}
gcd <- function(a, b) {
if (isTRUE(all.equal(b, 0))) a else gcd(b, a %% b)
}
gcd_vector <- function(x) Reduce(gcd, x)
split_period <- function(x) {
output <- seconds_to_period(x)
list(
year = output$year, month = output$month, day = output$day,
hour = output$hour, minute = output$minute, second = output$second
)
}
has_tz <- function(x) {
tz <- attr(x, "tzone")[[1]]
!(is_null(tz) && !inherits(x, "POSIXt"))
}
#' @importFrom methods setOldClass setMethod
setOldClass(c("interval", "vctrs_rcrd", "vctrs_vctr"))
#' @importMethodsFrom lubridate as.period
setMethod("as.period", "interval", function(x, ...) {
period(
year = x$year,
month = x$quarter * 3 + x$month,
week = x$week,
day = x$day,
hour = x$hour,
minute = x$minute,
second = x$second + x$millisecond / 1e3 + x$microsecond / 1e6 + x$nanosecond / 1e9)
})
#' @importMethodsFrom lubridate as.duration
setMethod("as.duration", "interval", function(x, ...) {
as.duration(as.period(x))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.