Nothing
#' @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
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.