R/index-tk_index.R

In business-science/timekit: A Tool Kit for Working with Time Series

#' 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
}