Nothing
#' Extract an index of date or datetime from time series objects, models, forecasts
#'
#' @name tk_index
#'
#' @param data A time-based tibble, time-series object, time-series model,
#' or `forecast` object.
#' @param timetk_idx
#' If `timetk_idx` is `TRUE` a timetk time-based index attribute is attempted to be returned.
#' If `FALSE` the default index is returned. See discussion below for further details.
#' @param silent Used to toggle printing of messages and warnings.
#'
#' @return Returns a vector of date or date times
#'
#' @details
#' `tk_index()` is used to extract the date or datetime index from various
#' time series objects, models and forecasts.
#' The method can be used on `tbl`, `xts`, `zoo`, `zooreg`, and `ts` objects.
#' The method can additionally be used on `forecast` objects and a number of
#' objects generated by modeling functions such as `Arima`, `ets`, and `HoltWinters`
#' classes to get the index of the underlying data.
#'
#' The boolean `timetk_idx` argument is applicable to regularized time series objects
#' such as `ts` and `zooreg` classes that have both a regularized index and _potentially_
#' a "timetk index" (a time-based attribute).
#' When set to `FALSE` the regularized index is returned.
#' When set to `TRUE` the time-based timetk index is returned _if present_.
#'
#' `has_timetk_idx()` is used to determine if the object has a "timetk index" attribute
#' and can thus benefit from the `tk_index(timetk_idx = TRUE)`.
#' `TRUE` indicates the "timetk index" attribute is present.
#' `FALSE` indicates the "timetk index" attribute is not present.
#' If `FALSE`, the `tk_index()` function will return the default index for the data type.
#'
#' __Important Note__: To gain the benefit of `timetk_idx` the time series
#' must have a timetk index.
#' Use `has_timetk_idx` to determine if the object has a timetk index.
#' This is particularly important for `ts` objects, which
#' by default do not contain a time-based index and therefore must be coerced from time-based
#' objects such as `tbl`, `xts`, or `zoo` using the `tk_ts()` function in order
#' to get the "timetk index" attribute.
#' Refer to [tk_ts()] for creating persistent date / datetime index
#' during coercion to `ts`.
#'
#'
#'
#' @seealso [tk_ts()], [tk_tbl()], [tk_xts()], [tk_zoo()], [tk_zooreg()]
#'
#' @examples
#'
#' # Create time-based tibble
#' data_tbl <- tibble::tibble(
#' date = seq.Date(from = as.Date("2000-01-01"), by = 1, length.out = 5),
#' x = rnorm(5) * 10,
#' y = 5:1
#' )
#' tk_index(data_tbl) # Returns time-based index vector
#'
#' # Coerce to ts using tk_ts(): Preserves time-basis
#' data_ts <- tk_ts(data_tbl)
#' tk_index(data_ts, timetk_idx = FALSE) # Returns regularized index
#' tk_index(data_ts, timetk_idx = TRUE) # Returns original time-based index vector
#'
#' # Coercing back to tbl
#' tk_tbl(data_ts, timetk_idx = FALSE) # Returns regularized tbl
#' tk_tbl(data_ts, timetk_idx = TRUE) # Returns time-based tbl
#'
#'
#'
NULL
# FUNCTION tk_index() -----
#' @export
#' @rdname tk_index
tk_index <- function(data, timetk_idx = FALSE, silent = FALSE) {
UseMethod("tk_index", data)
}
#' @export
tk_index.data.frame <- function(data, timetk_idx = FALSE, silent = FALSE) {
date_var <- tk_get_timeseries_variables(data)
if (length(date_var) == 0) stop("No date or date-time identified.")
date_var <- date_var[[1]]
# Get contents of date_var column
ret <- data[[date_var]]
return(ret)
}
#' @export
tk_index.ts <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_idx <- attr(data, "index")
if (timetk_idx && !is.null(tk_idx)) {
# Return timetk "time-based" index
# Coerce numeric class to date-time
ret <- attr(data, "index")
# Set time class to date if Date class
tclass <- attr(tk_idx, "tclass")
if (!is.null(tclass)) {
if ("Date" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% lubridate::as_date()
if ("yearmon" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% zoo::as.yearmon()
if ("yearqtr" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% zoo::as.yearqtr()
if ("POSIXt" %in% tclass) {
tzone <- attr(ret, "tzone")
ret <- ret %>% as.numeric() %>% lubridate::as_datetime(tz = tzone)
}
}
class <- attr(attr(data, "index"), "class")
if (!is.null(class))
if (class == "Date") ret <- lubridate::as_date(ret)
}
if (timetk_idx && is.null(tk_idx)) {
if (!silent) warning("timetk attribute `index` not found. Returning default instead.")
timetk_idx <- FALSE
}
if (!timetk_idx) {
# Return default index
ret <- zoo::index(data)
}
return(ret)
}
#' @export
tk_index.zoo <- function(data, timetk_idx = FALSE, silent = FALSE) {
ret <- tk_xts(data, silent = silent) %>%
tk_index()
return(ret)
}
#' @export
tk_index.zooreg <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_idx <- rownames(data)
first_val <- tk_idx[[1]]
if (timetk_idx && !is.null(tk_idx)) {
# Return timetk "time-based" index
# Coerce character date to date-time
len <- stringr::str_length(first_val)
if (len > 10) {
# date-time
ret <- rownames(data) %>%
lubridate::as_datetime()
} else {
# date
ret <- rownames(data) %>%
lubridate::as_date()
}
}
if (timetk_idx && is.null(tk_idx)) {
if (!silent) warning("timetk attribute `index` not found. Returning default instead.")
timetk_idx = FALSE
}
if (!timetk_idx) {
# Return default index
ret <- zoo::index(data)
}
return(ret)
}
#' @export
tk_index.xts <- function(data, timetk_idx = FALSE, silent = FALSE) {
if (is.null(attr(data, "index"))) {
stop("Attribute `index` not found.")
}
# Coerce numeric class to date-time
ret <- attr(data, "index")
# Set time class to date if Date class
tclass <- xts::tclass(data)
if ("Date" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% lubridate::as_date()
if ("yearmon" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% zoo::as.yearmon()
if ("yearqtr" %in% tclass) ret <- ret %>% lubridate::as_datetime() %>% zoo::as.yearqtr()
if ("POSIXt" %in% tclass) {
tzone <- attr(ret, "tzone")
ret <- ret %>% as.numeric() %>% lubridate::as_datetime(tz = tzone)
}
# # Set the timezone
# if (!is.null(tzone))
# if (!(tclass[[1]] %in% c("yearmon", "yearqtr", "Date")))
# lubridate::tz(ret) <- tzone[[1]]
return(ret)
}
#' @export
tk_index.forecast <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.Arima <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.ets <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.stl <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$time.series, timetk_idx, silent)
}
#' @export
tk_index.stlm <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.baggedETS <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$y, timetk_idx, silent)
}
#' @export
tk_index.fracdiff <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.bats <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$y, timetk_idx, silent)
}
#' @export
tk_index.HoltWinters <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.nnetar <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.StructTS <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$data, timetk_idx, silent)
}
#' @export
tk_index.decomposed.ts <- function(data, timetk_idx = FALSE, silent = FALSE) {
tk_index(data$x, timetk_idx, silent)
}
#' @export
tk_index.default <- function(data, timetk_idx = FALSE, silent = FALSE) {
warning(paste0("`tk_index` is not designed to work with objects of class ", class(data), "."))
invisible(data)
}
# FUNCTION has_timetk_idx() -----
#' @export
#' @rdname tk_index
has_timetk_idx <- function(data) {
UseMethod("has_timetk_idx", data)
}
#' @export
has_timetk_idx.data.frame <- function(data) {
FALSE
}
#' @export
has_timetk_idx.xts <- function(data) {
FALSE
}
#' @export
has_timetk_idx.zoo <- function(data) {
FALSE
}
#' @export
has_timetk_idx.zooreg <- function(data) {
has_timetk_index <- TRUE
if (is.null(rownames(data))) has_timetk_index <- FALSE
return(has_timetk_index)
}
#' @export
has_timetk_idx.ts <- function(data) {
has_timetk_index <- TRUE
if (is.null(attr(data, "index"))) has_timetk_index <- FALSE
return(has_timetk_index)
}
#' @export
has_timetk_idx.forecast <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.Arima <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.ets <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.stl <- function(data) {
has_timetk_idx(data$time.series)
}
#' @export
has_timetk_idx.stlm <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.baggedETS <- function(data) {
has_timetk_idx(data$y)
}
#' @export
has_timetk_idx.fracdiff <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.bats <- function(data) {
has_timetk_idx(data$y)
}
#' @export
has_timetk_idx.HoltWinters <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.nnetar <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.StructTS <- function(data) {
has_timetk_idx(data$data)
}
#' @export
has_timetk_idx.decomposed.ts <- function(data) {
has_timetk_idx(data$x)
}
#' @export
has_timetk_idx.default <- function(data) {
warning(paste0("`has_timetk_idx` is not designed to work with objects of class ", class(data), "."))
FALSE
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.