globalVariables(c("name"))
pivot_longer.tbl_ts <- function(data, cols, names_to = "name", ...) {
if (!has_length(names_to)) {
abort("`pivot_longer(<tsibble>)` can't accept zero-length `names_to`.")
}
if (".value" %in% names_to) {
abort("`pivot_longer(<tsibble>)` can't accept the special \".value\" in `names_to`.")
}
new_key <- c(key_vars(data), names_to)
vars <- names(eval_select(enquo(cols), data))
data <- mutate_index2(data, vars)
tbl <- tidyr::pivot_longer(as_tibble(data),
cols = !!enquo(cols), names_to = names_to, ...)
build_tsibble(tbl,
key = !!new_key, index = !!index(data), index2 = !!index2(data),
ordered = is_ordered(data), interval = interval(data), validate = FALSE
)
}
pivot_wider.tbl_ts <- function(data, id_cols = NULL, names_from = name, ...) {
key_var <- vars_pull(names(data), !!enquo(names_from))
if (has_index(key_var, data)) {
abort(c(
sprintf("Column `%s` (index) can't be widened.", key_var),
i = "Please use `as_tibble()` to coerce."
))
}
key_left <- setdiff(key_vars(data), key_var)
new_key <- key_vars(remove_key(data, .vars = key_left))
tbl <- tidyr::pivot_wider(as_tibble(data),
id_cols = !!enquo(id_cols), names_from = !!enquo(names_from), ...)
tbl <- retain_tsibble(tbl, new_key, index(data))
vars <- names(tbl)
data <- mutate_index2(data, vars)
build_tsibble(
tbl,
key = !!new_key, index = !!index(data), index2 = !!index2(data),
ordered = is_ordered(data), interval = is_regular(data),
validate = FALSE
)
}
gather.tbl_ts <- function(data, key = "key", value = "value", ...,
na.rm = FALSE, convert = FALSE, factor_key = FALSE) {
key <- as_string(enexpr(key))
new_key <- c(key_vars(data), key)
value <- enexpr(value)
exprs <- enexprs(...)
if (is_empty(exprs)) {
exprs <- setdiff(
names(data),
c(quo_name(key), quo_name(value), quo_name(index(data)))
)
}
vars <- names(eval_select(expr(c(...)), data))
data <- mutate_index2(data, vars)
tbl <- tidyr::gather(
as_tibble(data),
key = !!key, value = !!value, !!!exprs,
na.rm = na.rm, convert = convert, factor_key = factor_key
)
build_tsibble(tbl,
key = !!new_key, index = !!index(data), index2 = !!index2(data),
ordered = is_ordered(data), interval = interval(data), validate = FALSE
)
}
spread.tbl_ts <- function(data, key, value, ...) {
key <- enexpr(key)
value <- enexpr(value)
key_var <- vars_pull(names(data), !!key)
if (has_index(key_var, data)) {
abort(c(
sprintf("Column `%s` (index) can't be spread.", key_var),
i = "Please use `as_tibble()` to coerce."
))
}
key_left <- setdiff(key_vars(data), key_var)
new_key <- key_vars(remove_key(data, .vars = key_left))
tbl <- tidyr::spread(as_tibble(data), key = !!key, value = !!value, ...)
tbl <- retain_tsibble(tbl, new_key, index(data))
vars <- names(tbl)
data <- mutate_index2(data, vars)
build_tsibble(
tbl,
key = !!new_key, index = !!index(data), index2 = !!index2(data),
ordered = is_ordered(data), interval = is_regular(data),
validate = FALSE
)
}
nest.tbl_ts <- function(.data, ...) {
data <- .data
tbl_nest <- tidyr::nest(as_tibble(data), ...)
data_names <- names(data)
nest_names <- names(tbl_nest)
nest_vars <- setdiff(data_names, nest_names)
if (!has_all_key(nest_vars, data) && !has_index(nest_vars, data)) {
build_tsibble(tbl_nest,
key = setdiff(key_vars(data), nest_vars),
index = !!index(data), validate = FALSE
)
} else if (!has_index(nest_vars, data)) {
build_tsibble(tbl_nest, index = !!index(data), validate = FALSE)
} else {
new_lst <- nest_names[map_lgl(tbl_nest, is_list)]
old_lst <- data_names[map_lgl(data, is_list)]
lst_vars <- setdiff(new_lst, old_lst)
data <- remove_key(ungroup(data), nest_vars)
tbl_nest[[lst_vars]] <- lapply(tbl_nest[[lst_vars]],
function(x) update_meta(x, data))
tbl_nest
}
}
nest.grouped_ts <- nest.tbl_ts
unnest.tbl_ts <- function(data, ...) {
data <- as_tibble(data)
NextMethod()
}
#' Unnest a data frame consisting of tsibbles to a tsibble
#'
#' @description
#' `r lifecycle::badge('deprecated')`
#'
#' @param data A data frame contains homogenous tsibbles in the list-columns.
#' @param cols Names of columns to unnest.
#' @inheritParams as_tsibble
#' @keywords internal
#' @export
unnest_tsibble <- function(data, cols, key = NULL, validate = TRUE) {
if (!is_installed("tidyr") && utils::packageVersion("tidyr") >= "0.9.0") {
abort("Package 'tidyr' (>= v1.0.0) required for `unnest_tsibble()`.")
}
cols <- enquo(cols)
if (quo_is_missing(cols)) {
abort("Argument `cols` for columns to unnest is required.")
}
unnested_data <- tidyr::unnest(as_tibble(data), cols = !!cols)
if (is_tsibble(data)) {
idx <- index(data)
tsbl <- data
} else {
data_names <- names(data)
unnested_names <- names(unnested_data)
new_lst <- unnested_names[map_lgl(unnested_data, is_list)]
old_lst <- data_names[map_lgl(data, is_list)]
lst_cols <- setdiff(old_lst, new_lst)
# checking if the nested columns has `tbl_ts` class
tsbl_col <- map_lgl(data[lst_cols], validate_list_of_tsibble)
if (sum(tsbl_col) == 0) {
abort("Unnested columns contain no tsibble columns.")
}
first_nested <- data[lst_cols][1L, ]
eval_col <- map(first_nested, first)
tsbl <- eval_col[tsbl_col][[1L]]
idx <- index(tsbl)
}
key <- names(eval_select(enquo(key), data = unnested_data))
idx_chr <- as_string(idx)
class(unnested_data[[idx_chr]]) <- class(tsbl[[idx_chr]])
build_tsibble(
unnested_data,
key = !!key, index = !!idx, index2 = !!index2(tsbl),
ordered = is_ordered(tsbl), interval = is_regular(tsbl), validate = validate
)
}
validate_list_of_tsibble <- function(x) {
all(vapply(x, function(x) is_tsibble(x), logical(1)))
}
fill.tbl_ts <- function(data, ..., .direction = c("down", "up")) {
res <- NextMethod()
update_meta2(res, data, ordered = is_ordered(data), interval = interval(data))
}
fill.grouped_ts <- fill.tbl_ts
drop_na.tbl_ts <- function(data, ...) {
res <- NextMethod()
update_meta2(res, data, ordered = is_ordered(data), interval = interval(data))
}
drop_na.grouped_ts <- drop_na.tbl_ts
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.