Permalink
Cannot retrieve contributors at this time
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
284 lines (252 sloc)
8.39 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #' Tidyverse methods for tsibble | |
| #' | |
| #' @description | |
| #' Current dplyr verbs that tsibble has support for: | |
| #' | |
| #' * [dplyr::filter()], [dplyr::slice()], [dplyr::arrange()] | |
| #' * [dplyr::select()], [dplyr::transmute()], [dplyr::mutate()], [dplyr::relocate()], | |
| #' [dplyr::summarise()], [dplyr::group_by()] | |
| #' * [dplyr::left_join()], [dplyr::right_join()], [dplyr::full_join()], | |
| #' [dplyr::inner_join()], [dplyr::semi_join()], [dplyr::anti_join()], | |
| #' [dplyr::nest_join()] | |
| #' * [dplyr::bind_rows()], [dplyr::bind_cols()] | |
| #' | |
| #' Current tidyr verbs that tsibble has support for: | |
| #' | |
| #' * [tidyr::pivot_longer()], [tidyr::pivot_wider()], | |
| #' [tidyr::gather()], [tidyr::spread()] | |
| #' * [tidyr::nest()], [tidyr::fill()], [tidyr::drop_na()] | |
| #' | |
| #' @section Column-wise verbs: | |
| #' * The index variable cannot be dropped for a tsibble object. | |
| #' * When any key variable is modified, a check on the validity of the resulting | |
| #' tsibble will be performed internally. | |
| #' * Use `as_tibble()` to convert tsibble to a general data frame. | |
| #' | |
| #' @section Row-wise verbs: | |
| #' A warning is likely to be issued, if observations are not arranged in | |
| #' past-to-future order. | |
| #' | |
| #' @section Join verbs: | |
| #' Joining with other data sources triggers the check on the validity of the | |
| #' resulting tsibble. | |
| #' | |
| #' @usage NULL | |
| #' @name tsibble-tidyverse | |
| #' @examples | |
| #' library(dplyr, warn.conflicts = FALSE) | |
| #' # `summarise()` a tsibble always aggregates over time | |
| #' # Sum over sensors | |
| #' pedestrian %>% | |
| #' index_by() %>% | |
| #' summarise(Total = sum(Count)) | |
| #' # shortcut | |
| #' pedestrian %>% | |
| #' summarise(Total = sum(Count)) | |
| #' # Back to tibble | |
| #' pedestrian %>% | |
| #' as_tibble() %>% | |
| #' summarise(Total = sum(Count)) | |
| #' | |
| #' library(tidyr) | |
| #' stocks <- tsibble( | |
| #' time = as.Date("2009-01-01") + 0:9, | |
| #' X = rnorm(10, 0, 1), | |
| #' Y = rnorm(10, 0, 2), | |
| #' Z = rnorm(10, 0, 4) | |
| #' ) | |
| #' (stocksm <- stocks %>% | |
| #' pivot_longer(-time, names_to = "stock", values_to = "price")) | |
| #' stocksm %>% | |
| #' pivot_wider(names_from = stock, values_from = price) | |
| NULL | |
| #' @export | |
| arrange.tbl_ts <- function(.data, ...) { | |
| arr_data <- arrange(as_tibble(.data), ...) | |
| update_meta(arr_data, .data, ordered = FALSE, interval = interval(.data)) | |
| } | |
| #' @export | |
| arrange.grouped_ts <- arrange.tbl_ts | |
| #' @export | |
| select.tbl_ts <- function(.data, ...) { | |
| loc <- eval_select(expr(c(...)), .data) | |
| data_cp <- .data | |
| names(data_cp)[loc] <- names(loc) | |
| bind_tsibble(NextMethod(), data_cp, position = "after") | |
| } | |
| #' @export | |
| select.grouped_ts <- select.tbl_ts | |
| #' @export | |
| transmute.tbl_ts <- function(.data, ...) { | |
| bind_tsibble(NextMethod(), .data, position = "before") | |
| } | |
| #' @export | |
| transmute.grouped_ts <- transmute.tbl_ts | |
| #' @export | |
| summarise.tbl_ts <- function(.data, ..., .groups = NULL) { | |
| # Unlike summarise.grouped_df(), summarise.tbl_ts() doesn't compute values for | |
| # empty groups. Bc information is unavailable over the time range for empty | |
| # groups. | |
| idx <- index(.data) | |
| idx2 <- index2(.data) | |
| grped_data <- as_tibble(index_by(.data, !!idx2)) | |
| sum_tbl <- summarise(grped_data, ..., .groups = .groups) | |
| groups_handler <- function(group_vars, .groups = NULL) { | |
| if (is_null(.groups) || .groups == "drop_last") { | |
| head(group_vars, -2) # remove index2 and last grp | |
| } else if (.groups == "drop") { | |
| character() | |
| } else if (.groups == "keep") { | |
| head(group_vars, -1) | |
| } else { # not sure how to handle "rowwise" for tsibble yet | |
| abort("Don't know how to handle \"rowwise\" for a tsibble.") | |
| } | |
| } | |
| sum_data <- grouped_df(sum_tbl, | |
| groups_handler(group_vars(grped_data), .groups = .groups)) | |
| if (identical(idx, idx2)) int <- is_regular(.data) else int <- TRUE | |
| grps <- setdiff(group_vars(.data), as_string(idx2)) | |
| # since summarise() handles a vector of length n, it may violate validity | |
| validate <- vec_size(sum_data) > vec_size(group_data(grped_data)) | |
| if (validate) { | |
| sum_data <- retain_tsibble(sum_data, grps, idx2) | |
| } | |
| build_tsibble(sum_data, | |
| key = !!grps, index = !!idx2, ordered = TRUE, interval = int, | |
| validate = FALSE) | |
| } | |
| #' @export | |
| summarise.grouped_ts <- summarise.tbl_ts | |
| #' @importFrom dplyr group_by_drop_default | |
| #' @export | |
| group_by.tbl_ts <- function(.data, ..., .add = FALSE, | |
| .drop = group_by_drop_default(.data)) { | |
| lst_quos <- enquos(..., .named = TRUE) | |
| grp_vars <- names(lst_quos) | |
| if (.add) grp_vars <- union(group_vars(.data), grp_vars) | |
| if (is_empty(grp_vars)) return(.data) | |
| index <- index_var(.data) | |
| if (index %in% grp_vars) { | |
| abort(c( | |
| sprintf("Column `%s` (index) can't be a grouping variable for a tsibble.", index), | |
| i = "Did you mean `index_by()`?")) | |
| } | |
| grp_key <- identical(grp_vars, key_vars(.data)) && | |
| identical(.drop, key_drop_default(.data)) | |
| if (grp_key) { | |
| grped_tbl <- new_grouped_df(.data, groups = key_data(.data)) | |
| } else { | |
| grped_tbl <- NextMethod() | |
| } | |
| build_tsibble( | |
| grped_tbl, | |
| key = !!key_vars(.data), | |
| key_data = if (grp_key) key_data(.data) else NULL, | |
| index = !!index(.data), index2 = !!index2(.data), | |
| ordered = is_ordered(.data), interval = interval(.data), validate = FALSE | |
| ) | |
| } | |
| #' Group by key variables | |
| #' | |
| #' @description | |
| #' \lifecycle{stable} | |
| #' | |
| #' @param .data A `tbl_ts` object. | |
| #' @param ... Ignored. | |
| #' @inheritParams dplyr::group_by | |
| #' @export | |
| #' @examples | |
| #' tourism %>% | |
| #' group_by_key() | |
| group_by_key <- function(.data, ..., .drop = key_drop_default(.data)) { | |
| group_by(.data, !!!key(.data), .drop = .drop) | |
| } | |
| #' @export | |
| ungroup.grouped_ts <- function(x, ...) { | |
| tbl <- ungroup(as_tibble(x)) | |
| build_tsibble( | |
| tbl, | |
| key_data = key_data(x), index = !!index(x), | |
| ordered = is_ordered(x), interval = interval(x), validate = FALSE | |
| ) | |
| } | |
| #' @export | |
| ungroup.tbl_ts <- function(x, ...) { | |
| attr(x, "index2") <- index_var(x) | |
| x | |
| } | |
| distinct.tbl_ts <- function(.data, ...) { | |
| dplyr::distinct(as_tibble(.data), ...) | |
| } | |
| tally.tbl_ts <- function(x, wt = NULL, sort = FALSE, name = NULL) { | |
| dplyr::tally(as_tibble(x), wt = !!enquo(wt), sort = sort, name = name) | |
| } | |
| count.tbl_ts <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) { | |
| dplyr::count(as_tibble(x), ..., wt = !!enquo(wt), sort = sort, name = name) | |
| } | |
| #' @export | |
| dplyr_row_slice.tbl_ts <- function(data, i, ..., preserve = FALSE) { | |
| tbl <- as_tibble(data) | |
| loc_df <- summarise(tbl, !!".loc" := list2(i)) | |
| ascending <- all(map_lgl(loc_df[[".loc"]], validate_order)) | |
| res <- dplyr_row_slice(tbl, i, ..., preserve = preserve) | |
| if (preserve) { | |
| update_meta2(res, data, ordered = ascending, interval = interval(data)) | |
| } else { | |
| update_meta(res, data, ordered = ascending, interval = interval(data)) | |
| } | |
| } | |
| #' @export | |
| dplyr_row_slice.grouped_ts <- dplyr_row_slice.tbl_ts | |
| #' @export | |
| dplyr_col_modify.tbl_ts <- function(data, cols) { | |
| res <- dplyr_col_modify(as_tibble(data), cols) | |
| idx_chr <- index_var(data) | |
| if (is_false(idx_chr %in% names(res))) { # index has been removed | |
| abort(c( | |
| "Column `%s` (index) can't be removed for a tsibble.", | |
| i = sprintf("Do you need `as_tibble()` to work with data frame?"), idx_chr)) | |
| } | |
| vec_names <- names(cols) | |
| # either key or index is present in `cols` | |
| # suggests that the operations are done on these variables | |
| # validate = TRUE to check if tsibble still holds | |
| val_idx <- has_index(vec_names, data) | |
| if (val_idx) interval <- TRUE else interval <- interval(data) | |
| val_key <- has_any_key(vec_names, data) | |
| if (val_key) { | |
| key_vars <- setdiff(names(res), measured_vars(data)) | |
| data <- remove_key(data, key_vars) | |
| } | |
| validate <- val_idx || val_key | |
| if (validate) { | |
| res <- retain_tsibble(res, key_vars(data), index(data)) | |
| } | |
| build_tsibble( | |
| res, | |
| key = !!key_vars(data), | |
| key_data = if (val_key) NULL else key_data(data), index = !!index(data), | |
| index2 = !!index2(data), ordered = is_ordered(data), interval = interval, | |
| validate = FALSE, .drop = is_key_dropped(data) | |
| ) | |
| } | |
| #' @export | |
| dplyr_col_modify.grouped_ts <- dplyr_col_modify.tbl_ts | |
| #' @export | |
| dplyr_reconstruct.tbl_ts <- function(data, template) { | |
| template <- rename_join_tsibble(data, template) | |
| update_meta(data, template, | |
| ordered = NULL, interval = is_regular(template), | |
| validate = TRUE) | |
| } | |
| #' @export | |
| dplyr_reconstruct.grouped_ts <- function(data, template) { | |
| data <- grouped_df(data, group_vars(template)) | |
| dplyr_reconstruct.tbl_ts(data, template) | |
| } | |
| rename_join_tsibble <- function(data, template) { | |
| nm <- names(template) | |
| key_idx_pos <- vec_match(c(index_var(template), key_vars(template)), nm) | |
| names(template)[key_idx_pos] <- names(data)[key_idx_pos] | |
| template | |
| } |