/
ts2tsibble.R
144 lines (135 loc) · 3.91 KB
/
ts2tsibble.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
#' @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