#' @rdname as-tsibble
#' @param tz Time zone. May be useful when a `ts` object is more frequent than
#' daily.
#'
#' @examples
#' # coerce ts to tsibble
#' as_tsibble(AirPassengers)
#' as_tsibble(sunspot.year)
#' as_tsibble(sunspot.month)
#' as_tsibble(austres)
#' @export
as_tsibble.ts <- function(x, ..., tz = "UTC") {
idx <- time_to_date(x, tz = tz)
value <- as.numeric(x) # rm its ts class
tbl <- tibble(index = idx, value = value)
build_tsibble(tbl,
key = NULL, index = index, ordered = TRUE, validate = FALSE
)
}
#' @rdname as-tsibble
#' @param pivot_longer `TRUE` gives a "longer" form of the data, otherwise as is.
#'
#' @examples
#' # coerce mts to tsibble
#' z <- ts(matrix(rnorm(300), 100, 3), start = c(1961, 1), frequency = 12)
#' as_tsibble(z)
#' as_tsibble(z, pivot_longer = FALSE)
#' @export
as_tsibble.mts <- function(x, ..., tz = "UTC", pivot_longer = TRUE) {
if (pivot_longer) {
long_tbl <- pivot_longer_tsibble(x, tz = tz)
build_tsibble(
long_tbl,
key = key, index = index, ordered = TRUE, validate = FALSE
)
} else {
wide_tbl <- make_index_explicit(x, tz = tz)
build_tsibble(
wide_tbl,
key = NULL, index = index, ordered = TRUE, validate = FALSE
)
}
}
make_index_explicit <- function(x, tz = "UTC") {
vec_cbind(index = time_to_date(x, tz = tz), as_tibble(x))
}
pivot_longer_tsibble <- function(x, tz = "UTC") {
idx <- time_to_date(x, tz = tz)
list2(
"index" := vec_rep(idx, times = ncol(x)),
"key" := vec_rep_each(colnames(x), vec_size(x)),
"value" := vec_c(!!!unclass(x))
)
}
# from ts time to dates
time_to_date <- function(x, tz = "UTC") {
freq <- frequency(x)
time_x <- round(as.numeric(time(x)), digits = 6) # floating
if (freq == 52) {
warn("Expected frequency of weekly data: 365.25 / 7 (approx 52.18), not 52.")
}
if (freq == 7) { # daily
start_year <- trunc(time_x[1])
as.Date(round_date(
date_decimal(start_year + (time_x - start_year) * 7 / 365),
unit = "day"
))
} else if (round(freq, 2) == 52.18) { # weekly
yearweek(date_decimal(time_x))
} else if (freq > 4 && freq <= 12) { # monthly
yearmonth.yearmon(time_x)
} else if (freq > 1 && freq <= 4) { # quarterly
yearquarter.yearqtr(time_x)
} else if (freq == 1) { # yearly
time_x
} else {
if (end(x)[1] > 1581) {
date_x <- date_decimal(time_x, tz = tz)
round_date(date_x, unit = "seconds")
} else {
time_x
}
}
}
# nocov start
#' @keywords internal
#' @export
as_tsibble.msts <- function(x, ..., tz = "UTC", pivot_longer = TRUE) {
if (NCOL(x) == 1) {
as_tsibble.ts(x, ..., tz = tz)
} else {
as_tsibble.mts(x, ..., tz = tz, pivot_longer = pivot_longer)
}
}
#' @keywords internal
#' @export
as_tsibble.hts <- function(x, ..., tz = "UTC") {
full_labs <- extract_labels(x)
tbl <- pivot_longer_tsibble(x$bts, tz = tz)[c("index", "value")]
tbl_hts <- vec_cbind(!!!full_labs, !!!tbl)
# this would work around the special character issue in headers for parse()
key <- colnames(tbl_hts)[1:vec_size(full_labs)]
build_tsibble(tbl_hts,
key = !!key, index = index, ordered = TRUE,
validate = FALSE
)
}
# recursive function to repeat nodes for hts
rep_nodes <- function(x, level = 1L, index = seq_along(x[[level]])) {
if (has_length(x[[1]], 1)) {
x <- x[-1]
}
index <- rep.int(index, x[[level]])
if (has_length(x, level)) {
index
} else {
rep_nodes(x, level + 1L, index)
}
}
extract_labels <- function(x) {
nodes <- x$nodes
old_labels <- x$labels
btm_labels <- old_labels[[length(old_labels)]]
new_labels <- old_labels[-c(1, length(old_labels))]
chr_labs <- map2(
new_labels, seq_along(new_labels),
function(.x, .y) .x[rep_nodes(nodes, level = .y)]
)
nr <- nrow(x$bts)
full_labs <- map(chr_labs, function(.x) rep(.x, each = nr))
full_labs <- c(full_labs, list(rep(btm_labels, each = nr)))
names(full_labs) <- names(old_labels[-1])
full_labs
}
# nocov end
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.