R/tk_index.R

In timekit: A Collection of Tools for Working with Time Series in R

#' 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 timekit_idx
#' If `timekit_idx` is `TRUE` a timekit 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 `timekit_idx` argument is applicable to regularized time series objects
#' such as `ts` and `zooreg` classes that have both a regularized index and _potentially_
#' a "timekit index" (a time-based attribute).
#' When set to `FALSE` the regularized index is returned.
#' When set to `TRUE` the time-based timekit index is returned _if present_.
#'
#' `has_timekit_idx()` is used to determine if the object has a timekit index attribute
#' and can thus benefit from the `tk_index(timekit_idx = TRUE)`.
#' `TRUE` indicates the "timekit index" attribute is present.
#' `FALSE` indicates the "timekit 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 `timekit_idx` the time series
#' must have a timekit index.
#' Use `has_timekit_idx` to determine if the object has a timekit 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 "timekit 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
#' library(tidyverse)
#' library(timekit)
#'
#' # 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, timekit_idx = FALSE) # Returns regularized index
#' tk_index(data_ts, timekit_idx = TRUE)  # Returns original time-based index vector
#'
#' # Coercing back to tbl
#' tk_tbl(data_ts, timekit_idx = FALSE) # Returns regularized tbl
#' tk_tbl(data_ts, timekit_idx = TRUE)  # Returns time-based tbl
#'
#'
#'
NULL

# FUNCTION tk_index() -----

#' @export
#' @rdname tk_index
tk_index <- function(data, timekit_idx = FALSE, silent = FALSE) {
    UseMethod("tk_index", data)
}


#' @export
tk_index.data.frame <- function(data, timekit_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, timekit_idx = FALSE, silent = FALSE) {

    tk_idx <- attr(data, "index")

    if (timekit_idx && !is.null(tk_idx)) {
        # Return timekit "time-based" index

        # Coerce numeric date to date-time
        ret <- attr(data, "index") %>%
            lubridate::as_datetime()

        # Set time class to date if Date class
        tclass <- attr(attr(data, "index"), "tclass")
        if (!is.null(tclass)) {
            if ("Date" %in% tclass) ret <- lubridate::as_date(ret)
            if ("yearmon" %in% tclass) ret <- zoo::as.yearmon(ret)
            if ("yearqtr" %in% tclass) ret <- zoo::as.yearqtr(ret)
        }

        class <- attr(attr(data, "index"), "class")
        if (!is.null(class))
            if (class == "Date") ret <- lubridate::as_date(ret)

        # Set the timezone
        tzone <- attr(attr(data, "index"), "tzone")
        if (!is.null(tzone))
            if (!(tclass %in% c("yearmon", "yearqtr")))
                lubridate::tz(ret) <- tzone

    }

    if (timekit_idx && is.null(tk_idx)) {
        if (!silent) warning("timekit attribute `index` not found. Returning default instead.")
        timekit_idx <-  FALSE
    }

    if (!timekit_idx) {
        # Return default index
        ret <- zoo::index(data)
    }


    return(ret)

}

#' @export
tk_index.zoo <- function(data, timekit_idx = FALSE, silent = FALSE) {

    ret <- tk_xts(data, silent = silent) %>%
        tk_index()

    return(ret)

}

#' @export
tk_index.zooreg <- function(data, timekit_idx = FALSE, silent = FALSE) {

    tk_idx <- rownames(data)
    first_val <- tk_idx[[1]]

    if (timekit_idx && !is.null(tk_idx)) {
        # Return timekit "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 (timekit_idx && is.null(tk_idx)) {
        if (!silent) warning("timekit attribute `index` not found. Returning default instead.")
        timekit_idx = FALSE
    }

    if (!timekit_idx) {
        # Return default index
        ret <- zoo::index(data)
    }

    return(ret)

}

#' @export
tk_index.xts <- function(data, timekit_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") %>%
        lubridate::as_datetime()

    # Set time class to date if Date class
    tclass <- xts::tclass(data)
    if ("Date" %in% tclass)    ret <- lubridate::as_date(ret)
    if ("yearmon" %in% tclass) ret <- zoo::as.yearmon(ret)
    if ("yearqtr" %in% tclass) ret <- zoo::as.yearqtr(ret)

    # Set the timezone
    tzone <- xts::indexTZ(data)
    if (!is.null(tzone))
        if (!(tclass %in% c("yearmon", "yearqtr")))
            lubridate::tz(ret) <- tzone

    return(ret)

}

#' @export
tk_index.forecast <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.Arima <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.ets <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.stl <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$time.series, timekit_idx, silent)
}

#' @export
tk_index.stlm <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.baggedETS <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$y, timekit_idx, silent)
}

#' @export
tk_index.fracdiff <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.bats <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$y, timekit_idx, silent)
}

#' @export
tk_index.HoltWinters <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.nnetar <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.StructTS <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$data, timekit_idx, silent)
}

#' @export
tk_index.decomposed.ts <- function(data, timekit_idx = FALSE, silent = FALSE) {
    tk_index(data$x, timekit_idx, silent)
}

#' @export
tk_index.default <- function(data, timekit_idx = FALSE, silent = FALSE) {
    warning(paste0("`tk_index` is not designed to work with objects of class ", class(data), "."))
    invisible(data)
}

# FUNCTION has_timekit_idx() -----

#' @export
#' @rdname tk_index
has_timekit_idx <- function(data) {
    UseMethod("has_timekit_idx", data)
}

#' @export
has_timekit_idx.data.frame <- function(data) {
    FALSE
}

#' @export
has_timekit_idx.xts <- function(data) {
    FALSE
}

#' @export
has_timekit_idx.zoo <- function(data) {
    FALSE
}

#' @export
has_timekit_idx.zooreg <- function(data) {
    has_timekit_index <- TRUE
    if (is.null(rownames(data))) has_timekit_index <- FALSE
    return(has_timekit_index)
}

#' @export
has_timekit_idx.ts <- function(data) {
    has_timekit_index <- TRUE
    if (is.null(attr(data, "index"))) has_timekit_index <- FALSE
    return(has_timekit_index)
}

#' @export
has_timekit_idx.forecast <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.Arima <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.ets <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.stl <- function(data) {
    has_timekit_idx(data$time.series)
}

#' @export
has_timekit_idx.stlm <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.baggedETS <- function(data) {
    has_timekit_idx(data$y)
}

#' @export
has_timekit_idx.fracdiff <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.bats <- function(data) {
    has_timekit_idx(data$y)
}

#' @export
has_timekit_idx.HoltWinters <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.nnetar <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.StructTS <- function(data) {
    has_timekit_idx(data$data)
}

#' @export
has_timekit_idx.decomposed.ts <- function(data) {
    has_timekit_idx(data$x)
}

#' @export
has_timekit_idx.default <- function(data) {
    warning(paste0("`has_timekit_idx` is not designed to work with objects of class ", class(data), "."))
    FALSE
}