1 +
#' @seealso [dplyr::filter]
2 +
#' @export
3 +
# ToDo: filter(pkgs_ts, ~ year() == 2016)? => tbl_ts
4 +
# ToDo: filter(pkgs_ts, ~ month() == 1)? => tbl_df
5 +
filter.tbl_ts <- function(.data, ...) {
6 +
key <- get_key(.data)
7 +
index <- get_index(.data)
8 +
interval <- get_interval(.data)
9 +
cls <- class(.data)
10 +
.data <- NextMethod()
11 +
return(structure(
12 +
.data, key = key, index = index, interval = interval, class = cls
13 +
))
14 +
}
15 + 16 +
#' @seealso [dplyr::select]
17 +
#' @export
18 +
# ToDo: select should work with everything(), ends_with() and etc. too
19 +
select.tbl_ts <- function(.data, ...) {
20 +
cls <- class(.data)
21 +
key <- get_key(.data)
22 +
index <- get_index(.data)
23 +
interval <- get_interval(.data)
24 +
.data <- NextMethod()
25 +
dots_cap <- quos(...)
26 +
idx_there <- any(map_lgl(dots_cap, function(x) x == index))
27 +
key_there <- any(rlang::flatten_lgl(map(key, function(x)
28 +
map_lgl(dots_cap, function(y) y == x)
29 +
)))
30 +
if (idx_there && key_there) {
31 +
return(structure(
32 +
.data, key = key, index = index, interval = interval, class = cls
33 +
))
34 +
} else {
35 +
return(structure(.data, class = c("tbl_df", "tbl", "data.frame")))
36 +
}
37 +
}
38 + 39 +
#' @seealso [dplyr::mutate]
40 +
#' @export
41 +
mutate.tbl_ts <- function(.data, ...) {
42 +
key <- get_key(.data)
43 +
index <- get_index(.data)
44 +
interval <- get_interval(.data)
45 +
cls <- class(.data)
46 +
.data <- NextMethod()
47 +
return(structure(
48 +
.data, key = key, index = index, interval = interval, class = cls
49 +
))
50 +
}
51 + 52 +
#' @seealso [dplyr::group_by]
53 +
#' @export
54 +
group_by.tbl_ts <- function(.data, ..., add = FALSE) {
55 +
key <- get_key(.data)
56 +
index <- get_index(.data)
57 +
interval <- get_interval(.data)
58 +
.data <- NextMethod(.Generic, object = .data, add = add)
59 +
cls <- c("tbl_ts", class(.data))
60 +
return(structure(
61 +
.data, key = key, index = index, interval = interval, class = cls
62 +
))
63 +
}
64 + 65 +
#' @title Aggregate over calendar periods
66 +
#'
67 +
#' @description It computes summary statistics for a tsibble over calendar
68 +
#' periods, usually used in combination of [group_by].
69 +
#'
70 +
#' @param .data A tsibble (of `tbl_ts` class).
71 +
#' @param ... Name-value pairs of summary functions. To aggregate tsibble over
72 +
#' a certain calendar period, for example yearly aggregates, `~ year()` needs
73 +
#' passing to `...`. Please see details.
74 +
#'
75 +
#' @author Earo Wang
76 +
#' @rdname summarise
77 +
#' @seealso [dplyr::summarise]
78 +
#' @details It's S3 method implemented for [tsibble()] (`tbl_ts`) obtained from
79 +
#' [dplyr::summarise()]. A formula with `~` followed by one of calendar component
80 +
#' functions from base, [lubridate] and [zoo] specifies the period when summary
81 +
#' functions are carried out. Currently `~ year()` indicates yearly aggregates.
82 +
#' `~ yearqtr()` indicates quarterly aggregates. `~ yearmon()` indicates
83 +
#' monthly aggregates. `~ as_date()` or `as.Date()` indicates daily aggregates.
84 +
#' @return A tsibble class when the `~` is present.
85 +
#'
86 +
#' @examples
87 +
#' # pkgs_ts <- as_tsibble(tidypkgs, key = key_vars(package), index = date)
88 +
#' # pkgs_ts %>%
89 +
#' # group_by(package) %>%
90 +
#' # summarise(avg_count = mean(count), month = ~ as.yearmon())
91 +
#'
92 +
#' @export
93 +
summarise.tbl_ts <- function(.data, ...) {
94 +
cls <- class(.data)
95 +
grped <- is.grouped_df(.data)
96 +
if (grped) grps <- groups(.data)
97 +
index <- get_index(.data)
98 +
dots_cap <- quos(..., .named = TRUE)
99 +
# Find the special formula from a set of quos
100 +
sp_f <- tilde_detect(dots_cap)
101 +
idx <- sp_f$index
102 +
if (is_empty(idx)) { # if there's no ~ in ..., tbl_ts is dropped
103 +
.data <- NextMethod()
104 +
# drop tbl_ts
105 +
return(structure(.data, class = c("tbl_ts", "tbl_df", "data.frame")))
106 +
} else {
107 +
str_time <- sp_f$var_name
108 +
sym_time <- sym(str_time)
109 +
fun <- sp_f$fun
110 +
# check whether fun is in the dictionary
111 +
if (is_false(fun %in% builtin_dict())) {
112 +
abort(paste(fun, "is not supported yet."))
113 +
}
114 +
# using group_by, sometimes it drops class attributes, e.g. as.yearmon
115 +
.data <- .data %>%
116 +
ungroup() %>%
117 +
dplyr::mutate(!!str_time := UQ(sym(fun))(!!index))
118 +
sum_args <- dots_cap[-idx] # used for summarise
119 +
if (grped) {
120 +
.data <- .data %>%
121 +
dplyr::group_by(!!!grps) %>%
122 +
dplyr::group_by(!!sym_time, add = TRUE)
123 +
} else {
124 +
.data <- .data %>%
125 +
dplyr::group_by(!!sym_time)
126 +
}
127 +
.data <- .data %>%
128 +
dplyr::summarise(!!!sum_args)
129 +
attr(.data, "key") <- if (grped) {
130 +
# ToDo: check if grouping vars should be key variables
131 +
map(grps, as_quosure)
132 +
} else {
133 +
key_vars()
134 +
}
135 +
attr(.data, "index") <- sym_time
136 +
attr(.data, "interval") <- pull_interval(
137 +
eval_tidy(sym_time, data = .data)
138 +
)
139 +
return(structure(.data, class = cls))
140 +
}
141 +
}
142 + 143 +
#' @rdname summarise
144 +
#' @export
145 +
summarize.tbl_ts <- summarise.tbl_ts
146 + 147 +
tilde_detect <- function(...) { # x be a list of quosures
148 +
dots_names <- names2(quos_auto_name(...))
149 +
strs <- dots2str(...)
150 +
sp_f <- grepl("^~", strs) # should only length(TRUE) <= 1
151 +
sp_idx <- which(sp_f == TRUE, useNames = FALSE)
152 +
sp_time <- gsub("^~(.*)\\()", "\\1", strs[sp_idx])
153 +
return(list(
154 +
index = sp_idx,
155 +
fun = sp_time,
156 +
var_name = dots_names[sp_idx]
157 +
))
158 +
}
159 + 160 +
builtin_dict <- function() {
161 +
return(c(
162 +
"year", "as.yearmon", "as.yearqtr", "as_date", "as.Date"
163 +
))
164 +
}
165 +
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4