slider/0000755000176200001440000000000014067416152011542 5ustar liggesusersslider/NAMESPACE0000644000176200001440000000662214067412251012763 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(cnd_body,slider_error_endpoints_cannot_be_na) S3method(cnd_body,slider_error_endpoints_must_be_ascending) S3method(cnd_body,slider_error_generated_endpoints_cannot_be_na) S3method(cnd_body,slider_error_generated_endpoints_incompatible_size) S3method(cnd_body,slider_error_generated_endpoints_must_be_ascending) S3method(cnd_body,slider_error_index_cannot_be_na) S3method(cnd_body,slider_error_index_incompatible_size) S3method(cnd_body,slider_error_index_incompatible_type) S3method(cnd_body,slider_error_index_must_be_ascending) S3method(cnd_header,slider_error_endpoints_cannot_be_na) S3method(cnd_header,slider_error_endpoints_must_be_ascending) S3method(cnd_header,slider_error_generated_endpoints_cannot_be_na) S3method(cnd_header,slider_error_generated_endpoints_incompatible_size) S3method(cnd_header,slider_error_generated_endpoints_must_be_ascending) S3method(cnd_header,slider_error_index_cannot_be_na) S3method(cnd_header,slider_error_index_incompatible_size) S3method(cnd_header,slider_error_index_incompatible_type) S3method(cnd_header,slider_error_index_must_be_ascending) export(block) export(hop) export(hop2) export(hop2_vec) export(hop_index) export(hop_index2) export(hop_index2_vec) export(hop_index_vec) export(hop_vec) export(phop) export(phop_index) export(phop_index_vec) export(phop_vec) export(pslide) export(pslide_chr) export(pslide_dbl) export(pslide_dfc) export(pslide_dfr) export(pslide_index) export(pslide_index_chr) export(pslide_index_dbl) export(pslide_index_dfc) export(pslide_index_dfr) export(pslide_index_int) export(pslide_index_lgl) export(pslide_index_vec) export(pslide_int) export(pslide_lgl) export(pslide_period) export(pslide_period_chr) export(pslide_period_dbl) export(pslide_period_dfc) export(pslide_period_dfr) export(pslide_period_int) export(pslide_period_lgl) export(pslide_period_vec) export(pslide_vec) export(slide) export(slide2) export(slide2_chr) export(slide2_dbl) export(slide2_dfc) export(slide2_dfr) export(slide2_int) export(slide2_lgl) export(slide2_vec) export(slide_all) export(slide_any) export(slide_chr) export(slide_dbl) export(slide_dfc) export(slide_dfr) export(slide_index) export(slide_index2) export(slide_index2_chr) export(slide_index2_dbl) export(slide_index2_dfc) export(slide_index2_dfr) export(slide_index2_int) export(slide_index2_lgl) export(slide_index2_vec) export(slide_index_all) export(slide_index_any) export(slide_index_chr) export(slide_index_dbl) export(slide_index_dfc) export(slide_index_dfr) export(slide_index_int) export(slide_index_lgl) export(slide_index_max) export(slide_index_mean) export(slide_index_min) export(slide_index_prod) export(slide_index_sum) export(slide_index_vec) export(slide_int) export(slide_lgl) export(slide_max) export(slide_mean) export(slide_min) export(slide_period) export(slide_period2) export(slide_period2_chr) export(slide_period2_dbl) export(slide_period2_dfc) export(slide_period2_dfr) export(slide_period2_int) export(slide_period2_lgl) export(slide_period2_vec) export(slide_period_chr) export(slide_period_dbl) export(slide_period_dfc) export(slide_period_dfr) export(slide_period_int) export(slide_period_lgl) export(slide_period_vec) export(slide_prod) export(slide_sum) export(slide_vec) import(rlang) import(vctrs) importFrom(glue,glue_collapse) importFrom(glue,glue_data) importFrom(warp,warp_boundary) importFrom(warp,warp_distance) useDynLib(slider, .registration = TRUE) slider/LICENSE0000644000176200001440000000005313617023371012542 0ustar liggesusersYEAR: 2020 COPYRIGHT HOLDER: Davis Vaughan slider/README.md0000644000176200001440000002607414067412046013030 0ustar liggesusers # slider [![Codecov test coverage](https://codecov.io/gh/DavisVaughan/slider/branch/master/graph/badge.svg)](https://codecov.io/gh/DavisVaughan/slider?branch=master) [![R-CMD-check](https://github.com/DavisVaughan/slider/workflows/R-CMD-check/badge.svg)](https://github.com/DavisVaughan/slider/actions) slider provides a family of general purpose “sliding window” functions. The API is purposefully *very* similar to purrr. The goal of these functions is usually to compute rolling averages, cumulative sums, rolling regressions, or other “window” based computations. There are 3 core functions in slider: - `slide()` iterates over your data like [`purrr::map()`](https://purrr.tidyverse.org/reference/map.html), but uses a sliding window to do so. It is type-stable, and always returns a result with the same size as its input. - `slide_index()` computes a rolling calculation *relative to an index*. If you have ever wanted to compute something like a “3 month rolling average” where the number of days in each month is irregular, you might like this function. - `slide_period()` is similar to `slide_index()` in that it slides relative to an index, but it first breaks the index up into “time blocks”, like 2 month blocks of time, and then it slides over `.x` using indices defined by those blocks. Each of these core functions have the same variants as `purrr::map()`. For example, `slide()` has `slide_dbl()`, `slide2()`, and `pslide()`, along with the other combinations of these variants that you might expect from having previously used purrr. To learn more about these three functions, read the [introduction vignette](https://davisvaughan.github.io/slider/articles/slider.html). There are also a set of extremely fast specialized variants of `slide_dbl()` for the most common use cases. These include `slide_sum()` for rolling sums and `slide_mean()` for rolling averages. There are index variants of each of these as well, like `slide_index_sum()`. ## Installation Install the released version from [CRAN](https://CRAN.R-project.org) with: ``` r install.packages("slider") ``` Install the development version from [GitHub](https://github.com/) with: ``` r remotes::install_github("DavisVaughan/slider") ``` ## Examples The [help page for `slide()`](https://davisvaughan.github.io/slider/reference/slide.html) has many examples, but here are a few: ``` r library(slider) ``` The classic example would be to do a moving average. `slide()` handles this with a combination of the `.before` and `.after` arguments, which control the width of the window and the alignment. ``` r # Moving average (Aligned right) # "The current element + 2 elements before" slide_dbl(1:5, ~mean(.x), .before = 2) #> [1] 1.0 1.5 2.0 3.0 4.0 # Align left # "The current element + 2 elements after" slide_dbl(1:5, ~mean(.x), .after = 2) #> [1] 2.0 3.0 4.0 4.5 5.0 # Center aligned # "The current element + 1 element before + 1 element after" slide_dbl(1:5, ~mean(.x), .before = 1, .after = 1) #> [1] 1.5 2.0 3.0 4.0 4.5 ``` With `Inf`, you can do a “cumulative slide” to compute cumulative expressions. I think of this as saying “give me everything before the current element.” ``` r slide(1:4, ~.x, .before = Inf) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` With `.complete`, you can decide whether or not `.f` should be evaluated on incomplete windows. In the following example, the requested window size is 3, but the first two results are computed on windows of size 1 and 2 because partial results are allowed by default. When `.complete` is set to `TRUE`, the first two results are not computed. ``` r slide(1:4, ~.x, .before = 2) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 2 3 4 slide(1:4, ~.x, .before = 2, .complete = TRUE) #> [[1]] #> NULL #> #> [[2]] #> NULL #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 2 3 4 ``` ## Data frames Unlike `purrr::map()`, `slide()` iterates over data frames in a row wise fashion. Interestingly this means the default of `slide()` becomes a generic row wise iterator, with nice syntax for accessing data frame columns. There is a [vignette specifically about this](https://davisvaughan.github.io/slider/articles/rowwise.html). ``` r mini_cars <- cars[1:4,] slide(mini_cars, ~.x) #> [[1]] #> speed dist #> 1 4 2 #> #> [[2]] #> speed dist #> 1 4 10 #> #> [[3]] #> speed dist #> 1 7 4 #> #> [[4]] #> speed dist #> 1 7 22 slide_dbl(mini_cars, ~.x$speed + .x$dist) #> [1] 6 14 11 29 ``` This makes rolling regressions trivial! ``` r library(tibble) set.seed(123) df <- tibble( y = rnorm(100), x = rnorm(100) ) # Window size of 20 rows # The current row + 19 before # (see slide_index() for how to do this relative to a date vector!) df$regressions <- slide(df, ~lm(y ~ x, data = .x), .before = 19, .complete = TRUE) df[15:25,] #> # A tibble: 11 x 3 #> y x regressions #> #> 1 -0.556 0.519 #> 2 1.79 0.301 #> 3 0.498 0.106 #> 4 -1.97 -0.641 #> 5 0.701 -0.850 #> 6 -0.473 -1.02 #> 7 -1.07 0.118 #> 8 -0.218 -0.947 #> 9 -1.03 -0.491 #> 10 -0.729 -0.256 #> 11 -0.625 1.84 ``` ## Index sliding In many business settings, the value you want to compute is tied to some *index*, like a date vector. In these cases, you’ll probably want to compute sliding windows relative to the index, and not using the fixed window that `slide()` provides. You can use `slide_index()` to pass in both `.x` and an index, `.i`, and the window will be calculated relative to that index. Here, when computing a “2 day window”, you probably don’t want `"2019-08-16"` and `"2019-08-18"` to be grouped together. `slide()` has no concept of an index, so when you specify a window size of 2, it will group these two together. `slide_index()`, on the other hand, will do the right thing. ``` r x <- 1:3 i <- as.Date(c("2019-08-15", "2019-08-16", "2019-08-18")) # slide() has no concept of an "index" slide(x, ~.x, .before = 1) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 2 3 # "index aware" slide_index(x, i, ~.x, .before = 1) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 3 ``` Essentially what happens is that when we get to `"2019-08-18"`, it “looks backwards” 1 day to set a window boundary at `"2019-08-17"`. Since the date at position 2, `"2019-08-16"`, is before `"2019-08-17"`, it is not included. Powerfully, you can pass through any object to `.before` that computes a value from `.i - .before`. This means that you could also have used a lubridate period object (which gets even more interesting when you use `weeks()` or `months()`): ``` r slide_index(x, i, ~.x, .before = lubridate::days(1)) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 3 ``` ## Period sliding `slide_period()` is different from `slide_index()` in that it first breaks the index into “time blocks” and then slides over `.x` relative to those blocks. For example, in the monthly period slide below, `i` is broken up into 4 time blocks of “the current block of monthly data, plus one block before this one”. The locations of those blocks are the locations that are used to slice `.x` with. ``` r i <- as.Date(c( "2019-01-29", "2019-01-30", "2019-02-05", "2019-04-01", "2019-05-10" )) slide_period(i, i, "month", ~.x, .before = 1) #> [[1]] #> [1] "2019-01-29" "2019-01-30" #> #> [[2]] #> [1] "2019-01-29" "2019-01-30" "2019-02-05" #> #> [[3]] #> [1] "2019-04-01" #> #> [[4]] #> [1] "2019-04-01" "2019-05-10" ``` One neat thing to notice is that `slide_period()` is aware of the distance between elements of `.i` in the period you specify. The practical implication of this is that in the above example, group 3 with `2019-04-01` did *not* include `2019-02-05` in it, because it is more than 1 month group away. ## Inspiration This package is inspired heavily by SQL’s window functions. The API is similar, but more general because you can iterate over any kind of R object. There have been multiple attempts at creating sliding window functions (I personally created `rollify()`, and worked a little bit on `tsibble::slide()` with [Earo Wang](https://github.com/earowang)). - `zoo::rollapply()` - `tibbletime::rollify()` - `tsibble::slide()` I believe that slider is the next iteration of these. There are a few reasons for this: - To me, the API is more intuitive, and is more flexible because `.before` and `.after` let you completely control the entry point (as opposed to fixed entry points like `"center"`, `"left"`, etc. - It is objectively faster because it is written purely in C. - With `slide_vec()` you can return any kind of object, and are not limited to the suffixed versions: `_dbl`, `_int`, etc. - It iterates rowwise over data frames, consistent with the vctrs framework. - I believe it is overall more consistent, backed by a theory that can always justify the sliding window generated by any combination of the parameters. Earo and I have spoken, and we have mutually agreed that it would be best to deprecate `tsibble::slide()` in favor of `slider::slide()`. Additionally, [data.table](https://github.com/Rdatatable/data.table)’s non-equi joins have been pretty much the only solution to the problem that `slide_index()` tries to solve. Their solution is robust and quite fast, and has been a nice benchmark for slider. slider is trying to solve a much narrower problem, so the API here is more focused. ## Performance Like `purrr::map()`, the core functions of slider, such as `slide()` and `slide_index()`, are optimized in C to be as fast as possible, but there is overhead involved in calling `.f` repeatedly. These functions are meant to be as *general purpose* as possible, at the cost of some performance. This means that slider can be used for more abstract computations, like rolling regressions, or any other custom function that you want to use in a rolling fashion. slider also provides *specialized* functions for some of the most common use cases, such as `slide_mean()`, or `slide_index_sum()`. These compute their corresponding metric at the C level, using a specialized algorithm, and are often much faster than their `slide_dbl(x, fn)` equivalent. ## References I’ve found the following references very useful to understand more about window functions: - [Postgres SQL documentation](https://www.postgresql.org/docs/current/sql-expressions.html#SYNTAX-WINDOW-FUNCTIONS) - [dbplyr window function vignette](https://dbplyr.tidyverse.org/articles/translation-function.html#window-functions) - [SQLite documentation - with a flowchart](https://www.sqlite.org/windowfunctions.html) - [Vertica Rows vs Range discussion](https://www.vertica.com/docs/9.2.x/HTML/Content/Authoring/SQLReferenceManual/Functions/Analytic/window_frame_clause.htm?origin_team=T02V9CHFH#ROWSversusRANGE) slider/man/0000755000176200001440000000000014024643631012312 5ustar liggesusersslider/man/slide2.Rd0000644000176200001440000001715113736067057014003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide2.R, R/pslide.R \name{slide2} \alias{slide2} \alias{slide2_vec} \alias{slide2_dbl} \alias{slide2_int} \alias{slide2_lgl} \alias{slide2_chr} \alias{slide2_dfr} \alias{slide2_dfc} \alias{pslide} \alias{pslide_vec} \alias{pslide_dbl} \alias{pslide_int} \alias{pslide_lgl} \alias{pslide_chr} \alias{pslide_dfr} \alias{pslide_dfc} \title{Slide over multiple inputs simultaneously} \usage{ slide2( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide2_vec( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL ) slide2_dbl( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide2_int( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide2_lgl( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide2_chr( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide2_dfr( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide2_dfc( .x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) pslide(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) pslide_vec( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL ) pslide_dbl( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) pslide_int( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) pslide_lgl( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) pslide_chr( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) pslide_dfr( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) pslide_dfc( .l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x, .y}{\verb{[vector]} Vectors to iterate over. Vectors of size 1 will be recycled.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.before, .after}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{.step}{\verb{[positive integer(1)]} The number of elements to shift the window forward between function calls.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} \item{.l}{\verb{[list]} A list of vectors. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. If \code{.l} has names, they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 1 will be recycled.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide2()}}{ \itemize{ \item \code{vec_size(slide2(.x, .y)) == vec_size_common(.x, .y)} \item \code{vec_ptype(slide2(.x, .y)) == list()} } } \subsection{\code{slide2_vec()} and \verb{slide2_*()} variants}{ \itemize{ \item \code{vec_size(slide2_vec(.x, .y)) == vec_size_common(.x, .y)} \item \code{vec_size(slide2_vec(.x, .y)[[1]]) == 1L} \item \code{vec_ptype(slide2_vec(.x, .y, .ptype = ptype)) == ptype} } } \subsection{\code{pslide()}}{ \itemize{ \item \code{vec_size(pslide(.l)) == vec_size_common(!!! .l)} \item \code{vec_ptype(pslide(.l)) == list()} } } \subsection{\code{pslide_vec()} and \verb{pslide_*()} variants}{ \itemize{ \item \code{vec_size(pslide_vec(.l)) == vec_size_common(!!! .l)} \item \code{vec_size(pslide_vec(.l)[[1]]) == 1L} \item \code{vec_ptype(pslide_vec(.l, .ptype = ptype)) == ptype} } } } \description{ These are variants of \code{\link[=slide]{slide()}} that iterate over multiple inputs in parallel. They are parallel in the sense that each input is processed in parallel with the others, not in the sense of multicore computing. These functions work similarly to \code{map2()} and \code{pmap()} from purrr. } \examples{ # Slide along two inputs at once slide2(1:4, 5:8, ~list(.x, .y), .before = 2) # Or, for more than two, use `pslide()` pslide(list(1:4, 5:8, 9:12), ~list(.x, .y, ..3), .before = 2) # You can even slide along the rows of multiple data frames of # equal size at once set.seed(16) x <- data.frame(a = rnorm(5), b = rnorm(5)) y <- data.frame(c = letters[1:5], d = letters[6:10]) row_return <- function(x_rows, y_rows) { if (sum(x_rows$a) < 0) { x_rows } else { y_rows } } slide2(x, y, row_return, .before = 1, .after = 2) } \seealso{ \code{\link[=slide]{slide()}}, \code{\link[=slide_index2]{slide_index2()}}, \code{\link[=hop_index2]{hop_index2()}} } slider/man/hop.Rd0000644000176200001440000000775413612324041013375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hop.R \name{hop} \alias{hop} \alias{hop_vec} \title{Hop} \usage{ hop(.x, .starts, .stops, .f, ...) hop_vec(.x, .starts, .stops, .f, ..., .ptype = NULL) } \arguments{ \item{.x}{\verb{[vector]} The vector to iterate over and apply \code{.f} to.} \item{.starts, .stops}{\verb{[integer]} Vectors of boundary locations that make up the windows to bucket \code{.x} with. Both \code{.starts} and \code{.stops} will be recycled to their common size, and that common size will be the size of the result. Both vectors should be integer locations along \code{.x}, but out-of-bounds values are allowed.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} } \value{ A vector fulfilling the following invariants: \subsection{\code{hop()}}{ \itemize{ \item \code{vec_size(hop(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(hop(.x, .starts, .stops)) == list()} } } \subsection{\code{hop_vec()}}{ \itemize{ \item \code{vec_size(hop_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(hop_vec(.x, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(hop_vec(.x, .starts, .stops, .ptype = ptype)) == ptype} } } } \description{ \code{hop()} is the lower level engine that powers \code{\link[=slide]{slide()}} (at least in theory). It has slightly different invariants than \code{slide()}, and is useful when you either need to hand craft boundary locations, or want to compute a result with a size that is different from \code{.x}. } \details{ \code{hop()} is very close to being a faster version of:\preformatted{map2( .starts, .stops, function(start, stop) \{ x_slice <- vec_slice(.x, start:stop) .f(x_slice, ...) \} ) } Because of this, \code{\link[=hop_index]{hop_index()}} is often the more useful function. \code{hop()} mainly exists for API completeness. The main difference is that the start and stop values make up ranges of \emph{possible} locations along \code{.x}, and it is not enforced that these locations actually exist along \code{.x}. As an example, with \code{hop()} you can do the following, which would be an error with \code{vec_slice()} because \code{0L} is out of bounds.\preformatted{hop(c("a", "b"), .starts = 0L, .stops = 1L, ~.x) #> [[1]] #> [1] "a" } \code{hop()} allows these out of bounds values to be fully compatible with \code{slide()}. It is always possible to construct a \code{hop()} call from a \code{slide()} call. For example, the following are equivalent:\preformatted{slide(1:2, ~.x, .before = 1) hop(1:2, .starts = c(0, 1), .stops = c(1, 2), ~.x) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 } } \examples{ # `hop()` let's you manually specify locations to apply `.f` at. hop(1:3, .starts = c(1, 3), .stops = 3, ~.x) # `hop()`'s start/stop locations are allowed to be out of bounds relative # to the size of `.x`. hop( mtcars, .starts = c(-1, 3), .stops = c(2, 6), ~.x ) } \seealso{ \code{\link[=hop2]{hop2()}}, \code{\link[=hop_index]{hop_index()}}, \code{\link[=slide]{slide()}} } slider/man/slider-package.Rd0000644000176200001440000000145414024427556015466 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slider-package.R \docType{package} \name{slider-package} \alias{slider-package} \alias{_PACKAGE} \title{slider: Sliding Window Functions} \description{ Provides type-stable rolling window functions over any R data type. Cumulative and expanding windows are also supported. For more advanced usage, an index can be used as a secondary vector that defines how sliding windows are to be created. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/DavisVaughan/slider} \item Report bugs at \url{https://github.com/DavisVaughan/slider/issues} } } \author{ \strong{Maintainer}: Davis Vaughan \email{davis@rstudio.com} Other contributors: \itemize{ \item RStudio [copyright holder] } } \keyword{internal} slider/man/hop2.Rd0000644000176200001440000000732713612324041013453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hop2.R, R/phop.R \name{hop2} \alias{hop2} \alias{hop2_vec} \alias{phop} \alias{phop_vec} \title{Hop along multiple inputs simultaneously} \usage{ hop2(.x, .y, .starts, .stops, .f, ...) hop2_vec(.x, .y, .starts, .stops, .f, ..., .ptype = NULL) phop(.l, .starts, .stops, .f, ...) phop_vec(.l, .starts, .stops, .f, ..., .ptype = NULL) } \arguments{ \item{.x, .y}{\verb{[vector]} Vectors to iterate over. Vectors of size 1 will be recycled.} \item{.starts, .stops}{\verb{[integer]} Vectors of boundary locations that make up the windows to bucket \code{.x} with. Both \code{.starts} and \code{.stops} will be recycled to their common size, and that common size will be the size of the result. Both vectors should be integer locations along \code{.x}, but out-of-bounds values are allowed.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.l}{\verb{[list]} A list of vectors. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. If \code{.l} has names, they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 1 will be recycled.} } \value{ A vector fulfilling the following invariants: \subsection{\code{hop2()}}{ \itemize{ \item \code{vec_size(hop2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(hop2(.x, .y, .starts, .stops)) == list()} } } \subsection{\code{hop2_vec()}}{ \itemize{ \item \code{vec_size(hop2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(hop2_vec(.x, .y, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(hop2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype} } } \subsection{\code{phop()}}{ \itemize{ \item \code{vec_size(phop(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(phop(.l, .starts, .stops)) == list()} } } \subsection{\code{phop_vec()}}{ \itemize{ \item \code{vec_size(phop_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(phop_vec(.l, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(phop_vec(.l, .starts, .stops, .ptype = ptype)) == ptype} } } } \description{ \code{hop2()} and \code{phop()} represent the combination of \code{\link[=slide2]{slide2()}} and \code{\link[=pslide]{pslide()}} with \code{\link[=hop]{hop()}}, allowing you to iterate over multiple vectors at once, hopping along them using boundaries defined by \code{.starts} and \code{.stops}. } \examples{ hop2(1:2, 3:4, .starts = 1, .stops = c(2, 1), ~c(x = .x, y = .y)) phop( list(1, 2:4, 5:7), .starts = c(0, 1), .stops = c(2, 4), ~c(x = ..1, y = ..2, z = ..3) ) } \seealso{ \code{\link[=hop]{hop()}}, \code{\link[=hop_index]{hop_index()}}, \code{\link[=slide2]{slide2()}} } slider/man/summary-slide.Rd0000644000176200001440000001401614024643631015376 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary-slide.R \name{summary-slide} \alias{summary-slide} \alias{slide_sum} \alias{slide_prod} \alias{slide_mean} \alias{slide_min} \alias{slide_max} \alias{slide_all} \alias{slide_any} \title{Specialized sliding functions} \usage{ slide_sum( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_prod( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_mean( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_min( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_max( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_all( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) slide_any( x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE ) } \arguments{ \item{x}{\verb{[vector]} A vector to compute the sliding function on. \itemize{ \item For sliding sum, mean, prod, min, and max, \code{x} will be cast to a double vector with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}. \item For sliding any and all, \code{x} will be cast to a logical vector with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}. }} \item{...}{These dots are for future extensions and must be empty.} \item{before}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{after}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{step}{\verb{[positive integer(1)]} The number of elements to shift the window forward between function calls.} \item{complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{na_rm}{\verb{[logical(1)]} Should missing values be removed from the computation?} } \value{ A vector the same size as \code{x} containing the result of applying the summary function over the sliding windows. \itemize{ \item For sliding sum, mean, prod, min, and max, a double vector will be returned. \item For sliding any and all, a logical vector will be returned. } } \description{ These functions are specialized variants of the most common ways that \code{\link[=slide]{slide()}} is generally used. Notably, \code{\link[=slide_sum]{slide_sum()}} can be used for rolling sums, and \code{\link[=slide_mean]{slide_mean()}} can be used for rolling averages. These specialized variants are \emph{much} faster and more memory efficient than using an otherwise equivalent call constructed with \code{\link[=slide_dbl]{slide_dbl()}} or \code{\link[=slide_lgl]{slide_lgl()}}, especially with a very wide window. } \details{ Note that these functions are \emph{not} generic and do not respect method dispatch of the corresponding summary function (i.e. \code{\link[base:sum]{base::sum()}}, \code{\link[base:mean]{base::mean()}}). Input will always be cast to a double or logical vector using \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}, and an internal method for computing the summary function will be used. Due to the structure of segment trees, \code{slide_mean()} does not perform the same "two pass" mean that \code{mean()} does (the intention of the second pass is to perform a floating point error correction). Because of this, there may be small differences between \code{slide_mean(x)} and \code{slide_dbl(x, mean)} in some cases. } \section{Implementation}{ These variants are implemented using a data structure known as a \emph{segment tree}, which allows for extremely fast repeated range queries without loss of precision. One alternative to segment trees is to directly recompute the summary function on each full window. This is what is done by using, for example, \code{slide_dbl(x, sum)}. This is extremely slow with large window sizes and wastes a lot of effort recomputing nearly the same information on each window. It can be made slightly faster by moving the sum to C to avoid intermediate allocations, but it still fairly slow. A second alternative is to use an \emph{online} algorithm, which uses information from the previous window to compute the next window. These are extremely fast, only requiring a single pass through the data, but often suffer from numerical instability issues. Segment trees are an attempt to reconcile the performance issues of the direct approach with the numerical issues of the online approach. The performance of segment trees isn't quite as fast as online algorithms, but is close enough that it should be usable on most large data sets without any issues. Unlike online algorithms, segment trees don't suffer from any extra numerical instability issues. } \examples{ x <- c(1, 5, 3, 2, 6, 10) # `slide_sum()` can be used for rolling sums. # The following are equivalent, but `slide_sum()` is much faster. slide_sum(x, before = 2) slide_dbl(x, sum, .before = 2) # `slide_mean()` can be used for rolling averages slide_mean(x, before = 2) # Only evaluate the sum on complete windows slide_sum(x, before = 2, after = 1, complete = TRUE) # Skip every other calculation slide_sum(x, before = 2, step = 2) } \references{ Leis, Kundhikanjana, Kemper, and Neumann (2015). "Efficient Processing of Window Functions in Analytical SQL Queries". https://dl.acm.org/doi/10.14778/2794367.2794375 } \seealso{ \code{\link[=slide_index_sum]{slide_index_sum()}} } slider/man/slide.Rd0000644000176200001440000002132413736067057013716 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide.R \name{slide} \alias{slide} \alias{slide_vec} \alias{slide_dbl} \alias{slide_int} \alias{slide_lgl} \alias{slide_chr} \alias{slide_dfr} \alias{slide_dfc} \title{Slide} \usage{ slide(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) slide_vec( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL ) slide_dbl( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide_int( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide_lgl( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide_chr( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE ) slide_dfr( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide_dfc( .x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x}{\verb{[vector]} The vector to iterate over and apply \code{.f} to.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.before, .after}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{.step}{\verb{[positive integer(1)]} The number of elements to shift the window forward between function calls.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide()}}{ \itemize{ \item \code{vec_size(slide(.x)) == vec_size(.x)} \item \code{vec_ptype(slide(.x)) == list()} } } \subsection{\code{slide_vec()} and \verb{slide_*()} variants}{ \itemize{ \item \code{vec_size(slide_vec(.x)) == vec_size(.x)} \item \code{vec_size(slide_vec(.x)[[1]]) == 1L} \item \code{vec_ptype(slide_vec(.x, .ptype = ptype)) == ptype} } } } \description{ \code{slide()} iterates through \code{.x} using a sliding window, applying \code{.f} to each sub-window of \code{.x}. } \details{ Unlike \code{lapply()} or \code{purrr::map()}, which construct calls like\preformatted{.f(.x[[i]], ...) } the equivalent with \code{slide()} looks like\preformatted{.f(vctrs::vec_slice(.x, i), ...) } which is approximately\preformatted{.f(.x[i], ...) } except in the case of data frames or arrays, which are iterated over row-wise. If \code{.x} has names, then the output will preserve those names. Using \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}, the output of \code{.f} will be automatically cast to the type required by the variant of \verb{slide_*()} being used. } \examples{ # The defaults work similarly to `map()` slide(1:5, ~.x) # Use `.before`, `.after`, and `.step` to control the window slide(1:5, ~.x, .before = 1) # This can be used for rolling means slide_dbl(rnorm(5), mean, .before = 2) # Or more flexible rolling operations slide(rnorm(5), ~ .x - mean(.x), .before = 2) # `.after` allows you to "align to the left" rather than the right slide(1:5, ~.x, .after = 2) # And a mixture of `.before` and `.after` # allows you complete control over the exact alignment. # Below, "center alignment" is used. slide(1:5, ~.x, .before = 1, .after = 1) # The `.step` controls how the window is shifted along `.x`, # allowing you to "skip" iterations if you only need a less granular result slide(1:10, ~.x, .before = 2, .step = 3) # `.complete` controls whether or not partial results are computed. # By default, they are, but setting `.complete = TRUE` restricts # `slide()` to only evaluate the function where a complete window exists. slide(1:5, ~.x, .before = 2, .after = 1) slide(1:5, ~.x, .before = 2, .after = 1, .complete = TRUE) # --------------------------------------------------------------------------- # Data frames # Data frames are iterated over rowwise mtcars_rowwise <- slide(mtcars, ~.x) mtcars_rowwise[1:3] # This means that any column name is easily accessible slide_dbl(mtcars, ~.x$mpg + .x$cyl) # More advanced rowwise iteration is available as well by using the # other arguments mtcars_rowwise_window <- slide(mtcars, ~.x, .before = 1, .after = 1) mtcars_rowwise_window[1:3] # --------------------------------------------------------------------------- # Cumulative sliding # Using the special cased value, `Inf`, you can ask `slide()` to pin the # start of the sliding window to the first element, effectively creating # a cumulative window slide(1:5, ~.x, .before = Inf) # Same with `.after`, this creates a window where you start with all of the # elements, but decrease the total number over each iteration slide(1:5, ~.x, .after = Inf) # --------------------------------------------------------------------------- # Negative `.before` / `.after` # `.before` is allowed to be negative, allowing you to "look forward" in # your vector. Note that `abs(.before) <= .after` must hold if `.before` is # negative. In this example, we look forward to elements in locations 2 and 3 # but place the result in position 1 in the output. slide(1:5, ~.x, .before = -1, .after = 2) # `.after` can be negative as well to "look backwards" slide(1:5, ~.x, .before = 2, .after = -1) # --------------------------------------------------------------------------- # Removing padding # If you are looking for a way to remove the `NA` values from something like # this, then it doesn't exist as a built in option. x <- rnorm(10) slide_dbl(x, mean, .before = 3, .step = 2, .complete = TRUE) # Adding an option to `slide_dbl()` to remove the `NA` values would destroy # its size stability. Instead, you can use a combination of `slide_dfr()` # to get the start/stop indices with `hop_index_vec()`. i <- seq_along(x) idx <- slide_dfr( i, ~data.frame(start = .x[1], stop = .x[length(.x)]), .before = 3, .step = 2, .complete = TRUE ) idx hop_index_vec(x, i, idx$start, idx$stop, mean, .ptype = double()) } \seealso{ \code{\link[=slide2]{slide2()}}, \code{\link[=slide_index]{slide_index()}}, \code{\link[=hop]{hop()}} } slider/man/block.Rd0000644000176200001440000000644713612200440013673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/block.R \name{block} \alias{block} \title{Break a vector into blocks} \usage{ block(x, i, period, every = 1L, origin = NULL) } \arguments{ \item{x}{\verb{[vector]} The vector to block.} \item{i}{\verb{[Date / POSIXct / POSIXlt]} The datetime index to block by. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} } \value{ A vector fulfilling the following invariants: \itemize{ \item \code{vec_size(block(x)) == vec_size(unique(warp::warp_boundary(i)))} \item \code{vec_ptype(block(x)) == list()} \item \code{vec_ptype(block(x)[[1]]) == vec_ptype(x)} } } \description{ \code{block()} breaks up the \code{i}-ndex by \code{period}, and then uses that to define the indices to chop \code{x} with. For example, it can split \code{x} into monthly or yearly blocks. Combined with \code{purrr::map()}, it is a way to iterate over a vector in "time blocks". } \details{ \code{block()} determines the indices to block by with \code{\link[warp:warp_boundary]{warp::warp_boundary()}}, and splits \code{x} by those indices using \code{\link[vctrs:vec_chop]{vctrs::vec_chop()}}. Like \code{\link[=slide]{slide()}}, \code{block()} splits data frame \code{x} values row wise. } \examples{ x <- 1:6 i <- as.Date("2019-01-01") + c(-2:2, 31) block(i, i, period = "year") # Data frames are split row wise df <- data.frame(x = x, i = i) block(df, i, period = "month") # Iterate over these blocks to apply a function over # non-overlapping period blocks. For example, to compute a # mean over yearly or monthly blocks. vapply(block(x, i, "year"), mean, numeric(1)) vapply(block(x, i, "month"), mean, numeric(1)) # block by every 2 months, ensuring that we start counting # the 1st of the 2 months from `2019-01-01` block(i, i, period = "month", every = 2, origin = as.Date("2019-01-01")) # Use the `origin` to instead start counting from `2018-12-01`, meaning # that [2018-12, 2019-01] gets bucketed together. block(i, i, period = "month", every = 2, origin = as.Date("2018-12-01")) } \seealso{ \code{\link[=slide_period]{slide_period()}}, \code{\link[=slide]{slide()}}, \code{\link[=slide_index]{slide_index()}} } slider/man/slide_index2.Rd0000644000176200001440000002156014024427556015164 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide-index2.R, R/pslide-index.R \name{slide_index2} \alias{slide_index2} \alias{slide_index2_vec} \alias{slide_index2_dbl} \alias{slide_index2_int} \alias{slide_index2_lgl} \alias{slide_index2_chr} \alias{slide_index2_dfr} \alias{slide_index2_dfc} \alias{pslide_index} \alias{pslide_index_vec} \alias{pslide_index_dbl} \alias{pslide_index_int} \alias{pslide_index_lgl} \alias{pslide_index_chr} \alias{pslide_index_dfr} \alias{pslide_index_dfc} \title{Slide along multiples inputs simultaneously relative to an index} \usage{ slide_index2(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index2_vec( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) slide_index2_dbl( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE ) slide_index2_int( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE ) slide_index2_lgl( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE ) slide_index2_chr( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE ) slide_index2_dfr( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide_index2_dfc( .x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) pslide_index(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) pslide_index_vec( .l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) pslide_index_dbl(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) pslide_index_int(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) pslide_index_lgl(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) pslide_index_chr(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) pslide_index_dfr( .l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) pslide_index_dfc( .l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x, .y}{\verb{[vector]} Vectors to iterate over. Vectors of size 1 will be recycled.} \item{.i}{\verb{[vector]} The index vector that determines the window sizes. It is fairly common to supply a date vector as the index, but not required. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.before, .after}{\verb{[vector(1) / function / Inf]} \itemize{ \item If a vector of size 1, these represent the number of values before or after the current element of \code{.i} to include in the sliding window. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}. Boundaries are computed from these elements as \code{.i - .before} and \code{.i + .after}. Any object that can be added or subtracted from \code{.i} with \code{+} and \code{-} can be used. For example, a lubridate period, such as \code{\link[lubridate:period]{lubridate::weeks()}}. \item If \code{Inf}, this selects all elements before or after the current element. \item If a function, or a one-sided formula which can be coerced to a function, it is applied to \code{.i} to compute the boundaries. Note that this function will only be applied to the \emph{unique} values of \code{.i}, so it should not rely on the original length of \code{.i} in any way. This is useful for applying a complex arithmetic operation that can't be expressed with a single \code{-} or \code{+} operation. One example would be to use \code{\link[lubridate:mplus]{lubridate::add_with_rollback()}} to avoid invalid dates at the end of the month. } The ranges that result from applying \code{.before} and \code{.after} have the same 3 restrictions as \code{.i} itself.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} \item{.l}{\verb{[list]} A list of vectors. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. If \code{.l} has names, they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 1 will be recycled.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide_index2()}}{ \itemize{ \item \code{vec_size(slide_index2(.x, .y)) == vec_size_common(.x, .y)} \item \code{vec_ptype(slide_index2(.x, .y)) == list()} } } \subsection{\code{slide_index2_vec()} and \verb{slide_index2_*()} variants}{ \itemize{ \item \code{vec_size(slide_index2_vec(.x, .y)) == vec_size_common(.x, .y)} \item \code{vec_size(slide_index2_vec(.x, .y)[[1]]) == 1L} \item \code{vec_ptype(slide_index2_vec(.x, .y, .ptype = ptype)) == ptype} } } \subsection{\code{pslide_index()}}{ \itemize{ \item \code{vec_size(pslide_index(.l)) == vec_size_common(!!! .l)} \item \code{vec_ptype(pslide_index(.l)) == list()} } } \subsection{\code{pslide_index_vec()} and \verb{pslide_index_*()} variants}{ \itemize{ \item \code{vec_size(pslide_index_vec(.l)) == vec_size_common(!!! .l)} \item \code{vec_size(pslide_index_vec(.l)[[1]]) == 1L} \item \code{vec_ptype(pslide_index_vec(.l, .ptype = ptype)) == ptype} } } } \description{ \code{slide_index2()} and \code{pslide_index()} represent the combination of \code{\link[=slide2]{slide2()}} and \code{\link[=pslide]{pslide()}} with \code{\link[=slide_index]{slide_index()}}, allowing you to iterate over multiple vectors at once relative to an \code{.i}-ndex. } \examples{ # Notice that `i` is an irregular index! x <- 1:5 y <- 6:10 i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) # When we slide over `i` looking back 1 day, the irregularity is respected. # When there is a gap in dates, only 2 values are returned (one from # `x` and one from `y`), otherwise, 4 values are returned. slide_index2(x, y, i, ~c(.x, .y), .before = 1) } \seealso{ \code{\link[=slide2]{slide2()}}, \code{\link[=hop_index2]{hop_index2()}}, \code{\link[=slide_index]{slide_index()}} } slider/man/summary-index.Rd0000644000176200001440000001532214024427556015414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary-index.R \name{summary-index} \alias{summary-index} \alias{slide_index_sum} \alias{slide_index_prod} \alias{slide_index_mean} \alias{slide_index_min} \alias{slide_index_max} \alias{slide_index_all} \alias{slide_index_any} \title{Specialized sliding functions relative to an index} \usage{ slide_index_sum( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_prod( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_mean( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_min( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_max( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_all( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) slide_index_any( x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE ) } \arguments{ \item{x}{\verb{[vector]} A vector to compute the sliding function on. \itemize{ \item For sliding sum, mean, prod, min, and max, \code{x} will be cast to a double vector with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}. \item For sliding any and all, \code{x} will be cast to a logical vector with \code{\link[vctrs:vec_cast]{vctrs::vec_cast()}}. }} \item{i}{\verb{[vector]} The index vector that determines the window sizes. It is fairly common to supply a date vector as the index, but not required. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{...}{These dots are for future extensions and must be empty.} \item{before}{\verb{[vector(1) / function / Inf]} \itemize{ \item If a vector of size 1, these represent the number of values before or after the current element of \code{.i} to include in the sliding window. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}. Boundaries are computed from these elements as \code{.i - .before} and \code{.i + .after}. Any object that can be added or subtracted from \code{.i} with \code{+} and \code{-} can be used. For example, a lubridate period, such as \code{\link[lubridate:period]{lubridate::weeks()}}. \item If \code{Inf}, this selects all elements before or after the current element. \item If a function, or a one-sided formula which can be coerced to a function, it is applied to \code{.i} to compute the boundaries. Note that this function will only be applied to the \emph{unique} values of \code{.i}, so it should not rely on the original length of \code{.i} in any way. This is useful for applying a complex arithmetic operation that can't be expressed with a single \code{-} or \code{+} operation. One example would be to use \code{\link[lubridate:mplus]{lubridate::add_with_rollback()}} to avoid invalid dates at the end of the month. } The ranges that result from applying \code{.before} and \code{.after} have the same 3 restrictions as \code{.i} itself.} \item{after}{\verb{[vector(1) / function / Inf]} \itemize{ \item If a vector of size 1, these represent the number of values before or after the current element of \code{.i} to include in the sliding window. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}. Boundaries are computed from these elements as \code{.i - .before} and \code{.i + .after}. Any object that can be added or subtracted from \code{.i} with \code{+} and \code{-} can be used. For example, a lubridate period, such as \code{\link[lubridate:period]{lubridate::weeks()}}. \item If \code{Inf}, this selects all elements before or after the current element. \item If a function, or a one-sided formula which can be coerced to a function, it is applied to \code{.i} to compute the boundaries. Note that this function will only be applied to the \emph{unique} values of \code{.i}, so it should not rely on the original length of \code{.i} in any way. This is useful for applying a complex arithmetic operation that can't be expressed with a single \code{-} or \code{+} operation. One example would be to use \code{\link[lubridate:mplus]{lubridate::add_with_rollback()}} to avoid invalid dates at the end of the month. } The ranges that result from applying \code{.before} and \code{.after} have the same 3 restrictions as \code{.i} itself.} \item{complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{na_rm}{\verb{[logical(1)]} Should missing values be removed from the computation?} } \value{ A vector the same size as \code{x} containing the result of applying the summary function over the sliding windows. \itemize{ \item For sliding sum, mean, prod, min, and max, a double vector will be returned. \item For sliding any and all, a logical vector will be returned. } } \description{ These functions are specialized variants of the most common ways that \code{\link[=slide_index]{slide_index()}} is generally used. Notably, \code{\link[=slide_index_sum]{slide_index_sum()}} can be used for rolling sums relative to an index (like a Date column), and \code{\link[=slide_index_mean]{slide_index_mean()}} can be used for rolling averages. These specialized variants are \emph{much} faster and more memory efficient than using an otherwise equivalent call constructed with \code{\link[=slide_index_dbl]{slide_index_dbl()}} or \code{\link[=slide_index_lgl]{slide_index_lgl()}}, especially with a very wide window. } \details{ For more details about the implementation, see the help page of \code{\link[=slide_sum]{slide_sum()}}. } \examples{ x <- c(1, 5, 3, 2, 6, 10) i <- as.Date("2019-01-01") + c(0, 1, 3, 4, 6, 8) # `slide_index_sum()` can be used for rolling sums relative to an index, # allowing you to "respect gaps" in your series. Notice that the rolling # sum in row 3 is only computed from `2019-01-04` and `2019-01-02` since # `2019-01-01` is more than two days before the current date. data.frame( i = i, x = x, roll = slide_index_sum(x, i, before = 2) ) # `slide_index_mean()` can be used for rolling averages slide_index_mean(x, i, before = 2) # Only evaluate the sum on windows that have the potential to be complete slide_index_sum(x, i, before = 2, after = 1, complete = TRUE) } \seealso{ \code{\link[=slide_sum]{slide_sum()}} } slider/man/hop_index2.Rd0000644000176200001440000001146514024427556014655 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hop-index2.R, R/phop-index.R \name{hop_index2} \alias{hop_index2} \alias{hop_index2_vec} \alias{phop_index} \alias{phop_index_vec} \title{Hop along multiple inputs simultaneously relative to an index} \usage{ hop_index2(.x, .y, .i, .starts, .stops, .f, ...) hop_index2_vec(.x, .y, .i, .starts, .stops, .f, ..., .ptype = NULL) phop_index(.l, .i, .starts, .stops, .f, ...) phop_index_vec(.l, .i, .starts, .stops, .f, ..., .ptype = NULL) } \arguments{ \item{.x, .y}{\verb{[vector]} Vectors to iterate over. Vectors of size 1 will be recycled.} \item{.i}{\verb{[vector]} The index vector that determines the window sizes. It is fairly common to supply a date vector as the index, but not required. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.starts, .stops}{\verb{[vector]} Vectors of boundary values that make up the windows to bucket \code{.i} with. Both \code{.starts} and \code{.stops} will be recycled to their common size, and that common size will be the size of the result. Both vectors should be the same type as \code{.i}. These boundaries are both \emph{inclusive}, meaning that the slice of \code{.x} that will be used in each call to \code{.f} is where \code{.i >= start & .i <= stop} returns \code{TRUE}.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.l}{\verb{[list]} A list of vectors. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. If \code{.l} has names, they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 1 will be recycled.} } \value{ A vector fulfilling the following invariants: \subsection{\code{hop_index2()}}{ \itemize{ \item \code{vec_size(hop_index2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(hop_index2(.x, .y, .starts, .stops)) == list()} } } \subsection{\code{hop_index2_vec()}}{ \itemize{ \item \code{vec_size(hop_index2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(hop_index2_vec(.x, .y, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(hop_index2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype} } } \subsection{\code{phop_index()}}{ \itemize{ \item \code{vec_size(phop_index(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(phop_index(.l, .starts, .stops)) == list()} } } \subsection{\code{phop_index_vec()}}{ \itemize{ \item \code{vec_size(phop_index_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(phop_index_vec(.l, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(phop_index_vec(.l, .starts, .stops, .ptype = ptype)) == ptype} } } } \description{ \code{hop_index2()} and \code{phop_index()} represent the combination of \code{\link[=slide2]{slide2()}} and \code{\link[=pslide]{pslide()}} with \code{\link[=hop_index]{hop_index()}}, allowing you to iterate over multiple vectors at once, relative to an \code{.i}-ndex with boundaries defined by \code{.starts} and \code{.stops}. } \examples{ # Notice that `i` is an irregular index! x <- 1:5 i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) # Manually create starts/stops. They don't have to be equally spaced, # and they don't have to be the same size as `.x` or `.i`. starts <- as.Date(c("2019-08-15", "2019-08-18")) stops <- as.Date(c("2019-08-16", "2019-08-23")) # The output size is equal to the common size of `.starts` and `.stops` hop_index2(x, i, i, starts, stops, ~data.frame(x = .x, y = .y)) } \seealso{ \code{\link[=slide2]{slide2()}}, \code{\link[=slide_index2]{slide_index2()}}, \code{\link[=hop_index]{hop_index()}} } slider/man/slide_period2.Rd0000644000176200001440000002367713736067057015357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide-period2.R, R/pslide-period.R \name{slide_period2} \alias{slide_period2} \alias{slide_period2_vec} \alias{slide_period2_dbl} \alias{slide_period2_int} \alias{slide_period2_lgl} \alias{slide_period2_chr} \alias{slide_period2_dfr} \alias{slide_period2_dfc} \alias{pslide_period} \alias{pslide_period_vec} \alias{pslide_period_dbl} \alias{pslide_period_int} \alias{pslide_period_lgl} \alias{pslide_period_chr} \alias{pslide_period_dfr} \alias{pslide_period_dfc} \title{Slide along multiple inputs simultaneously relative to an index chunked by period} \usage{ slide_period2( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period2_vec( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) slide_period2_dbl( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period2_int( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period2_lgl( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period2_chr( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period2_dfr( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide_period2_dfc( .x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) pslide_period( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) pslide_period_vec( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) pslide_period_dbl( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) pslide_period_int( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) pslide_period_lgl( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) pslide_period_chr( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) pslide_period_dfr( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) pslide_period_dfc( .l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x, .y}{\verb{[vector]} Vectors to iterate over. Vectors of size 1 will be recycled.} \item{.i}{\verb{[Date / POSIXct / POSIXlt]} A datetime index to break into periods. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{.origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} \item{.before}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{.after}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} \item{.l}{\verb{[list]} A list of vectors. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. If \code{.l} has names, they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 1 will be recycled.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide_period2()}}{ \itemize{ \item \code{vec_size(slide_period2(.x, .y)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_ptype(slide_period2(.x, .y)) == list()} } } \subsection{\code{slide_period2_vec()} and \verb{slide_period2_*()} variants}{ \itemize{ \item \code{vec_size(slide_period2_vec(.x, .y)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_size(slide_period2_vec(.x, .y)[[1]]) == 1L} \item \code{vec_ptype(slide_period2_vec(.x, .y, .ptype = ptype)) == ptype} } } \subsection{\code{pslide_period()}}{ \itemize{ \item \code{vec_size(pslide_period(.l)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_ptype(pslide_period(.l)) == list()} } } \subsection{\code{pslide_period_vec()} and \verb{pslide_period_*()} variants}{ \itemize{ \item \code{vec_size(pslide_period_vec(.l)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_size(pslide_period_vec(.l)[[1]]) == 1L} \item \code{vec_ptype(pslide_period_vec(.l, .ptype = ptype)) == ptype} } } } \description{ \code{slide_period2()} and \code{pslide_period()} represent the combination of \code{\link[=slide2]{slide2()}} and \code{\link[=pslide]{pslide()}} with \code{\link[=slide_period]{slide_period()}}, allowing you to slide over multiple vectors at once, using indices defined by breaking up the \code{.i}-ndex by \code{.period}. } \examples{ i <- as.Date("2019-01-28") + 0:5 slide_period2( .x = 1:6, .y = i, .i = i, .period = "month", .f = ~data.frame(x = .x, i = .y) ) pslide_period( .l = list(1:6, 7:12, i), .i = i, .period = "month", .f = ~data.frame(x = .x, y = .y, i = ..3) ) } \seealso{ \code{\link[=slide2]{slide2()}}, \code{\link[=slide_index2]{slide_index2()}}, \code{\link[=slide_period]{slide_period()}} } slider/man/hop_index.Rd0000644000176200001440000001305714024427556014572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hop-index.R \name{hop_index} \alias{hop_index} \alias{hop_index_vec} \title{Hop relative to an index} \usage{ hop_index(.x, .i, .starts, .stops, .f, ...) hop_index_vec(.x, .i, .starts, .stops, .f, ..., .ptype = NULL) } \arguments{ \item{.x}{\verb{[vector]} The vector to iterate over and apply \code{.f} to.} \item{.i}{\verb{[vector]} The index vector that determines the window sizes. It is fairly common to supply a date vector as the index, but not required. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.starts, .stops}{\verb{[vector]} Vectors of boundary values that make up the windows to bucket \code{.i} with. Both \code{.starts} and \code{.stops} will be recycled to their common size, and that common size will be the size of the result. Both vectors should be the same type as \code{.i}. These boundaries are both \emph{inclusive}, meaning that the slice of \code{.x} that will be used in each call to \code{.f} is where \code{.i >= start & .i <= stop} returns \code{TRUE}.} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} } \value{ A vector fulfilling the following invariants: \subsection{\code{hop_index()}}{ \itemize{ \item \code{vec_size(hop_index(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_ptype(hop_index(.x, .starts, .stops)) == list()} } } \subsection{\code{hop_index_vec()}}{ \itemize{ \item \code{vec_size(hop_index_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} \item \code{vec_size(hop_index_vec(.x, .starts, .stops)[[1]]) == 1L} \item \code{vec_ptype(hop_index_vec(.x, .starts, .stops, .ptype = ptype)) == ptype} } } } \description{ \code{hop_index()} is the lower level engine that powers \code{\link[=slide_index]{slide_index()}}. It has slightly different invariants than \code{slide_index()}, and is useful when you either need to hand craft boundary values, or want to compute a result with a size that is different from \code{.x}. } \examples{ library(vctrs) library(lubridate, warn.conflicts = FALSE) # --------------------------------------------------------------------------- # Returning a size smaller than `.x` i <- as.Date("2019-01-25") + c(0, 1, 2, 3, 10, 20, 35, 42, 45) # slide_index() allows you to slide relative to `i` slide_index(i, i, ~.x, .before = weeks(1)) # But you might be more interested in coarser summaries. This groups # by year-month and computes 2 `.f` on 2 month windows. i_yearmonth <- year(i) + (month(i) - 1) / 12 slide_index(i, i_yearmonth, ~.x, .before = 1) # ^ This works nicely when working with dplyr if you are trying to create # a new column in a data frame, but you'll notice that there are really only # 3 months, so only 3 values are being calculated. If you only want to return # a vector of those 3 values, you can use `hop_index()`. You'll have to # hand craft the boundaries, but this is a general strategy # I've found useful: first_start <- floor_date(i[1], "months") last_stop <- ceiling_date(i[length(i)], "months") dates <- seq(first_start, last_stop, "1 month") inner <- dates[2:(length(dates) - 1L)] starts <- vec_c(first_start, inner) stops <- vec_c(inner - 1, last_stop) hop_index(i, i, starts, stops, ~.x) # --------------------------------------------------------------------------- # Non-existant dates with `lubridate::months()` # Imagine you want to compute a 1 month rolling average on this # irregular daily data. i <- vec_c(as.Date("2019-02-27") + 0:3, as.Date("2019-03-27") + 0:5) x <- rnorm(vec_seq_along(i)) # You might try `slide_index()` like this, but you'd run into this error library(rlang) with_options( catch_cnd( slide_index(x, i, mean, .before = months(1)) ), rlang_backtrace_on_error = current_env() ) # This is because when you actually compute the `.i - .before` sequence, # you hit non-existant dates. i.e. `"2019-03-29" - months(1)` doesn't exist. i - months(1) # To get around this, lubridate provides `add_with_rollback()`, # and the shortcut operation `\%m-\%`, which subtracts the month, then rolls # forward/backward if it hits an `NA`. You can manually generate boundaries, # then provide them to `hop_index()`. starts <- i \%m-\% months(1) stops <- i hop_index(x, i, starts, stops, mean) hop_index(i, i, starts, stops, ~.x) } \seealso{ \code{\link[=slide]{slide()}}, \code{\link[=slide_index]{slide_index()}}, \code{\link[=hop_index2]{hop_index2()}} } slider/man/slide_index.Rd0000644000176200001440000002642214024427556015104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide-index.R \name{slide_index} \alias{slide_index} \alias{slide_index_vec} \alias{slide_index_dbl} \alias{slide_index_int} \alias{slide_index_lgl} \alias{slide_index_chr} \alias{slide_index_dfr} \alias{slide_index_dfc} \title{Slide relative to an index} \usage{ slide_index(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index_vec( .x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) slide_index_dbl(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index_int(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index_lgl(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index_chr(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) slide_index_dfr( .x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide_index_dfc( .x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x}{\verb{[vector]} The vector to iterate over and apply \code{.f} to.} \item{.i}{\verb{[vector]} The index vector that determines the window sizes. It is fairly common to supply a date vector as the index, but not required. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.before, .after}{\verb{[vector(1) / function / Inf]} \itemize{ \item If a vector of size 1, these represent the number of values before or after the current element of \code{.i} to include in the sliding window. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}. Boundaries are computed from these elements as \code{.i - .before} and \code{.i + .after}. Any object that can be added or subtracted from \code{.i} with \code{+} and \code{-} can be used. For example, a lubridate period, such as \code{\link[lubridate:period]{lubridate::weeks()}}. \item If \code{Inf}, this selects all elements before or after the current element. \item If a function, or a one-sided formula which can be coerced to a function, it is applied to \code{.i} to compute the boundaries. Note that this function will only be applied to the \emph{unique} values of \code{.i}, so it should not rely on the original length of \code{.i} in any way. This is useful for applying a complex arithmetic operation that can't be expressed with a single \code{-} or \code{+} operation. One example would be to use \code{\link[lubridate:mplus]{lubridate::add_with_rollback()}} to avoid invalid dates at the end of the month. } The ranges that result from applying \code{.before} and \code{.after} have the same 3 restrictions as \code{.i} itself.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide_index()}}{ \itemize{ \item \code{vec_size(slide_index(.x)) == vec_size(.x)} \item \code{vec_ptype(slide_index(.x)) == list()} } } \subsection{\code{slide_index_vec()} and \verb{slide_index_*()} variants}{ \itemize{ \item \code{vec_size(slide_index_vec(.x)) == vec_size(.x)} \item \code{vec_size(slide_index_vec(.x)[[1]]) == 1L} \item \code{vec_ptype(slide_index_vec(.x, .ptype = ptype)) == ptype} } } } \description{ \code{slide_index()} is similar to \code{slide()}, but allows a secondary \code{.i}-ndex vector to be provided. This is often useful in business calculations, when you want to compute a rolling computation looking "3 months back", which is approximately but not equivalent to, 3 * 30 days. \code{slide_index()} allows for these irregular window sizes. } \examples{ library(lubridate) x <- 1:5 # In some cases, sliding over `x` with a strict window size of 2 # will fit your use case. slide(x, ~.x, .before = 1) # However, if this `i` is a date vector paired with `x`, when computing # rolling calculations you might want to iterate over `x` while # respecting the fact that `i` is an irregular sequence. i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) # For example, a "2 day" window should not pair `"2019-08-19"` and # `"2019-08-21"` together, even though they are next to each other in `x`. # `slide_index()` computes the lookback value from the current date in `.i`, # meaning that if you are currently on `"2019-08-21"` and look back 1 day, # it will correctly not include `"2019-08-19"`. slide_index(i, i, ~.x, .before = 1) # We could have equivalently used a lubridate period object for this as well, # since `i - lubridate::days(1)` is allowed slide_index(i, i, ~.x, .before = lubridate::days(1)) # --------------------------------------------------------------------------- # Functions for `.before` and `.after` # In some cases, it might not be appropriate to compute # `.i - .before` or `.i + .after`, either because there isn't a `-` or `+` # method defined, or because there is an alternative way to perform the # arithmetic. For example, subtracting 1 month with `- months(1)` (using # lubridate) can sometimes land you on an invalid date that doesn't exist. i <- as.Date(c("2019-01-31", "2019-02-28", "2019-03-31")) # 2019-03-31 - months(1) = 2019-02-31, which doesn't exist i - months(1) # These NAs create problems with `slide_index()`, which doesn't allow # missing values in the computed endpoints try(slide_index(i, i, identity, .before = months(1))) # In these cases, it is more appropriate to use `\%m-\%`, # which will snap to the end of the month, at least giving you something # to work with. i \%m-\% months(1) # To use this as your `.before` or `.after`, supply an anonymous function of # 1 argument that performs the computation slide_index(i, i, identity, .before = ~.x \%m-\% months(1)) # Notice that in the `.after` case, `2019-02-28 \%m+\% months(1)` doesn't # capture the end of March, so it isn't included in the 2nd result slide_index(i, i, identity, .after = ~.x \%m+\% months(1)) # --------------------------------------------------------------------------- # When `.i` has repeated values, they are always grouped together. i <- c(2017, 2017, 2018, 2019, 2020, 2020) slide_index(i, i, ~.x) slide_index(i, i, ~.x, .after = 1) # --------------------------------------------------------------------------- # Rolling regressions # Rolling regressions are easy with `slide_index()` because: # - Data frame `.x` values are iterated over rowwise # - The index is respected by using `.i` set.seed(123) df <- data.frame( y = rnorm(100), x = rnorm(100), i = as.Date("2019-08-15") + c(0, 2, 4, 6:102) # <- irregular ) # 20 day rolling regression. Current day + 19 days back. # Additionally, set `.complete = TRUE` to not compute partial results. regr <- slide_index(df, df$i, ~lm(y ~ x, .x), .before = 19, .complete = TRUE) regr[16:18] # The first 16 slots are NULL because there is no possible way to # look back 19 days from the 16th index position and construct a full # window. But on the 17th index position, `""2019-09-03"`, if we look # back 19 days we get to `""2019-08-15"`, which is the same value as # `i[1]` so a full window can be constructed. df$i[16] - 19 >= df$i[1] # FALSE df$i[17] - 19 >= df$i[1] # TRUE # --------------------------------------------------------------------------- # Accessing the current index value # A very simplistic version of `purrr::map2()` fake_map2 <- function(.x, .y, .f, ...) { Map(.f, .x, .y, ...) } # Occasionally you need to access the index value that you are currently on. # This is generally not possible with a single call to `slide_index()`, but # can be easily accomplished by following up a `slide_index()` call with a # `purrr::map2()`. In this example, we want to use the distance from the # current index value (in days) as a multiplier on `x`. Values further # away from the current date get a higher multiplier. set.seed(123) # 25 random days past 2000-01-01 i <- sort(as.Date("2000-01-01") + sample(100, 25)) df <- data.frame(i = i, x = rnorm(25)) weight_by_distance <- function(df, i) { df$weight = abs(as.integer(df$i - i)) df$x_weighted = df$x * df$weight df } # Use `slide_index()` to just generate the rolling data. # Here we take the current date + 5 days before + 5 days after. dfs <- slide_index(df, df$i, ~.x, .before = 5, .after = 5) # Follow up with a `map2()` with `i` as the second input. # This allows you to track the current `i` value and weight accordingly. result <- fake_map2(dfs, df$i, weight_by_distance) head(result) } \seealso{ \code{\link[=slide]{slide()}}, \code{\link[=hop_index]{hop_index()}}, \code{\link[=slide_index2]{slide_index2()}} } slider/man/slide_period.Rd0000644000176200001440000002057013736067057015262 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/slide-period.R \name{slide_period} \alias{slide_period} \alias{slide_period_vec} \alias{slide_period_dbl} \alias{slide_period_int} \alias{slide_period_lgl} \alias{slide_period_chr} \alias{slide_period_dfr} \alias{slide_period_dfc} \title{Slide relative to an index chunked by period} \usage{ slide_period( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period_vec( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL ) slide_period_dbl( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period_int( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period_lgl( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period_chr( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE ) slide_period_dfr( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique") ) slide_period_dfc( .x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal") ) } \arguments{ \item{.x}{\verb{[vector]} The vector to iterate over and apply \code{.f} to.} \item{.i}{\verb{[Date / POSIXct / POSIXlt]} A datetime index to break into periods. There are 3 restrictions on the index: \itemize{ \item The size of the index must match the size of \code{.x}, they will not be recycled to their common size. \item The index must be an \emph{increasing} vector, but duplicate values are allowed. \item The index cannot have missing values. }} \item{.period}{\verb{[character(1)]} A string defining the period to group by. Valid inputs can be roughly broken into: \itemize{ \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} \item \code{"yweek"}, \code{"mweek"} \item \code{"yday"}, \code{"mday"} }} \item{.f}{\verb{[function / formula]} If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions.} \item{...}{Additional arguments passed on to the mapped function.} \item{.every}{\verb{[positive integer(1)]} The number of periods to group together. For example, if the period was set to \code{"year"} with an every value of \code{2}, then the years 1970 and 1971 would be placed in the same group.} \item{.origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} The reference date time value. The default when left as \code{NULL} is the epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. This is generally used to define the anchor time to count from, which is relevant when the every value is \verb{> 1}.} \item{.before, .after}{\verb{[integer(1) / Inf]} The number of values before or after the current element to include in the sliding window. Set to \code{Inf} to select all elements before or after the current element. Negative values are allowed, which allows you to "look forward" from the current element if used as the \code{.before} value, or "look backwards" if used as \code{.after}.} \item{.complete}{\verb{[logical(1)]} Should the function be evaluated on complete windows only? If \code{FALSE}, the default, then partial computations will be allowed.} \item{.ptype}{\verb{[vector(0) / NULL]} A prototype corresponding to the type of the output. If \code{NULL}, the default, the output type is determined by computing the common type across the results of the calls to \code{.f}. If supplied, the result of each call to \code{.f} will be cast to that type, and the final output will have that type. If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be supplied. This is a way to make production code demand fixed types.} \item{.names_to}{This controls what to do with input names supplied in \code{...}. \itemize{ \item By default, input names are \link[rlang:zap]{zapped}. \item If a string, specifies a column where the input names will be copied. These names are often useful to identify rows with their original input. If a column name is supplied and \code{...} is not named, an integer column is used instead. \item If \code{NULL}, the input names are used as row names. }} \item{.name_repair}{One of \code{"unique"}, \code{"universal"}, or \code{"check_unique"}. See \code{\link[vctrs:vec_as_names]{vec_as_names()}} for the meaning of these options. With \code{vec_rbind()}, the repair function is applied to all inputs separately. This is because \code{vec_rbind()} needs to align their columns before binding the rows, and thus needs all inputs to have unique names. On the other hand, \code{vec_cbind()} applies the repair function after all inputs have been concatenated together in a final data frame. Hence \code{vec_cbind()} allows the more permissive minimal names repair.} \item{.size}{If, \code{NULL}, the default, will determine the number of rows in \code{vec_cbind()} output by using the standard recycling rules. Alternatively, specify the desired number of rows, and any inputs of length 1 will be recycled appropriately.} } \value{ A vector fulfilling the following invariants: \subsection{\code{slide_period()}}{ \itemize{ \item \code{vec_size(slide_period(.x)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_ptype(slide_period(.x)) == list()} } } \subsection{\code{slide_period_vec()} and \verb{slide_period_*()} variants}{ \itemize{ \item \code{vec_size(slide_period_vec(.x)) == vec_size(unique(warp::warp_distance(.i)))} \item \code{vec_size(slide_period_vec(.x)[[1]]) == 1L} \item \code{vec_ptype(slide_period_vec(.x, .ptype = ptype)) == ptype} } } } \description{ \code{slide_period()} breaks up the \code{.i}-ndex by \code{.period}, and then uses that to define the indices to slide over \code{.x} with. It can be useful for, say, sliding over daily data in monthly chunks. The underlying engine for breaking up \code{.i} is \code{\link[warp:warp_distance]{warp::warp_distance()}}. If you need more information about the \code{.period} types, that is the best place to look. } \examples{ i <- as.Date("2019-01-28") + 0:5 # Split `i` into 2-day periods to apply `.f` to slide_period(i, i, "day", identity, .every = 2) # Or into 1-month periods slide_period(i, i, "month", identity) # Now select: # - The current 2-day period # - Plus 1 2-day period before the current one slide_period(i, i, "day", identity, .every = 2, .before = 1) # Alter the `origin` to control the reference date for # how the 2-day groups are formed origin <- as.Date("2019-01-29") slide_period(i, i, "day", identity, .every = 2, .origin = origin) # This can be useful for, say, monthly averages daily_sales <- c(2, 5, 3, 6, 9, 4) slide_period_dbl(daily_sales, i, "month", mean) # If you need the index, slide over and return a data frame sales_df <- data.frame(i = i, sales = daily_sales) slide_period_dfr( sales_df, sales_df$i, "month", ~data.frame( i = max(.x$i), sales = mean(.x$sales) ) ) # One of the most unique features about `slide_period()` is that it is # aware of how far apart elements of `.i` are in the `.period` you are # interested in. For example, if you do a monthly slide with `i2`, selecting # the current month and 1 month before it, then it will recognize that # `2019-02-01` and `2019-04-01` are not beside each other, and it won't # group them together. i2 <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01", "2019-05-01")) slide_period(i2, i2, "month", identity, .before = 1) } \seealso{ \code{\link[=block]{block()}}, \code{\link[=slide]{slide()}}, \code{\link[=slide_index]{slide_index()}} } slider/DESCRIPTION0000644000176200001440000000327414067416152013256 0ustar liggesusersPackage: slider Title: Sliding Window Functions Version: 0.2.2 Authors@R: c(person(given = "Davis", family = "Vaughan", role = c("aut", "cre"), email = "davis@rstudio.com"), person(given = "RStudio", role = "cph")) Description: Provides type-stable rolling window functions over any R data type. Cumulative and expanding windows are also supported. For more advanced usage, an index can be used as a secondary vector that defines how sliding windows are to be created. License: MIT + file LICENSE URL: https://github.com/DavisVaughan/slider BugReports: https://github.com/DavisVaughan/slider/issues Depends: R (>= 3.3.0) Imports: ellipsis (>= 0.3.1), glue, rlang (>= 0.4.5), vctrs (>= 0.3.6), warp Suggests: covr, dplyr (>= 1.0.0), knitr, lubridate, rmarkdown, testthat (>= 3.0.0) LinkingTo: vctrs (>= 0.3.6) VignetteBuilder: knitr Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.1.1 SystemRequirements: C++11 Collate: 'block.R' 'conditions.R' 'hop-common.R' 'hop-index-common.R' 'hop-index.R' 'hop-index2.R' 'hop.R' 'hop2.R' 'names.R' 'phop-index.R' 'phop.R' 'slide-index2.R' 'pslide-index.R' 'slide-period2.R' 'pslide-period.R' 'slide2.R' 'pslide.R' 'segment-tree.R' 'slide-common.R' 'slide-index-common.R' 'slide-index.R' 'slide-period-common.R' 'slide-period.R' 'slide.R' 'slider-package.R' 'summary-index.R' 'summary-slide.R' 'utils.R' 'zzz.R' NeedsCompilation: yes Packaged: 2021-07-01 19:27:53 UTC; davis Author: Davis Vaughan [aut, cre], RStudio [cph] Maintainer: Davis Vaughan Repository: CRAN Date/Publication: 2021-07-01 19:50:01 UTC slider/build/0000755000176200001440000000000014067413470012641 5ustar liggesusersslider/build/vignette.rds0000644000176200001440000000042714067413470015203 0ustar liggesusersRAN0tPhZ$8 !|WRK7>ax!kxvvV[.,5]Rws(6TJ1s f-{Ѹ~@8+kٛD .*HnߩU2<JQ Nqcٰr$xa Xv8sM$ª B|F2[2 ^  }Y5h+'yAno*M&ڕ*p"&sP{O~m`Hslider/tests/0000755000176200001440000000000014024427556012707 5ustar liggesusersslider/tests/testthat/0000755000176200001440000000000014067416151014543 5ustar liggesusersslider/tests/testthat/helper-long-double.R0000644000176200001440000000027414024646364020361 0ustar liggesusersskip_if_no_long_double <- function() { skip_if( condition = .Machine$sizeof.longdouble <= 8L, message = "`long double` is less than or equal to `double` on this platform." ) } slider/tests/testthat/test-slide-period-vec.R0000644000176200001440000001560614024427556021012 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( slide_period_vec(1:2, new_date(c(1, 2)), "day", ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) expect_error( slide_period_dbl(1:2, new_date(c(1, 2)), "day", ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( slide_period_vec(1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( slide_period_vec(1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) test_that("type can be restricted", { expect_error( slide_period_dbl(1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {1} else {"hi"}), class = "vctrs_error_incompatible_type" ) }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(slide_period_dbl(integer(), new_date(), "year", ~.x, .complete = TRUE), double()) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(slide_period_vec(1, new_date(0), "day", ~.x), 1) expect_equal(slide_period_vec(1, new_date(0), "day", ~.x, .ptype = int()), 1L) expect_error(slide_period_vec(1, new_date(0), "day", ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( slide_period_vec(1, new_date(0), "day", ~.x, .ptype = NULL), slide_period_vec(1, new_date(0), "day", ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( slide_period_vec(1:2, new_date(c(0, 1)), "day", ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( slide_period_vec(1:2, new_date(c(0, 1)), "day", ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( slide_period_vec(1:2, new_date(c(0, 1)), "day", ~if(.x == 1L) {NULL} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { expect_equal(slide_period_vec(integer(), new_date(), "day", ~.x, .ptype = NULL), NULL) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( slide_period_vec(Sys.Date() + 1:5, new_date(c(1, 2, 3, 4, 5)), "day", ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("with `.complete = TRUE`, `.ptype` is used to pad", { expect_equal( slide_period_dbl( 1:3, new_date(c(1, 2, 3)), "day", ~1, .before = 1, .complete = TRUE ), c(NA, 1, 1) ) }) test_that("with `.complete = TRUE`, padding is size stable (#93)", { expect_equal( slide_period_vec( 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(NA, 0, 0)) ) expect_equal( slide_period_vec( 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .after = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(0, 0, NA)) ) expect_equal( slide_period_vec( 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = NULL ), new_date(c(NA, 0, 0)) ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( slide_period_vec(1:5, new_date(c(1, 2, 3, 4, 5)), "day", ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`slide_period_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide_period_vec(1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide_period_vec(1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide_period_vec(1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x)), foobar(1:3)) expect_condition(slide_period_vec(1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide_period_int() works", { expect_equal(slide_period_int(1L, new_date(0), "day", ~.x), 1L) }) test_that("slide_period_int() can coerce", { expect_equal(slide_period_int(1, new_date(0), "day", ~.x), 1L) }) test_that("slide_period_dbl() works", { expect_equal(slide_period_dbl(1, new_date(0), "day", ~.x), 1) }) test_that("slide_period_dbl() can coerce", { expect_equal(slide_period_dbl(1L, new_date(0), "day", ~.x), 1) }) test_that("slide_period_chr() works", { expect_equal(slide_period_chr("x", new_date(0), "day", ~.x), "x") }) test_that("slide_period_chr() cannot coerce", { expect_error(slide_period_chr(1, new_date(0), "day", ~.x), class = "vctrs_error_incompatible_type") }) test_that("slide_period_lgl() works", { expect_equal(slide_period_lgl(TRUE, new_date(0), "day", ~.x), TRUE) }) test_that("slide_period_lgl() can coerce", { expect_equal(slide_period_lgl(1, new_date(0), "day", ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide_period_dfr() works", { expect_identical( slide_period_dfr( 1:2, new_date(c(1, 2)), "day", ~new_data_frame(list(x = list(.x))), .before = 1 ), slide_dfr(1:2, ~new_data_frame(list(x = list(.x))), .before = 1) ) }) test_that("slide_period_dfc() works", { x <- 1:2 fn <- function(x) { if (length(x) == 1) { data.frame(x1 = x) } else { data.frame(x2 = x) } } expect_identical( slide_period_dfc( 1:2, new_date(c(1, 2)), "day", fn, .before = 1 ), data.frame( x1 = c(1L, 1L), x2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- as.list(names) expect_equal(slide_period_vec(x, new_date(c(1, 2, 3, 4, 5)), "day", ~list(names(.x))), exp) }) test_that("names are never placed on the output", { x <- set_names(1:5, letters[1:5]) expect_null(names(slide_period_vec(x, new_date(c(1, 2, 3, 4, 5)), "day", ~.x))) expect_null(names(slide_period_vec(x, new_date(c(1, 2, 3, 4, 5)), "day", ~.x, .ptype = int()))) expect_null(names(slide_period_int(x, new_date(c(1, 2, 3, 4, 5)), "day", ~.x))) }) slider/tests/testthat/test-phop-index.R0000644000176200001440000000251213656610221017713 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { expect_equal(phop_index(list(integer(), integer()), integer(), integer(), integer(), ~.x), list()) expect_equal(phop_index(list(integer(), 1), integer(), integer(), integer(), ~.x), list()) expect_equal(phop_index(list(1, integer()), integer(), integer(), integer(), ~.x), list()) expect_error(phop_index(list(integer(), integer()), 1, integer(), integer(), ~.x), class = "slider_error_index_incompatible_size") }) test_that("completely empty input returns a list", { expect_equal(phop_index(list(), integer(), integer(), integer(), ~.x), list()) }) test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` ptype", { expect_equal(phop_index(list(), integer(), 1:2, 2:3, ~2), list(2, 2)) }) test_that("can't access non-existant `.x` with empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`", { # Note: Error message seems platform dependent expect_error(phop_index(list(), integer(), 1:2, 2:3, ~.x)) }) test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { expect_error(phop_index(list(), integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") expect_error(phop_index(list(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") }) slider/tests/testthat/test-phop.R0000644000176200001440000000337113663762054016624 0ustar liggesuserstest_that("Empty starts/stops results in empty `ptype` returned", { expect_equal(phop(list(1), integer(), integer(), ~.x), list()) expect_equal(phop_vec(list(1), integer(), integer(), ~.x, .ptype = integer()), integer()) }) test_that("Recycling is carried out using tidyverse recycling rules", { x0 <- integer() x1 <- 1L x2 <- c(2L, 2L) x3 <- c(3L, 3L, 3L) expect_equal(phop(list(x0, x0), integer(), integer(), ~.x), list()) expect_equal(phop(list(x0, x0), 1, 1, ~.x), list(integer())) expect_equal(phop(list(x0, x1), integer(), integer(), ~.x), list()) expect_equal(phop(list(x0, x1), 1, 1, ~.x), list(integer())) expect_error(phop(list(x0, x2), 1, 1, ~.x), class = "vctrs_error_incompatible_size") expect_equal(phop(list(x1, x1), 1, 1, ~.x), list(x1)) expect_equal(phop(list(x1, x2), 1:2, 1:2, ~.x), list(x1, x1)) expect_error(phop(list(x2, x3), 1:3, 1:3, ~.x), class = "vctrs_error_incompatible_size") }) test_that("phop() can iterate over a data frame", { x <- data.frame(x = 1:5, y = 6:10) expect_equal(phop(x, 1:5, 1:5, ~.x + .y), as.list(x$x + x$y)) }) test_that("phop() can iterate over a data frame with a data frame column", { x <- data.frame(c1 = 1:2) x$x <- x expect_equal( phop(x, 1:2, 1:2, ~list(...)), list(as.list(vec_slice(x, 1)), as.list(vec_slice(x, 2))) ) }) test_that("phop() requires a list-like input", { expect_error(phop(1:5, ~.x), "list, not integer") }) test_that("phop() forces arguments in the same way as base R / pmap()", { f_slide <- phop(list(1:2, 1:2, 1:2), 1:2, 1:2, function(i, j, k) function(x) x + i + j + k) f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/test-slide-vec.R0000644000176200001440000001620514024427556017526 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( slide_vec(1:2, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("size of each `.f` result must be 1", { expect_error( slide_dbl(1:2, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( slide_vec(1:2, ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( slide_vec(1:2, ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) test_that("inner type can be restricted", { expect_error( slide_dbl(1:2, ~if (.x == 1L) {1} else {"x"}), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(slide_vec(1, ~.x), 1) expect_equal(slide_vec(1, ~.x, .ptype = int()), 1L) expect_error(slide_vec(1, ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( slide_vec(1, ~.x, .ptype = NULL), slide_vec(1, ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( slide_vec(1:2, ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( slide_vec(1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) }) test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { expect_equal(slide_vec(integer(), ~.x, .ptype = NULL), NULL) }) test_that("`.ptype = NULL` is size stable (#78)", { expect_length(slide_vec(1:4, ~.x, .step = 2), 4) expect_length(slide_vec(1:4, ~1, .before = 1, .complete = TRUE), 4) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( slide_vec(Sys.Date() + 1:5, ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( slide_vec(1:5, ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`slide_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide_vec(1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide_vec(1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide_vec(1:3, ~foobar(.x)), foobar(1:3)) expect_condition(slide_vec(1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .step test_that(".step produces typed `NA` values", { expect_identical(slide_int(1:3, identity, .step = 2), c(1L, NA, 3L)) expect_identical(slide_dbl(1:3, identity, .step = 2), c(1, NA, 3)) expect_identical(slide_chr(c("a", "b", "c"), identity, .step = 2), c("a", NA, "c")) expect_identical(slide_vec(1:3, identity, .step = 2), c(1L, NA, 3L)) expect_identical(slide_vec(1:3, identity, .step = 2, .ptype = integer()), c(1L, NA, 3L)) }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(slide_int(1:3, ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(slide_dbl(1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_chr(1:3, ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(slide_vec(1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_vec(1:3, ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- set_names(as.list(names), names) expect_equal(slide_vec(x, ~list(names(.x))), exp) }) test_that("names can be placed on atomics", { names <- letters[1:5] x <- set_names(1:5, names) expect_equal(names(slide_vec(x, ~.x)), names) expect_equal(names(slide_vec(x, ~.x, .ptype = int())), names) expect_equal(names(slide_vec(x, ~.x, .ptype = dbl())), names) expect_equal(names(slide_int(x, ~.x)), names) expect_equal(names(slide_dbl(x, ~.x)), names) }) test_that("names from `.x` are kept, and new names from `.f` results are dropped", { x <- set_names(1, "x") expect_identical(slide_vec(x, ~c(y = 2), .ptype = NULL), c(x = 2)) expect_identical(slide_vec(1, ~c(y = 2), .ptype = NULL), 2) expect_identical(slide_dbl(x, ~c(y = 2)), c(x = 2)) expect_identical(slide_dbl(1, ~c(y = 2)), 2) }) test_that("names can be placed on data frames", { names <- letters[1:2] x <- set_names(1:2, names) out <- slide_vec(x, ~data.frame(x = .x)) expect_equal(rownames(out), names) out <- slide_vec(x, ~data.frame(x = .x), .ptype = data.frame(x = int())) expect_equal(rownames(out), names) }) test_that("names can be placed on arrays", { names <- letters[1:2] x <- set_names(1:2, names) out <- slide_vec(x, ~array(.x, c(1, 1)), .ptype = array(int(), dim = c(0, 1))) expect_equal(rownames(out), names) }) test_that("names can be placed correctly on proxied objects", { names <- letters[1:2] x <- set_names(1:2, names) datetime_lt <- as.POSIXlt(new_datetime(0)) out <- slide_vec(x, ~datetime_lt, .ptype = datetime_lt) expect_equal(names(out), names) }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide_int() works", { expect_equal(slide_int(1L, ~.x), 1L) }) test_that("slide_int() can coerce", { expect_equal(slide_int(1, ~.x), 1L) }) test_that("slide_dbl() works", { expect_equal(slide_dbl(1, ~.x), 1) }) test_that("slide_dbl() can coerce", { expect_equal(slide_dbl(1L, ~.x), 1) }) test_that("slide_chr() works", { expect_equal(slide_chr("x", ~.x), "x") }) test_that("slide_chr() cannot coerce", { expect_error(slide_chr(1, ~.x), class = "vctrs_error_incompatible_type") }) test_that("slide_lgl() works", { expect_equal(slide_lgl(TRUE, ~.x), TRUE) }) test_that("slide_lgl() can coerce", { expect_equal(slide_lgl(1, ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide_dfr() works", { expect_identical( slide_dfr( 1:2, ~new_data_frame(list(x = list(.x))), .before = 1 ), data_frame( x = list(1L, 1:2) ) ) }) test_that("slide_dfc() works", { x <- 1:2 fn <- function(x) { if (length(x) == 1) { data.frame(x1 = x) } else { data.frame(x2 = x) } } expect_identical( slide_dfc(1:2, fn, .before = 1), data.frame( x1 = c(1L, 1L), x2 = 1:2 ) ) }) slider/tests/testthat/test-pslide-period-vec.R0000644000176200001440000001527214024427556021171 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( pslide_period_vec(list(1:2, 1:2), new_date(c(1, 2)), "day", ~c(.x, .y)), "In iteration 1, the result of `.f` had size 2, not 1" ) expect_error( pslide_period_int(list(1:2, 1:2), new_date(c(1, 2)), "day", ~c(.x, .y)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( pslide_period_vec(list(1:2, 1:2), new_date(c(1, 2)), "day", ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( pslide_period_vec(list(1:2, 1:2), new_date(c(1, 2)), "day", ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) test_that("type can be restricted", { expect_error( pslide_period_int(list(1:2, 1:2), new_date(c(1, 2)), "day", ~if (.x == 1L) {1L} else {"hi"}), class = "vctrs_error_incompatible_type" ) }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(pslide_period_dbl(list(integer(), integer()), new_date(), "year", ~.x, .complete = TRUE), double()) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(pslide_period_vec(list(1, 1), new_date(0), "day", ~.x), 1) expect_equal(pslide_period_vec(list(1, 1), new_date(0), "day", ~.x, .ptype = int()), 1L) expect_error(pslide_period_vec(list(1, 1), new_date(0), "day", ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( pslide_period_vec(list(1, 1), new_date(0), "day", ~.x, .ptype = NULL), pslide_period_vec(list(1, 1), new_date(0), "day", ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", ~if(.x == 1L) {NULL} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { expect_equal(pslide_period_vec(list(integer(), integer()), new_date(), "day", ~.x, .ptype = NULL), NULL) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( pslide_period_vec(list(Sys.Date() + 1:5, 1:5), new_date(c(1, 2, 3, 4, 5)), "day", ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("with `.complete = TRUE`, `.ptype` is used to pad", { expect_equal( pslide_period_dbl( list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~1, .before = 1, .complete = TRUE ), c(NA, 1, 1) ) }) test_that("with `.complete = TRUE`, padding is size stable (#93)", { expect_equal( pslide_period_vec( list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(NA, 0, 0)) ) expect_equal( pslide_period_vec( list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~new_date(0), .after = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(0, 0, NA)) ) expect_equal( pslide_period_vec( list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = NULL ), new_date(c(NA, 0, 0)) ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( pslide_period_vec(list(1:5, 1:5), new_date(c(1, 2, 3, 4, 5)), "day", ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`pslide_period_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(pslide_period_vec(list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(pslide_period_vec(list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(pslide_period_vec(list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~foobar(.x)), foobar(1:3)) expect_condition(pslide_period_vec(list(1:3, 1:3), new_date(c(1, 2, 3)), "day", ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # suffix tests test_that("pslide_period_int() works", { expect_equal(pslide_period_int(list(1L, 1), new_date(0), "day", ~.x), 1L) }) test_that("pslide_period_int() can coerce", { expect_equal(pslide_period_int(list(1, 1), new_date(0), "day", ~.x), 1L) }) test_that("pslide_period_dbl() works", { expect_equal(pslide_period_dbl(list(1, 1), new_date(0), "day", ~.x), 1) }) test_that("pslide_period_dbl() can coerce", { expect_equal(pslide_period_dbl(list(1L, 1), new_date(0), "day", ~.x), 1) }) test_that("pslide_period_chr() works", { expect_equal(pslide_period_chr(list("x", 1), new_date(0), "day", ~.x), "x") }) test_that("pslide_period_chr() cannot coerce", { expect_error(pslide_period_chr(list(1, 1), new_date(0), "day", ~.x), class = "vctrs_error_incompatible_type") }) test_that("pslide_period_lgl() works", { expect_equal(pslide_period_lgl(list(TRUE, 1), new_date(0), "day", ~.x), TRUE) }) test_that("pslide_period_lgl() can coerce", { expect_equal(pslide_period_lgl(list(1, 1), new_date(0), "day", ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("pslide_period_dfr() works", { expect_identical( pslide_period_dfr( list(1:2, 1:2), new_date(c(1, 2)), "day", ~new_data_frame(list(x = list(.x))), .before = 1 ), slide_dfr(1:2, ~new_data_frame(list(x = list(.x))), .before = 1) ) }) test_that("pslide_period_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( pslide_period_dfc( list(x, x), new_date(c(1, 2)), "day", fn, .before = 1 ), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) slider/tests/testthat/test-hop-index2-vec.R0000644000176200001440000000402514024427556020400 0ustar liggesusers# ------------------------------------------------------------------------------ # hop_index2_vec test_that("hop_index2_vec() works", { expect_identical(hop_index2_vec(1L, 1L, 1, 1, 1, ~.x + .y), 2L) }) test_that("hop_index2_vec() doesn't retains names of x (#75)", { expect_named(hop_index2_vec(c(x = 1L), c(y = 1L), 1, 1, 1, ~.x + .y), NULL) }) test_that("hop_index2_vec() can simplify automatically", { expect_identical(hop_index2_vec(1, 2, 1, 1, 1, ~.x + .y, .ptype = NULL), 3) }) test_that("hop_index2_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("size 0 `.starts` / `.stops` returns size 0 `.ptype`", { expect_identical( hop_index2_vec(1:5, 1:5, 1:5, integer(), integer(), ~.x, .ptype = NULL), NULL ) expect_identical( hop_index2_vec(1:5, 1:5, 1:5, integer(), integer(), ~.x, .ptype = double()), double() ) }) test_that("`hop_index2_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) slider/tests/testthat/test-slide-period.R0000644000176200001440000001573613704130147020232 0ustar liggesuserstest_that("basic call works", { expect_equal( slide_period(1, as.Date("2019-01-01"), "year", identity), list(1) ) }) test_that("`.x` must be a vector", { expect_error(slide_period(call("fn")), class = "vctrs_error_scalar_type") }) test_that(".x must be the same size as .i", { expect_error(slide_period(1, new_date(c(1, 2)), "year", identity), class = "slider_error_index_incompatible_size") }) test_that(".i must be ascending", { expect_error(slide_period(1:2, new_date(c(2, 1)), "year", identity), class = "slider_error_index_must_be_ascending") }) test_that("empty input returns a list, but after the index size check", { expect_equal(slide_period(integer(), new_date(), "year", ~.x), list()) expect_error(slide_period(integer(), new_date(0), "year", ~.x), class = "slider_error_index_incompatible_size") }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(slide_period(integer(), new_date(), "year", ~.x, .complete = TRUE), list()) }) test_that(".i must not contain NA values", { expect_error(slide_period(1:2, new_date(c(1, NA)), "year", identity), class = "slider_error_index_cannot_be_na") expect_error(slide_period(1:2, new_date(c(NA, 1)), "year", identity), class = "slider_error_index_cannot_be_na") }) # ------------------------------------------------------------------------------ # .before test_that("`.before` works", { expect_equal( slide_period(1:2, new_date(c(30, 31)), "month", identity, .before = 1), list(1, c(1, 2)) ) }) test_that("`.before` skips over irregular period gaps", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .before = 1), list(1, 1:2, 3) ) expect_equal( slide_period(1:3, i, "month", identity, .before = 2), list(1, 1:2, 2:3) ) }) test_that("`.before` set to Inf works", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .before = Inf), list(1, 1:2, 1:3) ) }) test_that("can use negative `.before`", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .before = -1, .after = 1), list(2, integer(), integer()) ) }) test_that("`.before` range cannot be after `.after` range", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_error( slide_period(1:3, i, "month", identity, .before = -1), "start of the range is after" ) }) test_that("`.before` cannot be NA", { expect_error( slide_period(1, new_date(0), "year", identity, .before = NA_integer_), "`.before` cannot be `NA`" ) }) test_that("`.before` cannot be -Inf", { expect_error( slide_period(1, new_date(0), "year", identity, .before = -Inf), class = "vctrs_error_cast_lossy" ) }) test_that(".before must be size 1", { expect_error( slide_period(1, new_date(0), "year", identity, .before = c(1L, 2L)), class = "vctrs_error_assert_size" ) }) test_that("error if .before is NULL", { expect_error( slide_period(1, new_date(0), "year", identity, .before = NULL), class = "vctrs_error_scalar_type" ) }) # ------------------------------------------------------------------------------ # .after test_that("`.after` works", { expect_equal( slide_period(1:2, new_date(c(30, 31)), "month", identity, .after = 1), list(1:2, 2) ) }) test_that("`.after` skips over irregular period gaps", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .after = 1), list(1:2, 2, 3) ) expect_equal( slide_period(1:3, i, "month", identity, .after = 2), list(1:2, 2:3, 3) ) }) test_that("`.after` set to Inf works", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .after = Inf), list(1:3, 2:3, 3) ) }) test_that("can use negative `.after`", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_equal( slide_period(1:3, i, "month", identity, .after = -1, .before = 1), list(integer(), 1, integer()) ) }) test_that("`.after` range cannot be before `.before` range", { i <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01")) expect_error( slide_period(1:3, i, "month", identity, .after = -1), "start of the range is after" ) }) test_that("`.after` cannot be NA", { expect_error( slide_period(1, new_date(0), "year", identity, .after = NA_integer_), "`.after` cannot be `NA`" ) }) test_that("`.after` cannot be -Inf", { expect_error( slide_period(1, new_date(0), "year", identity, .after = -Inf), class = "vctrs_error_cast_lossy" ) }) test_that(".after must be size 1", { expect_error( slide_period(1, new_date(0), "year", identity, .after = c(1L, 2L)), class = "vctrs_error_assert_size" ) }) test_that("error if .after is NULL", { expect_error( slide_period(1, new_date(0), "year", identity, .after = NULL), class = "vctrs_error_scalar_type" ) }) # ------------------------------------------------------------------------------ # .complete test_that("`.complete` works", { expect_equal( slide_period(1:2, new_date(c(30, 31)), "month", identity, .before = 1, .complete = TRUE), list(NULL, 1:2) ) expect_equal( slide_period(1:2, new_date(c(30, 31)), "month", identity, .after = 1, .complete = TRUE), list(1:2, NULL) ) }) test_that(paste0( "proof that we need to be careful about slicing `starts` and `stops` ", "when `.complete = TRUE` if we are completely OOB" ), { expect_equal( slide_period(1:3, new_date(c(0, 2, 3)), "day", identity, .before = 4, .after = -4, .complete = TRUE), list(NULL, NULL, NULL) ) }) test_that("works when the window is between values and `.complete = TRUE`", { expect_equal( slide_period(1:3, new_date(c(0, 2, 3)), "day", identity, .before = 1, .after = -1, .complete = TRUE), list(NULL, integer(), 2) ) }) test_that("`.complete` cannot be NA", { expect_error( slide_period(1, new_date(0), "year", identity, .complete = NA), "`.complete` cannot be `NA`" ) }) test_that(".complete must be size 1", { expect_error( slide_period(1, new_date(0), "year", identity, .complete = c(TRUE, FALSE)), class = "vctrs_error_assert_size" ) }) test_that("error if .complete is NULL", { expect_error( slide_period(1, new_date(0), "year", identity, .complete = NULL), class = "vctrs_error_scalar_type" ) }) # ------------------------------------------------------------------------------ # misc test_that("being completely OOB returns 0-slices of `x`", { expect_equal( slide_period(1:3, new_date(c(0, 2, 3)), "day", identity, .before = 4, .after = -4), list(integer(), integer(), integer()) ) }) test_that("having a window completely between values returns 0-slices of `x`", { expect_equal( slide_period(1:3, new_date(c(0, 2, 3)), "day", identity, .before = 1, .after = -1), list(integer(), integer(), 2) ) }) slider/tests/testthat/test-summary-slide.R0000644000176200001440000004662714024646413020454 0ustar liggesusers# ------------------------------------------------------------------------------ # slide_sum() test_that("integer before works", { x <- 1:4 + 0 expect_identical(slide_sum(x, before = 1), c(1, 3, 5, 7)) expect_identical(slide_sum(x, before = 2), c(1, 3, 6, 9)) }) test_that("integer after works", { x <- 1:4 + 0 expect_identical(slide_sum(x, after = 1), c(3, 5, 7, 4)) expect_identical(slide_sum(x, after = 2), c(6, 9, 7, 4)) }) test_that("negative before/after works", { x <- 1:4 + 0 expect_identical(slide_sum(x, before = -1, after = 2), c(5, 7, 4, 0)) expect_identical(slide_sum(x, before = 2, after = -1), c(0, 1, 3, 5)) expect_identical(slide_sum(x, before = -1, after = 2, complete = TRUE), c(5, 7, NA, NA)) expect_identical(slide_sum(x, before = 2, after = -1, complete = TRUE), c(NA, NA, 3, 5)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 expect_identical(slide_sum(x, before = Inf), cumsum(x)) expect_identical(slide_sum(x, after = Inf), rev(cumsum(rev(x)))) }) test_that("step / complete works", { x <- 1:4 + 0 expect_identical(slide_sum(x, before = 1, step = 2), c(1, NA, 5, NA)) expect_identical(slide_sum(x, before = 1, step = 2, complete = TRUE), c(NA, 3, NA, 7)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) expect_identical( slide_sum(x, before = 3), slide_dbl(x, sum, .before = 3) ) expect_identical( slide_sum(y, before = 3), slide_dbl(y, sum, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_sum(rev(y), before = 3), # slide_dbl(rev(y), sum, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_sum(x, na_rm = TRUE), 0) expect_identical(slide_sum(y, na_rm = TRUE, before = 1), c(1, 1, 2, 5)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_sum(x, before = 1), c(1, Inf, NaN, -Inf)) }) test_that("precision matches base R (long doubles)", { skip_if_no_long_double() x <- rep(1/7, 10) expect_identical(sum(x), slide_sum(x, before = Inf)[[length(x)]]) }) test_that("Inf + -Inf = NaN propagates with `na_rm = TRUE`", { x <- c(-Inf, Inf, rep(1, SEGMENT_TREE_FANOUT - 2L)) before <- SEGMENT_TREE_FANOUT - 1L expect_identical( slide_sum(x, before = before, na_rm = T), slide_dbl(x, sum, .before = before, na_rm = T) ) }) # ------------------------------------------------------------------------------ # slide_prod() test_that("integer before works", { x <- 1:4 + 0 expect_identical(slide_prod(x, before = 1), c(1, 2, 6, 12)) expect_identical(slide_prod(x, before = 2), c(1, 2, 6, 24)) }) test_that("integer after works", { x <- 1:4 + 0 expect_identical(slide_prod(x, after = 1), c(2, 6, 12, 4)) expect_identical(slide_prod(x, after = 2), c(6, 24, 12, 4)) }) test_that("negative before/after works", { x <- 1:4 + 0 expect_identical(slide_prod(x, before = -1, after = 2), c(6, 12, 4, 1)) expect_identical(slide_prod(x, before = 2, after = -1), c(1, 1, 2, 6)) expect_identical(slide_prod(x, before = -1, after = 2, complete = TRUE), c(6, 12, NA, NA)) expect_identical(slide_prod(x, before = 2, after = -1, complete = TRUE), c(NA, NA, 2, 6)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 expect_identical(slide_prod(x, before = Inf), cumprod(x)) expect_identical(slide_prod(x, after = Inf), rev(cumprod(rev(x)))) }) test_that("step / complete works", { x <- 1:4 + 0 expect_identical(slide_prod(x, before = 1, step = 2), c(1, NA, 6, NA)) expect_identical(slide_prod(x, before = 1, step = 2, complete = TRUE), c(NA, 2, NA, 12)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) expect_identical( slide_prod(x, before = 3), slide_dbl(x, prod, .before = 3) ) expect_identical( slide_prod(y, before = 3), slide_dbl(y, prod, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_prod(rev(y), before = 3), # slide_dbl(rev(y), prod, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_prod(x, na_rm = TRUE), 1) expect_identical(slide_prod(y, na_rm = TRUE, before = 1), c(1, 1, 2, 6)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 0) expect_identical(slide_prod(x, before = 1), c(1, Inf, -Inf, NaN)) }) test_that("Inf * 0 = NaN propagates with `na_rm = TRUE`", { x <- c(Inf, 0, rep(1, SEGMENT_TREE_FANOUT - 2L)) before <- SEGMENT_TREE_FANOUT - 1L expect_identical( slide_prod(x, before = before, na_rm = T), slide_dbl(x, prod, .before = before, na_rm = T) ) }) # ------------------------------------------------------------------------------ # slide_mean() test_that("integer before works", { x <- 1:4 + 0 expect_identical(slide_mean(x, before = 1), slide_dbl(x, mean, .before = 1)) expect_identical(slide_mean(x, before = 2), slide_dbl(x, mean, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 expect_identical(slide_mean(x, after = 1), slide_dbl(x, mean, .after = 1)) expect_identical(slide_mean(x, after = 2), slide_dbl(x, mean, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 expect_identical(slide_mean(x, before = -1, after = 2), slide_dbl(x, mean, .before = -1, .after = 2)) expect_identical(slide_mean(x, before = 2, after = -1), slide_dbl(x, mean, .before = 2, .after = -1)) expect_identical(slide_mean(x, before = -1, after = 2, complete = TRUE), slide_dbl(x, mean, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_mean(x, before = 2, after = -1, complete = TRUE), slide_dbl(x, mean, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 expect_identical(slide_mean(x, before = Inf), slide_dbl(x, mean, .before = Inf)) expect_identical(slide_mean(x, after = Inf), slide_dbl(x, mean, .after = Inf)) }) test_that("step / complete works", { x <- 1:4 + 0 expect_identical(slide_mean(x, before = 1, step = 2), slide_dbl(x, mean, .before = 1, .step = 2)) expect_identical(slide_mean(x, before = 1, step = 2, complete = TRUE), slide_dbl(x, mean, .before = 1, .step = 2, .complete = TRUE)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) expect_identical( slide_mean(x, before = 3), slide_dbl(x, mean, .before = 3) ) expect_identical( slide_mean(y, before = 3), slide_dbl(y, mean, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_mean(rev(y), before = 3), # slide_dbl(rev(y), mean, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_mean(x, na_rm = TRUE), NaN) expect_identical(slide_mean(y, na_rm = TRUE, before = 1), c(1, 1, 2, 2.5)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_mean(x, before = 1), c(1, Inf, NaN, -Inf)) }) test_that("precision matches base R (long doubles)", { skip_if_no_long_double() x <- c(1/7, 1/7, 1/3) expect_identical(mean(x), slide_mean(x, before = Inf)[[length(x)]]) }) test_that("Inf + -Inf = NaN propagates with `na_rm = TRUE`", { x <- c(-Inf, Inf, rep(1, SEGMENT_TREE_FANOUT - 2L)) before <- SEGMENT_TREE_FANOUT - 1L expect_identical( slide_mean(x, before = before, na_rm = T), slide_dbl(x, mean, .before = before, na_rm = T) ) }) test_that("computes correctly with wider width", { expect_identical( slide_mean(1:1000, before = 100), slide_dbl(1:1000, mean, .before = 100) ) }) # ------------------------------------------------------------------------------ # slide_min() test_that("integer before works", { x <- 1:4 + 0 expect_identical(slide_min(x, before = 1), slide_dbl(x, min, .before = 1)) expect_identical(slide_min(x, before = 2), slide_dbl(x, min, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 expect_identical(slide_min(x, after = 1), slide_dbl(x, min, .after = 1)) expect_identical(slide_min(x, after = 2), slide_dbl(x, min, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 expect_identical(slide_min(x, before = -1, after = 2), c(2, 3, 4, Inf)) expect_identical(slide_min(x, before = 2, after = -1), c(Inf, 1, 1, 2)) expect_identical(slide_min(x, before = -1, after = 2, complete = TRUE), slide_dbl(x, min, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_min(x, before = 2, after = -1, complete = TRUE), slide_dbl(x, min, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 expect_identical(slide_min(x, before = Inf), slide_dbl(x, min, .before = Inf)) expect_identical(slide_min(x, after = Inf), slide_dbl(x, min, .after = Inf)) }) test_that("step / complete works", { x <- 1:4 + 0 expect_identical(slide_min(x, before = 1, step = 2), slide_dbl(x, min, .before = 1, .step = 2)) expect_identical(slide_min(x, before = 1, step = 2, complete = TRUE), slide_dbl(x, min, .before = 1, .step = 2, .complete = TRUE)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) expect_identical( slide_min(x, before = 3), slide_dbl(x, min, .before = 3) ) expect_identical( slide_min(y, before = 3), slide_dbl(y, min, .before = 3) ) expect_identical( slide_min(rev(y), before = 3), slide_dbl(rev(y), min, .before = 3) ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_min(x, na_rm = TRUE), Inf) expect_identical(slide_min(y, na_rm = TRUE, before = 1), c(1, 1, 2, 2)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_min(x, before = 1), c(1, 1, -Inf, -Inf)) }) # ------------------------------------------------------------------------------ # slide_max() test_that("integer before works", { x <- 1:4 + 0 expect_identical(slide_max(x, before = 1), slide_dbl(x, max, .before = 1)) expect_identical(slide_max(x, before = 2), slide_dbl(x, max, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 expect_identical(slide_max(x, after = 1), slide_dbl(x, max, .after = 1)) expect_identical(slide_max(x, after = 2), slide_dbl(x, max, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 expect_identical(slide_max(x, before = -1, after = 2), c(3, 4, 4, -Inf)) expect_identical(slide_max(x, before = 2, after = -1), c(-Inf, 1, 2, 3)) expect_identical(slide_max(x, before = -1, after = 2, complete = TRUE), slide_dbl(x, max, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_max(x, before = 2, after = -1, complete = TRUE), slide_dbl(x, max, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 expect_identical(slide_max(x, before = Inf), slide_dbl(x, max, .before = Inf)) expect_identical(slide_max(x, after = Inf), slide_dbl(x, max, .after = Inf)) }) test_that("step / complete works", { x <- 1:4 + 0 expect_identical(slide_max(x, before = 1, step = 2), slide_dbl(x, max, .before = 1, .step = 2)) expect_identical(slide_max(x, before = 1, step = 2, complete = TRUE), slide_dbl(x, max, .before = 1, .step = 2, .complete = TRUE)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) expect_identical( slide_max(x, before = 3), slide_dbl(x, max, .before = 3) ) expect_identical( slide_max(y, before = 3), slide_dbl(y, max, .before = 3) ) expect_identical( slide_max(rev(y), before = 3), slide_dbl(rev(y), max, .before = 3) ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_max(x, na_rm = TRUE), -Inf) expect_identical(slide_max(y, na_rm = TRUE, before = 1), c(1, 1, 2, 3)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_max(x, before = 1), c(1, Inf, Inf, 1)) }) # ------------------------------------------------------------------------------ # slide_all() test_that("integer before works", { x <- c(TRUE, FALSE, TRUE, TRUE) expect_identical(slide_all(x, before = 1), slide_lgl(x, all, .before = 1)) expect_identical(slide_all(x, before = 2), slide_lgl(x, all, .before = 2)) }) test_that("integer after works", { x <- c(TRUE, FALSE, TRUE, TRUE) expect_identical(slide_all(x, after = 1), slide_lgl(x, all, .after = 1)) expect_identical(slide_all(x, after = 2), slide_lgl(x, all, .after = 2)) }) test_that("negative before/after works", { x <- c(TRUE, FALSE, TRUE, TRUE) expect_identical(slide_all(x, before = -1, after = 2), slide_lgl(x, all, .before = -1, .after = 2)) expect_identical(slide_all(x, before = 2, after = -1), slide_lgl(x, all, .before = 2, .after = -1)) expect_identical(slide_all(x, before = -1, after = 2, complete = TRUE), slide_lgl(x, all, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_all(x, before = 2, after = -1, complete = TRUE), slide_lgl(x, all, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- c(TRUE, FALSE, TRUE, TRUE) expect_identical(slide_all(x, before = Inf), slide_lgl(x, all, .before = Inf)) expect_identical(slide_all(x, after = Inf), slide_lgl(x, all, .after = Inf)) }) test_that("step / complete works", { x <- c(TRUE, FALSE, TRUE, TRUE) expect_identical(slide_all(x, before = 1, step = 2), slide_lgl(x, all, .before = 1, .step = 2)) expect_identical(slide_all(x, before = 1, step = 2, complete = TRUE), slide_lgl(x, all, .before = 1, .step = 2, .complete = TRUE)) }) test_that("NA / NaN results are correct", { x <- c(rep(TRUE, 10), rep(NA, 10), c(TRUE, TRUE, FALSE, TRUE)) expect_identical( slide_all(x, before = 3), slide_lgl(x, all, .before = 3) ) }) test_that("FALSE dominates NAs, matching all()", { x <- c(NA, FALSE, FALSE) expect_identical(slide_all(x, before = 2), c(NA, FALSE, FALSE)) expect_identical(slide_all(x, before = 2), slide_lgl(x, all, .before = 2)) x <- c(FALSE, NA, FALSE) expect_identical(slide_all(x, before = 2), c(FALSE, FALSE, FALSE)) expect_identical(slide_all(x, before = 2), slide_lgl(x, all, .before = 2)) x <- c(FALSE, FALSE, NA) expect_identical(slide_all(x, before = 2), c(FALSE, FALSE, FALSE)) expect_identical(slide_all(x, before = 2), slide_lgl(x, all, .before = 2)) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(TRUE, NA, FALSE, NA, TRUE) expect_identical(slide_all(x, na_rm = TRUE), TRUE) expect_identical(slide_all(y, na_rm = TRUE, before = 1), slide_lgl(y, all, na.rm = TRUE, .before = 1)) }) test_that("works when the window is completely OOB", { x <- c(TRUE, FALSE, NA) expect_identical(slide_all(x, before = 4, after = -4), c(TRUE, TRUE, TRUE)) expect_identical(slide_all(x, before = 4, after = -4), slide_lgl(x, all, .before = 4, .after = -4)) }) test_that("input must be castable to logical", { expect_error(slide_all(1:5), class = "vctrs_error_cast_lossy") }) # ------------------------------------------------------------------------------ # slide_any() test_that("integer before works", { x <- c(FALSE, TRUE, FALSE, FALSE) expect_identical(slide_any(x, before = 1), slide_lgl(x, any, .before = 1)) expect_identical(slide_any(x, before = 2), slide_lgl(x, any, .before = 2)) }) test_that("integer after works", { x <- c(FALSE, TRUE, FALSE, FALSE) expect_identical(slide_any(x, after = 1), slide_lgl(x, any, .after = 1)) expect_identical(slide_any(x, after = 2), slide_lgl(x, any, .after = 2)) }) test_that("negative before/after works", { x <- c(FALSE, TRUE, FALSE, FALSE) expect_identical(slide_any(x, before = -1, after = 2), slide_lgl(x, any, .before = -1, .after = 2)) expect_identical(slide_any(x, before = 2, after = -1), slide_lgl(x, any, .before = 2, .after = -1)) expect_identical(slide_any(x, before = -1, after = 2, complete = TRUE), slide_lgl(x, any, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_any(x, before = 2, after = -1, complete = TRUE), slide_lgl(x, any, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- c(FALSE, TRUE, FALSE, FALSE) expect_identical(slide_any(x, before = Inf), slide_lgl(x, any, .before = Inf)) expect_identical(slide_any(x, after = Inf), slide_lgl(x, any, .after = Inf)) }) test_that("step / complete works", { x <- c(FALSE, TRUE, FALSE, FALSE) expect_identical(slide_any(x, before = 1, step = 2), slide_lgl(x, any, .before = 1, .step = 2)) expect_identical(slide_any(x, before = 1, step = 2, complete = TRUE), slide_lgl(x, any, .before = 1, .step = 2, .complete = TRUE)) }) test_that("NA results are correct", { x <- c(rep(FALSE, 10), rep(NA, 10), c(FALSE, FALSE, TRUE, FALSE)) expect_identical( slide_any(x, before = 3), slide_lgl(x, any, .before = 3) ) }) test_that("TRUE dominates NAs, matching any()", { x <- c(NA, TRUE, TRUE) expect_identical(slide_any(x, before = 2), c(NA, TRUE, TRUE)) expect_identical(slide_any(x, before = 2), slide_lgl(x, any, .before = 2)) x <- c(TRUE, NA, TRUE) expect_identical(slide_any(x, before = 2), c(TRUE, TRUE, TRUE)) expect_identical(slide_any(x, before = 2), slide_lgl(x, any, .before = 2)) x <- c(TRUE, TRUE, NA) expect_identical(slide_any(x, before = 2), c(TRUE, TRUE, TRUE)) expect_identical(slide_any(x, before = 2), slide_lgl(x, any, .before = 2)) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(TRUE, NA, FALSE, NA, TRUE) expect_identical(slide_any(x, na_rm = TRUE), FALSE) expect_identical(slide_any(y, na_rm = TRUE, before = 1), slide_lgl(y, any, na.rm = TRUE, .before = 1)) }) test_that("works when the window is completely OOB", { x <- c(TRUE, FALSE, NA) expect_identical(slide_any(x, before = 4, after = -4), c(FALSE, FALSE, FALSE)) expect_identical(slide_any(x, before = 4, after = -4), slide_lgl(x, any, .before = 4, .after = -4)) }) test_that("input must be castable to logical", { expect_error(slide_any(1:5), class = "vctrs_error_cast_lossy") }) # ------------------------------------------------------------------------------ # Misc test_that("works with size 0 input", { expect_identical(slide_sum(integer()), double()) expect_identical(slide_sum(integer(), before = 5, after = 1), double()) expect_identical(slide_sum(integer(), step = 2, na_rm = TRUE), double()) }) test_that("names are kept (even on casting)", { expect_named(slide_sum(c(x = 1, y = 2), before = 1), c("x", "y")) expect_named(slide_sum(c(x = 1L, y = 2L), before = 1), c("x", "y")) }) test_that("can cast integer and logical input", { expect_identical(slide_sum(1:5, before = 1), slide_sum(1:5 + 0, before = 1)) expect_identical(slide_sum(c(TRUE, FALSE, TRUE), before = 1), slide_sum(c(1, 0, 1), before = 1)) }) test_that("types that can't be cast to numeric are not supported", { expect_error(slide_sum("x"), class = "vctrs_error_incompatible_type") }) test_that("arrays of dimensionality 1 are supported", { expect_identical( slide_sum(array(1:5), before = 1), slide_sum(1:5, before = 1) ) }) test_that("arrays of dimensionality >1 are not supported", { expect_error(slide_sum(array(1:4, dim = c(2, 2)), before = 1), class = "vctrs_error_incompatible_type") }) test_that("works when the window is completely OOB", { expect_identical( slide_sum(1:3, before = 4, after = -4), c(0, 0, 0) ) }) slider/tests/testthat/test-block.R0000644000176200001440000000223413613034205016726 0ustar liggesuserstest_that("block works as expected with year blocks", { i <- as.Date("2019-01-01") + c(-2:2, 31) expect_equal(block(i, i, period = "year"), list(i[1:2], i[3:6])) }) test_that("block works as expected with month blocks", { i <- as.Date("2019-01-01") + c(-2:2, 31) expect_equal(block(i, i, period = "month"), list(i[1:2], i[3:5], i[6])) }) test_that("`x` must be a vector", { expect_error(block(as.name("x"), new_date(0)), class = "vctrs_error_scalar_type") }) test_that("works with empty input", { x <- numeric() i <- structure(numeric(), class = "Date") expect_equal(block(x, i, "year"), list()) }) test_that("`i` can not have `NA` values", { expect_error(block(1:2, new_date(c(0, NA_real_))), class = "slider_error_index_cannot_be_na") }) test_that("type of `i` is validated", { expect_error(block(1, 1), class = "slider_error_index_incompatible_type") }) test_that("length of `i` must be identical to `x`", { expect_error(block(c(1, 2), new_date(0)), class = "slider_error_index_incompatible_size") }) test_that("`i` must be ascending", { expect_error(block(c(1, 2, 3), new_date(c(2, 1, 0))), class = "slider_error_index_must_be_ascending") }) slider/tests/testthat/test-pslide-index.R0000644000176200001440000000157713656544162020251 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { expect_equal(pslide_index(list(integer(), integer()), integer(), ~.x), list()) expect_equal(pslide_index(list(integer(), 1), integer(), ~.x), list()) expect_equal(pslide_index(list(1, integer()), integer(), ~.x), list()) expect_error(pslide_index(list(integer(), integer()), 1, ~.x), class = "slider_error_index_incompatible_size") }) test_that("completely empty input returns a list", { expect_equal(pslide_index(list(), integer(), ~.x), list()) }) test_that("pslide_index() forces arguments in the same way as base R / pmap()", { f_slide <- pslide_index(list(1:2, 1:2, 1:2), 1:2, function(i, j, k) function(x) x + i + j + k) f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/test-slide.R0000644000176200001440000002455113663755662016770 0ustar liggesuserstest_that("default settings is the same as map()", { expect_equal(slide(1:5, identity), as.list(1:5)) }) # ------------------------------------------------------------------------------ # .before / .after test_that("can use .before for right alignment", { expect_equal( slide(1:7, identity, .before = 1), list( 1L, 1:2, 2:3, 3:4, 4:5, 5:6, 6:7 ) ) expect_equal( slide(1:7, identity, .before = 2), list( 1L, 1:2, 1:3, 2:4, 3:5, 4:6, 5:7 ) ) }) test_that("can use .after for left alignment", { expect_equal( slide(1:7, identity, .after = 1), list( 1:2, 2:3, 3:4, 4:5, 5:6, 6:7, 7L ) ) expect_equal( slide(1:7, identity, .after = 2), list( 1:3, 2:4, 3:5, 4:6, 5:7, 6:7, 7L ) ) }) test_that("can use .before / .after for center alignment", { expect_equal( slide(1:7, identity, .before = 1, .after = 1), list( 1:2, 1:3, 2:4, 3:5, 4:6, 5:7, 6:7 ) ) expect_equal( slide(1:7, identity, .before = 2, .after = 2), list( 1:3, 1:4, 1:5, 2:6, 3:7, 4:7, 5:7 ) ) }) test_that("can use .before / .after for center-left alignment", { expect_equal( slide(1:7, identity, .before = 2, .after = 1), list( 1:2, 1:3, 1:4, 2:5, 3:6, 4:7, 5:7 ) ) }) test_that("can use .before / .after for center-right alignment", { expect_equal( slide(1:7, identity, .before = 1, .after = 2), list( 1:3, 1:4, 2:5, 3:6, 4:7, 5:7, 6:7 ) ) }) # ------------------------------------------------------------------------------ # negative before test_that("can use a negative before to 'look forward'", { expect_equal( slide(1:5, identity, .before = -1, .after = 1), list( 2L, 3L, 4L, 5L, integer() ) ) expect_equal( slide(1:5, identity, .before = -1, .after = Inf), list( 2:5, 3:5, 4:5, 5L, integer() ) ) }) test_that("error if negative .before's abs() is > .after", { expect_error(slide(1:5, identity, .before = -1), "cannot be greater than `.after`.") }) test_that("both .before and .after cannot be negative", { expect_error(slide(1:5, identity, .before = -1, .after = -1), "cannot both be negative.") }) # ------------------------------------------------------------------------------ # negative after test_that("can use a negative .after to 'look backward'", { expect_equal( slide(1:5, identity, .before = 1, .after = -1), list( integer(), 1L, 2L, 3L, 4L ) ) expect_equal( slide(1:5, identity, .before = Inf, .after = -1), list( integer(), 1L, 1:2, 1:3, 1:4 ) ) }) test_that("error if negative .after's abs() is > .before", { expect_error(slide(1:5, identity, .after = -1), "cannot be greater than `.before`.") }) # ------------------------------------------------------------------------------ # .step test_that("can step to skip over function calls", { expect_equal( slide(1:7, identity, .step = 2), list( 1, NULL, 3, NULL, 5, NULL, 7 ) ) expect_equal( slide(1:7, identity, .step = 3), list( 1, NULL, NULL, 4, NULL, NULL, 7 ) ) expect_equal( slide(1:6, identity, .before = 1, .step = 2), list( 1, NULL, 2:3, NULL, 4:5, NULL ) ) }) # ------------------------------------------------------------------------------ # .complete test_that(".complete doesn't change the result if not required", { expect_equal( slide(1:7, identity, .complete = TRUE), slide(1:7, identity) ) expect_equal( slide(1:7, identity, .complete = TRUE, .step = 2L), slide(1:7, identity, .step = 2L) ) }) test_that(".complete works when the size shrinks over the last iterations", { expect_equal( slide(1:7, identity, .complete = TRUE, .after = 2L), list( 1:3, 2:4, 3:5, 4:6, 5:7, NULL, NULL ) ) }) test_that(".complete works when doing center alignment", { expect_equal( slide(1:5, identity, .complete = TRUE, .before = 1, .after = 1), list( NULL, 1:3, 2:4, 3:5, NULL ) ) }) test_that(".complete works with negative .before", { expect_equal( slide(1:5, ~.x, .before = -1, .after = 2, .complete = TRUE), list( 2:3, 3:4, 4:5, NULL, NULL ) ) }) # ------------------------------------------------------------------------------ # unbounded test_that("can use Inf in .before for cumulative sliding", { expect_equal( slide(1:5, identity, .before = Inf), list( 1L, 1:2, 1:3, 1:4, 1:5 ) ) }) test_that("can use Inf in .before + set .after", { expect_equal( slide(1:5, identity, .before = Inf, .after = 1L), list( 1:2, 1:3, 1:4, 1:5, 1:5 ) ) expect_equal( slide(1:5, identity, .before = Inf, .after = -1L), list( integer(), 1L, 1:2, 1:3, 1:4 ) ) }) test_that("can use Inf in .after for cumulative sliding", { expect_equal( slide(1:5, identity, .after = Inf), list( 1:5, 2:5, 3:5, 4:5, 5L ) ) }) test_that("can use Inf in .after + set .before", { expect_equal( slide(1:5, identity, .after = Inf, .before = 1L), list( 1:5, 1:5, 2:5, 3:5, 4:5 ) ) expect_equal( slide(1:5, identity, .after = Inf, .before = 1L, .complete = TRUE), list( NULL, 1:5, 2:5, 3:5, 4:5 ) ) expect_equal( slide(1:5, identity, .after = Inf, .before = -1L), list( 2:5, 3:5, 4:5, 5L, integer() ) ) }) test_that("can be doubly unbounded", { expect_equal( slide(1:5, identity, .before = Inf, .after = Inf), list( 1:5, 1:5, 1:5, 1:5, 1:5 ) ) expect_equal( slide(1:5, identity, .before = Inf, .after = Inf, .complete = TRUE), list( 1:5, 1:5, 1:5, 1:5, 1:5 ) ) }) # ------------------------------------------------------------------------------ # data frames test_that("slide() is a rowwise iterator", { x <- data.frame(x = 1:3, y = 2:4) expect_equal( slide(x, identity), list( vec_slice(x, 1), vec_slice(x, 2), vec_slice(x, 3) ) ) expect_equal( slide(x, identity, .before = 1L), list( vec_slice(x, 1L), vec_slice(x, 1:2), vec_slice(x, 2:3) ) ) expect_equal( slide(x, identity, .before = 1L, .complete = TRUE), list( NULL, vec_slice(x, 1:2), vec_slice(x, 2:3) ) ) }) # ------------------------------------------------------------------------------ # type / size relaxed-ness test_that("slide() doesn't require `size = 1`", { expect_equal( slide(1:2, ~c(.x, 1)), list( c(1L, 1L), c(2L, 1L) ) ) }) test_that("`slide()` doesn't require a common inner type", { expect_equal( slide(1:2, ~if (.x == 1L) {1} else {"hi"}), list(1, "hi") ) }) # ------------------------------------------------------------------------------ # input names test_that("input names are retained with atomics", { names <- letters[1:5] x <- set_names(1:5, names) expect_equal(names(slide(x, ~.x)), names) }) test_that("input names are retained from proxied objects", { names <- letters[1:5] x <- as.POSIXlt(new_datetime(0:4 + 0)) x <- set_names(x, names) expect_equal(names(slide(x, ~.x)), names) }) test_that("row names are extracted from data frames", { x <- data.frame(x = 1:5, row.names = letters[1:5]) expect_equal(names(slide(x, ~.x)), letters[1:5]) }) test_that("row names are extracted from arrays", { x <- array(1:4, c(2, 2), dimnames = list(c("r1", "r2"), c("c1", "c2"))) expect_equal(names(slide(x, ~.x)), c("r1", "r2")) }) test_that("names are retained on inner sliced object", { names <- letters[1:5] x <- set_names(1:5, names) exp <- set_names(as.list(names), names) expect_equal(slide(x, ~names(.x)), exp) names <- letters[1:5] x <- data.frame(x = 1:5, row.names = names) expect <- set_names(as.list(names), names) expect_equal(slide(x, ~rownames(.x)), expect) names <- c("r1", "r2") x <- array(1:4, c(2, 2), dimnames = list(names, c("c1", "c2"))) exp <- set_names(as.list(names), names) expect_equal(slide(x, ~rownames(.x)), exp) }) # ------------------------------------------------------------------------------ # validation test_that("cannot use invalid .before", { expect_error(slide(1, identity, .before = c(1, 2)), regexp = "1, not 2") expect_error(slide(1, identity, .before = "x"), class = "vctrs_error_incompatible_type") }) test_that("cannot use invalid .after", { expect_error(slide(1, identity, .after = c(1, 2)), regexp = "1, not 2") expect_error(slide(1, identity, .after = "x"), class = "vctrs_error_incompatible_type") }) test_that("cannot use invalid .step", { expect_error(slide(1, identity, .step = -1), "at least 1, not -1") expect_error(slide(1, identity, .step = 0), "at least 1, not 0") expect_error(slide(1, identity, .step = c(1, 2)), regexp = "1, not 2") expect_error(slide(1, identity, .step = "x"), class = "vctrs_error_incompatible_type") }) test_that("cannot use invalid .complete", { expect_error(slide(1, identity, .complete = c(TRUE, TRUE)), regexp = "1, not 2") expect_error(slide(1, identity, .complete = "hi"), class = "vctrs_error_incompatible_type") }) # ------------------------------------------------------------------------------ # misc test_that("slide() forces arguments in the same way as base R / map()", { f_slide <- slide(1:2, function(i) function(x) x + i) f_base <- lapply(1:2, function(i) function(x) x + i) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) test_that(paste0( "proof that the `window_stop < window_start` check is required for ", "cases where the window is completely OOB" ), { expect_equal( slide(1:3, identity, .before = 4, .after = -4), list(integer(), integer(), integer()) ) }) slider/tests/testthat/test-slide2.R0000644000176200001440000000143313656541631017033 0ustar liggesuserstest_that("Recycling is carried out using tidyverse recycling rules", { x0 <- integer() x1 <- 1L x2 <- c(2L, 2L) x3 <- c(3L, 3L, 3L) expect_equal(slide2(x0, x0, ~.x), list()) expect_equal(slide2(x0, x1, ~.x), list()) expect_error(slide2(x0, x2, ~.x), class = "vctrs_error_incompatible_size") expect_equal(slide2(x1, x1, ~.x), list(x1)) expect_equal(slide2(x1, x2, ~.x), list(x1, x1)) expect_error(slide2(x2, x3, ~.x), class = "vctrs_error_incompatible_size") }) test_that("slide2() forces arguments in the same way as base R / map2()", { f_slide <- slide2(1:2, 1:2, function(i, j) function(x) x + i + j) f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/output/0000755000176200001440000000000013607131574016105 5ustar liggesusersslider/tests/testthat/output/test-stop-index-must-be-ascending-1.txt0000644000176200001440000000021614067407072025355 0ustar liggesusers> check_index_must_be_ascending(c(1, 2, 1, 4, 5, 3), ".i") Error: `.i` must be in ascending order. i It is not ascending at locations: 3, 6. slider/tests/testthat/output/test-stop-index-cannot-be-na-2.txt0000644000176200001440000000020714067407072024313 0ustar liggesusers> check_index_cannot_be_na(rep(NA, 100), ".i") Error: `.i` cannot be `NA`. i It is `NA` at locations: 1, 2, 3, 4, 5, 6, 7, 8, 9, .... slider/tests/testthat/output/test-stop-index-cannot-be-na-1.txt0000644000176200001440000000015514067407072024314 0ustar liggesusers> check_index_cannot_be_na(c(NA, 1, NA), ".i") Error: `.i` cannot be `NA`. i It is `NA` at locations: 1, 3. slider/tests/testthat/output/test-stop-index-incompatible-type-1.txt0000644000176200001440000000021414067407072025473 0ustar liggesusers> check_index_incompatible_type(1, ".i") Error: `.i` has an incorrect type. x It must inherit from Date, POSIXct, or POSIXlt, not numeric. slider/tests/testthat/output/test-stop-endpoints-cannot-be-na-1.txt0000644000176200001440000000017314067407072025210 0ustar liggesusers> check_endpoints_cannot_be_na(c(NA, 1, NA), ".starts") Error: `.starts` cannot be `NA`. i It is `NA` at locations: 1, 3. slider/tests/testthat/output/test-stop-endpoints-must-be-ascending-1.txt0000644000176200001440000000023414067407072026251 0ustar liggesusers> check_endpoints_must_be_ascending(c(1, 2, 1, 3, 4, 2), ".starts") Error: `.starts` must be in ascending order. i It is not ascending at locations: 3, 6. slider/tests/testthat/output/test-stop-index-incompatible-type-2.txt0000644000176200001440000000022014067407072025471 0ustar liggesusers> check_index_incompatible_type(x, ".i") Error: `.i` has an incorrect type. x It must inherit from Date, POSIXct, or POSIXlt, not foo/bar/baz. slider/tests/testthat/output/test-stop-generated-endpoints-cannot-be-na-1.txt0000644000176200001440000000023714067407072027145 0ustar liggesusers> check_generated_endpoints_cannot_be_na(c(NA, 1, NA), ".before") Error: Endpoints generated by `.before` cannot be `NA`. i They are `NA` at locations: 1, 3. slider/tests/testthat/output/test-stop-index-incompatible-size-1.txt0000644000176200001440000000015514067407072025470 0ustar liggesusers> stop_index_incompatible_size(1, 2, ".i") Error: `.i` has an incorrect size. x It must have size 2, not 1. slider/tests/testthat/test-hop-index.R0000644000176200001440000002001014024427556017533 0ustar liggesuserstest_that("trivial case works", { expect_equal( hop_index(1:2, 1:2, 1:2, 1:2, ~.x), list(1L, 2L) ) }) test_that("can work with with Date `.i`", { i <- new_date(c(0, 1, 2, 3)) x <- 1:4 expect_equal( hop_index(x, i, i, i, identity), list( 1L, 2L, 3L, 4L ) ) }) test_that(".x must be the same size as .i", { expect_error(hop_index(1, 1:2, 1, 1, identity), class = "slider_error_index_incompatible_size") }) test_that(".i must be ascending", { expect_error(hop_index(1:2, 2:1, 1:2, 1:2, identity), class = "slider_error_index_must_be_ascending") }) test_that(".starts must be ascending", { expect_error(hop_index(1:2, 1:2, 2:1, 1:2, identity), class = "slider_error_endpoints_must_be_ascending") }) test_that(".stops must be ascending", { expect_error(hop_index(1:2, 1:2, 1:2, 2:1, identity), class = "slider_error_endpoints_must_be_ascending") }) test_that("empty input returns a list, but after the index size check", { expect_equal(hop_index(integer(), integer(), integer(), integer(), ~.x), list()) expect_error(hop_index(integer(), 1, integer(), integer(), ~.x), class = "slider_error_index_incompatible_size") }) test_that("empty `.x` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` ptype", { expect_equal(hop_index(integer(), integer(), 1:2, 2:3, ~.x), list(integer(), integer())) }) test_that("empty `.x` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { expect_error(hop_index(integer(), integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") expect_error(hop_index(integer(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") }) test_that(".i must not contain NA values", { expect_error(hop_index(1:2, c(1, NA), 1:2, 1:2, identity), class = "slider_error_index_cannot_be_na") expect_error(hop_index(1:2, c(NA, 1), 1:2, 1:2, identity), class = "slider_error_index_cannot_be_na") }) test_that(".starts must not contain NA values", { expect_error(hop_index(1:2, 1:2, c(1, NA), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") expect_error(hop_index(1:2, 1:2, c(NA, 1), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") }) test_that(".stops must not contain NA values", { expect_error(hop_index(1:2, 1:2, 1:2, c(1, NA), identity), class = "slider_error_endpoints_cannot_be_na") expect_error(hop_index(1:2, 1:2, 1:2, c(NA, 1), identity), class = "slider_error_endpoints_cannot_be_na") }) test_that("recycling is used for .starts/.stops", { expect_equal( hop_index(1:2, 1:2, 1, 1:2, ~.x), list( 1L, 1:2 ) ) expect_equal( hop_index(1:2, 1:2, 1:2, 2, ~.x), list( 1:2, 2L ) ) expect_error(hop_index(1:2, 1:2, 1:2, 1:3, ~.x), class = "vctrs_error_incompatible_size") }) test_that("0 length .starts/.stops are allowed", { expect_equal(hop_index(1, 1, integer(), integer(), ~.x), list()) }) test_that(".starts and .stops are cast to .i", { i <- new_date(c(0, 1)) starts <- c("x", "y") stops <- i expect_error( hop_index(1:2, i, starts, stops, ~.x), class = "vctrs_error_incompatible_type" ) }) test_that("output size is the common size of .starts/.stops", { expect_equal( hop_index(1:5, 1:5, 1, 2, ~.x), list(1:2) ) expect_equal( hop_index(1:2, 1:2, c(1, 1, 2), c(1, 2, 2), ~.x), list(1L, 1:2, 2L) ) }) test_that("out of bounds .starts/.stops result in NULLs", { expect_equal( hop_index(1:2, 1:2, 3, 4, ~.x), list(integer()) ) expect_equal( hop_index(1:2, 1:2, c(3, 4), c(4, 6), ~.x), list(integer(), integer()) ) expect_equal( hop_index(1:2, 1:2, c(-1, 4), c(0, 6), ~.x), list(integer(), integer()) ) expect_equal( hop_index(1:2, 1:2, c(-1, 1, 4), c(0, 2, 6), ~.x), list(integer(), 1:2, integer()) ) }) test_that("indexing into gaps in an irregular .i results in 0 size .x values", { expect_equal( hop_index(1:4, c(1, 2, 5, 6), 3, 4, ~.x), list(integer()) ) expect_equal( hop_index(1:4, c(1, 2, 5, 6), c(3, 3, 3), c(3, 4, 5), ~.x), list(integer(), integer(), 3) ) }) test_that("duplicated .starts/.stops pairs are allowed", { expect_equal( hop_index(1:4, 1:4, c(1, 2, 2), c(2, 2, 2), ~.x), list( 1:2, 2L, 2L ) ) }) # ------------------------------------------------------------------------------ # nonexistant dates with lubridate::months() test_that("can use `%m-%` and `add_with_rollback()` to solve month rollback issues", { requireNamespace("lubridate", quietly = TRUE) `%m-%` <- lubridate::`%m-%` i <- vec_c(as.Date("2019-02-27") + 0:3, as.Date("2019-03-27") + 0:5) x <- seq_along(i) starts <- i %m-% months(1) stops <- i # 3/27 rollback to 2/27 # 3/28 rollback to 2/28 # 3/29 rollback to 2/28 # 3/30 rollback to 2/28 # 3/31 rollback to 2/28 # 4/01 rollback to 3/01 expect_equal( hop_index(x, i, starts, stops, identity), list( 1L, 1:2, 1:3, 1:4, 1:5, 2:6, 2:7, 2:8, 2:9, 3:10 ) ) starts <- lubridate::add_with_rollback(i, -months(1), roll_to_first = TRUE) stops <- i # 3/27 rollback to 2/27 # 3/28 rollback to 2/28 # 3/29 rollback to 2/28 then forward to 3/01 # 3/30 rollback to 2/28 then forward to 3/01 # 3/31 rollback to 2/28 then forward to 3/01 # 4/01 rollback to 3/01 expect_equal( hop_index(x, i, starts, stops, identity), list( 1L, 1:2, 1:3, 1:4, 1:5, 2:6, 3:7, 3:8, 3:9, 3:10 ) ) }) # ------------------------------------------------------------------------------ # data frame indices test_that("can order by two vectors using a data frame", { i <- data.frame( date1 = new_date(c(0, 3, 4, 5)), date2 = new_date(c(0, 1, 2, 4)) ) before <- data.frame(date1 = 2, date2 = 1) starts <- i - vec_recycle(before, vec_size(i)) stops <- i # NOTE - This is a bit tricky. It always tries to determine the comparison # order using the first column that it comes across. If the values are equal, # only then will it look to the second column expect_equal( hop_index(i, i, starts, stops, ~.x), list( # At row 1, subtracting makes no difference # Return row 1 vec_slice(i, 1L), # "1970-01-04" - 2 days = "1970-01-02" # "1970-01-02" > "1970-01-01". Done. # Return row 2 vec_slice(i, 2L), # "1970-01-05" - 2 days = "1970-01-03" # "1970-01-03" < "1970-01-04" so use row 2 # "1970-01-03" > "1970-01-01" so don't use row 1 # Return row 2 and 3 vec_slice(i, 2:3), # "1970-01-06" - 2 days = "1970-01-04" # "1970-01-04" < "1970-01-05" so use row 3 # "1970-01-04" = "1970-01-04" so look to column 2 # "1970-01-05" - 1 day = "1970-01-04" (col 2) # "1970-01-04" > "1970-01-02" so don't use row 2 # Return row 3 and 4 vec_slice(i, 3:4) ) ) }) test_that("can use a data frame index where the first column breaks ties (#133)", { i <- vec_c( data.frame(year = 2019, month = c(4, 5, 5, 6, 7, 8)), data.frame(year = 2020, month = 1:4) ) starts <- data.frame(year = 2019, month = 5:6) stops <- data.frame(year = 2020, month = 2:3) expect_identical( hop_index(i, i, starts, stops, identity), list( vec_slice(i, 2:8), vec_slice(i, 4:9) ) ) }) test_that("can select no rows when using a data frame index", { i <- data.frame(year = 2020, month = 2) starts <- data.frame(year = 2020, month = 3) stops <- data.frame(year = 2020, month = 4) expect_identical( hop_index(i, i, starts, stops, identity), list(vec_slice(i, NULL)) ) }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- as.list(names) expect_equal(hop_index(x, 1:5, 1:5, 1:5, ~names(.x)), exp) }) test_that("names are never placed on the output", { x <- set_names(1:5, letters[1:5]) expect_null(names(hop_index(x, 1:5, 1:5, 1:5, ~.x))) }) slider/tests/testthat/test-hop2.R0000644000176200001440000000163613663762054016530 0ustar liggesuserstest_that("Recycling is carried out using tidyverse recycling rules", { x0 <- integer() x1 <- 1L x2 <- c(2L, 2L) x3 <- c(3L, 3L, 3L) expect_equal(hop2(x0, x0, integer(), integer(), ~.x), list()) expect_equal(hop2(x0, x1, 1, 1, ~.x), list(integer())) expect_equal(hop2(x0, x1, integer(), integer(), ~.x), list()) expect_error(hop2(x0, x2, 1:2, 1:2, ~.x), class = "vctrs_error_incompatible_size") expect_equal(hop2(x1, x1, 1, 1, ~.x), list(x1)) expect_equal(hop2(x1, x2, 1:2, 1:2, ~.x), list(x1, x1)) expect_error(hop2(x2, x3, 1:2, 1:2, ~.x), class = "vctrs_error_incompatible_size") }) test_that("hop2() forces arguments in the same way as base R / map2()", { f_slide <- hop2(1:2, 1:2, 1:2, 1:2, function(i, j) function(x) x + i + j) f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/test-slide2-vec.R0000644000176200001440000001052714024427556017611 0ustar liggesusers# ------------------------------------------------------------------------------ # slide2_*() test_that("slide2_*() works", { expect_identical(slide2_vec(1L, 1L, ~.x + .y), 2L) expect_identical(slide2_int(1L, 1L, ~.x + .y), 2L) }) test_that("slide2_*() retains names of x", { expect_identical(slide2_vec(c(x = 1L), c(y = 1L), ~.x + .y), c(x = 2L)) expect_identical(slide2_int(c(x = 1L), c(y = 1L), ~.x + .y), c(x = 2L)) }) test_that("slide2_vec() can simplify automatically", { expect_identical(slide2_vec(1, 2, ~.x + .y, .ptype = NULL), 3) }) test_that("slide2_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( slide2_vec(1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("slide2_*() errors if it can't cast", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( slide2_int(1:2, 1:2, fn), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide2_int() works", { expect_identical(slide2_int(1L, 1L, ~.x + .y), 2L) }) test_that("slide2_int() can coerce", { expect_identical(slide2_int(1, 1, ~.x + .y), 2L) }) test_that("slide2_dbl() works", { expect_identical(slide2_dbl(1, 1, ~.x), 1) }) test_that("slide2_dbl() can coerce", { expect_identical(slide2_dbl(1L, 1L, ~.x + .y), 2) }) test_that("slide2_chr() works", { expect_identical(slide2_chr("x", 1, ~.x), "x") }) test_that("slide2_chr() cannot coerce", { expect_error(slide2_chr(1, 1, ~.x + .y), class = "vctrs_error_incompatible_type") }) test_that("slide2_lgl() works", { expect_identical(slide2_lgl(TRUE, 1, ~.x), TRUE) }) test_that("slide2_lgl() can coerce", { expect_identical(slide2_lgl(1, 0, ~.x + .y), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide2_dfr() works", { expect_identical( slide2_dfr( 1:2, 1:2, ~new_data_frame(list(x = list(.x), y = list(.y))), .before = 1 ), data_frame( x = list(1L, 1:2), y = list(1L, 1:2) ) ) }) test_that("slide2_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( slide2_dfc(x, x, fn, .before = 1), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` is size stable (#78)", { expect_length(slide2_vec(1:4, 1:4, ~.x, .step = 2), 4) expect_length(slide2_vec(1:4, 1:4, ~1, .before = 1, .complete = TRUE), 4) }) test_that("`slide2_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide2_vec(1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide2_vec(1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide2_vec(1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(slide2_vec(1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .step test_that(".step produces typed `NA` values", { expect_identical(slide2_int(1:3, 1:3, ~.x, .step = 2), c(1L, NA, 3L)) expect_identical(slide2_dbl(1:3, 1:3, ~.x, .step = 2), c(1, NA, 3)) expect_identical(slide2_chr(c("a", "b", "c"), 1:3, ~.x, .step = 2), c("a", NA, "c")) expect_identical(slide2_vec(1:3, 1:3, ~.x, .step = 2), c(1L, NA, 3L)) expect_identical(slide2_vec(1:3, 1:3, ~.x, .step = 2, .ptype = integer()), c(1L, NA, 3L)) }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(slide2_int(1:3, 1:3, ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(slide2_dbl(1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide2_chr(1:3, 1:3, ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(slide2_vec(1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide2_vec(1:3, 1:3, ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) slider/tests/testthat/test-slide-index2-vec.R0000644000176200001440000001037214024427556020714 0ustar liggesusers# ------------------------------------------------------------------------------ # slide_index2_*() test_that("slide_index2_*() works", { expect_identical(slide_index2_vec(1L, 1L, 1, ~.x + .y), 2L) expect_identical(slide_index2_int(1L, 1L, 1, ~.x + .y), 2L) }) test_that("slide_index2_*() retains names of x", { expect_identical(slide_index2_vec(c(x = 1L), c(y = 1L), 1, ~.x + .y), c(x = 2L)) expect_identical(slide_index2_int(c(x = 1L), c(y = 1L), 1, ~.x + .y), c(x = 2L)) }) test_that("slide_index2_vec() can simplify automatically", { expect_identical(slide_index2_vec(1, 2, 1, ~.x + .y, .ptype = NULL), 3) }) test_that("slide_index2_*() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( slide_index2_vec(1:2, 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) expect_error( slide_index2_int(1:2, 1:2, 1:2, fn), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide_index2_int() works", { expect_equal(slide_index2_int(1L, 1L, 1, ~.x), 1L) }) test_that("slide_index2_int() can coerce", { expect_equal(slide_index2_int(1, 1, 1, ~.x), 1L) }) test_that("slide_index2_dbl() works", { expect_equal(slide_index2_dbl(1, 1, 1, ~.x), 1) }) test_that("slide_index2_dbl() can coerce", { expect_equal(slide_index2_dbl(1L, 1, 1, ~.x), 1) }) test_that("slide_index2_chr() works", { expect_equal(slide_index2_chr("x", 1, 1, ~.x), "x") }) test_that("slide_index2_chr() cannot coerce", { expect_error(slide_index2_chr(1, 1, 1, ~.x), class = "vctrs_error_incompatible_type") }) test_that("slide_index2_lgl() works", { expect_equal(slide_index2_lgl(TRUE, 1, 1, ~.x), TRUE) }) test_that("slide_index2_lgl() can coerce", { expect_equal(slide_index2_lgl(1, 1, 1, ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide_index2_dfr() works", { expect_identical( slide_index2_dfr( 1:2, 1:2, 1:2, ~new_data_frame(list(x = list(.x), y = list(.y))), .before = 1 ), data_frame( x = list(1L, 1:2), y = list(1L, 1:2) ) ) }) test_that("pslide_index_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( slide_index2_dfc( 1:2, 1:2, 1:2, fn, .before = 1 ), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` is size stable (#78)", { expect_length(slide_index2_vec(1:4, 1:4, 1:4, ~1, .before = 1, .complete = TRUE), 4) }) test_that("size 0 inputs returns .ptype", { expect_identical(slide_index2_vec(integer(), integer(), integer(), ~.x, .ptype = NULL), NULL) expect_identical(slide_index2_vec(integer(), integer(), integer(), ~.x, .ptype = double()), double()) }) test_that("`slide_index2_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide_index2_vec(1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide_index2_vec(1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide_index2_vec(1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(slide_index2_vec(1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(slide_index2_int(1:3, 1:3, 1:3, ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(slide_index2_dbl(1:3, 1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_index2_chr(1:3, 1:3, 1:3, ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(slide_index2_vec(1:3, 1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_index2_vec(1:3, 1:3, 1:3, ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) slider/tests/testthat/test-pslide-vec.R0000644000176200001440000001104114024427556017677 0ustar liggesusers# ------------------------------------------------------------------------------ # pslide_*() test_that("pslide_*() works", { expect_identical(pslide_vec(list(1L, 1L), ~.x + .y), 2L) expect_identical(pslide_int(list(1L, 1L), ~.x + .y), 2L) }) test_that("pslide_*() retains names of first input", { expect_identical(pslide_vec(list(c(x = 1L), c(y = 1L)), ~.x + .y), c(x = 2L)) expect_identical(pslide_int(list(c(x = 1L), c(y = 1L)), ~.x + .y), c(x = 2L)) }) test_that("pslide_vec() can simplify automatically", { expect_identical(pslide_vec(list(1, 2), ~.x + .y, .ptype = NULL), 3) }) test_that("pslide_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( pslide_vec(list(1:2, 1:2), fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("pslide_*() errors if it can't cast", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( pslide_int(list(1:2, 1:2), fn), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # suffix tests test_that("pslide_int() works", { expect_identical(pslide_int(list(1L, 1L), ~.x + .y), 2L) }) test_that("pslide_int() can coerce", { expect_identical(pslide_int(list(1, 1), ~.x + .y), 2L) }) test_that("pslide_dbl() works", { expect_identical(pslide_dbl(list(1, 1), ~.x), 1) }) test_that("pslide_dbl() can coerce", { expect_identical(pslide_dbl(list(1L, 1L), ~.x + .y), 2) }) test_that("pslide_chr() works", { expect_identical(pslide_chr(list("x", 1), ~.x), "x") }) test_that("pslide_chr() cannot coerce", { expect_error(pslide_chr(list(1, 1), ~.x + .y), class = "vctrs_error_incompatible_type") }) test_that("pslide_lgl() works", { expect_identical(pslide_lgl(list(TRUE, 1), ~.x), TRUE) }) test_that("pslide_lgl() can coerce", { expect_identical(pslide_lgl(list(1, 0), ~.x + .y), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("pslide_dfr() works", { expect_identical( pslide_dfr( list(1:2, 1:2), ~new_data_frame(list(x = list(.x), y = list(.y))), .before = 1 ), data_frame( x = list(1L, 1:2), y = list(1L, 1:2) ) ) }) test_that("pslide_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( pslide_dfc(list(x, x), fn, .before = 1), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` is size stable (#78)", { expect_length(pslide_vec(list(1:4, 1:4), ~.x, .step = 2), 4) expect_length(pslide_vec(list(1:4, 1:4), ~1, .before = 1, .complete = TRUE), 4) }) test_that("`pslide_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(pslide_vec(list(1:3, 1:3), ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(pslide_vec(list(1:3, 1:3), ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(pslide_vec(list(1:3, 1:3), ~foobar(.x)), foobar(1:3)) expect_condition(pslide_vec(list(1:3, 1:3), ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .step test_that(".step produces typed `NA` values", { expect_identical(pslide_int(list(1:3, 1:3), ~.x, .step = 2), c(1L, NA, 3L)) expect_identical(pslide_dbl(list(1:3, 1:3), ~.x, .step = 2), c(1, NA, 3)) expect_identical(pslide_chr(list(c("a", "b", "c"), 1:3), ~.x, .step = 2), c("a", NA, "c")) expect_identical(pslide_vec(list(1:3, 1:3), ~.x, .step = 2), c(1L, NA, 3L)) expect_identical(pslide_vec(list(1:3, 1:3), ~.x, .step = 2, .ptype = integer()), c(1L, NA, 3L)) }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(pslide_int(list(1:3, 1:3), ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(pslide_dbl(list(1:3, 1:3), ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(pslide_chr(list(1:3, 1:3), ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(pslide_vec(list(1:3, 1:3), ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(pslide_vec(list(1:3, 1:3), ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) slider/tests/testthat/test-slide-index-vec.R0000644000176200001440000001317614024427556020637 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( slide_index_vec(1:2, 1:2, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) expect_error( slide_index_dbl(1:2, 1:2, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( slide_index_vec(1:2, 1:2, ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( slide_index_vec(1:2, 1:2, ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) test_that("type of suffixed versions can be restricted", { expect_error( slide_index_dbl(1:2, 1:2, ~if (.x == 1L) {1} else {"hi"}), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(slide_index_vec(1, 1, ~.x), 1) expect_equal(slide_index_vec(1, 1, ~.x, .ptype = int()), 1L) expect_error(slide_index_vec(1, 1, ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( slide_index_vec(1, 1, ~.x, .ptype = NULL), slide_index_vec(1, 1, ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( slide_index_vec(1:2, 1:2, ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( slide_index_vec(1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) }) test_that("size 0 `.x` returns .ptype", { expect_identical(slide_index_vec(integer(), integer(), ~.x, .ptype = NULL), NULL) expect_identical(slide_index_vec(integer(), integer(), ~.x, .ptype = double()), double()) }) test_that("`.ptype = NULL` is size stable (#78)", { expect_length(slide_index_vec(1:4, 1:4, ~1, .before = 1, .complete = TRUE), 4) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( slide_index_vec(Sys.Date() + 1:5, 1:5, ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( slide_index_vec(1:5, 1:5, ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`slide_index_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide_index_vec(1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide_index_vec(1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide_index_vec(1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(slide_index_vec(1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(slide_index_int(1:3, 1:3, ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(slide_index_dbl(1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_index_chr(1:3, 1:3, ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(slide_index_vec(1:3, 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(slide_index_vec(1:3, 1:3, ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide_index_int() works", { expect_equal(slide_index_int(1L, 1L, ~.x), 1L) }) test_that("slide_index_int() can coerce", { expect_equal(slide_index_int(1, 1, ~.x), 1L) }) test_that("slide_index_dbl() works", { expect_equal(slide_index_dbl(1, 1, ~.x), 1) }) test_that("slide_index_dbl() can coerce", { expect_equal(slide_index_dbl(1L, 1, ~.x), 1) }) test_that("slide_index_chr() works", { expect_equal(slide_index_chr("x", 1, ~.x), "x") }) test_that("slide_index_chr() cannot coerce", { expect_error(slide_index_chr(1, 1, ~.x), class = "vctrs_error_incompatible_type") }) test_that("slide_index_lgl() works", { expect_equal(slide_index_lgl(TRUE, 1, ~.x), TRUE) }) test_that("slide_index_lgl() can coerce", { expect_equal(slide_index_lgl(1, 1, ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide_index_dfr() works", { expect_identical( slide_index_dfr( 1:2, 1:2, ~new_data_frame(list(x = list(.x))), .before = 1 ), data_frame( x = list(1L, 1:2) ) ) }) test_that("slide_index_dfc() works", { x <- 1:2 fn <- function(x) { if (length(x) == 1) { data.frame(x1 = x) } else { data.frame(x2 = x) } } expect_identical( slide_index_dfc( 1:2, 1:2, fn, .before = 1 ), data.frame( x1 = c(1L, 1L), x2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # recycling test_that("size 1 results are recycled when there are repeated indices", { i <- c(1, 1, 2, 3, 3) x <- seq_along(i) expect_equal( slide_index_dbl(x, i, mean), vapply(vec_slice(vec_split(x, i)$val, i), mean, double(1)) ) }) slider/tests/testthat/helper-date.R0000644000176200001440000000010713606126254017056 0ustar liggesusersnew_date <- function(x = double()) { vctrs::new_date(as.double(x)) } slider/tests/testthat/test-phop-index-vec.R0000644000176200001440000000574014024427556020503 0ustar liggesusers# ------------------------------------------------------------------------------ # phop_index_vec test_that("phop_index_vec() works", { expect_identical(phop_index_vec(list(1L, 1L), 1, 1, 1, ~.x + .y), 2L) }) test_that("phop_index_vec() doesn't retains names of first input (#75)", { expect_named(phop_index_vec(list(c(x = 1L), c(y = 1L)), 1, 1, 1, ~.x + .y), NULL) }) test_that("phop_index_vec() can simplify automatically", { expect_identical(phop_index_vec(list(1, 2), 1, 1, 1, ~.x + .y, .ptype = NULL), 3) }) test_that("phop_index_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("completely empty input returns ptype", { expect_equal(phop_index_vec(list(), integer(), integer(), integer(), ~.x), NULL) expect_equal(phop_index_vec(list(), integer(), integer(), integer(), ~.x, .ptype = list()), list()) expect_equal(phop_index_vec(list(), integer(), integer(), integer(), ~.x, .ptype = int()), int()) }) test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` ptype", { expect_identical( phop_index_vec(list(), integer(), 1:2, 2:3, ~2, .ptype = int()), c(2L, 2L) ) expect_identical( phop_index_vec(list(), integer(), 1:2, 2:3, ~2, .ptype = NULL), c(2, 2) ) }) test_that("can't access non-existant `.x` with empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`", { # Note: Error message seems platform dependent expect_error(phop_index_vec(list(), integer(), 1:2, 2:3, ~.x, .ptype = int())) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("size 0 `.starts` / `.stops` returns size 0 `.ptype`", { expect_identical( phop_index_vec(list(1:5), 1:5, integer(), integer(), ~.x, .ptype = NULL), NULL ) expect_identical( phop_index_vec(list(1:5), 1:5, integer(), integer(), ~.x, .ptype = double()), double() ) }) test_that("`phop_index_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) slider/tests/testthat/test-slide-period2.R0000644000176200001440000000177313704130176020312 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { expect_equal( slide_period2( .x = integer(), .y = integer(), .i = structure(numeric(), class = "Date"), .period = "day", .f = ~.x ), list() ) expect_equal( slide_period2( .x = integer(), .y = 1, .i = structure(numeric(), class = "Date"), .period = "day", .f = ~.x ), list() ) expect_equal( slide_period2( .x = 1, .y = integer(), .i = structure(numeric(), class = "Date"), .period = "day", .f = ~.x ), list() ) expect_error( slide_period2( .x = integer(), .y = integer(), .i = structure(0, class = "Date"), .period = "day", .f = ~.x ), class = "slider_error_index_incompatible_size" ) }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(slide_period2(integer(), integer(), new_date(), "year", ~.x, .complete = TRUE), list()) }) slider/tests/testthat/test-slide-index2.R0000644000176200001440000000132313656543542020141 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { expect_equal(slide_index2(integer(), integer(), integer(), ~.x), list()) expect_equal(slide_index2(integer(), 1, integer(), ~.x), list()) expect_equal(slide_index2(1, integer(), integer(), ~.x), list()) expect_error(slide_index2(integer(), integer(), 1, ~.x), class = "slider_error_index_incompatible_size") }) test_that("slide_index2() forces arguments in the same way as base R / map2()", { f_slide <- slide_index2(1:2, 1:2, 1:2, function(i, j) function(x) x + i + j) f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/test-hop-vec.R0000644000176200001440000000631014024427556017210 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( hop_vec(1:2, 1, 1, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( hop_vec(1:2, 1:2, 1:2, ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( hop_vec(1:2, 1:2, 1:2, ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(hop_vec(1, 1, 1, ~.x), 1) expect_equal(hop_vec(1, 1, 1, ~.x, .ptype = int()), 1L) expect_error(hop_vec(1, 1, 1, ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( hop_vec(1, 1, 1, ~.x, .ptype = NULL), hop_vec(1, 1, 1, ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( hop_vec(1:2, 1:2, 1:2, ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( hop_vec(1:2, 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( hop_vec(1:2, 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { expect_equal(hop_vec(integer(), integer(), integer(), ~.x, .ptype = NULL), NULL) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( hop_vec(Sys.Date() + 1:5, 1:5, 1:5, ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( hop_vec(1:5, 1:5, 1:5, ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`hop_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(hop_vec(1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(hop_vec(1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(hop_vec(1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(hop_vec(1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- as.list(names) expect_equal(hop_vec(x, 1:5, 1:5, ~list(names(.x))), exp) }) test_that("names are never placed on the output", { x <- set_names(1:5, letters[1:5]) expect_null(names(hop_vec(x, 1:5, 1:5, ~.x))) expect_null(names(hop_vec(x, 1:5, 1:5, ~.x, .ptype = int()))) }) slider/tests/testthat/test-pslide-period.R0000644000176200001440000000140113704130246020372 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { i <- new_date() expect_equal(pslide_period(list(integer(), integer()), i, "day", ~.x), list()) expect_equal(pslide_period(list(integer(), 1), i, "day", ~.x), list()) expect_equal(pslide_period(list(1, integer()), i, "day", ~.x), list()) i <- new_date(0) expect_error(pslide_period(list(integer(), integer()), i, "day", ~.x), class = "slider_error_index_incompatible_size") }) test_that("completely empty input returns a list", { expect_equal(pslide_period(list(), new_date(), "day", ~.x), list()) }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(pslide_period(list(integer(), integer()), new_date(), "year", ~.x, .complete = TRUE), list()) }) slider/tests/testthat/_snaps/0000755000176200001440000000000014024427556016032 5ustar liggesusersslider/tests/testthat/_snaps/slide-index.md0000644000176200001440000000222514067407076020564 0ustar liggesusers# .before/.after - generated endpoints must be in weakly ascending order Endpoints generated by `.before` must be in ascending order. i They are not ascending at locations: 2. --- Endpoints generated by `.after` must be in ascending order. i They are not ascending at locations: 2. # .before/.after - generated endpoints must maintain .before <= .after ordering In the ranges generated by `.before` and `.after`, the start of the range is after the end of the range at location(s): 1, 2. --- In the ranges generated by `.before` and `.after`, the start of the range is after the end of the range at location(s): 1, 2. # .before/.after - generated endpoints can't be NA Endpoints generated by `.before` cannot be `NA`. i They are `NA` at locations: 1, 2. --- Endpoints generated by `.after` cannot be `NA`. i They are `NA` at locations: 1, 2. # .before/.after - generated endpoints shouldn't rely on original `.i` length Endpoints generated by `.before` have an incorrect size. i They must have size 1, not 2. --- Endpoints generated by `.after` have an incorrect size. i They must have size 1, not 2. slider/tests/testthat/test-summary-index.R0000644000176200001440000004736514024427556020470 0ustar liggesusers# ------------------------------------------------------------------------------ # slide_index_sum() test_that("integer before works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_sum(x, i, before = 1), slide_index_dbl(x, i, sum, .before = 1)) expect_identical(slide_index_sum(x, i, before = 2), slide_index_dbl(x, i, sum, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_sum(x, i, after = 1), slide_index_dbl(x, i, sum, .after = 1)) expect_identical(slide_index_sum(x, i, after = 2), slide_index_dbl(x, i, sum, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_sum(x, i, before = -1, after = 2), slide_index_dbl(x, i, sum, .before = -1, .after = 2)) expect_identical(slide_index_sum(x, i, before = 2, after = -1), slide_index_dbl(x, i, sum, .before = 2, .after = -1)) expect_identical(slide_index_sum(x, i, before = -1, after = 2, complete = TRUE), slide_index_dbl(x, i, sum, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_sum(x, i, before = 2, after = -1, complete = TRUE), slide_index_dbl(x, i, sum, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_sum(x, i, before = Inf), slide_index_dbl(x, i, sum, .before = Inf)) expect_identical(slide_index_sum(x, i, after = Inf), slide_index_dbl(x, i, sum, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) i <- seq_along(x) expect_identical( slide_index_sum(x, i, before = 3), slide_index_dbl(x, i, sum, .before = 3) ) expect_identical( slide_index_sum(y, i, before = 3), slide_index_dbl(y, i, sum, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_index_sum(rev(y), i, before = 3), # slide_index_dbl(rev(y), i, sum, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_index_sum(x, 1, na_rm = TRUE), 0) expect_identical(slide_index_sum(y, 1:4, na_rm = TRUE, before = 1), c(1, 1, 2, 5)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) i <- seq_along(x) expect_identical(slide_index_sum(x, i, before = 1), c(1, Inf, NaN, -Inf)) }) # ------------------------------------------------------------------------------ # slide_index_prod() test_that("integer before works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_prod(x, i, before = 1), slide_index_dbl(x, i, prod, .before = 1)) expect_identical(slide_index_prod(x, i, before = 2), slide_index_dbl(x, i, prod, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_prod(x, i, after = 1), slide_index_dbl(x, i, prod, .after = 1)) expect_identical(slide_index_prod(x, i, after = 2), slide_index_dbl(x, i, prod, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_prod(x, i, before = -1, after = 2), slide_index_dbl(x, i, prod, .before = -1, .after = 2)) expect_identical(slide_index_prod(x, i, before = 2, after = -1), slide_index_dbl(x, i, prod, .before = 2, .after = -1)) expect_identical(slide_index_prod(x, i, before = -1, after = 2, complete = TRUE), slide_index_dbl(x, i, prod, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_prod(x, i, before = 2, after = -1, complete = TRUE), slide_index_dbl(x, i, prod, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_prod(x, i, before = Inf), slide_index_dbl(x, i, prod, .before = Inf)) expect_identical(slide_index_prod(x, i, after = Inf), slide_index_dbl(x, i, prod, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) i <- seq_along(x) expect_identical( slide_index_prod(x, i, before = 3), slide_index_dbl(x, i, prod, .before = 3) ) expect_identical( slide_index_prod(y, i, before = 3), slide_index_dbl(y, i, prod, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_index_prod(rev(y), i, before = 3), # slide_index_dbl(rev(y), i, prod, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_index_prod(x, 1, na_rm = TRUE), 1) expect_identical(slide_index_prod(y, 1:4, na_rm = TRUE, before = 1), c(1, 1, 2, 6)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 0) expect_identical(slide_index_prod(x, 1:4, before = 1), c(1, Inf, -Inf, NaN)) }) # ------------------------------------------------------------------------------ # slide_index_mean() test_that("integer before works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_mean(x, i, before = 1), slide_index_dbl(x, i, mean, .before = 1)) expect_identical(slide_index_mean(x, i, before = 2), slide_index_dbl(x, i, mean, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_mean(x, i, after = 1), slide_index_dbl(x, i, mean, .after = 1)) expect_identical(slide_index_mean(x, i, after = 2), slide_index_dbl(x, i, mean, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_mean(x, i, before = -1, after = 2), slide_index_dbl(x, i, mean, .before = -1, .after = 2)) expect_identical(slide_index_mean(x, i, before = 2, after = -1), slide_index_dbl(x, i, mean, .before = 2, .after = -1)) expect_identical(slide_index_mean(x, i, before = -1, after = 2, complete = TRUE), slide_index_dbl(x, i, mean, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_mean(x, i, before = 2, after = -1, complete = TRUE), slide_index_dbl(x, i, mean, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_mean(x, i, before = Inf), slide_index_dbl(x, i, mean, .before = Inf)) expect_identical(slide_index_mean(x, i, after = Inf), slide_index_dbl(x, i, mean, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) i <- seq_along(x) expect_identical( slide_index_mean(x, i, before = 3), slide_index_dbl(x, i, mean, .before = 3) ) expect_identical( slide_index_mean(y, i, before = 3), slide_index_dbl(y, i, mean, .before = 3) ) # The NA / NaN ordering is platform dependent # expect_identical( # slide_index_mean(rev(y), i, before = 3), # slide_index_dbl(rev(y), i, mean, .before = 3) # ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_index_mean(x, 1, na_rm = TRUE), NaN) expect_identical(slide_index_mean(y, 1:4, na_rm = TRUE, before = 1), c(1, 1, 2, 2.5)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_index_mean(x, 1:4, before = 1), c(1, Inf, NaN, -Inf)) }) # ------------------------------------------------------------------------------ # slide_index_min() test_that("integer before works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_min(x, i, before = 1), slide_index_dbl(x, i, min, .before = 1)) expect_identical(slide_index_min(x, i, before = 2), slide_index_dbl(x, i, min, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_min(x, i, after = 1), slide_index_dbl(x, i, min, .after = 1)) expect_identical(slide_index_min(x, i, after = 2), slide_index_dbl(x, i, min, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_min(x, i, before = -1, after = 2), c(2, 3, 4, Inf)) expect_identical(slide_index_min(x, i, before = 2, after = -1), c(Inf, 1, 2, 3)) expect_identical(slide_index_min(x, i, before = -1, after = 2, complete = TRUE), slide_index_dbl(x, i, min, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_min(x, i, before = 2, after = -1, complete = TRUE), slide_index_dbl(x, i, min, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_min(x, i, before = Inf), slide_index_dbl(x, i, min, .before = Inf)) expect_identical(slide_index_min(x, i, after = Inf), slide_index_dbl(x, i, min, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) i <- seq_along(x) expect_identical( slide_index_min(x, i, before = 3), slide_index_dbl(x, i, min, .before = 3) ) expect_identical( slide_index_min(y, i, before = 3), slide_index_dbl(y, i, min, .before = 3) ) expect_identical( slide_index_min(rev(y), i, before = 3), slide_index_dbl(rev(y), i, min, .before = 3) ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_index_min(x, 1, na_rm = TRUE), Inf) expect_identical(slide_index_min(y, 1:4, na_rm = TRUE, before = 1), c(1, 1, 2, 2)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_index_min(x, 1:4, before = 1), c(1, 1, -Inf, -Inf)) }) # ------------------------------------------------------------------------------ # slide_index_max() test_that("integer before works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_max(x, i, before = 1), slide_index_dbl(x, i, max, .before = 1)) expect_identical(slide_index_max(x, i, before = 2), slide_index_dbl(x, i, max, .before = 2)) }) test_that("integer after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_max(x, i, after = 1), slide_index_dbl(x, i, max, .after = 1)) expect_identical(slide_index_max(x, i, after = 2), slide_index_dbl(x, i, max, .after = 2)) }) test_that("negative before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_max(x, i, before = -1, after = 2), c(2, 3, 4, -Inf)) expect_identical(slide_index_max(x, i, before = 2, after = -1), c(-Inf, 1, 2, 3)) expect_identical(slide_index_max(x, i, before = -1, after = 2, complete = TRUE), slide_index_dbl(x, i, max, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_max(x, i, before = 2, after = -1, complete = TRUE), slide_index_dbl(x, i, max, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- 1:4 + 0 i <- c(1, 2, 4, 5) expect_identical(slide_index_max(x, i, before = Inf), slide_index_dbl(x, i, max, .before = Inf)) expect_identical(slide_index_max(x, i, after = Inf), slide_index_dbl(x, i, max, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(1, 10), rep(NA, 10), 1:4) y <- c(rep(NA, 10), rep(NaN, 10), 1:4) i <- seq_along(x) expect_identical( slide_index_max(x, i, before = 3), slide_index_dbl(x, i, max, .before = 3) ) expect_identical( slide_index_max(y, i, before = 3), slide_index_dbl(y, i, max, .before = 3) ) expect_identical( slide_index_max(rev(y), i, before = 3), slide_index_dbl(rev(y), i, max, .before = 3) ) }) test_that("`na_rm = TRUE` works", { x <- NA y <- c(1, NA, 2, 3) expect_identical(slide_index_max(x, 1, na_rm = TRUE), -Inf) expect_identical(slide_index_max(y, 1:4, na_rm = TRUE, before = 1), c(1, 1, 2, 3)) }) test_that("Inf and -Inf results are correct", { x <- c(1, Inf, -Inf, 1) expect_identical(slide_index_max(x, 1:4, before = 1), c(1, Inf, Inf, 1)) }) # ------------------------------------------------------------------------------ # slide_index_all() test_that("integer before works", { x <- c(TRUE, FALSE, TRUE, TRUE) i <- c(1, 2, 4, 5) expect_identical(slide_index_all(x, i, before = 1), slide_index_lgl(x, i, all, .before = 1)) expect_identical(slide_index_all(x, i, before = 2), slide_index_lgl(x, i, all, .before = 2)) }) test_that("integer after works", { x <- c(TRUE, FALSE, TRUE, TRUE) i <- c(1, 2, 4, 5) expect_identical(slide_index_all(x, i, after = 1), slide_index_lgl(x, i, all, .after = 1)) expect_identical(slide_index_all(x, i, after = 2), slide_index_lgl(x, i, all, .after = 2)) }) test_that("negative before/after works", { x <- c(TRUE, FALSE, TRUE, TRUE) i <- c(1, 2, 4, 5) expect_identical(slide_index_all(x, i, before = -1, after = 2), slide_index_lgl(x, i, all, .before = -1, .after = 2)) expect_identical(slide_index_all(x, i, before = 2, after = -1), slide_index_lgl(x, i, all, .before = 2, .after = -1)) expect_identical(slide_index_all(x, i, before = -1, after = 2, complete = TRUE), slide_index_lgl(x, i, all, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_all(x, i, before = 2, after = -1, complete = TRUE), slide_index_lgl(x, i, all, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- c(TRUE, FALSE, TRUE, TRUE) i <- c(1, 2, 4, 5) expect_identical(slide_index_all(x, i, before = Inf), slide_index_lgl(x, i, all, .before = Inf)) expect_identical(slide_index_all(x, i, after = Inf), slide_index_lgl(x, i, all, .after = Inf)) }) test_that("NA / NaN results are correct", { x <- c(rep(TRUE, 10), rep(NA, 10), c(TRUE, TRUE, FALSE, TRUE)) i <- seq_along(x) expect_identical( slide_index_all(x, i, before = 3), slide_index_lgl(x, i, all, .before = 3) ) }) test_that("FALSE dominates NAs, matching all()", { i <- c(1, 2, 3) x <- c(NA, FALSE, FALSE) expect_identical(slide_index_all(x, i, before = 2), c(NA, FALSE, FALSE)) expect_identical(slide_index_all(x, i, before = 2), slide_index_lgl(x, i, all, .before = 2)) x <- c(FALSE, NA, FALSE) expect_identical(slide_index_all(x, i, before = 2), c(FALSE, FALSE, FALSE)) expect_identical(slide_index_all(x, i, before = 2), slide_index_lgl(x, i, all, .before = 2)) x <- c(FALSE, FALSE, NA) expect_identical(slide_index_all(x, i, before = 2), c(FALSE, FALSE, FALSE)) expect_identical(slide_index_all(x, i, before = 2), slide_index_lgl(x, i, all, .before = 2)) }) test_that("`na_rm = TRUE` works", { x <- NA i <- 1L expect_identical(slide_index_all(x, i, na_rm = TRUE), TRUE) y <- c(TRUE, NA, FALSE, NA, TRUE) i <- seq_along(y) expect_identical(slide_index_all(y, i, na_rm = TRUE, before = 1), slide_index_lgl(y, i, all, na.rm = TRUE, .before = 1)) }) test_that("works when the window is completely OOB", { x <- c(TRUE, FALSE, NA) i <- seq_along(x) expect_identical(slide_index_all(x, i, before = 4, after = -4), c(TRUE, TRUE, TRUE)) expect_identical(slide_index_all(x, i, before = 4, after = -4), slide_index_lgl(x, i, all, .before = 4, .after = -4)) }) test_that("input must be castable to logical", { expect_error(slide_index_all(1:5, 1:5), class = "vctrs_error_cast_lossy") }) # ------------------------------------------------------------------------------ # slide_index_any() test_that("integer before works", { x <- c(FALSE, TRUE, FALSE, FALSE) i <- c(1, 2, 4, 5) expect_identical(slide_index_any(x, i, before = 1), slide_index_lgl(x, i, any, .before = 1)) expect_identical(slide_index_any(x, i, before = 2), slide_index_lgl(x, i, any, .before = 2)) }) test_that("integer after works", { x <- c(FALSE, TRUE, FALSE, FALSE) i <- c(1, 2, 4, 5) expect_identical(slide_index_any(x, i, after = 1), slide_index_lgl(x, i, any, .after = 1)) expect_identical(slide_index_any(x, i, after = 2), slide_index_lgl(x, i, any, .after = 2)) }) test_that("negative before/after works", { x <- c(FALSE, TRUE, FALSE, FALSE) i <- c(1, 2, 4, 5) expect_identical(slide_index_any(x, i, before = -1, after = 2), slide_index_lgl(x, i, any, .before = -1, .after = 2)) expect_identical(slide_index_any(x, i, before = 2, after = -1), slide_index_lgl(x, i, any, .before = 2, .after = -1)) expect_identical(slide_index_any(x, i, before = -1, after = 2, complete = TRUE), slide_index_lgl(x, i, any, .before = -1, .after = 2, .complete = TRUE)) expect_identical(slide_index_any(x, i, before = 2, after = -1, complete = TRUE), slide_index_lgl(x, i, any, .before = 2, .after = -1, .complete = TRUE)) }) test_that("`Inf` before/after works", { x <- c(FALSE, TRUE, FALSE, FALSE) i <- c(1, 2, 4, 5) expect_identical(slide_index_any(x, i, before = Inf), slide_index_lgl(x, i, any, .before = Inf)) expect_identical(slide_index_any(x, i, after = Inf), slide_index_lgl(x, i, any, .after = Inf)) }) test_that("NA results are correct", { x <- c(rep(FALSE, 10), rep(NA, 10), c(FALSE, FALSE, TRUE, FALSE)) i <- seq_along(x) expect_identical( slide_index_any(x, i, before = 3), slide_index_lgl(x, i, any, .before = 3) ) }) test_that("TRUE dominates NAs, matching any()", { i <- c(1, 2, 3) x <- c(NA, TRUE, TRUE) expect_identical(slide_index_any(x, i, before = 2), c(NA, TRUE, TRUE)) expect_identical(slide_index_any(x, i, before = 2), slide_index_lgl(x, i, any, .before = 2)) x <- c(TRUE, NA, TRUE) expect_identical(slide_index_any(x, i, before = 2), c(TRUE, TRUE, TRUE)) expect_identical(slide_index_any(x, i, before = 2), slide_index_lgl(x, i, any, .before = 2)) x <- c(TRUE, TRUE, NA) expect_identical(slide_index_any(x, i, before = 2), c(TRUE, TRUE, TRUE)) expect_identical(slide_index_any(x, i, before = 2), slide_index_lgl(x, i, any, .before = 2)) }) test_that("`na_rm = TRUE` works", { x <- NA i <- 1L expect_identical(slide_index_any(x, i, na_rm = TRUE), FALSE) y <- c(TRUE, NA, FALSE, NA, TRUE) i <- seq_along(y) expect_identical(slide_index_any(y, i, na_rm = TRUE, before = 1), slide_index_lgl(y, i, any, na.rm = TRUE, .before = 1)) }) test_that("works when the window is completely OOB", { x <- c(TRUE, FALSE, NA) i <- seq_along(x) expect_identical(slide_index_any(x, i, before = 4, after = -4), c(FALSE, FALSE, FALSE)) expect_identical(slide_index_any(x, i, before = 4, after = -4), slide_index_lgl(x, i, any, .before = 4, .after = -4)) }) test_that("input must be castable to logical", { expect_error(slide_index_any(1:5, 1:5), class = "vctrs_error_cast_lossy") }) # ------------------------------------------------------------------------------ # Misc test_that("works with size 0 input", { expect_identical(slide_index_sum(integer(), integer()), double()) expect_identical(slide_index_sum(integer(), integer(), before = 5, after = 1), double()) }) test_that("x and i must be the same size", { expect_error(slide_index_sum(1, 1:3), class = "slider_error_index_incompatible_size") }) test_that("names are kept (even on casting)", { expect_named(slide_index_sum(c(x = 1, y = 2), 1:2, before = 1), c("x", "y")) expect_named(slide_index_sum(c(x = 1L, y = 2L), 1:2, before = 1), c("x", "y")) }) test_that("can cast integer and logical input", { expect_identical(slide_index_sum(1:5, 1:5, before = 1), slide_index_sum(1:5 + 0, 1:5, before = 1)) expect_identical(slide_index_sum(c(TRUE, FALSE, TRUE), 1:3, before = 1), slide_index_sum(c(1, 0, 1), 1:3, before = 1)) }) test_that("types that can't be cast to numeric are not supported", { expect_error(slide_index_sum("x", 1), class = "vctrs_error_incompatible_type") }) test_that("arrays of dimensionality 1 are supported", { expect_identical( slide_index_sum(array(1:5), 1:5, before = 1), slide_index_sum(1:5, 1:5, before = 1) ) }) test_that("arrays of dimensionality >1 are not supported", { expect_error(slide_index_sum(array(1:4, dim = c(2, 2)), 1:2, before = 1), class = "vctrs_error_incompatible_type") }) test_that("works when the window is completely OOB", { expect_identical( slide_index_sum(1:3, 1:3, before = 4, after = -4), c(0, 0, 0) ) }) slider/tests/testthat/test-slide-period2-vec.R0000644000176200001440000001477014024427556021075 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( slide_period2_vec(1:2, 1:2, new_date(c(1, 2)), "day", ~c(.x, .y)), "In iteration 1, the result of `.f` had size 2, not 1" ) expect_error( slide_period2_int(1:2, 1:2, new_date(c(1, 2)), "day", ~c(.x, .y)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( slide_period2_vec(1:2, 1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( slide_period2_vec(1:2, 1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) test_that("type can be restricted", { expect_error( slide_period2_int(1:2, 1:2, new_date(c(1, 2)), "day", ~if (.x == 1L) {1L} else {"hi"}), class = "vctrs_error_incompatible_type" ) }) test_that("empty input works with `.complete = TRUE` (#111)", { expect_equal(slide_period2_dbl(integer(), integer(), new_date(), "year", ~.x, .complete = TRUE), double()) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(slide_period2_vec(1, 1, new_date(0), "day", ~.x), 1) expect_equal(slide_period2_vec(1, 1, new_date(0), "day", ~.x, .ptype = int()), 1L) expect_error(slide_period2_vec(1, 1, new_date(0), "day", ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( slide_period2_vec(1, 1, new_date(0), "day", ~.x, .ptype = NULL), slide_period2_vec(1, 1, new_date(0), "day", ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~if(.x == 1L) {NULL} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { expect_equal(slide_period2_vec(integer(), integer(), new_date(), "day", ~.x, .ptype = NULL), NULL) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( slide_period2_vec(Sys.Date() + 1:5, 1:5, new_date(c(1, 2, 3, 4, 5)), "day", ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("with `.complete = TRUE`, `.ptype` is used to pad", { expect_equal( slide_period2_dbl( 1:3, 1:3, new_date(c(1, 2, 3)), "day", ~1, .before = 1, .complete = TRUE ), c(NA, 1, 1) ) }) test_that("with `.complete = TRUE`, padding is size stable (#93)", { expect_equal( slide_period2_vec( 1:3, 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(NA, 0, 0)) ) expect_equal( slide_period2_vec( 1:3, 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .after = 1, .complete = TRUE, .ptype = new_date() ), new_date(c(0, 0, NA)) ) expect_equal( slide_period2_vec( 1:3, 1:3, new_date(c(1, 2, 3)), "day", ~new_date(0), .before = 1, .complete = TRUE, .ptype = NULL ), new_date(c(NA, 0, 0)) ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( slide_period2_vec(1:5, 1:5, new_date(c(1, 2, 3, 4, 5)), "day", ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`slide_period2_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(slide_period2_vec(1:3, 1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(slide_period2_vec(1:3, 1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(slide_period2_vec(1:3, 1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x)), foobar(1:3)) expect_condition(slide_period2_vec(1:3, 1:3, new_date(c(1, 2, 3)), "day", ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # suffix tests test_that("slide_period2_int() works", { expect_equal(slide_period2_int(1L, 1, new_date(0), "day", ~.x), 1L) }) test_that("slide_period2_int() can coerce", { expect_equal(slide_period2_int(1, 1, new_date(0), "day", ~.x), 1L) }) test_that("slide_period2_dbl() works", { expect_equal(slide_period2_dbl(1, 1, new_date(0), "day", ~.x), 1) }) test_that("slide_period2_dbl() can coerce", { expect_equal(slide_period2_dbl(1L, 1, new_date(0), "day", ~.x), 1) }) test_that("slide_period2_chr() works", { expect_equal(slide_period2_chr("x", 1, new_date(0), "day", ~.x), "x") }) test_that("slide_period2_chr() cannot coerce", { expect_error(slide_period2_chr(1, 1, new_date(0), "day", ~.x), class = "vctrs_error_incompatible_type") }) test_that("slide_period2_lgl() works", { expect_equal(slide_period2_lgl(TRUE, 1, new_date(0), "day", ~.x), TRUE) }) test_that("slide_period2_lgl() can coerce", { expect_equal(slide_period2_lgl(1, 1, new_date(0), "day", ~.x), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("slide_period2_dfr() works", { expect_identical( slide_period2_dfr( 1:2, 1:2, new_date(c(1, 2)), "day", ~new_data_frame(list(x = list(.x))), .before = 1 ), slide_dfr(1:2, ~new_data_frame(list(x = list(.x))), .before = 1) ) }) test_that("slide_period2_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( slide_period2_dfc( 1:2, 1:2, new_date(c(1, 2)), "day", fn, .before = 1 ), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) slider/tests/testthat/test-utils.R0000644000176200001440000000057114024427556017012 0ustar liggesuserstest_that("`is_unbounded()` returns `FALSE` for classed objects", { # We only care about checking if an exact literal `Inf` is supplied. # We don't want to call `is.infinite()` on any object, as vctrs classes # don't support `is.infinite()` by default and error if `is.infinite()` # is called. x <- structure(Inf, class = "foobar") expect_false(is_unbounded(x)) }) slider/tests/testthat/helper-s3.R0000644000176200001440000000073014024142165016462 0ustar liggesusersfoobar <- function(x = list()) { structure(x, class = "slider_foobar") } local_methods <- function(..., .frame = caller_env()) { local_bindings(..., .env = global_env(), .frame = .frame) } local_c_foobar <- function(frame = caller_env()) { local_methods(.frame = frame, c.slider_foobar = function(...) { signal("", class = "slider_c_foobar") xs <- list(...) xs <- lapply(xs, unclass) out <- vec_unchop(xs) foobar(out) } ) } slider/tests/testthat/test-hop-index-vec.R0000644000176200001440000001013514024427556020315 0ustar liggesusers# ------------------------------------------------------------------------------ # type / size strict-ness test_that("size of each `.f` result must be 1", { expect_error( hop_index_vec(1, 1, 1, 1, ~c(.x, 1)), "In iteration 1, the result of `.f` had size 2, not 1" ) }) test_that("inner type is allowed to be different", { expect_equal( hop_index_vec(1:2, 1:2, 1:2, 1:2, ~if (.x == 1L) {list(1)} else {list("hi")}, .ptype = list()), list(1, "hi") ) }) test_that("inner type can be restricted with list_of", { expect_error( hop_index_vec(1:2, 1:2, 1:2, 1:2, ~if (.x == 1L) {list_of(1)} else {list_of("hi")}, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that(".ptype is respected", { expect_equal(hop_index_vec(1, 1, 1, 1, ~.x), 1) expect_equal(hop_index_vec(1, 1, 1, 1, ~.x, .ptype = int()), 1L) expect_error(hop_index_vec(1, 1, 1, 1, ~.x + .5, .ptype = integer()), class = "vctrs_error_cast_lossy") }) test_that("`.ptype = NULL` results in 'guessed' .ptype", { expect_equal( hop_index_vec(1, 1, 1, 1, ~.x, .ptype = NULL), hop_index_vec(1, 1, 1, 1, ~.x, .ptype = dbl()) ) }) test_that("`.ptype = NULL` fails if no common type is found", { expect_error( hop_index_vec(1:2, 1:2, 1:2, 1:2, ~ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( hop_index_vec(1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( hop_index_vec(1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("size 0 `.starts` / `.stops` returns size 0 `.ptype`", { expect_identical( hop_index_vec(1:5, 1:5, integer(), integer(), ~.x, .ptype = NULL), NULL ) expect_identical( hop_index_vec(1:5, 1:5, integer(), integer(), ~.x, .ptype = double()), double() ) }) test_that("`.ptype = NULL` returns `NULL` with one size 0 and one size 1 starts / stops", { expect_equal( hop_index_vec(integer(), integer(), integer(), 1, ~.x, .ptype = NULL), NULL ) expect_equal( hop_index_vec(integer(), integer(), 1, integer(), ~.x, .ptype = NULL), NULL ) }) test_that("`.ptype = NULL` errors with non recyclable starts/stops", { expect_error( hop_index_vec(integer(), integer(), integer(), 1:2, ~.x, .ptype = NULL), class = "vctrs_error_incompatible_size" ) }) test_that(".ptypes with a vec_proxy() are restored to original type", { expect_s3_class( hop_index_vec(Sys.Date() + 1:5, 1:5, 1:5, 1:5, ~.x, .ptype = as.POSIXlt(Sys.Date())), "POSIXlt" ) }) test_that("can return a matrix and rowwise bind the results together", { mat <- matrix(1, ncol = 2) expect_equal( hop_index_vec(1:5, 1:5, 1:5, 1:5, ~mat, .ptype = mat), rbind(mat, mat, mat, mat, mat) ) }) test_that("`hop_index_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(hop_index_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(hop_index_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(hop_index_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(hop_index_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- as.list(names) i <- vec_seq_along(x) expect_equal(hop_index_vec(x, i, i, i, ~list(names(.x))), exp) }) test_that("names are never placed on the output", { names <- letters[1:5] x <- set_names(1:5, names) i <- vec_seq_along(x) expect_null(names(hop_index_vec(x, i, i, i, ~.x))) expect_null(names(hop_index_vec(x, i, i, i, ~.x, .ptype = int()))) }) slider/tests/testthat/test-hop-index2.R0000644000176200001440000000261713656610221017623 0ustar liggesuserstest_that("empty input returns a list, but after the index size check", { expect_equal( hop_index2( .x = integer(), .y = integer(), .i = integer(), .starts = integer(), .stops = integer(), .f = ~.x ), list() ) expect_equal( hop_index2( .x = integer(), .y = 1, .i = integer(), .starts = integer(), .stops = integer(), .f = ~.x ), list() ) expect_equal( hop_index2( .x = 1, .y = integer(), .i = integer(), .starts = integer(), .stops = integer(), .f = ~.x ), list() ) expect_error( hop_index2( .x = integer(), .y = integer(), .i = 1, .starts = integer(), .stops = integer(), .f = ~.x ), class = "slider_error_index_incompatible_size" ) }) test_that("empty `.x` and `.y` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` empty ptype", { expect_equal(hop_index2(integer(), integer(), integer(), 1:2, 2:3, ~.x), list(integer(), integer())) }) test_that("empty `.x` and `.y` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { expect_error(hop_index2(integer(), integer(), integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") expect_error(hop_index2(integer(), integer(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") }) slider/tests/testthat/test-hop2-vec.R0000644000176200001440000000313414024427556017273 0ustar liggesusers# ------------------------------------------------------------------------------ # hop2_vec test_that("hop2_vec() works", { expect_identical(hop2_vec(1L, 1L, 1, 1, ~.x + .y), 2L) }) test_that("hop2_vec() doesn't retains names of x (#75)", { expect_named(hop2_vec(c(x = 1L), c(y = 1L), 1, 1, ~.x + .y), NULL) }) test_that("hop2_vec() can simplify automatically", { expect_identical(hop2_vec(1, 2, 1, 1, ~.x + .y, .ptype = NULL), 3) }) test_that("hop2_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( hop2_vec(1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( hop2_vec(1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( hop2_vec(1:2, 1:2, 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`hop2_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(hop2_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(hop2_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(hop2_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(hop2_vec(1:3, 1:3, 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) slider/tests/testthat/test-phop-vec.R0000644000176200001440000000324214024427556017371 0ustar liggesusers# ------------------------------------------------------------------------------ # phop_vec test_that("phop_vec() works", { expect_identical(phop_vec(list(1L, 1L), 1, 1, ~.x + .y), 2L) }) test_that("phop_vec() doesn't retains names of first input (#75)", { expect_named(phop_vec(list(c(x = 1L), c(y = 1L)), 1, 1, ~.x + .y), NULL) }) test_that("phop_vec() can simplify automatically", { expect_identical(phop_vec(list(1, 2), 1, 1, ~.x + .y, .ptype = NULL), 3) }) test_that("phop_vec() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( phop_vec(list(1:2, 1:2), 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` validates that element lengths are 1", { expect_error( phop_vec(list(1:2, 1:2), 1:2, 1:2, ~if(.x == 1L) {1:2} else {1}, .ptype = NULL), "In iteration 1, the result of `.f` had size 2, not 1." ) expect_error( phop_vec(list(1:2, 1:2), 1:2, 1:2, ~if(.x == 1L) {NULL} else {2}, .ptype = NULL), "In iteration 1, the result of `.f` had size 0, not 1." ) }) test_that("`phop_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(phop_vec(list(1:3, 1:3), 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(phop_vec(list(1:3, 1:3), 1:3, 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(phop_vec(list(1:3, 1:3), 1:3, 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(phop_vec(list(1:3, 1:3), 1:3, 1:3, ~foobar(.x)), class = "slider_c_foobar") }) slider/tests/testthat/test-pslide-index-vec.R0000644000176200001440000001132714024427556021013 0ustar liggesusers# ------------------------------------------------------------------------------ # pslide_index_*() test_that("pslide_index_*() works", { expect_identical(pslide_index_vec(list(1L, 1L), 1, ~.x + .y), 2L) expect_identical(pslide_index_int(list(1L, 1L), 1, ~.x + .y), 2L) }) test_that("pslide_index_*() retains names of first input", { expect_identical(pslide_index_vec(list(c(x = 1L), c(y = 1L)), 1, ~.x + .y), c(x = 2L)) expect_identical(pslide_index_int(list(c(x = 1L), c(y = 1L)), 1, ~.x + .y), c(x = 2L)) }) test_that("pslide_index_vec() can simplify automatically", { expect_identical(pslide_index_vec(list(1, 2), 1, ~.x + .y, .ptype = NULL), 3) }) test_that("pslide_index_*() errors if it can't simplify", { fn <- function(x, y) if (x == 1L) {1} else {"hi"} expect_error( pslide_index_vec(list(1:2, 1:2), 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type" ) expect_error( pslide_index_int(list(1:2, 1:2), 1:2, fn), class = "vctrs_error_incompatible_type" ) }) test_that("completely empty input returns ptype", { expect_equal(pslide_index_vec(list(), integer(), ~.x), NULL) expect_equal(pslide_index_vec(list(), integer(), ~.x, .ptype = list()), list()) expect_equal(pslide_index_vec(list(), integer(), ~.x, .ptype = int()), int()) expect_equal(pslide_index_int(list(), integer(), ~.x), int()) }) # ------------------------------------------------------------------------------ # suffix tests test_that("pslide_index_int() works", { expect_identical(pslide_index_int(list(1L, 1L), 1, ~.x + .y), 2L) }) test_that("pslide_index_int() can coerce", { expect_identical(pslide_index_int(list(1, 1), 1, ~.x + .y), 2L) }) test_that("pslide_index_dbl() works", { expect_identical(pslide_index_dbl(list(1, 1), 1, ~.x), 1) }) test_that("pslide_index_dbl() can coerce", { expect_identical(pslide_index_dbl(list(1L, 1L), 1, ~.x + .y), 2) }) test_that("pslide_index_chr() works", { expect_identical(pslide_index_chr(list("x", 1), 1, ~.x), "x") }) test_that("pslide_index_chr() cannot coerce", { expect_error(pslide_index_chr(list(1, 1), 1, ~.x + .y), class = "vctrs_error_incompatible_type") }) test_that("pslide_index_lgl() works", { expect_identical(pslide_index_lgl(list(TRUE, 1), 1, ~.x), TRUE) }) test_that("pslide_index_lgl() can coerce", { expect_identical(pslide_index_lgl(list(1, 0), 1, ~.x + .y), TRUE) }) # ------------------------------------------------------------------------------ # data frame suffix tests test_that("pslide_index_dfr() works", { expect_identical( pslide_index_dfr( list(1:2, 1:2), 1:2, ~new_data_frame(list(x = list(.x), y = list(.y))), .before = 1 ), data_frame( x = list(1L, 1:2), y = list(1L, 1:2) ) ) x <- 1:2 expect_identical( pslide_index_dfr(list(x, x), 1:2, ~data.frame(x = .x, y = .y), .before = 1), data.frame(x = c(1L, 1L, 2L), y = c(1L, 1L, 2L)) ) }) test_that("pslide_index_dfc() works", { x <- 1:2 fn <- function(x, y) { if (length(x) == 1) { data.frame(x1 = x, y1 = y) } else { data.frame(x2 = x, y2 = y) } } expect_identical( pslide_index_dfc( list(x, x), 1:2, fn, .before = 1 ), data.frame( x1 = c(1L, 1L), y1 = c(1L, 1L), x2 = 1:2, y2 = 1:2 ) ) }) # ------------------------------------------------------------------------------ # .ptype test_that("`.ptype = NULL` is size stable (#78)", { expect_length(pslide_index_vec(list(1:4, 1:4), 1:4, ~1, .before = 1, .complete = TRUE), 4) }) test_that("`pslide_index_vec()` falls back to `c()` method as required", { local_c_foobar() expect_identical(pslide_index_vec(list(1:3, 1:3), 1:3, ~foobar(.x), .ptype = foobar(integer())), foobar(1:3)) expect_condition(pslide_index_vec(list(1:3, 1:3), 1:3, ~foobar(.x), .ptype = foobar(integer())), class = "slider_c_foobar") expect_identical(pslide_index_vec(list(1:3, 1:3), 1:3, ~foobar(.x)), foobar(1:3)) expect_condition(pslide_index_vec(list(1:3, 1:3), 1:3, ~foobar(.x)), class = "slider_c_foobar") }) # ------------------------------------------------------------------------------ # .complete test_that(".complete produces typed `NA` values", { expect_identical(pslide_index_int(list(1:3, 1:3), 1:3, ~1L, .before = 1, .complete = TRUE), c(NA, 1L, 1L)) expect_identical(pslide_index_dbl(list(1:3, 1:3), 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(pslide_index_chr(list(1:3, 1:3), 1:3, ~"1", .before = 1, .complete = TRUE), c(NA, "1", "1")) expect_identical(pslide_index_vec(list(1:3, 1:3), 1:3, ~1, .before = 1, .complete = TRUE), c(NA, 1, 1)) expect_identical(pslide_index_vec(list(1:3, 1:3), 1:3, ~1, .before = 1, .complete = TRUE, .ptype = integer()), c(NA, 1L, 1L)) }) slider/tests/testthat/test-slide-index.R0000644000176200001440000007244614024427556020071 0ustar liggesuserstest_that("trivial case works", { expect_equal( slide_index(1:2, 1:2, ~.x), list(1L, 2L) ) }) test_that("defaults work with `.i`", { i <- new_date(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity), list( 1L, 2L, 3L, 4L ) ) }) test_that(".x must be the same size as .i", { expect_error(slide_index(1, 1:2, identity), class = "slider_error_index_incompatible_size") }) test_that(".i must be ascending", { expect_error(slide_index(1:2, 2:1, identity), class = "slider_error_index_must_be_ascending") }) test_that("empty input returns a list, but after the index size check", { expect_equal(slide_index(integer(), integer(), ~.x), list()) expect_error(slide_index(integer(), 1, ~.x), class = "slider_error_index_incompatible_size") }) test_that(".i must not contain NA values", { expect_error(slide_index(1:2, c(1, NA), identity), class = "slider_error_index_cannot_be_na") expect_error(slide_index(1:2, c(NA, 1), identity), class = "slider_error_index_cannot_be_na") }) # ------------------------------------------------------------------------------ # .before - integer test_that("can use integer .before on a Date index", { i <- new_date(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = 1L), list( 1L, 1:2, 2:3, 3:4 ) ) }) test_that("can use integer .before on a POSIXct index", { i <- new_datetime(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = 1L), list( 1L, 1:2, 2:3, 3:4 ) ) }) test_that("using .before on an irregular date index works", { i <- new_date(c(0, 2, 3, 4)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = 1L), list( 1L, 2L, 2:3, 3:4 ) ) expect_equal( slide_index(x, i, identity, .before = 2L), list( 1L, 1:2, 2:3, 2:4 ) ) }) test_that(".before must be size 1", { expect_error( slide_index(1, 1, identity, .before = c(1L, 2L)), class = "vctrs_error_assert_size" ) }) test_that("error if .before is NULL", { expect_error( slide_index(1, 1, identity, .before = NULL), class = "vctrs_error_scalar_type" ) }) # ------------------------------------------------------------------------------ # .before - negative test_that("can use a negative .before with a date index", { i <- new_datetime(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = -1L, .after = 1L), list( 2L, 3L, 4L, integer() ) ) expect_equal( slide_index(x, i, identity, .before = -1L, .after = 2L), list( 2:3, 3:4, 4L, integer() ) ) }) test_that("can use a negative .before with an irregular date index", { i <- new_datetime(c(0, 1, 1, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = -1L, .after = 2L), list( 2:3, 4L, 4L, integer() ) ) }) test_that("can select no elements when using a negative .before", { i <- new_datetime(c(0, 1, 1, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .before = -1L, .after = 1L), list( 2:3, integer(), integer(), integer() ) ) }) test_that("negative .before errors if its absolute value is past .after", { i <- new_date(c(0, 1, 2, 3)) x <- i expect_error( slide_index(x, i, identity, .before = -1, .after = 0), "the start of the range is after the end of the range at location[(]s[)]: 1, 2, 3, 4" ) }) # ------------------------------------------------------------------------------ # .before - numeric test_that("ranges use an inclusive .before bound", { i <- c(1000, 3000, 5000.000001) x <- seq_along(i) # Should include 1000 in the second slot of the output expect_equal( slide_index(x, i, identity, .before = 2000), list( 1L, 1:2, 3 ) ) }) test_that("can define ranges based on an irregular numeric index", { i <- c(1000, 2000, 4000, 8000, 10000, 11000) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = 2000), list( 1L, 1:2, 2:3, 4L, 4:5, 5:6 ) ) }) # ------------------------------------------------------------------------------ # .before - lubridate - Durations test_that("can use hour Durations with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::dhours(1)), list( 1L, 2L, 3L, 4L ) ) expect_equal( slide_index(x, i, identity, .before = lubridate::dhours(24)), slide_index(x, i, identity, .before = 24 * 60 * 60) ) }) test_that("can use day Durations with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::ddays(1)), slide_index(x, i, identity, .before = 24 * 60 * 60) ) expect_equal( slide_index(x, i, identity, .before = lubridate::ddays(2)), slide_index(x, i, identity, .before = 2 * 24 * 60 * 60) ) }) test_that("can use week Durations with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 6, 7, 8))) x <- seq_along(i) before <- lubridate::dweeks(1) # Current element of i, + everything since i - dweeks(1), inclusive! expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 1:2, 1:3, 2:4 ) ) }) test_that("can use year Durations with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 365, 365 * 2))) x <- seq_along(i) before <- lubridate::dyears(1) expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 1:2, 2:3 ) ) }) test_that("can use negative Durations with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = -lubridate::ddays(1), .after = lubridate::ddays(1)), list( 2L, 3L, 4L, integer() ) ) expect_equal( slide_index(x, i, identity, .before = -lubridate::ddays(1), .after = lubridate::ddays(2)), list( 2:3, 3:4, 4L, integer() ) ) }) test_that("errors if negative .before Duration is further than .after", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_error( slide_index(x, i, identity, .before = -lubridate::ddays(1), .after = 0), "the start of the range is after the end of the range at location[(]s[)]: 1, 2, 3, 4" ) }) test_that("can use millisecond Durations with POSIXct", { i <- new_datetime(c(0, 0.001, 0.002, 0.003)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::dmilliseconds(1)), list( 1L, 1:2, 2:3, 3:4 ) ) }) test_that("can use second Durations with POSIXct", { i <- new_datetime(c(0, 1, 2, 3)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::dseconds(1)), list( 1L, 1:2, 2:3, 3:4 ) ) }) # ------------------------------------------------------------------------------ # .before - lubridate - Periods test_that("can use hour Periods with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::hours(1)), list( 1L, 2L, 3L, 4L ) ) expect_equal( slide_index(x, i, identity, .before = lubridate::hours(24)), list( 1L, 1:2, 2:3, 3:4 ) ) }) test_that("can use day Periods with Dates", { i <- new_date(c(0, 1, 2, 3)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = lubridate::days(1)), slide_index(x, i, identity, .before = 1L) ) expect_equal( slide_index(x, i, identity, .before = lubridate::days(2)), slide_index(x, i, identity, .before = 2L) ) }) test_that("can use week Periods with Dates", { i <- new_date(c(0, 6, 7, 8)) x <- seq_along(i) before <- lubridate::weeks(1) # Current element of i, + everything since i - weeks(1), inclusive! # So it includes the data point at 1 week prior, and today expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 1:2, 1:3, 2:4 ) ) # If you want to avoid that 1 week prior data point, bump it back # to 1 week - 1 second i <- lubridate::as_datetime(i) before <- lubridate::seconds(604799) expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 1:2, 2:3, 2:4 ) ) }) test_that("can generally use (tricky!) month Periods with Dates", { requireNamespace("lubridate", quietly = TRUE) i <- new_date(0) + months(0:3) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = months(1)), list( 1L, 1:2, 2:3, 3:4 ) ) # Problematic when dates don't exist! Nothing we can do to help! # General solution is to use ~ .x %m-% months(1) instead i <- as.Date("2019-03-30") + months(0:3) expect_error( slide_index(x, i, identity, .before = months(1)), class = "slider_error_generated_endpoints_cannot_be_na" ) }) # ------------------------------------------------------------------------------ # .before - lubridate - Leap Years / DST test_that("can use year Durations/Periods with Dates and leap years", { # 2008 = leap year i <- as.POSIXct(c("2008-01-01", "2009-01-01", "2010-01-01"), "UTC") x <- seq_along(i) before <- lubridate::dyears(1) # There are MORE than ~52.14 weeks in a leap year # So subtracting 1 dyears() from 2009-01-01 should NOT include 2008-01-01 expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 2L, 2:3 ) ) # Using Period objects results in "expected" behavior as it is calendar # time and not clock time before <- lubridate::years(1) expect_equal( slide_index(x, i, identity, .before = before), list( 1L, 1:2, 2:3 ) ) }) # ------------------------------------------------------------------------------ # .before - nanotime # TODO - vec_compare() can't handle nanotime objects # could provide a vec_proxy_compare # vctrs:::vec_proxy_compare.integer64(nanotime::nanotime(c(1, 2, 3, 6, 4))) # test_that("can use nanotime resolution", { # i <- nanotime::nanotime(1:5) # x <- seq_along(i) # # expect_equal( # slide_index(x, i, identity, .before = 1L), # list( # 1L, # 1:2, # 2:3, # 3:4, # 4:5 # ) # ) # # expect_equal( # slide_index(x, i, identity, .before = 2L), # list( # 1L, # 1:2, # 1:3, # 2:4, # 3:5 # ) # ) # }) # ------------------------------------------------------------------------------ # .after - integer test_that("can use integer .after on a Date index", { i <- new_date(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = 1L), list( 1:2, 2:3, 3:4, 4L ) ) }) test_that("can use integer .after on a POSIXct index", { i <- new_datetime(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = 1L), list( 1:2, 2:3, 3:4, 4L ) ) }) test_that("using .after on an irregular date index works", { i <- new_date(c(0, 2, 3, 4)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = 1L), list( 1L, 2:3, 3:4, 4L ) ) expect_equal( slide_index(x, i, identity, .after = 2L), list( 1:2, 2:4, 3:4, 4L ) ) }) test_that(".after must be size 1", { expect_error( slide_index(1, 1, identity, .after = c(1L, 2L)), class = "vctrs_error_assert_size" ) }) test_that("error if .after is NULL", { expect_error( slide_index(1, 1, identity, .after = NULL), class = "vctrs_error_scalar_type" ) }) # ------------------------------------------------------------------------------ # .after - negative test_that("can use a negative .after with integer index", { i <- 1:5 x <- i expect_equal( slide_index(x, i, identity, .before = 2L, .after = -1L), list( integer(), 1L, 1:2, 2:3, 3:4 ) ) }) test_that("can use a negative .after with a date index", { i <- new_datetime(c(0, 1, 2, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = -1L, .before = 1L), list( integer(), 1L, 2L, 3L ) ) expect_equal( slide_index(x, i, identity, .after = -1L, .before = 2L), list( integer(), 1L, 1:2, 2:3 ) ) }) test_that("can use a negative .after with an irregular date index", { i <- new_datetime(c(0, 1, 1, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = -1L, .before = 2L), list( integer(), 1L, 1L, 2:3 ) ) }) test_that("can select no elements when using a negative .after", { i <- new_datetime(c(0, 1, 1, 3)) x <- 1:4 expect_equal( slide_index(x, i, identity, .after = -1L, .before = 1L), list( integer(), 1, 1, integer() ) ) }) test_that("negative .after errors if its absolute value is past .before", { i <- new_date(c(0, 1, 2, 3)) x <- i expect_error( slide_index(x, i, identity, .after = -1, .before = 0), "the start of the range is after the end of the range at location[(]s[)]: 1, 2, 3, 4" ) }) # ------------------------------------------------------------------------------ # .after - numeric test_that("ranges use an inclusive .after bound", { i <- c(1000, 3000, 5000.000001) x <- seq_along(i) # Should include 1000 in the second slot of the output expect_equal( slide_index(x, i, identity, .after = 2000), list( 1:2, 2L, 3L ) ) }) test_that("can define ranges based on an irregular numeric index", { i <- c(1000, 2000, 4000, 8000, 10000, 11000) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .after = 2000), list( 1:2, 2:3, 3L, 4:5, 5:6, 6L ) ) }) # ------------------------------------------------------------------------------ # .after - lubridate - Periods test_that("can use hour Periods with POSIXct", { i <- lubridate::as_datetime(new_date(c(0, 1, 2, 3))) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .after = lubridate::hours(1)), list( 1L, 2L, 3L, 4L ) ) expect_equal( slide_index(x, i, identity, .after = lubridate::hours(24)), list( 1:2, 2:3, 3:4, 4L ) ) }) test_that("can use day Periods with Dates", { i <- new_date(c(0, 1, 2, 3)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .after = lubridate::days(1)), slide_index(x, i, identity, .after = 1L) ) expect_equal( slide_index(x, i, identity, .after = lubridate::days(2)), slide_index(x, i, identity, .after = 2L) ) }) test_that("can use week Periods with Dates", { i <- new_date(c(0, 6, 7, 8)) x <- seq_along(i) after <- lubridate::weeks(1) # Current element of i, + everything since i + weeks(1), inclusive! # So it includes the data point at 1 week prior, and today expect_equal( slide_index(x, i, identity, .after = after), list( 1:3, 2:4, 3:4, 4L ) ) # If you want to avoid that 1 week prior data point, bump it back # to 1 week - 1 second i <- lubridate::as_datetime(i) after <- lubridate::seconds(604799) expect_equal( slide_index(x, i, identity, .after = after), list( 1:2, 2:4, 3:4, 4L ) ) }) test_that("can generally use (tricky!) month Periods with Dates", { requireNamespace("lubridate", quietly = TRUE) i <- new_date(0) + months(0:3) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .after = months(1)), list( 1:2, 2:3, 3:4, 4L ) ) # Problematic when dates don't exist! Nothing we can do to help! # General solution is to use ~ .x %m-% months(1) instead i <- as.Date("2019-01-30") + months(-3:0) expect_error( slide_index(x, i, identity, .after = months(1)), class = "slider_error_generated_endpoints_cannot_be_na" ) }) # ------------------------------------------------------------------------------ # .after - lubridate - Leap Years / DST test_that("can use Durations/Periods to handle daylight savings differently", { i <- lubridate::ymd_hms("2009-03-08 01:59:59", tz = "America/Chicago") i <- i + lubridate::days(0:1) i <- vec_c(i, i[2] + lubridate::hours(1)) x <- seq_along(i) # When 1 days() is added to the boundary, it keeps the same hour value # because the calendar time should be equal everywhere except in the day slot # This means the 3rd data point is not included. expect_equal( slide_index(x, i, identity, .after = lubridate::days(1)), list( 1:2, 2:3, 3L ) ) # When 1 ddays() is added to the boundary, it adds a fixed number of seconds # to the boundary, which, after adjusting the time zone, ends up 1 day + # 1 hour forward past the boundary. # This means the 3rd data point gets included. expect_equal( slide_index(x, i, identity, .after = lubridate::ddays(1)), list( 1:3, 2:3, 3L ) ) }) # ------------------------------------------------------------------------------ # .before / .after - function test_that(".before/.after - can use a function", { x <- 1:5 expect_identical( slide_index(x, x, identity, .before = function(.x) .x - 2), slide_index(x, x, identity, .before = 2) ) expect_identical( slide_index(x, x, identity, .before = ~.x - 2), slide_index(x, x, identity, .before = 2) ) expect_identical( slide_index(x, x, identity, .after = function(.x) .x + 2), slide_index(x, x, identity, .after = 2) ) expect_identical( slide_index(x, x, identity, .after = ~.x + 2), slide_index(x, x, identity, .after = 2) ) }) test_that(".before/.after - using a function can help with lubridate `+ months(1)` invalid date issues", { x <- as.Date(c("2019-01-31", "2019-02-28", "2019-03-31")) expect_identical( slide_index(x, x, identity, .before = ~lubridate::add_with_rollback(.x, months(-1))), list(x[1], x[1:2], x[2:3]) ) expect_identical( slide_index(x, x, identity, .after = ~lubridate::add_with_rollback(.x, months(1))), list(x[1:2], x[2], x[3]) ) }) test_that(".before/.after - generated endpoints must be in weakly ascending order", { x <- c(1, 2) expect_error( slide_index(x, x, identity, .before = ~.x - c(2, 4)), class = "slider_error_generated_endpoints_must_be_ascending" ) expect_snapshot_error( slide_index(x, x, identity, .before = ~.x - c(2, 4)) ) expect_error( slide_index(x, x, identity, .after = ~.x + c(4, 2)), class = "slider_error_generated_endpoints_must_be_ascending" ) expect_snapshot_error( slide_index(x, x, identity, .after = ~.x + c(4, 2)) ) }) test_that(".before/.after - generated endpoints must maintain .before <= .after ordering", { expect_error( slide_index(1:2, 1:2, identity, .before = ~.x + 1, .after = 0), "start of the range is after the end of the range" ) expect_snapshot_error( slide_index(1:2, 1:2, identity, .before = ~.x + 1, .after = 0) ) expect_error( slide_index(1:2, 1:2, identity, .before = 0, .after = ~.x - 1), "start of the range is after the end of the range" ) expect_snapshot_error( slide_index(1:2, 1:2, identity, .before = 0, .after = ~.x - 1) ) }) test_that(".before/.after - generated endpoints can't be NA", { expect_error( slide_index(1:2, 1:2, identity, .before = ~rep(NA_integer_, length(.x))) ) expect_snapshot_error( slide_index(1:2, 1:2, identity, .before = ~rep(NA_integer_, length(.x))) ) expect_error( slide_index(1:2, 1:2, identity, .after = ~rep(NA_integer_, length(.x))) ) expect_snapshot_error( slide_index(1:2, 1:2, identity, .after = ~rep(NA_integer_, length(.x))) ) }) test_that(".before/.after - generated endpoints shouldn't rely on original `.i` length", { # Duplicates (peers) will be removed x <- c(1, 1) adjust <- c(2, 3) expect_error( slide_index(x, x, identity, .before = ~.x - adjust), class = "slider_error_generated_endpoints_incompatible_size" ) expect_snapshot_error( slide_index(x, x, identity, .before = ~.x - adjust) ) expect_error( slide_index(x, x, identity, .after = ~.x + adjust), class = "slider_error_generated_endpoints_incompatible_size" ) expect_snapshot_error( slide_index(x, x, identity, .after = ~.x + adjust) ) }) test_that(".before/.after - function must have 1 argument", { expect_error(slide_index(1, 1, identity, .before = function(x, y) x + y)) expect_error(slide_index(1, 1, identity, .before = ~.x + .y)) expect_error(slide_index(1, 1, identity, .after = function(x, y) x + y)) expect_error(slide_index(1, 1, identity, .after = ~.x + .y)) }) # ------------------------------------------------------------------------------ # .complete test_that("can match slide() usage of .complete", { x <- 1:5 expect_equal( slide_index(x, x, identity, .before = 1, .complete = TRUE), slide(x, identity, .before = 1, .complete = TRUE) ) expect_equal( slide_index(x, x, identity, .before = 1, .after = 2L, .complete = TRUE), slide(x, identity, .before = 1, .after = 2L, .complete = TRUE) ) }) test_that("can filter for .complete date ranges", { i <- new_date(c(0, 1, 2, 2, 3)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = 1, .complete = TRUE), list( NULL, 1:2, 2:4, 2:4, 3:5 ) ) }) test_that(".complete only ensures that there is at least 1 value before that could have been used", { i <- new_date(c(0, 2, 3, 4, 5)) x <- seq_along(i) # i.e., even though element 2 doesn't have a "complete" window of size 2, # it theoretically _could_ have because 1970-01-03 - 1 day = 1970-01-02 # which is above the boundary value of 1970-01-01, and that is what matters # when computing completeness expect_equal( slide_index(x, i, identity, .before = 1, .complete = TRUE), list( NULL, 2L, 2:3, 3:4, 4:5 ) ) # same idea here: # even though element 1 doesn't have a "complete" window of size 2, # it theoretically _could_ have because 1970-01-01 + 1 day = 1970-01-02 # which is below the boundary value of 1970-01-06, and that is what matters # when computing completeness expect_equal( slide_index(x, i, identity, .after = 1, .complete = TRUE), list( 1L, 2:3, 3:4, 4:5, NULL ) ) }) test_that("cannot use an invalid .complete value", { expect_error( slide_index(1, 1, identity, .complete = "hi"), class = "vctrs_error_incompatible_type" ) }) # ------------------------------------------------------------------------------ # unbounded test_that("can use unbounded .before", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = Inf), list( 1L, 1:2, 1:3, 1:4, 1:5 ) ) }) test_that("can use unbounded .after", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .after = Inf), list( 1:5, 2:5, 3:5, 4:5, 5L ) ) }) test_that("can use unbounded .before with positive .after", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = Inf, .after = 1), list( 1:2, 1:3, 1:4, 1:5, 1:5 ) ) }) test_that("can use unbounded .before with negative .after", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = Inf, .after = -1), list( integer(), 1L, 1:2, 1:3, 1:4 ) ) }) test_that("can use unbounded .before with lubridate .after", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = Inf, .after = lubridate::days(2)), list( 1:3, 1:4, 1:5, 1:5, 1:5 ) ) }) test_that("can be doubly unbounded", { i <- new_date(c(0, 1, 2, 3, 4)) x <- seq_along(i) expect_equal( slide_index(x, i, identity, .before = Inf, .after = Inf), list( 1:5, 1:5, 1:5, 1:5, 1:5 ) ) }) # ------------------------------------------------------------------------------ # type / size relaxed-ness test_that("slide_index() doesn't require `size = 1`", { expect_equal( slide_index(1:2, 1:2, ~c(.x, 1)), list( c(1L, 1L), c(2L, 1L) ) ) }) test_that("`slide_index()` doesn't require a common inner type", { expect_equal( slide_index(1:2, 1:2, ~if (.x == 1L) {1} else {"hi"}), list(1, "hi") ) }) # ------------------------------------------------------------------------------ # input names test_that("input names are retained with atomics", { names <- letters[1:5] x <- set_names(1:5, names) i <- vec_seq_along(x) expect_equal(names(slide_index(x, i, ~.x)), names) }) test_that("input names are retained from proxied objects", { names <- letters[1:5] x <- as.POSIXlt(new_datetime(0:4 + 0)) x <- set_names(x, names) i <- vec_seq_along(x) expect_equal(names(slide_index(x, i, ~.x)), names) }) test_that("row names are extracted from data frames", { x <- data.frame(x = 1:5, row.names = letters[1:5]) i <- vec_seq_along(x) expect_equal(names(slide_index(x, i, ~.x)), letters[1:5]) }) test_that("row names are extracted from arrays", { x <- array(1:4, c(2, 2), dimnames = list(c("r1", "r2"), c("c1", "c2"))) i <- vec_seq_along(x) expect_equal(names(slide_index(x, i, ~.x)), c("r1", "r2")) }) test_that("names are retained on inner sliced object", { names <- letters[1:5] x <- set_names(1:5, names) i <- vec_seq_along(x) exp <- set_names(as.list(names), names) expect_equal(slide_index(x, i, ~names(.x)), exp) names <- letters[1:5] x <- data.frame(x = 1:5, row.names = names) i <- vec_seq_along(x) expect <- set_names(as.list(names), names) expect_equal(slide_index(x, i, ~rownames(.x)), expect) names <- c("r1", "r2") x <- array(1:4, c(2, 2), dimnames = list(names, c("c1", "c2"))) i <- vec_seq_along(x) exp <- set_names(as.list(names), names) expect_equal(slide_index(x, i, ~rownames(.x)), exp) }) # ------------------------------------------------------------------------------ # .i types test_that("can use a data frame index", { expect_equal( slide_index(1:5, data.frame(x = c(1, 1, 2, 3, 4)), ~.x), list( 1:2, 1:2, 3L, 4L, 5L ) ) }) test_that("`.i - .before` must be castable to `.i`", { i <- 1L expect_error( slide_index(1, i, identity, .before = 1.5), class = "vctrs_error_cast_lossy" ) }) test_that("`.i + .after` must be castable to `.i`", { i <- 1L expect_error( slide_index(1, i, identity, .after = 1.5), class = "vctrs_error_cast_lossy" ) }) # ------------------------------------------------------------------------------ # misc test_that("repeated index values are grouped with the same values", { i <- c(1, 1, 1, 2, 2, 3, 4, 4, 5) x <- seq_along(i) expect_equal( slide_index(x, i, identity), as.list(vec_slice(vec_split(x, i)$val, i)) ) }) test_that("repeated date index values are grouped with the same values", { i <- new_date(c(0, 0, 1)) x <- seq_along(i) expect_equal( slide_index(x, i, identity), list( 1:2, 1:2, 3L ) ) expect_equal( slide_index(x, i, identity, .before = 1L), list( 1:2, 1:2, 1:3 ) ) }) test_that("can have an irregular index where the window is completely within two index values", { expect_equal( slide_index(1:7, c(10, 11, 13, 17, 18, 19, 20), ~.x, .before = 3, .after = -2), list( integer(), integer(), 1:2, integer(), integer(), 4L, 4:5 ) ) }) test_that("can select 0 values if before/after are completely out of range", { expect_equal( slide_index(1:5, 1:5, identity, .before = 10, .after = -10), rep(list(integer()), 5) ) }) test_that("indexing by vec_seq_along(.x) is the same as slide()", { expect_equal( slide(1:5, ~.x), slide_index(1:5, 1:5, ~.x) ) expect_equal( slide(1:5, ~.x, .before = 1), slide_index(1:5, 1:5, ~.x, .before = 1) ) }) test_that("lambdas are equivalent to functions (#10)", { expect_equal( slide_index(1:10, 1:10, sum, .before = 3), slide_index(1:10, 1:10, ~sum(.x), .before = 3) ) }) test_that("slide_index() forces arguments in the same way as base R / map()", { f_slide <- slide_index(1:2, 1:2, function(i) function(x) x + i) f_base <- lapply(1:2, function(i) function(x) x + i) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) test_that("stress test that we don't stack overflow (#34)", { expect_error(slide_index(1:1e6, 1:1e6, ~.x), NA) }) test_that(paste0( "proof that the `stops_pos < starts_pos` check is required for ", "cases where we have an irregular series and ", "the window is completely between values" ), { expect_equal( slide_index(1:3, c(1, 3, 4), identity, .before = -1, .after = 1), list(integer(), 3, integer()) ) }) slider/tests/testthat/test-conditions.R0000644000176200001440000000502213607131574020015 0ustar liggesusers# ------------------------------------------------------------------------------ # stop_index_incompatible_type() test_that("output is verified", { verify_output( test_path("output/test-stop-index-incompatible-type-1.txt"), check_index_incompatible_type(1, ".i") ) }) test_that("class names are collapsed", { x <- structure(1, class = c("foo", "bar", "baz")) verify_output( test_path("output/test-stop-index-incompatible-type-2.txt"), check_index_incompatible_type(x, ".i") ) }) # ------------------------------------------------------------------------------ # stop_endpoints_must_be_ascending() test_that("output is verified", { verify_output( test_path("output/test-stop-endpoints-must-be-ascending-1.txt"), check_endpoints_must_be_ascending(c(1, 2, 1, 3, 4, 2), ".starts") ) }) # ------------------------------------------------------------------------------ # stop_generated_endpoints_cannot_be_na() test_that("output is verified", { verify_output( test_path("output/test-stop-generated-endpoints-cannot-be-na-1.txt"), check_generated_endpoints_cannot_be_na(c(NA, 1, NA), ".before") ) }) # ------------------------------------------------------------------------------ # stop_endpoints_cannot_be_na() test_that("output is verified", { verify_output( test_path("output/test-stop-endpoints-cannot-be-na-1.txt"), check_endpoints_cannot_be_na(c(NA, 1, NA), ".starts") ) }) # ------------------------------------------------------------------------------ # stop_index_must_be_ascending() test_that("output is verified", { verify_output( test_path("output/test-stop-index-must-be-ascending-1.txt"), check_index_must_be_ascending(c(1, 2, 1, 4, 5, 3), ".i") ) }) test_that("not assuming strictly ascending", { expect_silent(check_index_must_be_ascending(c(1, 1))) }) # ------------------------------------------------------------------------------ # stop_index_cannot_be_na() test_that("output is verified", { verify_output( test_path("output/test-stop-index-cannot-be-na-1.txt"), check_index_cannot_be_na(c(NA, 1, NA), ".i") ) }) test_that("trimming works", { verify_output( test_path("output/test-stop-index-cannot-be-na-2.txt"), check_index_cannot_be_na(rep(NA, 100), ".i") ) }) # ------------------------------------------------------------------------------ # stop_index_incompatible_size() test_that("output is verified", { verify_output( test_path("output/test-stop-index-incompatible-size-1.txt"), stop_index_incompatible_size(1, 2, ".i") ) }) slider/tests/testthat/test-pslide.R0000644000176200001440000000305513656542065017135 0ustar liggesuserstest_that("An empty list() results in empty `ptype` returned", { expect_equal(pslide(list(), ~.x), list()) expect_equal(pslide_dbl(list(), ~.x), numeric()) expect_equal(pslide_vec(list(), ~.x, .ptype = 1:5), integer()) }) test_that("Recycling is carried out using tidyverse recycling rules", { x0 <- integer() x1 <- 1L x2 <- c(2L, 2L) x3 <- c(3L, 3L, 3L) expect_equal(pslide(list(x0, x0), ~.x), list()) expect_equal(pslide(list(x0, x1), ~.x), list()) expect_error(pslide(list(x0, x2), ~.x), class = "vctrs_error_incompatible_size") expect_equal(pslide(list(x1, x1), ~.x), list(x1)) expect_equal(pslide(list(x1, x2), ~.x), list(x1, x1)) expect_error(pslide(list(x2, x3), ~.x), class = "vctrs_error_incompatible_size") }) test_that("pslide() can iterate over a data frame", { x <- data.frame(x = 1:5, y = 6:10) expect_equal(pslide(x, ~.x + .y), as.list(x$x + x$y)) }) test_that("pslide() can iterate over a data frame with a data frame column", { x <- data.frame(c1 = 1:2) x$x <- x expect_equal( pslide(x, ~list(...)), list(as.list(vec_slice(x, 1)), as.list(vec_slice(x, 2))) ) }) test_that("pslide() requires a list-like input", { expect_error(pslide(1:5, ~.x), "list, not integer") }) test_that("pslide() forces arguments in the same way as base R / pmap()", { f_slide <- pslide(list(1:2, 1:2, 1:2), function(i, j, k) function(x) x + i + j + k) f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) expect_equal(f_slide[[1]](0), f_base[[1]](0)) expect_equal(f_slide[[2]](0), f_base[[2]](0)) }) slider/tests/testthat/test-hop.R0000644000176200001440000000656513663762054016454 0ustar liggesuserstest_that("trivial case works", { expect_equal( hop(1:2, 1:2, 1:2, ~.x), list(1L, 2L) ) }) test_that(".starts and .stops don't have to be ascending", { expect_equal(hop(1:5, c(2, 1), c(3, 2), identity), list(2:3, 1:2)) }) test_that(".starts must be before .stops", { expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity), "generated by `.starts` and `.stops`") expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity), "1, 2") }) test_that("empty input returns a list", { expect_equal(hop(integer(), integer(), integer(), ~.x), list()) }) test_that("empty `.x`, but size `n > 0` `.starts` and `.stops` returns size `n` empty ptype", { expect_equal(hop(integer(), 1:2, 2:3, ~.x), list(integer(), integer())) }) test_that("empty `.x`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { expect_error(hop(integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") expect_error(hop(integer(), 1, "x", ~.x), class = "vctrs_error_subscript_type") }) test_that(".starts must not contain NA values", { expect_error(hop(1:2, c(1, NA), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") expect_error(hop(1:2, c(NA, 1), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") }) test_that(".stops must not contain NA values", { expect_error(hop(1:2, 1:2, c(1, NA), identity), class = "slider_error_endpoints_cannot_be_na") expect_error(hop(1:2, 1:2, c(NA, 1), identity), class = "slider_error_endpoints_cannot_be_na") }) test_that("recycling is used for .starts/.stops", { expect_equal( hop(1:2, 1, 1:2, ~.x), list( 1L, 1:2 ) ) expect_equal( hop(1:2, 1:2, 2, ~.x), list( 1:2, 2L ) ) expect_error(hop(1:2, 1:2, 1:3, ~.x), class = "vctrs_error_incompatible_size") }) test_that("0 length .starts/.stops are allowed", { expect_equal(hop(1, integer(), integer(), ~.x), list()) }) test_that("output size is the common size of .starts/.stops", { expect_equal( hop(1:5, 1, 2, ~.x), list(1:2) ) expect_equal( hop(1:2, c(1, 1, 2), c(1, 2, 2), ~.x), list(1L, 1:2, 2L) ) }) test_that("out of bounds .starts/.stops result in size-0 slices", { expect_equal( hop(1:2, 3, 4, ~.x), list(integer()) ) expect_equal( hop(1:2, c(3, 4), c(4, 6), ~.x), list(integer(), integer()) ) }) test_that("negative / 0 out of bounds .starts/.stops result in size-0 slices", { expect_equal( hop(1:2, c(-1, 4), c(0, 6), ~.x), list(integer(), integer()) ) expect_equal( hop(1:2, c(-1, 1, 4), c(0, 2, 6), ~.x), list(integer(), 1:2, integer()) ) }) test_that("duplicated .starts/.stops pairs are allowed", { expect_equal( hop(1:4, c(1, 2, 2), c(2, 2, 2), ~.x), list( 1:2, 2L, 2L ) ) }) test_that("`.starts` and `.stops` must be integerish", { expect_error(hop(1, "x", 1, identity), class = "vctrs_error_subscript_type") expect_error(hop(1, 1, "x", identity), class = "vctrs_error_subscript_type") }) # ------------------------------------------------------------------------------ # input names test_that("names exist on inner sliced elements", { names <- letters[1:5] x <- set_names(1:5, names) exp <- as.list(names) expect_equal(hop(x, 1:5, 1:5, ~names(.x)), exp) }) test_that("names are never placed on the output", { x <- set_names(1:5, letters[1:5]) expect_null(names(hop(x, 1:5, 1:5, ~.x))) }) slider/tests/testthat.R0000644000176200001440000000007014024427556014667 0ustar liggesuserslibrary(testthat) library(slider) test_check("slider") slider/src/0000755000176200001440000000000014067413471012332 5ustar liggesusersslider/src/summary-core-align.h0000644000176200001440000000035314025156373016216 0ustar liggesusers#ifndef SLIDER_SUMMARY_CORE_ALIGN #define SLIDER_SUMMARY_CORE_ALIGN #include // size_t extern "C" { #include "summary-core-types.h" size_t align_of_long_double(); size_t align_of_mean_state_t(); } // extern "C" #endif slider/src/block.c0000644000176200001440000000110714024723061013557 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" // [[ export() ]] SEXP slider_block(SEXP x, SEXP starts, SEXP stops) { R_xlen_t size = Rf_xlength(starts); double* p_starts = REAL(starts); double* p_stops = REAL(stops); SEXP indices = PROTECT(Rf_allocVector(VECSXP, size)); for (R_xlen_t i = 0; i < size; ++i) { int start = p_starts[i]; int stop = p_stops[i]; int size = stop - start + 1; SEXP seq = compact_seq(start - 1, size, true); SET_VECTOR_ELT(indices, i, seq); } SEXP out = PROTECT(vec_chop(x, indices)); UNPROTECT(2); return out; } slider/src/summary-core-align.cpp0000644000176200001440000000067414025156373016557 0ustar liggesusers#include "summary-core-align.h" extern "C" { /* * `alignof()` is C++11 specific, so this single compilation unit requires * C++11, and we call these helpers from C in `summary-core.h`. * * Technically `alignof()` is also in C11, but it is unclear how well R supports * that. */ size_t align_of_long_double() { return alignof(long double); } size_t align_of_mean_state_t() { return alignof(struct mean_state_t); } } // extern "C" slider/src/init.c0000644000176200001440000000737714025143663013454 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP slide_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP hop_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slide_index_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP hop_index_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_block(SEXP, SEXP, SEXP); extern SEXP slider_compute_from(SEXP, SEXP, SEXP, SEXP); extern SEXP slider_compute_to(SEXP, SEXP, SEXP, SEXP); extern SEXP slider_vec_set_names(SEXP, SEXP); extern SEXP slider_vec_names(SEXP); extern SEXP slider_sum(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_mean(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_prod(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_min(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_max(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_all(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_any(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_sum_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_mean_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_prod_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_min_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_max_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_all_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP slider_index_any_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); // Defined below SEXP slider_initialize(SEXP); static const R_CallMethodDef CallEntries[] = { {"slide_common_impl", (DL_FUNC) &slide_common_impl, 5}, {"hop_common_impl", (DL_FUNC) &hop_common_impl, 7}, {"slide_index_common_impl", (DL_FUNC) &slide_index_common_impl, 13}, {"hop_index_common_impl", (DL_FUNC) &hop_index_common_impl, 12}, {"slider_block", (DL_FUNC) &slider_block, 3}, {"slider_compute_from", (DL_FUNC) &slider_compute_from, 4}, {"slider_compute_to", (DL_FUNC) &slider_compute_to, 4}, {"slider_vec_set_names", (DL_FUNC) &slider_vec_set_names, 2}, {"slider_vec_names", (DL_FUNC) &slider_vec_names, 1}, {"slider_sum", (DL_FUNC) &slider_sum, 6}, {"slider_mean", (DL_FUNC) &slider_mean, 6}, {"slider_prod", (DL_FUNC) &slider_prod, 6}, {"slider_min", (DL_FUNC) &slider_min, 6}, {"slider_max", (DL_FUNC) &slider_max, 6}, {"slider_all", (DL_FUNC) &slider_all, 6}, {"slider_any", (DL_FUNC) &slider_any, 6}, {"slider_index_sum_core", (DL_FUNC) &slider_index_sum_core, 7}, {"slider_index_mean_core", (DL_FUNC) &slider_index_mean_core, 7}, {"slider_index_prod_core", (DL_FUNC) &slider_index_prod_core, 7}, {"slider_index_min_core", (DL_FUNC) &slider_index_min_core, 7}, {"slider_index_max_core", (DL_FUNC) &slider_index_max_core, 7}, {"slider_index_all_core", (DL_FUNC) &slider_index_all_core, 7}, {"slider_index_any_core", (DL_FUNC) &slider_index_any_core, 7}, {"slider_initialize", (DL_FUNC) &slider_initialize, 1}, {NULL, NULL, 0} }; void R_init_slider(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } // slider-vctrs-private.c void slider_initialize_vctrs_private(); // slider-vctrs-public.c void slider_initialize_vctrs_public(); // utils.c void slider_initialize_utils(SEXP); SEXP slider_initialize(SEXP ns) { slider_initialize_vctrs_private(); slider_initialize_vctrs_public(); slider_initialize_utils(ns); return R_NilValue; } slider/src/summary-core-types.h0000644000176200001440000000025514025156373016271 0ustar liggesusers#ifndef SLIDER_SUMMARY_CORE_TYPES #define SLIDER_SUMMARY_CORE_TYPES #include // uintptr_t struct mean_state_t { long double sum; uint64_t count; }; #endif slider/src/slider-vctrs-public.c0000644000176200001440000000012213663762054016373 0ustar liggesusers#include void slider_initialize_vctrs_public() { vctrs_init_api(); } slider/src/index.h0000644000176200001440000000450614024427556013621 0ustar liggesusers#ifndef SLIDER_INDEX_H #define SLIDER_INDEX_H #include "slider.h" // ----------------------------------------------------------------------------- struct index_info { SEXP data; const int* p_data; int size; int last_pos; int current_start_pos; int current_stop_pos; }; #define PROTECT_INDEX_INFO(index, n) do { \ PROTECT((index)->data); \ *n += 1; \ } while (0) struct index_info new_index_info(SEXP); // ----------------------------------------------------------------------------- struct range_info { SEXP starts; SEXP stops; const int* p_starts; const int* p_stops; int size; bool start_unbounded; bool stop_unbounded; }; #define PROTECT_RANGE_INFO(range, n) do { \ PROTECT((range)->starts); \ PROTECT((range)->stops); \ *n += 2; \ } while (0) struct range_info new_range_info(SEXP, SEXP, int); // ----------------------------------------------------------------------------- struct window_info { const int* p_peer_sizes; const int* p_peer_starts; const int* p_peer_stops; SEXP seq; int* p_seq_val; }; #define PROTECT_WINDOW_INFO(window, n) do { \ PROTECT((window)->seq); \ *n += 1; \ } while (0) void fill_peer_info(const int* p_peer_sizes, int size, int* p_peer_starts, int* p_peer_stops); struct window_info new_window_info(const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops); int locate_peer_starts_pos(struct index_info* index, struct range_info range, int pos); int locate_peer_stops_pos(struct index_info* index, struct range_info range, int pos); void increment_window(struct window_info window, struct index_info* index, struct range_info range, int pos); // ----------------------------------------------------------------------------- int compute_min_iteration(struct index_info index, struct range_info range, bool complete); int compute_max_iteration(struct index_info index, struct range_info range, bool complete); // ----------------------------------------------------------------------------- #endif slider/src/params.h0000644000176200001440000000130013736067057013767 0ustar liggesusers#ifndef SLIDER_PARAMS_H #define SLIDER_PARAMS_H #include "slider.h" int validate_type(SEXP x); bool validate_constrain(SEXP x); bool validate_atomic(SEXP x); int validate_before(SEXP x, bool* before_unbounded, bool dot); int validate_after(SEXP x, bool* after_unbounded, bool dot); int validate_step(SEXP x, bool dot); int validate_complete(SEXP x, bool dot); int validate_na_rm(SEXP x, bool dot); void check_double_negativeness(int before, int after, bool before_positive, bool after_positive); void check_after_negativeness(int after, int before, bool after_positive, bool before_unbounded); void check_before_negativeness(int before, int after, bool before_positive, bool after_unbounded); #endif slider/src/utils.c0000644000176200001440000002101614025156373013635 0ustar liggesusers#include "slider.h" #include "utils.h" #include "slider-vctrs.h" SEXP strings_before = NULL; SEXP strings_after = NULL; SEXP strings_step = NULL; SEXP strings_complete = NULL; SEXP strings_na_rm = NULL; SEXP strings_dot_before = NULL; SEXP strings_dot_after = NULL; SEXP strings_dot_step = NULL; SEXP strings_dot_complete = NULL; SEXP strings_dot_na_rm = NULL; SEXP syms_dot_x = NULL; SEXP syms_dot_y = NULL; SEXP syms_dot_l = NULL; SEXP slider_shared_empty_lgl = NULL; SEXP slider_shared_empty_int = NULL; SEXP slider_shared_empty_dbl = NULL; SEXP slider_shared_na_lgl = NULL; SEXP slider_ns_env = NULL; // ----------------------------------------------------------------------------- #define SLIDER_INIT_ATOMIC(CTYPE, DEREF, NA_VALUE) do { \ SEXP out = PROTECT(Rf_allocVector(type, size)); \ CTYPE* p_out = DEREF(out); \ \ for (R_xlen_t i = 0; i < size; ++i) { \ p_out[i] = NA_VALUE; \ } \ \ UNPROTECT(1); \ return out; \ } while (0) // Lists are initialized with `NULL` elements static SEXP list_init(R_xlen_t size) { return Rf_allocVector(VECSXP, size); } SEXP slider_init(SEXPTYPE type, R_xlen_t size) { switch (type) { case LGLSXP: SLIDER_INIT_ATOMIC(int, LOGICAL, NA_LOGICAL); case INTSXP: SLIDER_INIT_ATOMIC(int, INTEGER, NA_INTEGER); case REALSXP: SLIDER_INIT_ATOMIC(double, REAL, NA_REAL); case STRSXP: SLIDER_INIT_ATOMIC(SEXP, STRING_PTR, NA_STRING); case VECSXP: return list_init(size); default: Rf_errorcall(R_NilValue, "Internal error: Unknown type in `slider_init()`."); } never_reached("slider_init"); } #undef SLIDER_INIT_ATOMIC // ----------------------------------------------------------------------------- void stop_not_all_size_one(int iteration, int size) { SEXP call = PROTECT( Rf_lang3( Rf_install("stop_not_all_size_one"), PROTECT(Rf_ScalarInteger(iteration)), PROTECT(Rf_ScalarInteger(size)) ) ); Rf_eval(call, slider_ns_env); Rf_error("Internal error: `stop_not_all_size_one()` should have jumped earlier"); } // ----------------------------------------------------------------------------- static void stop_slide_start_past_stop(SEXP starts, SEXP stops) { SEXP call = PROTECT( Rf_lang3( Rf_install("stop_slide_start_past_stop"), starts, stops ) ); Rf_eval(call, slider_ns_env); Rf_error("Internal error: `stop_slide_start_past_stop()` should have jumped earlier"); } static void stop_hop_start_past_stop(SEXP starts, SEXP stops) { SEXP call = PROTECT( Rf_lang3( Rf_install("stop_hop_start_past_stop"), starts, stops ) ); Rf_eval(call, slider_ns_env); Rf_error("Internal error: `stop_hop_start_past_stop()` should have jumped earlier"); } void check_slide_starts_not_past_stops(SEXP starts, SEXP stops, const int* p_starts, const int* p_stops, R_xlen_t size) { if (p_int_any_gt(p_starts, p_stops, size)) { stop_slide_start_past_stop(starts, stops); } } void check_hop_starts_not_past_stops(SEXP starts, SEXP stops, const int* p_starts, const int* p_stops, R_xlen_t size) { if (p_int_any_gt(p_starts, p_stops, size)) { stop_hop_start_past_stop(starts, stops); } } // ----------------------------------------------------------------------------- int compute_size(SEXP x, int type) { if (type == SLIDE) { return vec_size(x); } else if (type == PSLIDE_EMPTY) { return 0; } else { return vec_size(r_lst_get(x, 0)); } } // ----------------------------------------------------------------------------- int compute_force(int type) { if (type == SLIDE) { return 1; } else if (type == SLIDE2) { return 2; } else { return type; } } // ----------------------------------------------------------------------------- SEXP slider_names(SEXP x, int type) { if (type == SLIDE) { return vec_names(x); } else if (type == PSLIDE_EMPTY) { return R_NilValue; } else { return vec_names(r_lst_get(x, 0)); } } // ----------------------------------------------------------------------------- // `slice_and_update_env()` works by repeatedly overwriting the // `container` with the results of slicing into `x`. This is mainly important // for performance with `pslide()`, where `container` is a list the same size // as `.l`. By repeatedly overwriting 1 list, we don't have to reallocate one // every time we call `slice_and_update_env()`. For `slide()` and `slide2()`, // `container` is just `NULL`. // slide() // - Slice `x` directly // - Immediately define `container` as `.x` in `env` // slide2() // - Slice `x[[1]]` // - Define `container` as `.x` in `env` // - Slice `x[[2]]` // - Define `container` as `.y` in `env` // pslide() // - For i in 1:length(.l) // - Slice `x[[i]]` // - Set the slice result as `container[[i]]` // - Define `container` as `.l` in `env` SEXP make_slice_container(int type) { if (type == SLIDE || type == SLIDE2) { return R_NilValue; } return Rf_allocVector(VECSXP, type); } void slice_and_update_env(SEXP x, SEXP window, SEXP env, int type, SEXP container) { // slide() if (type == SLIDE) { container = vec_slice_impl(x, window); Rf_defineVar(syms_dot_x, container, env); return; } // slide2() if (type == SLIDE2) { container = vec_slice_impl(VECTOR_ELT(x, 0), window); Rf_defineVar(syms_dot_x, container, env); container = vec_slice_impl(VECTOR_ELT(x, 1), window); Rf_defineVar(syms_dot_y, container, env); return; } SEXP slice; // pslide() for (int i = 0; i < type; ++i) { slice = vec_slice_impl(VECTOR_ELT(x, i), window); SET_VECTOR_ELT(container, i, slice); } Rf_defineVar(syms_dot_l, container, env); } // ----------------------------------------------------------------------------- // [[register()]] void slider_initialize_utils(SEXP ns) { slider_ns_env = ns; syms_dot_x = Rf_install(".x"); syms_dot_y = Rf_install(".y"); syms_dot_l = Rf_install(".l"); strings_before = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_before); SET_STRING_ELT(strings_before, 0, Rf_mkChar("before")); strings_after = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_after); SET_STRING_ELT(strings_after, 0, Rf_mkChar("after")); strings_step = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_step); SET_STRING_ELT(strings_step, 0, Rf_mkChar("step")); strings_complete = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_complete); SET_STRING_ELT(strings_complete, 0, Rf_mkChar("complete")); strings_na_rm = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_na_rm); SET_STRING_ELT(strings_na_rm, 0, Rf_mkChar("na_rm")); strings_dot_before = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_dot_before); SET_STRING_ELT(strings_dot_before, 0, Rf_mkChar(".before")); strings_dot_after = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_dot_after); SET_STRING_ELT(strings_dot_after, 0, Rf_mkChar(".after")); strings_dot_step = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_dot_step); SET_STRING_ELT(strings_dot_step, 0, Rf_mkChar(".step")); strings_dot_complete = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_dot_complete); SET_STRING_ELT(strings_dot_complete, 0, Rf_mkChar(".complete")); strings_dot_na_rm = Rf_allocVector(STRSXP, 1); R_PreserveObject(strings_dot_na_rm); SET_STRING_ELT(strings_dot_na_rm, 0, Rf_mkChar(".na_rm")); slider_shared_empty_lgl = Rf_allocVector(LGLSXP, 0); R_PreserveObject(slider_shared_empty_lgl); MARK_NOT_MUTABLE(slider_shared_empty_lgl); slider_shared_empty_int = Rf_allocVector(INTSXP, 0); R_PreserveObject(slider_shared_empty_int); MARK_NOT_MUTABLE(slider_shared_empty_int); slider_shared_empty_dbl = Rf_allocVector(REALSXP, 0); R_PreserveObject(slider_shared_empty_dbl); MARK_NOT_MUTABLE(slider_shared_empty_dbl); slider_shared_na_lgl = Rf_allocVector(LGLSXP, 1); R_PreserveObject(slider_shared_na_lgl); LOGICAL(slider_shared_na_lgl)[0] = NA_LOGICAL; MARK_NOT_MUTABLE(slider_shared_na_lgl); } slider/src/slide.c0000644000176200001440000001353513736067057013614 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" #include "utils.h" #include "params.h" #include "assign.h" #include "opts-slide.h" // ----------------------------------------------------------------------------- #define SLIDE_LOOP(ASSIGN_ONE) do { \ for (int i = iter_min; i < iter_max; i += iter_step) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ int window_start = max(start, 0); \ int window_stop = min(stop, size - 1); \ int window_size = window_stop - window_start + 1; \ \ /* Happens when the entire window is OOB, we take a 0-slice of `x`. */ \ if (window_stop < window_start) { \ window_start = 0; \ window_size = 0; \ } \ \ start += start_step; \ stop += stop_step; \ \ init_compact_seq(p_window, window_start, window_size, true); \ \ slice_and_update_env(x, window, env, type, container); \ \ SEXP elt = PROTECT(r_force_eval(f_call, env, force)); \ \ if (atomic && vec_size(elt) != 1) { \ stop_not_all_size_one(i + 1, vec_size(elt)); \ } \ \ ASSIGN_ONE(p_out, i, elt, ptype); \ UNPROTECT(1); \ } \ } while(0) #define SLIDE_LOOP_ATOMIC(CTYPE, DEREF, ASSIGN_ONE) do { \ CTYPE* p_out = DEREF(out); \ SLIDE_LOOP(ASSIGN_ONE); \ } while (0) \ #define SLIDE_LOOP_BARRIER(ASSIGN_ONE) do { \ SEXP p_out = out; \ \ /* Initialize with `NA`, not `NULL` */ \ /* for size stability when auto-simplifying */ \ if (atomic && !constrain) { \ for (R_len_t i = 0; i < size; ++i) { \ SET_VECTOR_ELT(p_out, i, slider_shared_na_lgl); \ } \ } \ \ SLIDE_LOOP(ASSIGN_ONE); \ } while (0) // ----------------------------------------------------------------------------- // [[ register() ]] SEXP slide_common_impl(SEXP x, SEXP f_call, SEXP ptype, SEXP env, SEXP params) { const int type = validate_type(r_lst_get(params, 0)); const bool constrain = validate_constrain(r_lst_get(params, 1)); const bool atomic = validate_atomic(r_lst_get(params, 2)); const int force = compute_force(type); const int size = compute_size(x, type); SEXP before = r_lst_get(params, 3); SEXP after = r_lst_get(params, 4); SEXP step = r_lst_get(params, 5); SEXP complete = r_lst_get(params, 6); const bool dot = true; const struct slide_opts opts = new_slide_opts( before, after, step, complete, dot ); const struct iter_opts iopts = new_iter_opts(opts, size); int iter_min = iopts.iter_min; int iter_max = iopts.iter_max; int iter_step = iopts.iter_step; int start = iopts.start; int stop = iopts.stop; int start_step = iopts.start_step; int stop_step = iopts.stop_step; // The indices to slice x with SEXP window = PROTECT(compact_seq(0, 0, true)); int* p_window = INTEGER(window); // Mutable container for the results of slicing x SEXP container = PROTECT(make_slice_container(type)); SEXPTYPE out_type = TYPEOF(ptype); SEXP out = PROTECT(slider_init(out_type, size)); switch (out_type) { case INTSXP: SLIDE_LOOP_ATOMIC(int, INTEGER, assign_one_int); break; case REALSXP: SLIDE_LOOP_ATOMIC(double, REAL, assign_one_dbl); break; case LGLSXP: SLIDE_LOOP_ATOMIC(int, LOGICAL, assign_one_lgl); break; case STRSXP: SLIDE_LOOP_ATOMIC(SEXP, STRING_PTR, assign_one_chr); break; case VECSXP: SLIDE_LOOP_BARRIER(assign_one_lst); break; default: never_reached("slide_common_impl"); } SEXP names = slider_names(x, type); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(3); return out; } // ----------------------------------------------------------------------------- #undef SLIDE_LOOP #undef SLIDE_LOOP_ATOMIC #undef SLIDE_LOOP_BARRIER slider/src/utils.h0000644000176200001440000000543514025156373013651 0ustar liggesusers#ifndef SLIDER_UTILS_H #define SLIDER_UTILS_H #include "slider.h" #define PROTECT_N(x, n) (++*n, PROTECT(x)) #define r_int Rf_ScalarInteger static inline int min(int x, int y) { return x < y ? x : y; } static inline int max(int x, int y) { return x > y ? x : y; } static inline R_xlen_t min_size(R_xlen_t x, R_xlen_t y) { return x < y ? x : y; } static inline R_xlen_t max_size(R_xlen_t x, R_xlen_t y) { return x > y ? x : y; } static inline uint64_t min_u64(uint64_t x, uint64_t y) { return x < y ? x : y; } static inline SEXP r_force_eval(SEXP call, SEXP env, const int n_force) { #if defined(R_VERSION) && R_VERSION >= R_Version(3, 2, 3) return R_forceAndCall(call, n_force, env); #else return Rf_eval(call, env); #endif } static inline SEXP r_lst_get(SEXP x, int i) { return VECTOR_ELT(x, i); } static inline int r_scalar_int_get(SEXP x) { return INTEGER(x)[0]; } static inline int r_scalar_lgl_get(SEXP x) { return LOGICAL(x)[0]; } static inline const char* r_scalar_chr_get(SEXP x) { return CHAR(STRING_ELT(x, 0)); } static inline bool p_int_any_gt(const int* p_x, const int* p_y, R_xlen_t size) { for (R_xlen_t i = 0; i < size; ++i) { if (p_x[i] > p_y[i]) { return true; } } return false; } __attribute__((noreturn)) static inline void never_reached(const char* fn) { Rf_errorcall(R_NilValue, "Internal error: Reached the unreachable in `%s()`.", fn); } extern SEXP strings_before; extern SEXP strings_after; extern SEXP strings_step; extern SEXP strings_complete; extern SEXP strings_na_rm; extern SEXP strings_dot_before; extern SEXP strings_dot_after; extern SEXP strings_dot_step; extern SEXP strings_dot_complete; extern SEXP strings_dot_na_rm; extern SEXP syms_dot_x; extern SEXP syms_dot_y; extern SEXP syms_dot_l; extern SEXP slider_shared_empty_lgl; extern SEXP slider_shared_empty_int; extern SEXP slider_shared_empty_dbl; extern SEXP slider_shared_na_lgl; extern SEXP slider_ns_env; SEXP slider_init(SEXPTYPE type, R_xlen_t size); void stop_not_all_size_one(int iteration, int size); void check_slide_starts_not_past_stops(SEXP starts, SEXP stops, const int* p_starts, const int* p_stops, R_xlen_t size); void check_hop_starts_not_past_stops(SEXP starts, SEXP stops, const int* p_starts, const int* p_stops, R_xlen_t size); int compute_size(SEXP x, int type); int compute_force(int type); SEXP slider_names(SEXP x, int type); SEXP make_slice_container(int type); void slice_and_update_env(SEXP x, SEXP window, SEXP env, int type, SEXP container); #endif slider/src/segment-tree.h0000644000176200001440000000361114025156373015102 0ustar liggesusers#ifndef SLIDER_SEGMENT_TREE #define SLIDER_SEGMENT_TREE #include "slider.h" #define SEGMENT_TREE_FANOUT 16 #define SEGMENT_TREE_FANOUT_POWER 4 struct segment_tree { const void* p_leaves; SEXP p_level; void** p_p_level; SEXP nodes; void* p_nodes; void* p_state; uint64_t n_leaves; uint64_t n_levels; uint64_t n_nodes; void (*state_reset)(void* p_state); void (*state_finalize)(void* p_state, void* p_result); void* (*nodes_increment)(void* p_nodes); void (*aggregate_from_leaves)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest); void (*aggregate_from_nodes)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest); }; #define PROTECT_SEGMENT_TREE(p_tree, p_n) do { \ PROTECT((p_tree)->p_level); \ PROTECT((p_tree)->nodes); \ *(p_n) += 2; \ } while(0) struct segment_tree new_segment_tree(uint64_t n_leaves, const void* p_leaves, void* p_state, void (*state_reset)(void* p_state), void (*state_finalize)(void* p_state, void* p_result), void* (*nodes_increment)(void* p_nodes), SEXP (*nodes_initialize)(uint64_t n), void* (*nodes_void_deref)(SEXP nodes), void (*aggregate_from_leaves)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest), void (*aggregate_from_nodes)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest)); void segment_tree_aggregate(const struct segment_tree* p_tree, uint64_t begin, uint64_t end, void* p_result); #endif slider/src/slide-period.c0000644000176200001440000000403014024427556015055 0ustar liggesusers#include "slider.h" // ----------------------------------------------------------------------------- static SEXP compute_from(SEXP starts, double first, R_xlen_t n, bool before_unbounded); // [[ export() ]] SEXP slider_compute_from(SEXP starts, SEXP first, SEXP n, SEXP before_unbounded) { double first_ = REAL(first)[0]; // Support long vectors R_xlen_t n_; switch(TYPEOF(n)) { case REALSXP: n_ = REAL(n)[0]; break; case INTSXP: n_ = (double) INTEGER(n)[0]; break; default: Rf_errorcall(R_NilValue, "Internal error: `n` should be integer or double."); } bool before_unbounded_ = LOGICAL(before_unbounded)[0]; return compute_from(starts, first_, n_, before_unbounded_); } static SEXP compute_from(SEXP starts, double first, R_xlen_t n, bool before_unbounded) { double* p_starts = REAL(starts); R_xlen_t from = 1; if (before_unbounded) { return(Rf_ScalarReal(from)); } for (R_xlen_t i = 0; i < n; ++i) { if (first > p_starts[i]) { ++from; } else { break; } } return Rf_ScalarReal(from); } // ----------------------------------------------------------------------------- static SEXP compute_to(SEXP stops, double last, R_xlen_t n, bool after_unbounded); // [[ export() ]] SEXP slider_compute_to(SEXP stops, SEXP last, SEXP n, SEXP after_unbounded) { double last_ = REAL(last)[0]; // Support long vectors R_xlen_t n_; switch(TYPEOF(n)) { case REALSXP: n_ = REAL(n)[0]; break; case INTSXP: n_ = (double) INTEGER(n)[0]; break; default: Rf_errorcall(R_NilValue, "Internal error: `n` should be integer or double."); } bool after_unbounded_ = LOGICAL(after_unbounded)[0]; return compute_to(stops, last_, n_, after_unbounded_); } static SEXP compute_to(SEXP stops, double last, R_xlen_t n, bool after_unbounded) { double* p_stops = REAL(stops); R_xlen_t to = n; if (after_unbounded) { return(Rf_ScalarReal(to)); } for (R_xlen_t i = n - 1; i >= 0; --i) { if (last < p_stops[i]) { --to; } else { break; } } return Rf_ScalarReal(to); } slider/src/names.c0000644000176200001440000000031513630333127013572 0ustar liggesusers#include "slider-vctrs.h" // [[ export() ]] SEXP slider_vec_set_names(SEXP x, SEXP names) { return vec_set_names(x, names); } // [[ export() ]] SEXP slider_vec_names(SEXP x) { return vec_names(x); } slider/src/segment-tree.c0000644000176200001440000001375114025156373015103 0ustar liggesusers#include "segment-tree.h" #include "utils.h" static void segment_tree_initialize_levels(struct segment_tree* p_tree); // [[ include("segment-tree.h") ]] struct segment_tree new_segment_tree(uint64_t n_leaves, const void* p_leaves, void* p_state, void (*state_reset)(void* p_state), void (*state_finalize)(void* p_state, void* p_result), void* (*nodes_increment)(void* p_nodes), SEXP (*nodes_initialize)(uint64_t n), void* (*nodes_void_deref)(SEXP nodes), void (*aggregate_from_leaves)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest), void (*aggregate_from_nodes)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest)) { struct segment_tree tree; tree.n_leaves = n_leaves; tree.n_levels = 0; tree.n_nodes = 0; uint64_t n_level_nodes = n_leaves; while (n_level_nodes > 1) { n_level_nodes = (uint64_t) ceil((double) n_level_nodes / SEGMENT_TREE_FANOUT); tree.n_nodes += n_level_nodes; ++tree.n_levels; } tree.p_leaves = p_leaves; tree.p_state = p_state; tree.p_level = PROTECT(Rf_allocVector(RAWSXP, tree.n_levels * sizeof(void*))); tree.p_p_level = (void**) RAW(tree.p_level); tree.nodes = PROTECT(nodes_initialize(tree.n_nodes)); tree.p_nodes = nodes_void_deref(tree.nodes); tree.state_reset = state_reset; tree.state_finalize = state_finalize; tree.nodes_increment = nodes_increment; tree.aggregate_from_leaves = aggregate_from_leaves; tree.aggregate_from_nodes = aggregate_from_nodes; segment_tree_initialize_levels(&tree); UNPROTECT(2); return tree; } // ----------------------------------------------------------------------------- static void segment_tree_initialize_levels(struct segment_tree* p_tree) { uint64_t n_levels = p_tree->n_levels; if (n_levels == 0) { return; } uint64_t n_leaves = p_tree->n_leaves; const void* p_leaves = p_tree->p_leaves; void* p_dest = p_tree->p_nodes; void** p_p_level = p_tree->p_p_level; p_p_level[0] = p_dest; uint64_t n_nodes_next_source = 0; // Handle leaf aggregation for (uint64_t i = 0; i < n_leaves; i += SEGMENT_TREE_FANOUT) { uint64_t begin = i; uint64_t end = min_u64(n_leaves, i + SEGMENT_TREE_FANOUT); p_tree->aggregate_from_leaves(p_leaves, begin, end, p_dest); p_dest = p_tree->nodes_increment(p_dest); ++n_nodes_next_source; } void* p_source = p_p_level[0]; uint64_t n_nodes_source = n_nodes_next_source; // Handle node aggregation for (uint64_t i = 1; i < n_levels; ++i) { p_p_level[i] = p_dest; n_nodes_next_source = 0; for (uint64_t j = 0; j < n_nodes_source; j += SEGMENT_TREE_FANOUT) { uint64_t begin = j; uint64_t end = min_u64(n_nodes_source, j + SEGMENT_TREE_FANOUT); p_tree->aggregate_from_nodes(p_source, begin, end, p_dest); p_dest = p_tree->nodes_increment(p_dest); ++n_nodes_next_source; } p_source = p_p_level[i]; n_nodes_source = n_nodes_next_source; } } // ----------------------------------------------------------------------------- static void segment_tree_aggregate_level(const void* p_source, void (*aggregate)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest), uint64_t* p_begin, uint64_t* p_end, void* p_dest, bool* p_done); // [[ include("segment-tree.h") ]] void segment_tree_aggregate(const struct segment_tree* p_tree, uint64_t begin, uint64_t end, void* p_result) { bool done = false; void* p_state = p_tree->p_state; p_tree->state_reset(p_state); const void* p_leaves = p_tree->p_leaves; // Aggregate leaf level segment_tree_aggregate_level( p_leaves, p_tree->aggregate_from_leaves, &begin, &end, p_state, &done ); if (done) { p_tree->state_finalize(p_state, p_result); return; } void** p_p_level = p_tree->p_p_level; uint64_t n_levels = p_tree->n_levels; // Continue aggregation of node levels for (uint64_t i = 0; i < n_levels; ++i) { const void* p_level = p_p_level[i]; segment_tree_aggregate_level( p_level, p_tree->aggregate_from_nodes, &begin, &end, p_state, &done ); if (done) { break; } } p_tree->state_finalize(p_state, p_result); return; } static void segment_tree_aggregate_level(const void* p_source, void (*aggregate)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest), uint64_t* p_begin, uint64_t* p_end, void* p_state, bool* p_done) { uint64_t begin = *p_begin; uint64_t end = *p_end; // Integer division! Assume fanout is a power of 2 so we can use shifting // which is much faster than division uint64_t parent_begin = begin >> SEGMENT_TREE_FANOUT_POWER; uint64_t parent_end = end >> SEGMENT_TREE_FANOUT_POWER; // Same fan group if (parent_begin == parent_end) { aggregate(p_source, begin, end, p_state); *p_done = true; return; } uint64_t group_begin = parent_begin * SEGMENT_TREE_FANOUT; uint64_t group_end = parent_end * SEGMENT_TREE_FANOUT; if (begin != group_begin) { uint64_t stop = group_begin + SEGMENT_TREE_FANOUT; aggregate(p_source, begin, stop, p_state); parent_begin += 1; } if (end != group_end) { aggregate(p_source, group_end, end, p_state); } // Update for next level *p_begin = parent_begin; *p_end = parent_end; } slider/src/slider-vctrs-private.c0000644000176200001440000000210613663762054016573 0ustar liggesusers#include "slider-vctrs-private.h" // Experimental non-public vctrs functions SEXP (*vec_cast)(SEXP, SEXP) = NULL; SEXP (*vec_chop)(SEXP, SEXP) = NULL; SEXP (*vec_slice_impl)(SEXP, SEXP) = NULL; SEXP (*vec_names)(SEXP) = NULL; SEXP (*vec_set_names)(SEXP, SEXP) = NULL; SEXP (*compact_seq)(R_len_t, R_len_t, bool) = NULL; SEXP (*init_compact_seq)(int*, R_len_t, R_len_t, bool) = NULL; void slider_initialize_vctrs_private() { // Experimental non-public vctrs functions vec_cast = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_cast"); vec_chop = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_chop"); vec_slice_impl = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_slice_impl"); vec_names = (SEXP (*)(SEXP)) R_GetCCallable("vctrs", "exp_vec_names"); vec_set_names = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_set_names"); compact_seq = (SEXP (*)(R_len_t, R_len_t, bool)) R_GetCCallable("vctrs", "exp_short_compact_seq"); init_compact_seq = (SEXP (*)(int*, R_len_t, R_len_t, bool)) R_GetCCallable("vctrs", "exp_short_init_compact_seq"); } slider/src/slider-vctrs-private.h0000644000176200001440000000067113660526077016605 0ustar liggesusers#ifndef SLIDER_VCTRS_PRIVATE_H #define SLIDER_VCTRS_PRIVATE_H #include "slider.h" // Experimental non-public vctrs functions extern SEXP (*vec_cast)(SEXP, SEXP); extern SEXP (*vec_chop)(SEXP, SEXP); extern SEXP (*vec_slice_impl)(SEXP, SEXP); extern SEXP (*vec_names)(SEXP); extern SEXP (*vec_set_names)(SEXP, SEXP); extern SEXP (*compact_seq)(R_len_t, R_len_t, bool); extern SEXP (*init_compact_seq)(int*, R_len_t, R_len_t, bool); #endif slider/src/slider-vctrs-public.h0000644000176200001440000000026414024427556016404 0ustar liggesusers#ifndef SLIDER_VCTRS_PUBLIC_H #define SLIDER_VCTRS_PUBLIC_H #include "slider.h" #include static inline R_len_t vec_size(SEXP x) { return short_vec_size(x); } #endif slider/src/params.c0000644000176200001440000001231714024427556013767 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" #include "utils.h" #include "params.h" // ----------------------------------------------------------------------------- // Checking for scalar ptypes static bool is_scalar(SEXP x) { return vec_size(x) == 1; } static void stop_scalar(const char * arg, int size) { Rf_errorcall(R_NilValue, "`%s` must have size 1, not %i.", arg, size); } static void check_scalar(SEXP x, SEXP arg) { if (is_scalar(x)) { return; } stop_scalar(r_scalar_chr_get(arg), vec_size(x)); } static SEXP check_ptype(SEXP x, SEXP ptype) { return vec_cast(x, ptype); } static SEXP check_int(SEXP x) { return check_ptype(x, slider_shared_empty_int); } static SEXP check_lgl(SEXP x) { return check_ptype(x, slider_shared_empty_lgl); } static SEXP check_scalar_int(SEXP x, SEXP x_arg) { check_scalar(x, x_arg); return check_int(x); } static SEXP check_scalar_lgl(SEXP x, SEXP x_arg) { check_scalar(x, x_arg); return check_lgl(x); } // ----------------------------------------------------------------------------- static bool is_unbounded(SEXP x) { return !OBJECT(x) && TYPEOF(x) == REALSXP && REAL(x)[0] == R_PosInf; } // ----------------------------------------------------------------------------- // [[ include("params.h") ]] int validate_type(SEXP x) { return r_scalar_int_get(x); } // [[ include("params.h") ]] bool validate_constrain(SEXP x) { return r_scalar_lgl_get(x); } // [[ include("params.h") ]] bool validate_atomic(SEXP x) { return r_scalar_lgl_get(x); } // [[ include("params.h") ]] int validate_before(SEXP x, bool* before_unbounded, bool dot) { check_scalar(x, dot ? strings_dot_before : strings_before); if (is_unbounded(x)) { *before_unbounded = true; return 0; } x = PROTECT(check_int(x)); int out = r_scalar_int_get(x); if (out == NA_INTEGER) { if (dot) { Rf_errorcall(R_NilValue, "`.before` can't be missing."); } else { Rf_errorcall(R_NilValue, "`before` can't be missing."); } } UNPROTECT(1); return out; } // [[ include("params.h") ]] int validate_after(SEXP x, bool* after_unbounded, bool dot) { check_scalar(x, dot ? strings_dot_after : strings_after); if (is_unbounded(x)) { *after_unbounded = true; return 0; } x = PROTECT(check_int(x)); int out = r_scalar_int_get(x); if (out == NA_INTEGER) { if (dot) { Rf_errorcall(R_NilValue, "`.after` can't be missing."); } else { Rf_errorcall(R_NilValue, "`after` can't be missing."); } } UNPROTECT(1); return out; } // [[ include("params.h") ]] int validate_step(SEXP x, bool dot) { x = PROTECT(check_scalar_int(x, dot ? strings_dot_step : strings_step)); int step = r_scalar_int_get(x); if (step == NA_INTEGER) { if (dot) { Rf_errorcall(R_NilValue, "`.step` can't be missing."); } else { Rf_errorcall(R_NilValue, "`step` can't be missing."); } } if (step < 1) { if (dot) { Rf_errorcall(R_NilValue, "`.step` must be at least 1, not %i.", step); } else { Rf_errorcall(R_NilValue, "`step` must be at least 1, not %i.", step); } } UNPROTECT(1); return step; } // [[ include("params.h") ]] int validate_complete(SEXP x, bool dot) { x = PROTECT(check_scalar_lgl(x, dot ? strings_dot_complete : strings_complete)); int out = r_scalar_lgl_get(x); if (out == NA_LOGICAL) { if (dot) { Rf_errorcall(R_NilValue, "`.complete` can't be missing."); } else { Rf_errorcall(R_NilValue, "`complete` can't be missing."); } } UNPROTECT(1); return out; } // [[ include("params.h") ]] int validate_na_rm(SEXP x, bool dot) { x = PROTECT(check_scalar_lgl(x, dot ? strings_dot_na_rm : strings_na_rm)); int out = r_scalar_lgl_get(x); if (out == NA_LOGICAL) { if (dot) { Rf_errorcall(R_NilValue, "`.na_rm` can't be missing."); } else { Rf_errorcall(R_NilValue, "`na_rm` can't be missing."); } } UNPROTECT(1); return out; } // ----------------------------------------------------------------------------- // [[ include("params.h") ]] void check_double_negativeness(int before, int after, bool before_positive, bool after_positive) { if (!before_positive && !after_positive) { Rf_errorcall( R_NilValue, "`.before` (%i) and `.after` (%i) cannot both be negative.", before, after ); } } // [[ include("params.h") ]] void check_after_negativeness(int after, int before, bool after_positive, bool before_unbounded) { if (after_positive) { return; } if (before_unbounded) { return; } int abs_after = abs(after); if (abs_after > before) { Rf_errorcall( R_NilValue, "When `.after` (%i) is negative, it's absolute value (%i) cannot be greater than `.before` (%i).", after, abs_after, before ); } } // [[ include("params.h") ]] void check_before_negativeness(int before, int after, bool before_positive, bool after_unbounded) { if (before_positive) { return; } if (after_unbounded) { return; } int abs_before = abs(before); if (abs_before > after) { Rf_errorcall( R_NilValue, "When `.before` (%i) is negative, it's absolute value (%i) cannot be greater than `.after` (%i).", before, abs_before, after ); } } slider/src/index.c0000644000176200001440000003664414024427556013624 0ustar liggesusers#include "slider.h" #include "index.h" #include "slider-vctrs.h" #include "utils.h" #include "assign.h" // ----------------------------------------------------------------------------- #define SLIDE_INDEX_LOOP(ASSIGN_LOCS) do { \ for (int i = min_iteration; i < max_iteration; ++i) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ increment_window(window, &index, range, i); \ slice_and_update_env(x, window.seq, env, type, container); \ \ SEXP elt = PROTECT(r_force_eval(f_call, env, force)); \ \ if (atomic && vec_size(elt) != 1) { \ stop_not_all_size_one(i + 1, vec_size(elt)); \ } \ \ int peer_start = window.p_peer_starts[i]; \ int peer_size = window.p_peer_sizes[i]; \ \ ASSIGN_LOCS(p_out, peer_start, peer_size, elt, ptype); \ UNPROTECT(1); \ } \ } while (0) #define SLIDE_INDEX_LOOP_ATOMIC(CTYPE, DEREF, ASSIGN_LOCS) do { \ CTYPE* p_out = DEREF(out); \ SLIDE_INDEX_LOOP(ASSIGN_LOCS); \ } while (0) #define SLIDE_INDEX_LOOP_BARRIER(ASSIGN_LOCS) do { \ SEXP p_out = out; \ \ /* Initialize with `NA`, not `NULL` */ \ /* for size stability when auto-simplifying */ \ if (atomic && !constrain) { \ for (R_len_t i = 0; i < size; ++i) { \ SET_VECTOR_ELT(p_out, i, slider_shared_na_lgl); \ } \ } \ \ SLIDE_INDEX_LOOP(ASSIGN_LOCS); \ } while (0) // ----------------------------------------------------------------------------- // [[ register() ]] SEXP slide_index_common_impl(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP f_call, SEXP ptype, SEXP env, SEXP peer_sizes, SEXP type_, SEXP constrain_, SEXP atomic_, SEXP size_, SEXP complete_) { int n_prot = 0; const int type = r_scalar_int_get(type_); const int force = compute_force(type); const bool constrain = r_scalar_lgl_get(constrain_); const bool atomic = r_scalar_lgl_get(atomic_); const int size = r_scalar_int_get(size_); const bool complete = r_scalar_lgl_get(complete_); struct index_info index = new_index_info(i); PROTECT_INDEX_INFO(&index, &n_prot); const int* p_peer_sizes = INTEGER_RO(peer_sizes); int* p_peer_starts = (int*) R_alloc(index.size, sizeof(int)); int* p_peer_stops = (int*) R_alloc(index.size, sizeof(int)); fill_peer_info(p_peer_sizes, index.size, p_peer_starts, p_peer_stops); struct window_info window = new_window_info(p_peer_sizes, p_peer_starts, p_peer_stops); PROTECT_WINDOW_INFO(&window, &n_prot); struct range_info range = new_range_info(starts, stops, index.size); PROTECT_RANGE_INFO(&range, &n_prot); const int min_iteration = compute_min_iteration(index, range, complete); const int max_iteration = compute_max_iteration(index, range, complete); SEXP container = PROTECT_N(make_slice_container(type), &n_prot); SEXPTYPE out_type = TYPEOF(ptype); SEXP out = PROTECT_N(slider_init(out_type, size), &n_prot); switch (out_type) { case INTSXP: SLIDE_INDEX_LOOP_ATOMIC(int, INTEGER, assign_locs_int); break; case REALSXP: SLIDE_INDEX_LOOP_ATOMIC(double, REAL, assign_locs_dbl); break; case LGLSXP: SLIDE_INDEX_LOOP_ATOMIC(int, LOGICAL, assign_locs_lgl); break; case STRSXP: SLIDE_INDEX_LOOP_ATOMIC(SEXP, STRING_PTR, assign_locs_chr); break; case VECSXP: SLIDE_INDEX_LOOP_BARRIER(assign_locs_lst); break; default: never_reached("slide_index_common_impl"); } SEXP names = slider_names(x, type); Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(n_prot); return out; } #undef SLIDE_INDEX_LOOP #undef SLIDE_INDEX_LOOP_ATOMIC #undef SLIDE_INDEX_LOOP_BARRIER // ----------------------------------------------------------------------------- #define HOP_INDEX_LOOP(ASSIGN_ONE) do { \ for (int i = 0; i < range.size; ++i) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ increment_window(window, &index, range, i); \ slice_and_update_env(x, window.seq, env, type, container); \ \ SEXP elt = PROTECT(r_force_eval(f_call, env, force)); \ \ if (atomic && vec_size(elt) != 1) { \ stop_not_all_size_one(i + 1, vec_size(elt)); \ } \ \ ASSIGN_ONE(p_out, i, elt, ptype); \ UNPROTECT(1); \ } \ } while (0) #define HOP_INDEX_LOOP_ATOMIC(CTYPE, DEREF, ASSIGN_ONE) do { \ CTYPE* p_out = DEREF(out); \ HOP_INDEX_LOOP(ASSIGN_ONE); \ } while (0) #define HOP_INDEX_LOOP_BARRIER(ASSIGN_ONE) do { \ SEXP p_out = out; \ \ /* Initialize with `NA`, not `NULL` */ \ /* for size stability when auto-simplifying */ \ if (atomic && !constrain) { \ for (R_len_t i = 0; i < size; ++i) { \ SET_VECTOR_ELT(p_out, i, slider_shared_na_lgl); \ } \ } \ \ HOP_INDEX_LOOP(ASSIGN_ONE); \ } while (0) // ----------------------------------------------------------------------------- // [[ register() ]] SEXP hop_index_common_impl(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP f_call, SEXP ptype, SEXP env, SEXP peer_sizes, SEXP type_, SEXP constrain_, SEXP atomic_, SEXP size_) { int n_prot = 0; const int type = r_scalar_int_get(type_); const int force = compute_force(type); const bool constrain = r_scalar_lgl_get(constrain_); const bool atomic = r_scalar_lgl_get(atomic_); const int size = r_scalar_int_get(size_); struct index_info index = new_index_info(i); PROTECT_INDEX_INFO(&index, &n_prot); const int* p_peer_sizes = INTEGER_RO(peer_sizes); int* p_peer_starts = (int*) R_alloc(index.size, sizeof(int)); int* p_peer_stops = (int*) R_alloc(index.size, sizeof(int)); fill_peer_info(p_peer_sizes, index.size, p_peer_starts, p_peer_stops); struct window_info window = new_window_info(p_peer_sizes, p_peer_starts, p_peer_stops); PROTECT_WINDOW_INFO(&window, &n_prot); struct range_info range = new_range_info(starts, stops, size); PROTECT_RANGE_INFO(&range, &n_prot); SEXP container = PROTECT_N(make_slice_container(type), &n_prot); SEXPTYPE out_type = TYPEOF(ptype); SEXP out = PROTECT_N(slider_init(out_type, size), &n_prot); switch (out_type) { case INTSXP: HOP_INDEX_LOOP_ATOMIC(int, INTEGER, assign_one_int); break; case REALSXP: HOP_INDEX_LOOP_ATOMIC(double, REAL, assign_one_dbl); break; case LGLSXP: HOP_INDEX_LOOP_ATOMIC(int, LOGICAL, assign_one_lgl); break; case STRSXP: HOP_INDEX_LOOP_ATOMIC(SEXP, STRING_PTR, assign_one_chr); break; case VECSXP: HOP_INDEX_LOOP_BARRIER(assign_one_lst); break; default: never_reached("hop_index_common_impl"); } UNPROTECT(n_prot); return out; } #undef HOP_INDEX_LOOP #undef HOP_INDEX_LOOP_ATOMIC #undef HOP_INDEX_LOOP_BARRIER // ----------------------------------------------------------------------------- // [[ include("index.h") ]] struct window_info new_window_info(const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops) { struct window_info window; window.p_peer_sizes = p_peer_sizes; window.p_peer_starts = p_peer_starts; window.p_peer_stops = p_peer_stops; window.seq = PROTECT(compact_seq(0, 0, true)); window.p_seq_val = INTEGER(window.seq); UNPROTECT(1); return window; } // ----------------------------------------------------------------------------- // [[ include("index.h") ]] struct index_info new_index_info(SEXP i) { struct index_info index; index.data = i; index.p_data = INTEGER_RO(i); index.size = vec_size(i); index.last_pos = index.size - 1; index.current_start_pos = 0; index.current_stop_pos = 0; return index; } // ----------------------------------------------------------------------------- // [[ include("index.h") ]] struct range_info new_range_info(SEXP starts, SEXP stops, int size) { struct range_info range; range.starts = starts; range.stops = stops; range.start_unbounded = (starts == R_NilValue); range.stop_unbounded = (stops == R_NilValue); range.size = size; if (!range.start_unbounded) { range.p_starts = INTEGER_RO(starts); } if (!range.stop_unbounded) { range.p_stops = INTEGER_RO(stops); } if (!range.start_unbounded && !range.stop_unbounded) { check_slide_starts_not_past_stops( range.starts, range.stops, range.p_starts, range.p_stops, range.size ); } return range; } // ----------------------------------------------------------------------------- static int iteration_min_adjustment(struct index_info index, const int* p_range, int size); static int iteration_max_adjustment(struct index_info index, const int* p_range, int size); // [[ include("index.h") ]] int compute_min_iteration(struct index_info index, struct range_info range, bool complete) { int out = 0; if (!complete || range.start_unbounded) { return out; } out += iteration_min_adjustment(index, range.p_starts, range.size); return out; } // [[ include("index.h") ]] int compute_max_iteration(struct index_info index, struct range_info range, bool complete) { int out = range.size; if (!complete || range.stop_unbounded) { return out; } out -= iteration_max_adjustment(index, range.p_stops, range.size); return out; } static int iteration_min_adjustment(struct index_info index, const int* p_range, int size) { int forward_adjustment = 0; if (size == 0) { return forward_adjustment; } const int first_index = index.p_data[0]; for (int j = 0; j < size; ++j) { if (first_index > p_range[j]) { ++forward_adjustment; } else { break; } } return forward_adjustment; } static int iteration_max_adjustment(struct index_info index, const int* p_range, int size) { int backward_adjustment = 0; if (size == 0) { return backward_adjustment; } const int last_index = index.p_data[index.last_pos]; for (int j = size - 1; j >= 0; --j) { if (last_index < p_range[j]) { ++backward_adjustment; } else { break; } } return backward_adjustment; } // ----------------------------------------------------------------------------- // [[ include("index.h") ]] void fill_peer_info(const int* p_peer_sizes, int size, int* p_peer_starts, int* p_peer_stops) { int peer_start = 0; for (int i = 0; i < size; ++i) { const int peer_size = p_peer_sizes[i]; p_peer_starts[i] = peer_start; p_peer_stops[i] = peer_start + peer_size - 1; peer_start += peer_size; } } // ----------------------------------------------------------------------------- // `index` is passed by pointer so we can permanently // update the current start/stop position // [[ include("index.h") ]] int locate_peer_starts_pos(struct index_info* index, struct range_info range, int pos) { // Pin to the start if (range.start_unbounded) { return 0; } // Past the end? Signal OOB with `last_pos + 1`. // This also handles size zero `.i` with `.starts` / `.stops` that have size. // Current pos will be 0, but `last_pos` will be -1. if (index->current_start_pos > index->last_pos) { return index->last_pos + 1; } while (index->p_data[index->current_start_pos] < range.p_starts[pos]) { ++index->current_start_pos; // Past the end? Signal OOB with `last_pos + 1`. if (index->current_start_pos > index->last_pos) { return index->last_pos + 1; } } return index->current_start_pos; } // [[ include("index.h") ]] int locate_peer_stops_pos(struct index_info* index, struct range_info range, int pos) { // Pin to the end if (range.stop_unbounded) { return index->last_pos; } // Past the end? Pin to end. // This also handles size zero `.i` with `.starts` / `.stops` that have size. // Current pos will be 0, but `last_pos` will be -1. if (index->current_stop_pos > index->last_pos) { return index->last_pos; } while (index->p_data[index->current_stop_pos] <= range.p_stops[pos]) { ++index->current_stop_pos; // Past the end? Pin to end. if (index->current_stop_pos > index->last_pos) { return index->last_pos; } } return index->current_stop_pos - 1; } // ----------------------------------------------------------------------------- // [[ include("index.h") ]] void increment_window(struct window_info window, struct index_info* index, struct range_info range, int pos) { int peer_starts_pos = locate_peer_starts_pos(index, range, pos); int peer_stops_pos = locate_peer_stops_pos(index, range, pos); if (peer_stops_pos < peer_starts_pos) { init_compact_seq(window.p_seq_val, 0, 0, true); return; } int window_start = window.p_peer_starts[peer_starts_pos]; int window_stop = window.p_peer_stops[peer_stops_pos]; int window_size = window_stop - window_start + 1; init_compact_seq(window.p_seq_val, window_start, window_size, true); } slider/src/assign.h0000644000176200001440000000460514024427556013776 0ustar liggesusers#ifndef SLIDER_ASSIGN_H #define SLIDER_ASSIGN_H #include "slider.h" #include "slider-vctrs.h" // ----------------------------------------------------------------------------- #define ASSIGN_ONE(CONST_DEREF) do { \ elt = vec_cast(elt, ptype); \ p_out[i] = CONST_DEREF(elt)[0]; \ } while (0) static inline void assign_one_dbl(double* p_out, R_len_t i, SEXP elt, SEXP ptype) { ASSIGN_ONE(REAL_RO); } static inline void assign_one_int(int* p_out, R_len_t i, SEXP elt, SEXP ptype) { ASSIGN_ONE(INTEGER_RO); } static inline void assign_one_lgl(int* p_out, R_len_t i, SEXP elt, SEXP ptype) { ASSIGN_ONE(LOGICAL_RO); } static inline void assign_one_chr(SEXP* p_out, R_len_t i, SEXP elt, SEXP ptype) { ASSIGN_ONE(STRING_PTR_RO); } #undef ASSIGN_ONE static inline void assign_one_lst(SEXP out, R_len_t i, SEXP elt, SEXP ptype) { SET_VECTOR_ELT(out, i, elt); } // ----------------------------------------------------------------------------- #define ASSIGN_LOCS(CTYPE, CONST_DEREF) do { \ elt = PROTECT(vec_cast(elt, ptype)); \ const CTYPE value = CONST_DEREF(elt)[0]; \ \ for (R_len_t i = 0; i < size; ++i) { \ p_out[start] = value; \ ++start; \ } \ \ UNPROTECT(1); \ } while (0) static inline void assign_locs_dbl(double* p_out, int start, int size, SEXP elt, SEXP ptype) { ASSIGN_LOCS(double, REAL_RO); } static inline void assign_locs_int(int* p_out, int start, int size, SEXP elt, SEXP ptype) { ASSIGN_LOCS(int, INTEGER_RO); } static inline void assign_locs_lgl(int* p_out, int start, int size, SEXP elt, SEXP ptype) { ASSIGN_LOCS(int, LOGICAL_RO); } static inline void assign_locs_chr(SEXP* p_out, int start, int size, SEXP elt, SEXP ptype) { ASSIGN_LOCS(SEXP, STRING_PTR_RO); } #undef ASSIGN_LOCS static inline void assign_locs_lst(SEXP out, int start, int size, SEXP elt, SEXP ptype) { for (R_len_t i = 0; i < size; ++i) { SET_VECTOR_ELT(out, start, elt); ++start; } } // ----------------------------------------------------------------------------- #endif slider/src/hop.c0000644000176200001440000001165314025110720013253 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" #include "utils.h" #include "params.h" #include "assign.h" // ----------------------------------------------------------------------------- #define HOP_LOOP(ASSIGN_ONE) do { \ for (R_len_t i = 0; i < size; ++i) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ int window_start = max(p_starts[i] - 1, 0); \ int window_stop = min(p_stops[i] - 1, x_size - 1); \ int window_size = window_stop - window_start + 1; \ \ /* This can happen if both `window_start` and */ \ /* `window_stop` are outside the range of `x`. */ \ /* We return a 0-size slice of `x`. */ \ if (window_stop < window_start) { \ window_start = 0; \ window_size = 0; \ } \ \ init_compact_seq(p_window, window_start, window_size, true); \ \ slice_and_update_env(x, window, env, type, container); \ \ SEXP elt = PROTECT(r_force_eval(f_call, env, force)); \ \ if (atomic && vec_size(elt) != 1) { \ stop_not_all_size_one(i + 1, vec_size(elt)); \ } \ \ ASSIGN_ONE(p_out, i, elt, ptype); \ UNPROTECT(1); \ } \ } while (0) #define HOP_LOOP_ATOMIC(CTYPE, DEREF, ASSIGN_ONE) do { \ CTYPE* p_out = DEREF(out); \ HOP_LOOP(ASSIGN_ONE); \ } while (0) #define HOP_LOOP_BARRIER(ASSIGN_ONE) do { \ SEXP p_out = out; \ \ /* Initialize with `NA`, not `NULL` */ \ /* for size stability when auto-simplifying */ \ if (atomic && !constrain) { \ for (R_len_t i = 0; i < size; ++i) { \ SET_VECTOR_ELT(p_out, i, slider_shared_na_lgl); \ } \ } \ \ HOP_LOOP(ASSIGN_ONE); \ } while (0) // ----------------------------------------------------------------------------- // [[ register() ]] SEXP hop_common_impl(SEXP x, SEXP starts, SEXP stops, SEXP f_call, SEXP ptype, SEXP env, SEXP params) { const int type = validate_type(r_lst_get(params, 0)); const int force = compute_force(type); const bool constrain = validate_constrain(r_lst_get(params, 1)); const bool atomic = validate_atomic(r_lst_get(params, 2)); const R_len_t x_size = compute_size(x, type); const R_len_t size = vec_size(starts); const int* p_starts = INTEGER_RO(starts); const int* p_stops = INTEGER_RO(stops); check_hop_starts_not_past_stops(starts, stops, p_starts, p_stops, size); // The indices to slice x with SEXP window = PROTECT(compact_seq(0, 0, true)); int* p_window = INTEGER(window); // Mutable container for the results of slicing x SEXP container = PROTECT(make_slice_container(type)); SEXPTYPE out_type = TYPEOF(ptype); SEXP out = PROTECT(slider_init(out_type, size)); switch (out_type) { case INTSXP: HOP_LOOP_ATOMIC(int, INTEGER, assign_one_int); break; case REALSXP: HOP_LOOP_ATOMIC(double, REAL, assign_one_dbl); break; case LGLSXP: HOP_LOOP_ATOMIC(int, LOGICAL, assign_one_lgl); break; case STRSXP: HOP_LOOP_ATOMIC(SEXP, STRING_PTR, assign_one_chr); break; case VECSXP: HOP_LOOP_BARRIER(assign_one_lst); break; default: never_reached("hop_common_impl"); } UNPROTECT(3); return out; } // ----------------------------------------------------------------------------- #undef HOP_LOOP #undef HOP_LOOP_ATOMIC #undef HOP_LOOP_BARRIER slider/src/summary-slide.c0000644000176200001440000003477514025156373015310 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" #include "opts-slide.h" #include "utils.h" #include "segment-tree.h" #include "summary-core.h" // ----------------------------------------------------------------------------- typedef SEXP (*summary_fn)(SEXP x, struct slide_opts opts, bool na_rm); static SEXP slider_summary(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm, summary_fn fn) { bool dot = false; struct slide_opts opts = new_slide_opts(before, after, step, complete, dot); bool c_na_rm = validate_na_rm(na_rm, dot); return fn(x, opts, c_na_rm); } // ----------------------------------------------------------------------------- typedef void (*summary_impl_dbl_fn)(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out); typedef void (*summary_impl_lgl_fn)(const int* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, int* p_out); #define SLIDE_SUMMARY(PTYPE, CTYPE, SEXPTYPE, CONST_DEREF, DEREF) do { \ /* Before `vec_cast()`, which may drop names */ \ SEXP names = PROTECT(slider_names(x, SLIDE)); \ \ x = PROTECT(vec_cast(x, PTYPE)); \ const CTYPE* p_x = CONST_DEREF(x); \ \ const R_xlen_t size = Rf_xlength(x); \ const struct iter_opts iopts = new_iter_opts(opts, size); \ \ SEXP out = PROTECT(slider_init(SEXPTYPE, size)); \ CTYPE* p_out = DEREF(out); \ Rf_setAttrib(out, R_NamesSymbol, names); \ \ fn(p_x, size, &iopts, na_rm, p_out); \ \ UNPROTECT(3); \ return out; \ } while (0) static SEXP slide_summary_dbl(SEXP x, struct slide_opts opts, bool na_rm, summary_impl_dbl_fn fn) { SLIDE_SUMMARY(slider_shared_empty_dbl, double, REALSXP, REAL_RO, REAL); } static SEXP slide_summary_lgl(SEXP x, struct slide_opts opts, bool na_rm, summary_impl_lgl_fn fn) { SLIDE_SUMMARY(slider_shared_empty_lgl, int, LGLSXP, LOGICAL_RO, LOGICAL); } #undef SLIDE_SUMMARY // ----------------------------------------------------------------------------- #define SLIDE_SUMMARY_LOOP(CTYPE, INIT) do { \ R_xlen_t iter_min = p_opts->iter_min; \ R_xlen_t iter_max = p_opts->iter_max; \ R_xlen_t iter_step = p_opts->iter_step; \ \ R_xlen_t start = p_opts->start; \ R_xlen_t stop = p_opts->stop; \ \ R_xlen_t start_stop = p_opts->start_step; \ R_xlen_t stop_step = p_opts->stop_step; \ \ for (R_xlen_t i = iter_min; i < iter_max; i += iter_step) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ R_xlen_t window_start = max_size(start, 0); \ R_xlen_t window_stop = min_size(stop + 1, p_opts->size); \ \ /* Happens when the entire window is OOB */ \ /* essentially take a 0-slice */ \ if (window_stop < window_start) { \ window_start = 0; \ window_stop = 0; \ } \ \ start += start_stop; \ stop += stop_step; \ \ CTYPE result = INIT; \ \ segment_tree_aggregate( \ p_tree, \ window_start, \ window_stop, \ &result \ ); \ \ p_out[i] = result; \ } \ } while (0) static inline void slide_summary_loop_dbl(const struct segment_tree* p_tree, const struct iter_opts* p_opts, double* p_out) { SLIDE_SUMMARY_LOOP(double, 0); } static inline void slide_summary_loop_lgl(const struct segment_tree* p_tree, const struct iter_opts* p_opts, int* p_out) { SLIDE_SUMMARY_LOOP(int, 0); } #undef SLIDE_SUMMARY_LOOP // ----------------------------------------------------------------------------- static inline void slide_sum_impl(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out) { int n_prot = 0; long double state = 0; struct segment_tree tree = new_segment_tree( size, p_x, &state, sum_state_reset, sum_state_finalize, sum_nodes_increment, sum_nodes_initialize, sum_nodes_void_deref, na_rm ? sum_na_rm_aggregate_from_leaves : sum_na_keep_aggregate_from_leaves, na_rm ? sum_na_rm_aggregate_from_nodes : sum_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_dbl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_sum(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_dbl(x, opts, na_rm, slide_sum_impl); } // [[ register() ]] SEXP slider_sum(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_sum); } // ----------------------------------------------------------------------------- static inline void slide_prod_impl(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out) { int n_prot = 0; long double state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, prod_state_reset, prod_state_finalize, prod_nodes_increment, prod_nodes_initialize, prod_nodes_void_deref, na_rm ? prod_na_rm_aggregate_from_leaves : prod_na_keep_aggregate_from_leaves, na_rm ? prod_na_rm_aggregate_from_nodes : prod_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_dbl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_prod(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_dbl(x, opts, na_rm, slide_prod_impl); } // [[ register() ]] SEXP slider_prod(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_prod); } // ----------------------------------------------------------------------------- static inline void slide_mean_impl(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out) { int n_prot = 0; struct mean_state_t state = { .sum = 0, .count = 0 }; struct segment_tree tree = new_segment_tree( size, p_x, &state, mean_state_reset, mean_state_finalize, mean_nodes_increment, mean_nodes_initialize, mean_nodes_void_deref, na_rm ? mean_na_rm_aggregate_from_leaves : mean_na_keep_aggregate_from_leaves, na_rm ? mean_na_rm_aggregate_from_nodes : mean_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_dbl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_mean(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_dbl(x, opts, na_rm, slide_mean_impl); } // [[ register() ]] SEXP slider_mean(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_mean); } // ----------------------------------------------------------------------------- static inline void slide_min_impl(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out) { int n_prot = 0; double state = R_PosInf; struct segment_tree tree = new_segment_tree( size, p_x, &state, min_state_reset, min_state_finalize, min_nodes_increment, min_nodes_initialize, min_nodes_void_deref, na_rm ? min_na_rm_aggregate_from_leaves : min_na_keep_aggregate_from_leaves, na_rm ? min_na_rm_aggregate_from_nodes : min_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_dbl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_min(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_dbl(x, opts, na_rm, slide_min_impl); } // [[ register() ]] SEXP slider_min(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_min); } // ----------------------------------------------------------------------------- static inline void slide_max_impl(const double* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, double* p_out) { int n_prot = 0; double state = R_NegInf; struct segment_tree tree = new_segment_tree( size, p_x, &state, max_state_reset, max_state_finalize, max_nodes_increment, max_nodes_initialize, max_nodes_void_deref, na_rm ? max_na_rm_aggregate_from_leaves : max_na_keep_aggregate_from_leaves, na_rm ? max_na_rm_aggregate_from_nodes : max_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_dbl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_max(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_dbl(x, opts, na_rm, slide_max_impl); } // [[ register() ]] SEXP slider_max(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_max); } // ----------------------------------------------------------------------------- static inline void slide_all_impl(const int* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, int* p_out) { int n_prot = 0; int state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, all_state_reset, all_state_finalize, all_nodes_increment, all_nodes_initialize, all_nodes_void_deref, na_rm ? all_na_rm_aggregate_from_leaves : all_na_keep_aggregate_from_leaves, na_rm ? all_na_rm_aggregate_from_nodes : all_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_lgl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_all(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_lgl(x, opts, na_rm, slide_all_impl); } // [[ register() ]] SEXP slider_all(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_all); } // ----------------------------------------------------------------------------- static inline void slide_any_impl(const int* p_x, R_xlen_t size, const struct iter_opts* p_opts, bool na_rm, int* p_out) { int n_prot = 0; int state = 0; struct segment_tree tree = new_segment_tree( size, p_x, &state, any_state_reset, any_state_finalize, any_nodes_increment, any_nodes_initialize, any_nodes_void_deref, na_rm ? any_na_rm_aggregate_from_leaves : any_na_keep_aggregate_from_leaves, na_rm ? any_na_rm_aggregate_from_nodes : any_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_summary_loop_lgl(&tree, p_opts, p_out); UNPROTECT(n_prot); } static SEXP slide_any(SEXP x, struct slide_opts opts, bool na_rm) { return slide_summary_lgl(x, opts, na_rm, slide_any_impl); } // [[ register() ]] SEXP slider_any(SEXP x, SEXP before, SEXP after, SEXP step, SEXP complete, SEXP na_rm) { return slider_summary(x, before, after, step, complete, na_rm, slide_any); } slider/src/slider.h0000644000176200001440000000126213736067057013775 0ustar liggesusers#ifndef SLIDER_H #define SLIDER_H #define R_NO_REMAP #include #include #include #include #include #include // uint64_t // Definitions -------------------------------------------------- #define PSLIDE_EMPTY 0 #define SLIDE -1 #define SLIDE2 -2 // Compatibility ------------------------------------------------ #if (R_VERSION < R_Version(3, 5, 0)) #define LOGICAL_RO(x) ((const int*) LOGICAL(x)) #define INTEGER_RO(x) ((const int*) INTEGER(x)) #define REAL_RO(x) ((const double*) REAL(x)) #define RAW_RO(x) ((const Rbyte*) RAW(x)) #define STRING_PTR_RO(x) ((const SEXP*) STRING_PTR(x)) #endif #endif slider/src/slider-vctrs.h0000644000176200001440000000017213630333127015116 0ustar liggesusers#ifndef SLIDER_VCTRS_H #define SLIDER_VCTRS_H #include "slider-vctrs-public.h" #include "slider-vctrs-private.h" #endif slider/src/opts-slide.h0000644000176200001440000000550713736067057014604 0ustar liggesusers#ifndef SLIDER_OPTS_SLIDE_H #define SLIDER_OPTS_SLIDE_H #include "slider.h" #include "params.h" // ----------------------------------------------------------------------------- struct slide_opts { int before; bool before_unbounded; bool before_positive; int after; bool after_unbounded; bool after_positive; int step; bool complete; }; static inline struct slide_opts new_slide_opts(SEXP before, SEXP after, SEXP step, SEXP complete, bool dot) { bool c_before_unbounded = false; bool c_after_unbounded = false; int c_before = validate_before(before, &c_before_unbounded, dot); bool c_before_positive = c_before >= 0; int c_after = validate_after(after, &c_after_unbounded, dot); bool c_after_positive = c_after >= 0; check_double_negativeness(c_before, c_after, c_before_positive, c_after_positive); check_before_negativeness(c_before, c_after, c_before_positive, c_after_unbounded); check_after_negativeness(c_after, c_before, c_after_positive, c_before_unbounded); int c_step = validate_step(step, dot); bool c_complete = validate_complete(complete, dot); return (struct slide_opts) { .before = c_before, .before_unbounded = c_before_unbounded, .before_positive = c_before_positive, .after = c_after, .after_unbounded = c_after_unbounded, .after_positive = c_after_positive, .step = c_step, .complete = c_complete }; } // ----------------------------------------------------------------------------- struct iter_opts { R_xlen_t iter_min; R_xlen_t iter_max; R_xlen_t iter_step; R_xlen_t start; R_xlen_t start_step; R_xlen_t stop; R_xlen_t stop_step; R_xlen_t size; }; static inline struct iter_opts new_iter_opts(struct slide_opts opts, R_xlen_t size) { R_xlen_t iter_min = 0; R_xlen_t iter_max = size; R_xlen_t iter_step = opts.step; // Iteration adjustment if (opts.complete) { if (opts.before_positive) { iter_min += opts.before; } if (opts.after_positive) { iter_max -= opts.after; } } // Forward adjustment to match the number of iterations R_xlen_t offset = 0; if (opts.complete && opts.before_positive) { offset = opts.before; } R_xlen_t start; R_xlen_t start_step; if (opts.before_unbounded) { start = 0; start_step = 0; } else { start = offset - opts.before; start_step = opts.step; } R_xlen_t stop; R_xlen_t stop_step; if (opts.after_unbounded) { stop = size - 1; stop_step = 0; } else { stop = offset + opts.after; stop_step = opts.step; } return (struct iter_opts) { .iter_min = iter_min, .iter_max = iter_max, .iter_step = iter_step, .start = start, .start_step = start_step, .stop = stop, .stop_step = stop_step, .size = size }; } // ----------------------------------------------------------------------------- #endif slider/src/align.h0000644000176200001440000000166514025156373013604 0ustar liggesusers#ifndef SLIDER_ALIGN_H #define SLIDER_ALIGN_H /* * Following guidance of: * https://stackoverflow.com/questions/227897/how-to-allocate-aligned-memory-only-using-the-standard-library * * 1) Allocate enough space to shift the pointer * 2) Add to the pointer (p_x + buffer) * 3) Round down to the closest boundary using `& mask` */ #include "slider.h" #include // uintptr_t static inline SEXP aligned_allocate(R_xlen_t n_elements, size_t element_size, size_t element_align) { const size_t buffer = element_align - 1; const R_xlen_t size = n_elements * element_size + buffer; return Rf_allocVector(RAWSXP, size); } static inline void* aligned_void_deref(SEXP x, size_t element_align) { const size_t buffer = element_align - 1; uintptr_t mask = ~ (uintptr_t)buffer; uintptr_t p_x = (uintptr_t)RAW(x); uintptr_t p_aligned = (p_x + buffer) & mask; return (void*) p_aligned; } #endif slider/src/summary-core.h0000644000176200001440000005565614025156373015146 0ustar liggesusers#ifndef SLIDER_SUMMARY_CORE #define SLIDER_SUMMARY_CORE #include "slider.h" #include "summary-core-types.h" #include "align.h" // From `summary-core-align.hpp` size_t align_of_long_double(); size_t align_of_mean_state_t(); // ----------------------------------------------------------------------------- // Sum static inline void sum_state_reset(void* p_state) { long double* p_state_ = (long double*) p_state; *p_state_ = 0; } static inline void sum_state_finalize(void* p_state, void* p_result) { double* p_result_ = (double*) p_result; long double state = *((long double*) p_state); if (state > DBL_MAX) { *p_result_ = R_PosInf; } else if (state < -DBL_MAX) { *p_result_ = R_NegInf; } else { *p_result_ = (double) state; } return; } static inline void* sum_nodes_increment(void* p_nodes) { return (void*) (((long double*) p_nodes) + 1); } static inline void* sum_nodes_void_deref(SEXP nodes) { return aligned_void_deref(nodes, align_of_long_double()); } static inline long double* sum_nodes_deref(SEXP nodes) { return (long double*) sum_nodes_void_deref(nodes); } static inline SEXP sum_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(aligned_allocate(n, sizeof(long double), align_of_long_double())); long double* p_nodes = sum_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = 0; } UNPROTECT(1); return nodes; } static inline void sum_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; long double* p_dest_ = (long double*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(*p_dest_)) { return; } for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (isnan(elt)) { *p_dest_ = elt; return; } *p_dest_ += elt; } } static inline void sum_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const long double* p_source_ = (const long double*) p_source; long double* p_dest_ = (long double*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(*p_dest_)) { return; } for (uint64_t i = begin; i < end; ++i) { const long double elt = p_source_[i]; if (isnan(elt)) { *p_dest_ = elt; return; } *p_dest_ += elt; } } static inline void sum_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; long double* p_dest_ = (long double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (!isnan(elt)) { *p_dest_ += elt; } } } static inline void sum_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const long double* p_source_ = (const long double*) p_source; long double* p_dest_ = (long double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const long double elt = p_source_[i]; // Don't wrap with `if (!isnan(elt))`. Faster and more correct, this way // we propagate node `NaN` values resulting from `Inf + -Inf` *p_dest_ += elt; } } // ----------------------------------------------------------------------------- // Prod static inline void prod_state_reset(void* p_state) { long double* p_state_ = (long double*) p_state; *p_state_ = 1; } static inline void prod_state_finalize(void* p_state, void* p_result) { double* p_result_ = (double*) p_result; long double state = *((long double*) p_state); if (state > DBL_MAX) { *p_result_ = R_PosInf; } else if (state < -DBL_MAX) { *p_result_ = R_NegInf; } else { *p_result_ = (double) state; } return; } static inline void* prod_nodes_increment(void* p_nodes) { return (void*) (((long double*) p_nodes) + 1); } static inline void* prod_nodes_void_deref(SEXP nodes) { return aligned_void_deref(nodes, align_of_long_double()); } static inline long double* prod_nodes_deref(SEXP nodes) { return (long double*) prod_nodes_void_deref(nodes); } static inline SEXP prod_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(aligned_allocate(n, sizeof(long double), align_of_long_double())); long double* p_nodes = prod_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = 1; } UNPROTECT(1); return nodes; } static inline void prod_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; long double* p_dest_ = (long double*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(*p_dest_)) { return; } for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (isnan(elt)) { *p_dest_ = elt; return; } *p_dest_ *= elt; } } static inline void prod_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const long double* p_source_ = (const long double*) p_source; long double* p_dest_ = (long double*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(*p_dest_)) { return; } for (uint64_t i = begin; i < end; ++i) { const long double elt = p_source_[i]; if (isnan(elt)) { *p_dest_ = elt; return; } *p_dest_ *= elt; } } static inline void prod_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; long double* p_dest_ = (long double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (!isnan(elt)) { *p_dest_ *= elt; } } } static inline void prod_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const long double* p_source_ = (const long double*) p_source; long double* p_dest_ = (long double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const long double elt = p_source_[i]; // Don't wrap with `if (!isnan(elt))`. Faster and more correct, this way // we propagate node `NaN` values resulting from `Inf + -Inf` *p_dest_ *= elt; } } // ----------------------------------------------------------------------------- // Mean static inline void mean_state_reset(void* p_state) { struct mean_state_t* p_state_ = (struct mean_state_t*) p_state; p_state_->sum = 0; p_state_->count = 0; } static inline void mean_state_finalize(void* p_state, void* p_result) { struct mean_state_t* p_state_ = (struct mean_state_t*) p_state; double* p_result_ = (double*) p_result; *p_result_ = (double) (p_state_->sum / p_state_->count); return; } static inline void* mean_nodes_increment(void* p_nodes) { return (void*) (((struct mean_state_t*) p_nodes) + 1); } static inline void* mean_nodes_void_deref(SEXP nodes) { return aligned_void_deref(nodes, align_of_mean_state_t()); } static inline struct mean_state_t* mean_nodes_deref(SEXP nodes) { return (struct mean_state_t*) mean_nodes_void_deref(nodes); } static inline SEXP mean_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(aligned_allocate(n, sizeof(struct mean_state_t), align_of_mean_state_t())); struct mean_state_t* p_nodes = mean_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i].sum = 0; p_nodes[i].count = 0; } UNPROTECT(1); return nodes; } static inline void mean_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; struct mean_state_t* p_dest_ = (struct mean_state_t*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(p_dest_->sum)) { return; } for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (isnan(elt)) { // No need to worry about count p_dest_->sum = elt; return; } p_dest_->sum += elt; ++p_dest_->count; } } static inline void mean_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const struct mean_state_t* p_source_ = (const struct mean_state_t*) p_source; struct mean_state_t* p_dest_ = (struct mean_state_t*) p_dest; // If already NaN or NA, nothing can change it // Huge performance increase here b/c of slow arithmetic with nan long doubles if (isnan(p_dest_->sum)) { return; } for (uint64_t i = begin; i < end; ++i) { const long double sum = p_source_[i].sum; if (isnan(sum)) { // No need to worry about count p_dest_->sum = sum; return; } p_dest_->sum += sum; p_dest_->count += p_source_[i].count; } } static inline void mean_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; struct mean_state_t* p_dest_ = (struct mean_state_t*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (!isnan(elt)) { p_dest_->sum += elt; ++p_dest_->count; } } } static inline void mean_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const struct mean_state_t* p_source_ = (const struct mean_state_t*) p_source; struct mean_state_t* p_dest_ = (struct mean_state_t*) p_dest; for (uint64_t i = begin; i < end; ++i) { // Don't wrap with `if (!isnan(source.sum))`. Faster and more correct, // this way we propagate node `NaN` values resulting from `Inf + -Inf` p_dest_->sum += p_source_[i].sum; p_dest_->count += p_source_[i].count; } } // ----------------------------------------------------------------------------- // Min static inline void min_state_reset(void* p_state) { double* p_state_ = (double*) p_state; *p_state_ = R_PosInf; } static inline void min_state_finalize(void* p_state, void* p_result) { double* p_state_ = (double*) p_state; double* p_result_ = (double*) p_result; *p_result_ = *p_state_; return; } static inline void* min_nodes_increment(void* p_nodes) { return (void*) (((double*) p_nodes) + 1); } static inline double* min_nodes_deref(SEXP nodes) { return REAL(nodes); } static inline void* min_nodes_void_deref(SEXP nodes) { return (void*) min_nodes_deref(nodes); } static inline SEXP min_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(Rf_allocVector(REALSXP, n)); double* p_nodes = min_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = R_PosInf; } UNPROTECT(1); return nodes; } static inline void min_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; double* p_dest_ = (double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (isnan(elt)) { /* Match R - any `NA` trumps `NaN` */ if (ISNA(elt)) { *p_dest_ = NA_REAL; break; } else { *p_dest_ = R_NaN; } } else if (elt < *p_dest_) { *p_dest_ = elt; } } } static inline void min_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { min_na_keep_aggregate_from_leaves(p_source, begin, end, p_dest); } static inline void min_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; double* p_dest_ = (double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (elt < *p_dest_) { *p_dest_ = elt; } } } static inline void min_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { min_na_rm_aggregate_from_leaves(p_source, begin, end, p_dest); } // ----------------------------------------------------------------------------- // Max static inline void max_state_reset(void* p_state) { double* p_state_ = (double*) p_state; *p_state_ = R_NegInf; } static inline void max_state_finalize(void* p_state, void* p_result) { double* p_state_ = (double*) p_state; double* p_result_ = (double*) p_result; *p_result_ = *p_state_; return; } static inline void* max_nodes_increment(void* p_nodes) { return (void*) (((double*) p_nodes) + 1); } static inline double* max_nodes_deref(SEXP nodes) { return REAL(nodes); } static inline void* max_nodes_void_deref(SEXP nodes) { return (void*) max_nodes_deref(nodes); } static inline SEXP max_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(Rf_allocVector(REALSXP, n)); double* p_nodes = max_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = R_NegInf; } UNPROTECT(1); return nodes; } static inline void max_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; double* p_dest_ = (double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (isnan(elt)) { /* Match R - any `NA` trumps `NaN` */ if (ISNA(elt)) { *p_dest_ = NA_REAL; break; } else { *p_dest_ = R_NaN; } } else if (elt > *p_dest_) { *p_dest_ = elt; } } } static inline void max_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { max_na_keep_aggregate_from_leaves(p_source, begin, end, p_dest); } static inline void max_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const double* p_source_ = (const double*) p_source; double* p_dest_ = (double*) p_dest; for (uint64_t i = begin; i < end; ++i) { const double elt = p_source_[i]; if (elt > *p_dest_) { *p_dest_ = elt; } } } static inline void max_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { max_na_rm_aggregate_from_leaves(p_source, begin, end, p_dest); } // ----------------------------------------------------------------------------- // All static inline void all_state_reset(void* p_state) { int* p_state_ = (int*) p_state; *p_state_ = 1; } static inline void all_state_finalize(void* p_state, void* p_result) { int* p_result_ = (int*) p_result; const int state = *((int*) p_state); *p_result_ = state; return; } static inline void* all_nodes_increment(void* p_nodes) { return (void*) (((int*) p_nodes) + 1); } static inline int* all_nodes_deref(SEXP nodes) { return LOGICAL(nodes); } static inline void* all_nodes_void_deref(SEXP nodes) { return (void*) all_nodes_deref(nodes); } static inline SEXP all_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(Rf_allocVector(LGLSXP, n)); int* p_nodes = all_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = 1; } UNPROTECT(1); return nodes; } static inline void all_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const int* p_source_ = (const int*) p_source; int* p_dest_ = (int*) p_dest; // If already FALSE, we are done. // FALSE-ness overrides any potential NAs. if (!*p_dest_) { return; } for (uint64_t i = begin; i < end; ++i) { const int elt = p_source_[i]; if (!elt) { *p_dest_ = 0; return; } if (elt == NA_LOGICAL) { *p_dest_ = NA_LOGICAL; continue; } } } static inline void all_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { all_na_keep_aggregate_from_leaves(p_source, begin, end, p_dest); } static inline void all_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const int* p_source_ = (const int*) p_source; int* p_dest_ = (int*) p_dest; // If already FALSE, we are done. if (!*p_dest_) { return; } for (uint64_t i = begin; i < end; ++i) { const int elt = p_source_[i]; if (!elt) { *p_dest_ = 0; return; } } } static inline void all_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { all_na_rm_aggregate_from_leaves(p_source, begin, end, p_dest); } // ----------------------------------------------------------------------------- // Any static inline void any_state_reset(void* p_state) { int* p_state_ = (int*) p_state; *p_state_ = 0; } static inline void any_state_finalize(void* p_state, void* p_result) { int* p_result_ = (int*) p_result; const int state = *((int*) p_state); *p_result_ = state; return; } static inline void* any_nodes_increment(void* p_nodes) { return (void*) (((int*) p_nodes) + 1); } static inline int* any_nodes_deref(SEXP nodes) { return LOGICAL(nodes); } static inline void* any_nodes_void_deref(SEXP nodes) { return (void*) any_nodes_deref(nodes); } static inline SEXP any_nodes_initialize(uint64_t n) { SEXP nodes = PROTECT(Rf_allocVector(LGLSXP, n)); int* p_nodes = any_nodes_deref(nodes); for (uint64_t i = 0; i < n; ++i) { p_nodes[i] = 0; } UNPROTECT(1); return nodes; } static inline void any_na_keep_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const int* p_source_ = (const int*) p_source; int* p_dest_ = (int*) p_dest; // If already TRUE, we are done. // TRUE-ness overrides any potential NAs. if (*p_dest_ == 1) { return; } for (uint64_t i = begin; i < end; ++i) { const int elt = p_source_[i]; if (!elt) { continue; } if (elt == NA_LOGICAL) { *p_dest_ = NA_LOGICAL; continue; } *p_dest_ = 1; return; } } static inline void any_na_keep_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { any_na_keep_aggregate_from_leaves(p_source, begin, end, p_dest); } static inline void any_na_rm_aggregate_from_leaves(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { const int* p_source_ = (const int*) p_source; int* p_dest_ = (int*) p_dest; // If already TRUE, we are done. if (*p_dest_ == 1) { return; } for (uint64_t i = begin; i < end; ++i) { const int elt = p_source_[i]; if (elt == 1) { *p_dest_ = 1; return; } } } static inline void any_na_rm_aggregate_from_nodes(const void* p_source, uint64_t begin, uint64_t end, void* p_dest) { any_na_rm_aggregate_from_leaves(p_source, begin, end, p_dest); } // ----------------------------------------------------------------------------- #endif slider/src/summary-index.c0000644000176200001440000006501714025156373015310 0ustar liggesusers#include "slider.h" #include "slider-vctrs.h" #include "utils.h" #include "params.h" #include "index.h" #include "segment-tree.h" #include "summary-core.h" // ----------------------------------------------------------------------------- typedef SEXP (*summary_index_fn)(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm); static SEXP slider_index_summary(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm, summary_index_fn fn) { bool dot = false; bool c_complete = validate_complete(complete, dot); bool c_na_rm = validate_na_rm(na_rm, dot); return fn(x, i, starts, stops, peer_sizes, c_complete, c_na_rm); } // ----------------------------------------------------------------------------- typedef void (*summary_index_impl_dbl_fn)(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out); typedef void (*summary_index_impl_lgl_fn)(const int* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, int* p_out); #define SLIDE_INDEX_SUMMARY(PTYPE, CTYPE, SEXPTYPE, CONST_DEREF, DEREF) do { \ int n_prot = 0; \ \ /* Before `vec_cast()`, which may drop names */ \ SEXP names = PROTECT_N(slider_names(x, SLIDE), &n_prot); \ \ x = PROTECT_N(vec_cast(x, PTYPE), &n_prot); \ const CTYPE* p_x = CONST_DEREF(x); \ \ const R_xlen_t size = Rf_xlength(x); \ \ SEXP out = PROTECT_N(slider_init(SEXPTYPE, size), &n_prot); \ CTYPE* p_out = DEREF(out); \ Rf_setAttrib(out, R_NamesSymbol, names); \ \ struct index_info index = new_index_info(i); \ PROTECT_INDEX_INFO(&index, &n_prot); \ \ const int* p_peer_sizes = INTEGER_RO(peer_sizes); \ int* p_peer_starts = (int*) R_alloc(index.size, sizeof(int)); \ int* p_peer_stops = (int*) R_alloc(index.size, sizeof(int)); \ fill_peer_info(p_peer_sizes, index.size, p_peer_starts, p_peer_stops); \ \ struct range_info range = new_range_info(starts, stops, index.size); \ PROTECT_RANGE_INFO(&range, &n_prot); \ \ const int iter_min = compute_min_iteration(index, range, complete); \ const int iter_max = compute_max_iteration(index, range, complete); \ \ fn( \ p_x, \ size, \ iter_min, \ iter_max, \ range, \ p_peer_sizes, \ p_peer_starts, \ p_peer_stops, \ na_rm, \ &index, \ p_out \ ); \ \ UNPROTECT(n_prot); \ return out; \ } while (0) static SEXP slide_index_summary_dbl(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm, summary_index_impl_dbl_fn fn) { SLIDE_INDEX_SUMMARY(slider_shared_empty_dbl, double, REALSXP, REAL_RO, REAL); } static SEXP slide_index_summary_lgl(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm, summary_index_impl_lgl_fn fn) { SLIDE_INDEX_SUMMARY(slider_shared_empty_lgl, int, LGLSXP, LOGICAL_RO, LOGICAL); } #undef SLIDE_INDEX_SUMMARY // ----------------------------------------------------------------------------- #define SLIDE_INDEX_SUMMARY_LOOP(CTYPE, INIT) do { \ for (int i = iter_min; i < iter_max; ++i) { \ if (i % 1024 == 0) { \ R_CheckUserInterrupt(); \ } \ \ int peer_starts_pos = locate_peer_starts_pos(p_index, range, i); \ int peer_stops_pos = locate_peer_stops_pos(p_index, range, i); \ \ int window_start; \ int window_stop; \ \ if (peer_stops_pos < peer_starts_pos) { \ /* Signal that the window selection was completely OOB */ \ window_start = 0; \ window_stop = 0; \ } else { \ window_start = p_peer_starts[peer_starts_pos]; \ window_stop = p_peer_stops[peer_stops_pos] + 1; \ } \ \ CTYPE result = INIT; \ \ segment_tree_aggregate(p_tree, window_start, window_stop, &result); \ \ int peer_start = p_peer_starts[i]; \ int peer_size = p_peer_sizes[i]; \ \ for (int j = 0; j < peer_size; ++j) { \ p_out[peer_start] = result; \ ++peer_start; \ } \ } \ } while (0) static inline void slide_index_summary_loop_dbl(const struct segment_tree* p_tree, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, struct index_info* p_index, double* p_out) { SLIDE_INDEX_SUMMARY_LOOP(double, 0); } static inline void slide_index_summary_loop_lgl(const struct segment_tree* p_tree, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, struct index_info* p_index, int* p_out) { SLIDE_INDEX_SUMMARY_LOOP(int, 0); } // ----------------------------------------------------------------------------- static void slider_index_sum_core_impl(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out) { int n_prot = 0; long double state = 0; struct segment_tree tree = new_segment_tree( size, p_x, &state, sum_state_reset, sum_state_finalize, sum_nodes_increment, sum_nodes_initialize, sum_nodes_void_deref, na_rm ? sum_na_rm_aggregate_from_leaves : sum_na_keep_aggregate_from_leaves, na_rm ? sum_na_rm_aggregate_from_nodes : sum_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_dbl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_sum_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_dbl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_sum_core_impl ); } // [[ register() ]] SEXP slider_index_sum_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_sum_core ); } // ----------------------------------------------------------------------------- static void slider_index_prod_core_impl(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out) { int n_prot = 0; long double state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, prod_state_reset, prod_state_finalize, prod_nodes_increment, prod_nodes_initialize, prod_nodes_void_deref, na_rm ? prod_na_rm_aggregate_from_leaves : prod_na_keep_aggregate_from_leaves, na_rm ? prod_na_rm_aggregate_from_nodes : prod_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_dbl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_prod_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_dbl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_prod_core_impl ); } // [[ register() ]] SEXP slider_index_prod_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_prod_core ); } // ----------------------------------------------------------------------------- static void slider_index_mean_core_impl(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out) { int n_prot = 0; struct mean_state_t state = { .sum = 0, .count = 0 }; struct segment_tree tree = new_segment_tree( size, p_x, &state, mean_state_reset, mean_state_finalize, mean_nodes_increment, mean_nodes_initialize, mean_nodes_void_deref, na_rm ? mean_na_rm_aggregate_from_leaves : mean_na_keep_aggregate_from_leaves, na_rm ? mean_na_rm_aggregate_from_nodes : mean_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_dbl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_mean_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_dbl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_mean_core_impl ); } // [[ register() ]] SEXP slider_index_mean_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_mean_core ); } // ----------------------------------------------------------------------------- static void slider_index_min_core_impl(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out) { int n_prot = 0; long double state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, min_state_reset, min_state_finalize, min_nodes_increment, min_nodes_initialize, min_nodes_void_deref, na_rm ? min_na_rm_aggregate_from_leaves : min_na_keep_aggregate_from_leaves, na_rm ? min_na_rm_aggregate_from_nodes : min_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_dbl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_min_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_dbl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_min_core_impl ); } // [[ register() ]] SEXP slider_index_min_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_min_core ); } // ----------------------------------------------------------------------------- static void slider_index_max_core_impl(const double* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, double* p_out) { int n_prot = 0; long double state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, max_state_reset, max_state_finalize, max_nodes_increment, max_nodes_initialize, max_nodes_void_deref, na_rm ? max_na_rm_aggregate_from_leaves : max_na_keep_aggregate_from_leaves, na_rm ? max_na_rm_aggregate_from_nodes : max_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_dbl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_max_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_dbl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_max_core_impl ); } // [[ register() ]] SEXP slider_index_max_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_max_core ); } // ----------------------------------------------------------------------------- static void slider_index_all_core_impl(const int* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, int* p_out) { int n_prot = 0; int state = 1; struct segment_tree tree = new_segment_tree( size, p_x, &state, all_state_reset, all_state_finalize, all_nodes_increment, all_nodes_initialize, all_nodes_void_deref, na_rm ? all_na_rm_aggregate_from_leaves : all_na_keep_aggregate_from_leaves, na_rm ? all_na_rm_aggregate_from_nodes : all_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_lgl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_all_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_lgl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_all_core_impl ); } // [[ register() ]] SEXP slider_index_all_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_all_core ); } // ----------------------------------------------------------------------------- static void slider_index_any_core_impl(const int* p_x, R_xlen_t size, int iter_min, int iter_max, const struct range_info range, const int* p_peer_sizes, const int* p_peer_starts, const int* p_peer_stops, bool na_rm, struct index_info* p_index, int* p_out) { int n_prot = 0; int state = 0; struct segment_tree tree = new_segment_tree( size, p_x, &state, any_state_reset, any_state_finalize, any_nodes_increment, any_nodes_initialize, any_nodes_void_deref, na_rm ? any_na_rm_aggregate_from_leaves : any_na_keep_aggregate_from_leaves, na_rm ? any_na_rm_aggregate_from_nodes : any_na_keep_aggregate_from_nodes ); PROTECT_SEGMENT_TREE(&tree, &n_prot); slide_index_summary_loop_lgl( &tree, iter_min, iter_max, range, p_peer_sizes, p_peer_starts, p_peer_stops, p_index, p_out ); UNPROTECT(n_prot); } static SEXP slide_index_any_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, bool complete, bool na_rm) { return slide_index_summary_lgl( x, i, starts, stops, peer_sizes, complete, na_rm, slider_index_any_core_impl ); } // [[ register() ]] SEXP slider_index_any_core(SEXP x, SEXP i, SEXP starts, SEXP stops, SEXP peer_sizes, SEXP complete, SEXP na_rm) { return slider_index_summary( x, i, starts, stops, peer_sizes, complete, na_rm, slide_index_any_core ); } slider/vignettes/0000755000176200001440000000000014067413471013553 5ustar liggesusersslider/vignettes/tsibble.Rmd0000644000176200001440000001301714024427556015647 0ustar liggesusers--- title: "Converting from tsibble" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Converting from tsibble} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) # Turn off all evaluation! knitr::opts_chunk$set(eval = FALSE) ``` The [tsibble](https://tsibble.tidyverts.org/) package is where the name `slide()` originated. It contained original implementations of `slide()` and friends, along with variations like `tile()` and `stretch()`, all of which have been superceded by slider. As of tsibble 1.0.0, those functions have been completely removed in favor of using slider. The goal of this vignette is to explain how to transition from tsibble to slider. ## slide() tsibble's `.size` and `.align` arguments are roughly equivalent to using `.before` and `.after` in slider. In tsibble, you'd specify the full width of the window with `.size`, and then you'd specify how to construct that window by `.align`ing yourself to the left, right, or center. In slider, you always start at the "current" element, and then specify how many elements `.before` and `.after` the current element that you want in the window. The width of the window in slider terms could be computed as `.after - .before + 1`. ```{r} x <- 1:3 # The current element, and 1 before it slider::slide(x, identity, .before = 1, .complete = TRUE) #> [[1]] #> NULL #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 2 3 ``` ```{r} # Window size of 2, assume the current element is the right side of the window tsibble::slide(x, identity, .size = 2, .align = "right") #> [[1]] #> [1] NA #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 2 3 ``` We also have to set the `.complete` argument of slider's `slide()` to `TRUE`, as by default slider allows partial windows, but tsibble's version does not. The equivalent argument to this in tsibble is `.partial` (note that they are interpreted inversely of each other). There is no `.fill` equivalent in slider. slider always uses the vctrs definition of a missing value (a typed `NA` for most vectors, a `NULL` for lists). This is why the slider result above has a `NULL`, while the tsibble result used an `NA` (the default `.fill` value in tsibble). Specifying windows using `.before` and `.after` might first feel a bit unnatural to a tsibble or zoo user, but it is generally more flexible. You can generate irregular windows that aren't possible with tsibble, like: ```{r} # The current element, along with 1 before and 3 after (if they exist) slider::slide(1:6, identity, .before = 1, .after = 3) #> [[1]] #> [1] 1 2 3 4 #> #> [[2]] #> [1] 1 2 3 4 5 #> #> [[3]] #> [1] 2 3 4 5 6 #> #> [[4]] #> [1] 3 4 5 6 #> #> [[5]] #> [1] 4 5 6 #> #> [[6]] #> [1] 5 6 ``` As you will see in the next section, expanding windows are easy to create by setting `.before` or `.after` to `Inf`. This syntax also translates naturally to `slide_index()`, where the bounds of the window are (by default) computed as `.i - .before` and `.i + .after`, which often cannot be expressed by a single window size value. ## tile() Tiling uses non-overlapping windows. For example, this segments `x` into 4 non-overlapping buckets, where as many buckets as possible have a window size of 3. ```{r} x <- 1:10 tsibble::tile(x, identity, .size = 3) #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> [1] 4 5 6 #> #> [[3]] #> [1] 7 8 9 #> #> [[4]] #> [1] 10 ``` There is no direct equivalent to this in slider, but you can get close with `slide()`. `tile()` seems to left-align the index, so we need the current element plus two `.after` it. Since this is a non-overlapping window, we want to `.step` forward by the size of the window, three. ```{r} result <- slider::slide(x, identity, .after = 2, .step = 3) result #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> NULL #> #> [[3]] #> NULL #> #> [[4]] #> [1] 4 5 6 #> #> [[5]] #> NULL #> #> [[6]] #> NULL #> #> [[7]] #> [1] 7 8 9 #> #> [[8]] #> NULL #> #> [[9]] #> NULL #> #> [[10]] #> [1] 10 ``` This isn't exactly the same, as `slide()` is guaranteed to be size-stable, returning an object with the same size as `.x`. However, if you `purrr::compact()` the result to drop the `NULL` values, then they are equivalent. ```{r} purrr::compact(result) #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> [1] 4 5 6 #> #> [[3]] #> [1] 7 8 9 #> #> [[4]] #> [1] 10 ``` ## stretch() To construct expanding windows with tsibble, you've probably used `stretch()`. This fixes an initial window size, and then expands to add more observations without dropping any. ```{r} x <- 1:4 tsibble::stretch(x, identity) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` With slider, you can set `.before = Inf` to select the current element plus all elements before this one. ```{r} slider::slide(x, identity, .before = Inf) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` `stretch()` allows you to set `.init` to fix an initial minimum window size: ```{r} tsibble::stretch(x, identity, .init = 3) #> [[1]] #> [1] NA #> #> [[2]] #> [1] NA #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` There isn't a direct equivalent of this in slider, but your function could return `NULL` if the current window size didn't hold enough elements: ```{r} identity3 <- function(x) { if (length(x) < 3) { NULL } else { x } } slider::slide(x, identity3, .before = Inf) #> [[1]] #> NULL #> #> [[2]] #> NULL #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` slider/vignettes/rowwise.Rmd0000644000176200001440000001461213716771323015725 0ustar liggesusers--- title: "Row-wise iteration with slider" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Row-wise iteration with slider} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(slider) library(dplyr, warn.conflicts = FALSE) ``` slider is implemented with a new convention that began in vctrs, treating a data frame as a vector of rows. This makes `slide()` a _row-wise iterator_ over a data frame, which can be useful for solving some previously tricky problems in the tidyverse. The point of this vignette is to go through a few examples of a row-oriented workflow. The examples are adapted from [Jenny Bryan's talk of row-oriented workflows with purrr](https://github.com/jennybc/row-oriented-workflows), to show how this workflow is improved with `slide()`. ## Row-wise iteration Let's first explore using `slide()` as a row wise iterator in general. We'll start with this simple data frame. ```{r} example <- tibble( x = 1:4, y = letters[1:4] ) example ``` If we were to pass the `x` column to `slide()`, it would iterate over that using the window specified by `.before`, `.after`, and `.complete`. The defaults are similar to `purrr::map()`. ```{r} slide(example$x, ~.x) slide(example$x, ~.x, .before = 2) ``` When applied to the entire `example` data frame, `map()` treats it as a list and iterates over the columns. `slide()`, on the other hand, iterates over rows. This is consistent with the vctrs idea of _size_, which is the length of an atomic vector, but the number of rows of a data frame or matrix. `slide()` always returns an object with the same _size_ as its input. Because the number of rows in `example` is 4, the output size is 4 and you get one row per element in the output. ```{r} slide(example, ~.x) ``` You can still use the other arguments to `slide()` to control the window size. ```{r} # Current row + 2 before slide(example, ~.x, .before = 2) # Center aligned, with no partial results slide(example, ~.x, .before = 1, .after = 1, .complete = TRUE) ``` Often, using `slide()` with its defaults will be enough, as it is common to iterate over just one row at a time. ## Varying parameter combinations A nice use of a tibble is as a structured way to store parameter combinations. For example, we could store multiple rows of parameter combinations where each row could be supplied to `runif()` to generate different types of uniform random variables. ```{r} parameters <- tibble( n = 1:3, min = c(0, 10, 100), max = c(1, 100, 1000) ) parameters ``` With `slide()` you can pass these parameters on to `runif()` by iterating over `parameters` row-wise. This gives you access to the data frame of the current row through `.x`. Because it is a data frame, you have access to each column by name. Notice how there is no restriction that the columns of the data frame be the same as the argument names of `runif()`. ```{r} set.seed(123) slide(parameters, ~runif(.x$n, .x$min, .x$max)) ``` This can also be done with `purrr::pmap()`, but you either have to name the `parameters` tibble with the same column names as the function you are calling, or you have to access each column positionally as `..1`, `..3`, etc. A third alternative that works nicely here is to use `rowwise()` before calling `mutate()`. Just remember to wrap the result of `runif()` in a `list()`! ```{r} parameters %>% rowwise() %>% mutate(random = list(runif(n, min, max))) ``` ## Sliding inside a mutate() For these examples, we will consider a `company` data set containing the `day` a sale was made, the number of calls, `n_calls`, that were placed on that day, and the number of `sales` that resulted from those calls. ```{r} company <- tibble( day = rep(c(1, 2), each = 5), sales = sample(100, 10), n_calls = sales + sample(1000, 10) ) company ``` When `slide()`-ing inside of a `mutate()` call, there are a few scenarios that can arise. First, you might want to slide over a single column. This is easy enough in both the un-grouped and grouped case. ```{r} company %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) company %>% group_by(day) %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) ``` If you need to apply a sliding function that takes a data frame as input to slide over, then you'll need some way to access the "current" data frame that `mutate()` is acting on. As of dplyr 1.0.0, you can access this with `cur_data()`. When there is only 1 group, the current data frame is the input itself, but when there are multiple groups `cur_data()` returns the data frame corresponding to the current group that is being worked on. As an example, imagine you want to fit a rolling linear model predicting sales from the number of calls. The most robust way to do this in a `mutate()` is to use `cur_data()` to access the data frame to slide over. Since `slide()` iterates row-wise, `.x` corresponds to the current slice of the current data frame. ```{r} company %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` When you group by `day`, `cur_data()` will first correspond to all rows where `day == 1`, and then where `day == 2`. Notice how the output has two clumps of `NULL`s, proving that the rolling regressions "restarted" between groups. ```{r} company %>% group_by(day) %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` In the past, you might have used `.` in place of `cur_data()`. This `.` is actually from the magrittr `%>%`, not from dplyr, and has a few issues. The biggest one is that it won't work with grouped data frames, it will always return the entire data set rather than the current group's data frame. The other issue is that, even with un-grouped data frames, you can't take advantage of the sequential nature of how `mutate()` evaluates expressions. For example, the following doesn't work because `.` corresponds to `company` without the updated `log_sales` column. ```{r, error=TRUE} company %>% mutate( log_sales = log10(sales), regressions = slide( .x = ., .f = ~lm(log_sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` slider/vignettes/slider.Rmd0000644000176200001440000002343414024644665015513 0ustar liggesusers--- title: "Getting started with slider" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Getting started with slider} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(slider) library(dplyr, warn.conflicts = FALSE) library(lubridate, warn.conflicts = FALSE) ``` This vignette is meant to serve as an introduction to {slider}. In it, you'll learn about the three core functions in the package: `slide()`, `slide_index()`, and `slide_period()`, along with their many variants. slider is a package for rolling analysis using window functions. "Window functions" is a term that I've borrowed from SQL that means that some function is repeatedly applied to different "windows" of your data as you step through it. Typical examples of applications of window functions include rolling averages, cumulative sums, and more complex things such as rolling regressions. ## slide() To better understand window functions, we'll turn to our first core function, `slide()`. `slide()` is a bit like `purrr::map()`. You supply a vector to slide over, `.x`, and a function to apply to each window, `.f`. With those two things alone, `slide()` is almost identical to `map()`. ```{r} slide(1:4, ~.x) ``` On top of this, you can control the size and placement of the window by using the additional arguments to `slide()`. For example, you can ask for a window of size 3 containing "the current element, as well as the 2 before it" like this: ```{r} slide(1:4, ~.x, .before = 2) ``` You'll notice that the first two elements of the list contain partial or "incomplete" windows. By default, `slide()` assumes that you want to compute on these windows anyways, but if you don't care about them, you can change the `.complete` argument. ```{r} slide(1:4, ~.x, .before = 2, .complete = TRUE) ``` `slide()` is _size stable_, so you always get an output that is the same size as your input. Because of that, the partial results have been replaced by the corresponding missing value. For a list, that is `NULL`. Sometimes, changing the placement of the window is a critical part of your calculation. For example, you might want a "center alignment" where you have an equal number of values before and after the current element. To accomplish this, you can combine the `.before` argument with `.after` to get a centered window. Here we ask for a window of size 3 containing "the current element, as well as 1 element before and 1 element after". It is "centered" because in position 2 we have a complete window of the current element (2), along with one element before (1) and one after (3). ```{r} slide(1:4, ~.x, .before = 1, .after = 1) ``` `slide()` can also perform _expanding_ windows. These are the type that allow _cumulative_ operations to work. In prose, an expanding window would be "the current element, along with every element before this one". To construct this kind of window, you can set `.before` to `Inf`. ```{r} slide(1:4, ~.x, .before = Inf) ``` `slide()` is _type-stable_, meaning that it always returns an object of the same type, and the base form of `slide()` always returns a list. So far, this is all that we have used to illustrate how it works, but practically you are more likely to use one of the suffixed forms like `slide_dbl()` or `slide_int()`. For example, you might have a vector of sales data that you want to compute a 3 value moving average on. ```{r} sales_vec <- c(2, 4, 6, 2) slide_dbl(sales_vec, mean, .before = 2) ``` ## slide_index() To make things a bit more interesting, let's assume that the sales vector from the example above is also tied to some "index", like a date vector of when the sale actually occurred. ```{r} index_vec <- as.Date("2019-08-29") + c(0, 1, 5, 6) wday_vec <- as.character(wday(index_vec, label = TRUE)) company <- tibble( sales = sales_vec, index = index_vec, wday = wday_vec ) company ``` This index is increasing but irregular, meaning that we "jumped" from Friday to Tuesday because there were no sales between those dates. For the purpose of this example, let's assume that this is an online company where it is perfectly reasonable that you _could_ have sales on both Saturday and Sunday (If your use case requires that you "skip over" weekends and even holidays, you might like [{almanac}](https://github.com/DavisVaughan/almanac)). A reasonable business question to ask would be to compute a _3 day_ moving average. Is this different from the 3 value moving average we computed before? Here is the expected result, side by side with the 3 value one computed using `slide_dbl()` from before. ```{r, echo=FALSE} mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = 2) ) ``` The difference shows up in the third row, when computing the 3 day moving average looking back from Tuesday. To understand why they are different, consider what `slide_dbl()` does. It uses the `sales` column and looks at the "current row, along with two rows before it" to compute the result. When you are on row 3, this would select rows 1-3 giving the date range of `[Thu, Tue]`, which isn't 3 days. The correct answer would have been to look back 2 days from Tuesday, not 2 rows from row 3. This would have given us the date window of `[Sun, Tue]`, and only values in that range should be included in the moving average calculation for row 3. The only row in that range is row 3, so we should just be averaging the single value of `6` to get our result. `slide_dbl()` doesn't give us what we want because it is _unaware of the index column_. It just looks back a set number of values. What we need is a function that "knows" about the `index` and can adjust accordingly. For that, you can use `slide_index(.x, .i, .f, ...)` which has a `.i` argument to pass an index vector through. To understand how `slide_index()` works, take a look at the following comparison to `slide()`. For illustration, the current window of the weekday vector is printed out. Notice that in position 3, `slide()` gives us the "wrong" result of Thursday, Friday and Tuesday, because it just looks back 2 values. ```{r} wday_vec slide(wday_vec, ~.x, .before = 2) ``` On the other hand, `slide_index()` can be "aware" of the irregular index vector. By passing it through as `.i`, and by swapping a look back period of 2 for the lubridate object of `days(2)`, the start of the range is computed as `.i - days(2)`, which correctly computes a date window of `[Sun, Tue]` for the third element, so that we only capture Tuesday in the window. ```{r} slide_index(wday_vec, index_vec, ~.x, .before = days(2)) ``` Knowing this, we can swap out `slide_dbl()` for `slide_index_dbl()` to see how to correctly compute our 3 day rolling average. ```{r} mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = days(2)) ) ``` ## slide_period() With `slide_index()`, we always returned a vector of the same size as `.x`, and the idea was to build indices to slice `.x` with using "the current element of `.i` + some number of elements before/after it". `slide_period()` works a bit differently. It first breaks `.i` up into "time blocks" by some period (like monthly), and then uses those blocks to define how to slide over `.x`. To see an example, let's expand out our `company` sales data frame. ```{r} big_index_vec <- c( as.Date("2019-08-30") + 0:4, as.Date("2019-11-30") + 0:4 ) big_sales_vec <- c(2, 4, 6, 2, 8, 10, 9, 3, 5, 2) big_company <- tibble( sales = big_sales_vec, index = big_index_vec ) big_company ``` Now say we want to compute the monthly sales, and just return 1 value per month. Since we have 4 months, we should get 4 values back. What we really want to do here is break the `index` up into "time blocks" of 1 month, and then slide over those. That's what `slide_period()` does. ```{r} slide_period(big_company, big_company$index, "month", ~.x) ``` Since this returns 4 values, and not the same number of values as there are in `.x`, it won't fit naturally in a `mutate()` or `summarise()` statement. I find the easiest way to do this is to create a helper function that takes a data frame and returns one with the summary result for one time block, and then call that with `slide_period_dfr()`. ```{r} monthly_summary <- function(data) { summarise(data, index = max(index), sales = sum(sales)) } slide_period_dfr( big_company, big_company$index, "month", monthly_summary ) ``` Now you might be thinking, "I can do that with dplyr and lubridate!", and you'd be right: ```{r} big_company %>% mutate(monthly = floor_date(index, "month")) %>% group_by(monthly) %>% summarise(sales = sum(sales)) ``` But here is where things get interesting! Now what if we want to compute those monthly sales, but we want the time blocks to be made of the "current month block, plus 1 month block before it". For example, for the month of `2019-09`, it would include `2019-08` and `2019-09` together in the rolling summary. There isn't an easy way to do this in dplyr alone. With slider, there are two ways to do this. The first is with `slide_period_dfr()`, and it is as easy as adding `.before = 1`, to select the current month block and 1 before it. ```{r} slide_period_dfr( big_company, big_company$index, "month", monthly_summary, .before = 1 ) ``` Depending on your use case, you might want to append these results as a new column in `big_company`. To do this, we can instead go back to using `floor_date()` to generate monthly groupings, and slide over them using `slide_index_dbl()` with a lookback period of 1 month. ```{r} big_company %>% mutate( monthly = floor_date(index, "month"), sales_summary = slide_index_dbl(sales, monthly, sum, .before = months(1)) ) ``` slider/R/0000755000176200001440000000000014024643631011740 5ustar liggesusersslider/R/names.R0000644000176200001440000000033313613034205013157 0ustar liggesusers# vctrs doesn't publicly export these, but we can get # them through the C API vec_set_names <- function(x, names) { .Call(slider_vec_set_names, x, names) } vec_names <- function(x) { .Call(slider_vec_names, x) } slider/R/utils.R0000644000176200001440000000522114024427556013231 0ustar liggesusersglubort <- function (..., .sep = "", .envir = parent.frame()) { abort(glue::glue(..., .sep = .sep, .envir = .envir)) } collapse_and_trim <- function(x) { glue::glue_collapse(x, sep = ", ", width = 30L) } is_unbounded <- function(x) { identical(x, Inf) } check_is_list <- function(.l) { if (!is.list(.l)) { abort(paste0("`.l` must be a list, not ", vec_ptype_full(.l), ".")) } invisible(.l) } stop_not_all_size_one <- function(iteration, size) { glubort("In iteration {iteration}, the result of `.f` had size {size}, not 1.") } # Thrown to here from C stop_slide_start_past_stop <- function(starts, stops) { start_after_stop <- vec_compare(starts, stops) == 1L at <- which(start_after_stop) at <- collapse_and_trim(at) msg <- paste0( "In the ranges generated by `.before` and `.after`, ", "the start of the range is after the end of the range at location(s): {at}." ) glubort(msg) } # Thrown to here from C stop_hop_start_past_stop <- function(starts, stops) { start_after_stop <- vec_compare(starts, stops) == 1L at <- which(start_after_stop) at <- collapse_and_trim(at) msg <- paste0( "In the ranges generated by `.starts` and `.stops`, ", "a start is after a stop at location(s): {at}." ) glubort(msg) } compute_size <- function(x, type) { SLIDE <- -1L PSLIDE_EMPTY <- 0L if (type == SLIDE) { vec_size(x) } else if (type == PSLIDE_EMPTY) { 0L } else { vec_size(x[[1L]]) } } # Unconditionally use only the names from `.x` on the output when simplifying. # Ensures that the following are aligned: # # slide_vec(c(x = 1), ~c(y = 2)) # purrr::map_dbl(c(x = 1), ~c(y = 2)) # # slide_vec(1, ~c(y = 2)) # purrr::map_dbl(1, ~c(y = 2)) vec_simplify <- function(x, ptype) { names <- vec_names(x) x <- vec_set_names(x, NULL) out <- vec_unchop(x, ptype = ptype) vec_set_names(out, names) } compute_combined_ranks <- function(...) { args <- list2(...) combined <- vec_c(!!!args, .name_spec = zap()) ranks <- slider_dense_rank(combined) n_args <- length(args) sizes <- list_sizes(args) indices <- vector("list", n_args) current_start <- 1L for(i in seq_len(n_args)) { next_start <- current_start + sizes[[i]] current_stop <- next_start - 1L indices[[i]] <- seq2(current_start, current_stop) current_start <- next_start } out <- vec_chop(ranks, indices) names(out) <- names(args) out } # TODO: Replace with `vec_rank(x, ties = "dense")` # https://github.com/r-lib/vctrs/issues/1251 # # This impl is taken from `dplyr::dense_rank()`. # Expected that there are no missing values in `x`. slider_dense_rank <- function(x) { vec_match(x, vec_sort(vec_unique(x))) } slider/R/zzz.R0000644000176200001440000000036313663762054012733 0ustar liggesusers# nocov start .onLoad <- function(libname, pkgname) { # Load vctrs namespace for access to C callables requireNamespace("vctrs", quietly = TRUE) # Initialize slider C globals .Call(slider_initialize, ns_env("slider")) } # nocov end slider/R/slide-period-common.R0000644000176200001440000000644113704130147015733 0ustar liggesusersslide_period_common <- function(x, i, period, f_call, every, origin, before, after, complete, ptype, constrain, atomic, env, type) { check_index_incompatible_type(i, ".i") check_index_cannot_be_na(i, ".i") check_index_must_be_ascending(i, ".i") before_unbounded <- is_unbounded(before) after_unbounded <- is_unbounded(after) before <- check_slide_period_before(before, before_unbounded) after <- check_slide_period_after(after, after_unbounded) complete <- check_slide_period_complete(complete) groups <- warp_distance( i, period = period, every = every, origin = origin ) unique <- unique(groups) starts <- unique - before stops <- unique + after size_unique <- length(unique) size_front <- 0L size_back <- 0L if (complete && size_unique != 0L) { first <- unique[[1]] last <- unique[[size_unique]] from <- compute_from(starts, first, size_unique, before_unbounded) to <- compute_to(stops, last, size_unique, after_unbounded) size_front <- from - 1L size_back <- size_unique - to # Only slice if we have to # Important to use seq2()! Could have `from > to` if (from != 1L || to != size_unique) { starts <- starts[seq2(from, to)] stops <- stops[seq2(from, to)] } } out <- hop_index_common( x = x, i = groups, starts = starts, stops = stops, f_call = f_call, ptype = ptype, constrain = constrain, atomic = atomic, env = env, type = type ) if (!complete) { return(out) } # Initialize with `NA`, not `NULL`, for size stability when auto-simplifying if (atomic && !constrain) { front <- vec_init_unspecified_list(n = size_front) back <- vec_init_unspecified_list(n = size_back) } else { front <- vec_init(ptype, n = size_front) back <- vec_init(ptype, n = size_back) } out <- vec_c(front, out, back) out } compute_from <- function(starts, first, n, before_unbounded) { .Call(slider_compute_from, starts, first, n, before_unbounded) } compute_to <- function(stops, last, n, after_unbounded) { .Call(slider_compute_to, stops, last, n, after_unbounded) } check_slide_period_before <- function(x, unbounded) { vec_assert(x, size = 1L, arg = ".before") if (unbounded) { return(x) } x <- vec_cast(x, integer(), x_arg = ".before") if (is.na(x)) { abort("`.before` cannot be `NA`.") } x } check_slide_period_after <- function(x, unbounded) { vec_assert(x, size = 1L, arg = ".after") if (unbounded) { return(x) } x <- vec_cast(x, integer(), x_arg = ".after") if (is.na(x)) { abort("`.after` cannot be `NA`.") } x } check_slide_period_complete <- function(x) { vec_assert(x, size = 1L, arg = ".complete") x <- vec_cast(x, logical(), x_arg = ".complete") if (is.na(x)) { abort("`.complete` cannot be `NA`.") } x } vec_init_unspecified_list <- function(n) { rep_len(list(NA), n) } slider/R/slide-period2.R0000644000176200001440000002341713656610221014533 0ustar liggesusers#' Slide along multiple inputs simultaneously relative to an index chunked by period #' #' `slide_period2()` and `pslide_period()` represent the combination #' of [slide2()] and [pslide()] with [slide_period()], allowing you to slide #' over multiple vectors at once, using indices defined by breaking up the #' `.i`-ndex by `.period`. #' #' @inheritParams slide_period #' #' @template param-x-y #' @template param-l #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide_period2()`}{ #' #' * `vec_size(slide_period2(.x, .y)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_ptype(slide_period2(.x, .y)) == list()` #' #' } #' #' \subsection{`slide_period2_vec()` and `slide_period2_*()` variants}{ #' #' * `vec_size(slide_period2_vec(.x, .y)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_size(slide_period2_vec(.x, .y)[[1]]) == 1L` #' #' * `vec_ptype(slide_period2_vec(.x, .y, .ptype = ptype)) == ptype` #' #' } #' #' \subsection{`pslide_period()`}{ #' #' * `vec_size(pslide_period(.l)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_ptype(pslide_period(.l)) == list()` #' #' } #' #' \subsection{`pslide_period_vec()` and `pslide_period_*()` variants}{ #' #' * `vec_size(pslide_period_vec(.l)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_size(pslide_period_vec(.l)[[1]]) == 1L` #' #' * `vec_ptype(pslide_period_vec(.l, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' i <- as.Date("2019-01-28") + 0:5 #' #' slide_period2( #' .x = 1:6, #' .y = i, #' .i = i, #' .period = "month", #' .f = ~data.frame(x = .x, i = .y) #' ) #' #' pslide_period( #' .l = list(1:6, 7:12, i), #' .i = i, #' .period = "month", #' .f = ~data.frame(x = .x, y = .y, i = ..3) #' ) #' #' @seealso [slide2()], [slide_index2()], [slide_period()] #' @export slide_period2 <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period2_impl( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_period2 #' @export slide_period2_vec <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- slide_period2_impl( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide_period2_vec_direct <- function(.x, .y, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype) { slide_period2_impl( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_period2 #' @export slide_period2_dbl <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period2_vec_direct( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_period2 #' @export slide_period2_int <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period2_vec_direct( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_period2 #' @export slide_period2_lgl <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period2_vec_direct( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_period2 #' @export slide_period2_chr <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period2_vec_direct( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @rdname slide_period2 #' @export slide_period2_dfr <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide_period2( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @rdname slide_period2 #' @export slide_period2_dfc <- function(.x, .y, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide_period2( .x, .y, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide_period2_impl <- function(.x, .y, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) vec_assert(.y) # TODO - Do more efficiently internally by reusing rather than recycling # https://github.com/tidyverse/purrr/blob/e4d553989e3d18692ebeeedb334b6223ae9ea294/src/map.c#L129 # But use `vec_size_common()` to check sizes and get `.size` args <- vec_recycle_common(.x, .y) .f <- as_function(.f) f_call <- expr(.f(.x, .y, ...)) type <- -2L slide_period_common( x = args, i = .i, period = .period, f_call = f_call, every = .every, origin = .origin, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/pslide-period.R0000644000176200001440000001726713656610221014637 0ustar liggesusers#' @include slide-period2.R #' @rdname slide_period2 #' @export pslide_period <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { pslide_period_impl( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_period2 #' @export pslide_period_vec <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- pslide_period_impl( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } pslide_period_vec_direct <- function(.l, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype) { pslide_period_impl( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_period2 #' @export pslide_period_dbl <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { pslide_period_vec_direct( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_period2 #' @export pslide_period_int <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { pslide_period_vec_direct( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_period2 #' @export pslide_period_lgl <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { pslide_period_vec_direct( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_period2 #' @export pslide_period_chr <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { pslide_period_vec_direct( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @rdname slide_period2 #' @export pslide_period_dfr <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- pslide_period( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @rdname slide_period2 #' @export pslide_period_dfc <- function(.l, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- pslide_period( .l, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ pslide_period_impl <- function(.l, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype, .constrain, .atomic) { check_is_list(.l) lapply(.l, vec_assert) .f <- as_function(.f) # TODO - more efficiently? reuse elements rather than recycle .l <- vec_recycle_common(!!!.l) type <- vec_size(.l) slicers <- lapply( seq_len(type), function(x) { expr(.l[[!!x]]) } ) # Ensure names of `.l` are kept so they can be spliced # into `.f` as argument names names(slicers) <- names(.l) f_call <- expr(.f(!!! slicers, ...)) slide_period_common( x = .l, i = .i, period = .period, f_call = f_call, every = .every, origin = .origin, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/hop-index.R0000644000176200001440000001100613656610221013753 0ustar liggesusers#' Hop relative to an index #' #' `hop_index()` is the lower level engine that powers [slide_index()]. It #' has slightly different invariants than `slide_index()`, and is useful when #' you either need to hand craft boundary values, or want to compute a result #' with a size that is different from `.x`. #' #' @inheritParams slide_index #' #' @template param-starts-stops-hop-index #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`hop_index()`}{ #' #' * `vec_size(hop_index(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(hop_index(.x, .starts, .stops)) == list()` #' #' } #' #' \subsection{`hop_index_vec()`}{ #' #' * `vec_size(hop_index_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(hop_index_vec(.x, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(hop_index_vec(.x, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' library(vctrs) #' library(lubridate, warn.conflicts = FALSE) #' #' # --------------------------------------------------------------------------- #' # Returning a size smaller than `.x` #' #' i <- as.Date("2019-01-25") + c(0, 1, 2, 3, 10, 20, 35, 42, 45) #' #' # slide_index() allows you to slide relative to `i` #' slide_index(i, i, ~.x, .before = weeks(1)) #' #' # But you might be more interested in coarser summaries. This groups #' # by year-month and computes 2 `.f` on 2 month windows. #' i_yearmonth <- year(i) + (month(i) - 1) / 12 #' slide_index(i, i_yearmonth, ~.x, .before = 1) #' #' # ^ This works nicely when working with dplyr if you are trying to create #' # a new column in a data frame, but you'll notice that there are really only #' # 3 months, so only 3 values are being calculated. If you only want to return #' # a vector of those 3 values, you can use `hop_index()`. You'll have to #' # hand craft the boundaries, but this is a general strategy #' # I've found useful: #' first_start <- floor_date(i[1], "months") #' last_stop <- ceiling_date(i[length(i)], "months") #' dates <- seq(first_start, last_stop, "1 month") #' inner <- dates[2:(length(dates) - 1L)] #' starts <- vec_c(first_start, inner) #' stops <- vec_c(inner - 1, last_stop) #' #' hop_index(i, i, starts, stops, ~.x) #' #' # --------------------------------------------------------------------------- #' # Non-existant dates with `lubridate::months()` #' #' # Imagine you want to compute a 1 month rolling average on this #' # irregular daily data. #' i <- vec_c(as.Date("2019-02-27") + 0:3, as.Date("2019-03-27") + 0:5) #' x <- rnorm(vec_seq_along(i)) #' #' # You might try `slide_index()` like this, but you'd run into this error #' library(rlang) #' #' with_options( #' catch_cnd( #' slide_index(x, i, mean, .before = months(1)) #' ), #' rlang_backtrace_on_error = current_env() #' ) #' #' # This is because when you actually compute the `.i - .before` sequence, #' # you hit non-existant dates. i.e. `"2019-03-29" - months(1)` doesn't exist. #' i - months(1) #' #' # To get around this, lubridate provides `add_with_rollback()`, #' # and the shortcut operation `%m-%`, which subtracts the month, then rolls #' # forward/backward if it hits an `NA`. You can manually generate boundaries, #' # then provide them to `hop_index()`. #' starts <- i %m-% months(1) #' stops <- i #' #' hop_index(x, i, starts, stops, mean) #' #' hop_index(i, i, starts, stops, ~.x) #' #' @seealso [slide()], [slide_index()], [hop_index2()] #' @export hop_index <- function(.x, .i, .starts, .stops, .f, ...) { hop_index_impl( .x, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop_index #' @export hop_index_vec <- function(.x, .i, .starts, .stops, .f, ..., .ptype = NULL) { out <- hop_index_impl( .x, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ hop_index_impl <- function(.x, .i, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { vec_assert(.x) .f <- as_function(.f) f_call <- expr(.f(.x, ...)) type <- -1L hop_index_common( x = .x, i = .i, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/slide-index.R0000644000176200001440000002751614024427556014311 0ustar liggesusers#' Slide relative to an index #' #' @description #' `slide_index()` is similar to `slide()`, but allows a secondary `.i`-ndex #' vector to be provided. #' #' This is often useful in business calculations, when #' you want to compute a rolling computation looking "3 months back", which #' is approximately but not equivalent to, 3 * 30 days. `slide_index()` allows #' for these irregular window sizes. #' #' @inheritParams slide #' #' @param .i `[vector]` #' #' The index vector that determines the window sizes. It is fairly common to #' supply a date vector as the index, but not required. #' #' There are 3 restrictions on the index: #' #' - The size of the index must match the size of `.x`, they will not be #' recycled to their common size. #' #' - The index must be an _increasing_ vector, but duplicate values #' are allowed. #' #' - The index cannot have missing values. #' #' @template param-before-after-slide-index #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide_index()`}{ #' #' * `vec_size(slide_index(.x)) == vec_size(.x)` #' #' * `vec_ptype(slide_index(.x)) == list()` #' #' } #' #' \subsection{`slide_index_vec()` and `slide_index_*()` variants}{ #' #' * `vec_size(slide_index_vec(.x)) == vec_size(.x)` #' #' * `vec_size(slide_index_vec(.x)[[1]]) == 1L` #' #' * `vec_ptype(slide_index_vec(.x, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' library(lubridate) #' #' x <- 1:5 #' #' # In some cases, sliding over `x` with a strict window size of 2 #' # will fit your use case. #' slide(x, ~.x, .before = 1) #' #' # However, if this `i` is a date vector paired with `x`, when computing #' # rolling calculations you might want to iterate over `x` while #' # respecting the fact that `i` is an irregular sequence. #' i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) #' #' # For example, a "2 day" window should not pair `"2019-08-19"` and #' # `"2019-08-21"` together, even though they are next to each other in `x`. #' # `slide_index()` computes the lookback value from the current date in `.i`, #' # meaning that if you are currently on `"2019-08-21"` and look back 1 day, #' # it will correctly not include `"2019-08-19"`. #' slide_index(i, i, ~.x, .before = 1) #' #' # We could have equivalently used a lubridate period object for this as well, #' # since `i - lubridate::days(1)` is allowed #' slide_index(i, i, ~.x, .before = lubridate::days(1)) #' #' # --------------------------------------------------------------------------- #' # Functions for `.before` and `.after` #' #' # In some cases, it might not be appropriate to compute #' # `.i - .before` or `.i + .after`, either because there isn't a `-` or `+` #' # method defined, or because there is an alternative way to perform the #' # arithmetic. For example, subtracting 1 month with `- months(1)` (using #' # lubridate) can sometimes land you on an invalid date that doesn't exist. #' i <- as.Date(c("2019-01-31", "2019-02-28", "2019-03-31")) #' #' # 2019-03-31 - months(1) = 2019-02-31, which doesn't exist #' i - months(1) #' #' # These NAs create problems with `slide_index()`, which doesn't allow #' # missing values in the computed endpoints #' try(slide_index(i, i, identity, .before = months(1))) #' #' # In these cases, it is more appropriate to use `%m-%`, #' # which will snap to the end of the month, at least giving you something #' # to work with. #' i %m-% months(1) #' #' # To use this as your `.before` or `.after`, supply an anonymous function of #' # 1 argument that performs the computation #' slide_index(i, i, identity, .before = ~.x %m-% months(1)) #' #' # Notice that in the `.after` case, `2019-02-28 %m+% months(1)` doesn't #' # capture the end of March, so it isn't included in the 2nd result #' slide_index(i, i, identity, .after = ~.x %m+% months(1)) #' #' # --------------------------------------------------------------------------- #' #' # When `.i` has repeated values, they are always grouped together. #' i <- c(2017, 2017, 2018, 2019, 2020, 2020) #' slide_index(i, i, ~.x) #' slide_index(i, i, ~.x, .after = 1) #' #' # --------------------------------------------------------------------------- #' # Rolling regressions #' #' # Rolling regressions are easy with `slide_index()` because: #' # - Data frame `.x` values are iterated over rowwise #' # - The index is respected by using `.i` #' set.seed(123) #' #' df <- data.frame( #' y = rnorm(100), #' x = rnorm(100), #' i = as.Date("2019-08-15") + c(0, 2, 4, 6:102) # <- irregular #' ) #' #' # 20 day rolling regression. Current day + 19 days back. #' # Additionally, set `.complete = TRUE` to not compute partial results. #' regr <- slide_index(df, df$i, ~lm(y ~ x, .x), .before = 19, .complete = TRUE) #' #' regr[16:18] #' #' # The first 16 slots are NULL because there is no possible way to #' # look back 19 days from the 16th index position and construct a full #' # window. But on the 17th index position, `""2019-09-03"`, if we look #' # back 19 days we get to `""2019-08-15"`, which is the same value as #' # `i[1]` so a full window can be constructed. #' df$i[16] - 19 >= df$i[1] # FALSE #' df$i[17] - 19 >= df$i[1] # TRUE #' #' # --------------------------------------------------------------------------- #' # Accessing the current index value #' #' # A very simplistic version of `purrr::map2()` #' fake_map2 <- function(.x, .y, .f, ...) { #' Map(.f, .x, .y, ...) #' } #' #' # Occasionally you need to access the index value that you are currently on. #' # This is generally not possible with a single call to `slide_index()`, but #' # can be easily accomplished by following up a `slide_index()` call with a #' # `purrr::map2()`. In this example, we want to use the distance from the #' # current index value (in days) as a multiplier on `x`. Values further #' # away from the current date get a higher multiplier. #' set.seed(123) #' #' # 25 random days past 2000-01-01 #' i <- sort(as.Date("2000-01-01") + sample(100, 25)) #' #' df <- data.frame(i = i, x = rnorm(25)) #' #' weight_by_distance <- function(df, i) { #' df$weight = abs(as.integer(df$i - i)) #' df$x_weighted = df$x * df$weight #' df #' } #' #' # Use `slide_index()` to just generate the rolling data. #' # Here we take the current date + 5 days before + 5 days after. #' dfs <- slide_index(df, df$i, ~.x, .before = 5, .after = 5) #' #' # Follow up with a `map2()` with `i` as the second input. #' # This allows you to track the current `i` value and weight accordingly. #' result <- fake_map2(dfs, df$i, weight_by_distance) #' #' head(result) #' #' @seealso [slide()], [hop_index()], [slide_index2()] #' @export slide_index <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index_impl( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_index #' @export slide_index_vec <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- slide_index_impl( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide_index_vec_direct <- function(.x, .i, .f, ..., .before, .after, .complete, .ptype) { slide_index_impl( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_index #' @export slide_index_dbl <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index_vec_direct( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_index #' @export slide_index_int <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index_vec_direct( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_index #' @export slide_index_lgl <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index_vec_direct( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_index #' @export slide_index_chr <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index_vec_direct( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide_index #' @export slide_index_dfr <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide_index( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide_index #' @export slide_index_dfc <- function(.x, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide_index( .x, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide_index_impl <- function(.x, .i, .f, ..., .before, .after, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) .f <- as_function(.f) f_call <- expr(.f(.x, ...)) type <- -1L slide_index_common( x = .x, i = .i, f_call = f_call, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/summary-index.R0000644000176200001440000001664214024427556014704 0ustar liggesusers#' Specialized sliding functions relative to an index #' #' @description #' These functions are specialized variants of the most common ways that #' [slide_index()] is generally used. Notably, [slide_index_sum()] can be used #' for rolling sums relative to an index (like a Date column), and #' [slide_index_mean()] can be used for rolling averages. #' #' These specialized variants are _much_ faster and more memory efficient than #' using an otherwise equivalent call constructed with [slide_index_dbl()] #' or [slide_index_lgl()], especially with a very wide window. #' #' @details #' For more details about the implementation, see the help page of #' [slide_sum()]. #' #' @inheritParams ellipsis::dots_empty #' @inheritParams slide_index #' #' @param x `[vector]` #' #' A vector to compute the sliding function on. #' #' - For sliding sum, mean, prod, min, and max, `x` will be cast to a double #' vector with [vctrs::vec_cast()]. #' #' - For sliding any and all, `x` will be cast to a logical vector with #' [vctrs::vec_cast()]. #' #' @param na_rm `[logical(1)]` #' #' Should missing values be removed from the computation? #' #' @return #' A vector the same size as `x` containing the result of applying the #' summary function over the sliding windows. #' #' - For sliding sum, mean, prod, min, and max, a double vector will be #' returned. #' #' - For sliding any and all, a logical vector will be returned. #' #' @seealso [slide_sum()] #' #' @export #' @name summary-index #' @examples #' x <- c(1, 5, 3, 2, 6, 10) #' i <- as.Date("2019-01-01") + c(0, 1, 3, 4, 6, 8) #' #' # `slide_index_sum()` can be used for rolling sums relative to an index, #' # allowing you to "respect gaps" in your series. Notice that the rolling #' # sum in row 3 is only computed from `2019-01-04` and `2019-01-02` since #' # `2019-01-01` is more than two days before the current date. #' data.frame( #' i = i, #' x = x, #' roll = slide_index_sum(x, i, before = 2) #' ) #' #' # `slide_index_mean()` can be used for rolling averages #' slide_index_mean(x, i, before = 2) #' #' # Only evaluate the sum on windows that have the potential to be complete #' slide_index_sum(x, i, before = 2, after = 1, complete = TRUE) slide_index_sum <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_sum_core) } slide_index_sum_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_sum_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_prod <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_prod_core) } slide_index_prod_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_prod_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_mean <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_mean_core) } slide_index_mean_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_mean_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_min <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_min_core) } slide_index_min_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_min_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_max <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_max_core) } slide_index_max_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_max_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_all <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_all_core) } slide_index_all_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_all_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ #' @rdname summary-index #' @export slide_index_any <- function(x, i, ..., before = 0L, after = 0L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() slide_index_summary(x, i, before, after, complete, na_rm, slide_index_any_core) } slide_index_any_core <- function(x, i, starts, stops, peer_sizes, complete, na_rm) { .Call(slider_index_any_core, x, i, starts, stops, peer_sizes, complete, na_rm) } # ------------------------------------------------------------------------------ slide_index_summary <- function(x, i, before, after, complete, na_rm, fn_core) { info <- slide_index_info(i, before, after, "i", "before", "after") x_size <- compute_size(x, -1L) i_size <- vec_size(i) if (i_size != x_size) { stop_index_incompatible_size(i_size, x_size, "i") } complete <- check_complete(complete, "complete") i <- info$i starts <- info$starts stops <- info$stops peer_sizes <- info$peer_sizes fn_core(x, i, starts, stops, peer_sizes, complete, na_rm) } slider/R/slide-index-common.R0000644000176200001440000001003414024427556015562 0ustar liggesusersslide_index_common <- function(x, i, f_call, before, after, complete, ptype, constrain, atomic, env, type) { info <- slide_index_info(i, before, after, ".i", ".before", ".after") x_size <- compute_size(x, type) i_size <- vec_size(i) if (i_size != x_size) { stop_index_incompatible_size(i_size, x_size, ".i") } complete <- check_complete(complete, ".complete") i <- info$i starts <- info$starts stops <- info$stops peer_sizes <- info$peer_sizes .Call( slide_index_common_impl, x, i, starts, stops, f_call, ptype, env, peer_sizes, type, constrain, atomic, x_size, complete ) } # ------------------------------------------------------------------------------ slide_index_info <- function(i, before, after, i_arg, before_arg, after_arg) { vec_assert(i, arg = i_arg) check_index_cannot_be_na(i, i_arg) check_index_must_be_ascending(i, i_arg) # `i` is ascending, so we can detect uniques quickly with `vec_unrep()`. # We must unrep before applying `before`/`after`, as we expect that they are # only applied on the unique values of `i`. # Otherwise, the same value of `i` could have different start/stop values, # like `c(1, 1) - c(2, 3)`). unrep <- vec_unrep(i) i <- unrep$key before <- check_before(before, before_arg) after <- check_after(after, after_arg) ranges <- compute_ranges(i, before, after, i_arg, before_arg, after_arg) list( i = ranges$i, starts = ranges$starts, stops = ranges$stops, peer_sizes = unrep$times ) } compute_ranges <- function(i, before, after, i_arg, before_arg, after_arg) { i_size <- vec_size(i) start_unbounded <- before$unbounded stop_unbounded <- after$unbounded # Setting to `NULL`, as that is what the C level new_range_info() expects # for unbounded start / stop ranges if (start_unbounded) { starts <- NULL } else { starts <- before$fn(i) starts <- vec_cast(starts, i, to_arg = ".i") check_generated_endpoints_incompatible_size(starts, i_size, before_arg) check_generated_endpoints_cannot_be_na(starts, before_arg) check_generated_endpoints_must_be_ascending(starts, before_arg) } if (stop_unbounded) { stops <- NULL } else { stops <- after$fn(i) stops <- vec_cast(stops, i, to_arg = ".i") check_generated_endpoints_incompatible_size(stops, i_size, after_arg) check_generated_endpoints_cannot_be_na(stops, after_arg) check_generated_endpoints_must_be_ascending(stops, after_arg) } ranks <- compute_combined_ranks(i = i, starts = starts, stops = stops) i <- ranks$i if (!start_unbounded) { starts <- ranks$starts } if (!stop_unbounded) { stops <- ranks$stops } list(i = i, starts = starts, stops = stops) } # ------------------------------------------------------------------------------ check_before <- function(before, before_arg) { if (is_function(before)) { unbounded <- FALSE fn <- before } else if (is_formula(before)) { unbounded <- FALSE fn <- as_function(before) } else { vec_assert(before, size = 1L, arg = before_arg) unbounded <- is_unbounded(before) fn <- function(i) { i - before } } list(fn = fn, unbounded = unbounded) } check_after <- function(after, after_arg) { if (is_function(after)) { unbounded <- FALSE fn <- after } else if (is_formula(after)) { unbounded <- FALSE fn <- as_function(after) } else { vec_assert(after, size = 1L, arg = after_arg) unbounded <- is_unbounded(after) fn <- function(i) { i + after } } list(fn = fn, unbounded = unbounded) } check_complete <- function(complete, complete_arg) { complete <- vec_cast(complete, logical(), x_arg = complete_arg) vec_assert(complete, size = 1L, arg = complete_arg) complete } slider/R/phop-index.R0000644000176200001440000000356313656610221014144 0ustar liggesusers#' @include hop-index2.R #' @rdname hop_index2 #' @export phop_index <- function(.l, .i, .starts, .stops, .f, ...) { phop_index_impl( .l, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop_index2 #' @export phop_index_vec <- function(.l, .i, .starts, .stops, .f, ..., .ptype = NULL) { out <- phop_index_impl( .l, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ phop_index_impl <- function(.l, .i, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { check_is_list(.l) lapply(.l, vec_assert) .f <- as_function(.f) # TODO - more efficiently? reuse elements rather than recycle .l <- vec_recycle_common(!!!.l) type <- vec_size(.l) slicers <- lapply( seq_len(type), function(x) { expr(.l[[!!x]]) } ) # Ensure names of `.l` are kept so they can be spliced # into `.f` as argument names names(slicers) <- names(.l) f_call <- expr(.f(!!! slicers, ...)) hop_index_common( x = .l, i = .i, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/slide.R0000644000176200001440000002603113736067057013200 0ustar liggesusers#' Slide #' #' `slide()` iterates through `.x` using a sliding window, applying `.f` to each #' sub-window of `.x`. #' #' @param .x `[vector]` #' #' The vector to iterate over and apply `.f` to. #' #' @param .f `[function / formula]` #' #' If a __function__, it is used as is. #' #' If a __formula__, e.g. `~ .x + 2`, it is converted to a function. There #' are three ways to refer to the arguments: #' #' * For a single argument function, use `.` #' * For a two argument function, use `.x` and `.y` #' * For more arguments, use `..1`, `..2`, `..3` etc #' #' This syntax allows you to create very compact anonymous functions. #' #' @param ... Additional arguments passed on to the mapped function. #' #' @param .step `[positive integer(1)]` #' #' The number of elements to shift the window forward between function calls. #' #' @param .complete `[logical(1)]` #' #' Should the function be evaluated on complete windows only? If `FALSE`, #' the default, then partial computations will be allowed. #' #' @param .ptype `[vector(0) / NULL]` #' #' A prototype corresponding to the type of the output. #' #' If `NULL`, the default, the output type is determined by computing the #' common type across the results of the calls to `.f`. #' #' If supplied, the result of each call to `.f` will be cast to that type, #' and the final output will have that type. #' #' If `getOption("vctrs.no_guessing")` is `TRUE`, the `.ptype` must be #' supplied. This is a way to make production code demand fixed types. #' #' @template param-before-after-slide #' #' @details #' #' Unlike `lapply()` or `purrr::map()`, which construct calls like #' #' ``` #' .f(.x[[i]], ...) #' ``` #' #' the equivalent with `slide()` looks like #' #' ``` #' .f(vctrs::vec_slice(.x, i), ...) #' ``` #' #' which is approximately #' #' ``` #' .f(.x[i], ...) #' ``` #' #' except in the case of data frames or arrays, which are iterated #' over row-wise. #' #' If `.x` has names, then the output will preserve those names. #' #' Using [vctrs::vec_cast()], the output of `.f` will be automatically cast #' to the type required by the variant of `slide_*()` being used. #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide()`}{ #' #' * `vec_size(slide(.x)) == vec_size(.x)` #' #' * `vec_ptype(slide(.x)) == list()` #' #' } #' #' \subsection{`slide_vec()` and `slide_*()` variants}{ #' #' * `vec_size(slide_vec(.x)) == vec_size(.x)` #' #' * `vec_size(slide_vec(.x)[[1]]) == 1L` #' #' * `vec_ptype(slide_vec(.x, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' # The defaults work similarly to `map()` #' slide(1:5, ~.x) #' #' # Use `.before`, `.after`, and `.step` to control the window #' slide(1:5, ~.x, .before = 1) #' #' # This can be used for rolling means #' slide_dbl(rnorm(5), mean, .before = 2) #' #' # Or more flexible rolling operations #' slide(rnorm(5), ~ .x - mean(.x), .before = 2) #' #' # `.after` allows you to "align to the left" rather than the right #' slide(1:5, ~.x, .after = 2) #' #' # And a mixture of `.before` and `.after` #' # allows you complete control over the exact alignment. #' # Below, "center alignment" is used. #' slide(1:5, ~.x, .before = 1, .after = 1) #' #' # The `.step` controls how the window is shifted along `.x`, #' # allowing you to "skip" iterations if you only need a less granular result #' slide(1:10, ~.x, .before = 2, .step = 3) #' #' # `.complete` controls whether or not partial results are computed. #' # By default, they are, but setting `.complete = TRUE` restricts #' # `slide()` to only evaluate the function where a complete window exists. #' slide(1:5, ~.x, .before = 2, .after = 1) #' slide(1:5, ~.x, .before = 2, .after = 1, .complete = TRUE) #' #' # --------------------------------------------------------------------------- #' # Data frames #' #' # Data frames are iterated over rowwise #' mtcars_rowwise <- slide(mtcars, ~.x) #' mtcars_rowwise[1:3] #' #' # This means that any column name is easily accessible #' slide_dbl(mtcars, ~.x$mpg + .x$cyl) #' #' # More advanced rowwise iteration is available as well by using the #' # other arguments #' mtcars_rowwise_window <- slide(mtcars, ~.x, .before = 1, .after = 1) #' mtcars_rowwise_window[1:3] #' #' # --------------------------------------------------------------------------- #' # Cumulative sliding #' #' # Using the special cased value, `Inf`, you can ask `slide()` to pin the #' # start of the sliding window to the first element, effectively creating #' # a cumulative window #' slide(1:5, ~.x, .before = Inf) #' #' # Same with `.after`, this creates a window where you start with all of the #' # elements, but decrease the total number over each iteration #' slide(1:5, ~.x, .after = Inf) #' #' # --------------------------------------------------------------------------- #' # Negative `.before` / `.after` #' #' # `.before` is allowed to be negative, allowing you to "look forward" in #' # your vector. Note that `abs(.before) <= .after` must hold if `.before` is #' # negative. In this example, we look forward to elements in locations 2 and 3 #' # but place the result in position 1 in the output. #' slide(1:5, ~.x, .before = -1, .after = 2) #' #' # `.after` can be negative as well to "look backwards" #' slide(1:5, ~.x, .before = 2, .after = -1) #' #' # --------------------------------------------------------------------------- #' # Removing padding #' #' # If you are looking for a way to remove the `NA` values from something like #' # this, then it doesn't exist as a built in option. #' x <- rnorm(10) #' slide_dbl(x, mean, .before = 3, .step = 2, .complete = TRUE) #' #' # Adding an option to `slide_dbl()` to remove the `NA` values would destroy #' # its size stability. Instead, you can use a combination of `slide_dfr()` #' # to get the start/stop indices with `hop_index_vec()`. #' i <- seq_along(x) #' idx <- slide_dfr( #' i, #' ~data.frame(start = .x[1], stop = .x[length(.x)]), #' .before = 3, #' .step = 2, #' .complete = TRUE #' ) #' #' idx #' #' hop_index_vec(x, i, idx$start, idx$stop, mean, .ptype = double()) #' #' @seealso [slide2()], [slide_index()], [hop()] #' @export slide <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide_impl( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide #' @export slide_vec <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL) { out <- slide_impl( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide_vec_direct <- function(.x, .f, ..., .before, .after, .step, .complete, .ptype) { slide_impl( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide #' @export slide_dbl <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide_vec_direct( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = double() ) } #' @rdname slide #' @export slide_int <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide_vec_direct( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = integer() ) } #' @rdname slide #' @export slide_lgl <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide_vec_direct( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = logical() ) } #' @rdname slide #' @export slide_chr <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide_vec_direct( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide #' @export slide_dfr <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide #' @export slide_dfc <- function(.x, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide( .x, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide_impl <- function(.x, .f, ..., .before, .after, .step, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) .f <- as_function(.f) f_call <- expr(.f(.x, ...)) type <- -1L params <- list( type = type, constrain = .constrain, atomic = .atomic, before = .before, after = .after, step = .step, complete = .complete ) slide_common( x = .x, f_call = f_call, ptype = .ptype, env = environment(), params = params ) } slider/R/slider-package.R0000644000176200001440000000066613613034205014740 0ustar liggesusers#' @keywords internal #' @aliases slider-package "_PACKAGE" # The following block is used by usethis to automatically manage # roxygen namespace tags. Modify with care! ## usethis namespace: start #' @import rlang #' @import vctrs #' @importFrom warp warp_boundary #' @importFrom warp warp_distance #' @importFrom glue glue_data #' @importFrom glue glue_collapse #' @useDynLib slider, .registration = TRUE ## usethis namespace: end NULL slider/R/summary-slide.R0000644000176200001440000001455314024643631014666 0ustar liggesusers#' Specialized sliding functions #' #' @description #' These functions are specialized variants of the most common ways that #' [slide()] is generally used. Notably, [slide_sum()] can be used for #' rolling sums, and [slide_mean()] can be used for rolling averages. #' #' These specialized variants are _much_ faster and more memory efficient #' than using an otherwise equivalent call constructed with [slide_dbl()] #' or [slide_lgl()], especially with a very wide window. #' #' @details #' Note that these functions are _not_ generic and do not respect method #' dispatch of the corresponding summary function (i.e. [base::sum()], #' [base::mean()]). Input will always be cast to a double or logical vector #' using [vctrs::vec_cast()], and an internal method for computing the summary #' function will be used. #' #' Due to the structure of segment trees, `slide_mean()` does not perform the #' same "two pass" mean that `mean()` does (the intention of the second pass is #' to perform a floating point error correction). Because of this, there may be #' small differences between `slide_mean(x)` and `slide_dbl(x, mean)` in some #' cases. #' #' @inheritParams ellipsis::dots_empty #' @inheritParams slide #' #' @param x `[vector]` #' #' A vector to compute the sliding function on. #' #' - For sliding sum, mean, prod, min, and max, `x` will be cast to a double #' vector with [vctrs::vec_cast()]. #' #' - For sliding any and all, `x` will be cast to a logical vector with #' [vctrs::vec_cast()]. #' #' @param na_rm `[logical(1)]` #' #' Should missing values be removed from the computation? #' #' @return #' A vector the same size as `x` containing the result of applying the #' summary function over the sliding windows. #' #' - For sliding sum, mean, prod, min, and max, a double vector will be #' returned. #' #' - For sliding any and all, a logical vector will be returned. #' #' @section Implementation: #' #' These variants are implemented using a data structure known as a #' _segment tree_, which allows for extremely fast repeated range queries #' without loss of precision. #' #' One alternative to segment trees is to directly recompute the summary #' function on each full window. This is what is done by using, for example, #' `slide_dbl(x, sum)`. This is extremely slow with large window sizes and #' wastes a lot of effort recomputing nearly the same information on each #' window. It can be made slightly faster by moving the sum to C to avoid #' intermediate allocations, but it still fairly slow. #' #' A second alternative is to use an _online_ algorithm, which uses information #' from the previous window to compute the next window. These are extremely #' fast, only requiring a single pass through the data, but often suffer from #' numerical instability issues. #' #' Segment trees are an attempt to reconcile the performance issues of the #' direct approach with the numerical issues of the online approach. The #' performance of segment trees isn't quite as fast as online algorithms, but is #' close enough that it should be usable on most large data sets without any #' issues. Unlike online algorithms, segment trees don't suffer from any #' extra numerical instability issues. #' #' @references #' Leis, Kundhikanjana, Kemper, and Neumann (2015). "Efficient Processing of #' Window Functions in Analytical SQL Queries". #' https://dl.acm.org/doi/10.14778/2794367.2794375 #' #' @seealso [slide_index_sum()] #' #' @export #' @name summary-slide #' @examples #' x <- c(1, 5, 3, 2, 6, 10) #' #' # `slide_sum()` can be used for rolling sums. #' # The following are equivalent, but `slide_sum()` is much faster. #' slide_sum(x, before = 2) #' slide_dbl(x, sum, .before = 2) #' #' # `slide_mean()` can be used for rolling averages #' slide_mean(x, before = 2) #' #' # Only evaluate the sum on complete windows #' slide_sum(x, before = 2, after = 1, complete = TRUE) #' #' # Skip every other calculation #' slide_sum(x, before = 2, step = 2) slide_sum <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_sum, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_prod <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_prod, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_mean <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_mean, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_min <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_min, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_max <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_max, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_all <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_all, x, before, after, step, complete, na_rm) } #' @rdname summary-slide #' @export slide_any <- function(x, ..., before = 0L, after = 0L, step = 1L, complete = FALSE, na_rm = FALSE) { ellipsis::check_dots_empty() .Call(slider_any, x, before, after, step, complete, na_rm) } slider/R/hop-common.R0000644000176200001440000000131213663762054014145 0ustar liggesusershop_common <- function(x, starts, stops, f_call, ptype, env, type, constrain, atomic) { x_size <- compute_size(x, type) check_endpoints_cannot_be_na(starts, ".starts") check_endpoints_cannot_be_na(stops, ".stops") starts <- vec_as_subscript(starts, logical = "error", character = "error", arg = ".starts") stops <- vec_as_subscript(stops, logical = "error", character = "error", arg = ".stops") size <- vec_size_common(starts, stops) args <- vec_recycle_common(starts, stops, .size = size) starts <- args[[1L]] stops <- args[[2L]] params <- list( type = type, constrain = constrain, atomic = atomic ) .Call(hop_common_impl, x, starts, stops, f_call, ptype, env, params) } slider/R/slide-index2.R0000644000176200001440000001734613656610221014364 0ustar liggesusers#' Slide along multiples inputs simultaneously relative to an index #' #' `slide_index2()` and `pslide_index()` represent the combination #' of [slide2()] and [pslide()] with [slide_index()], allowing you to iterate #' over multiple vectors at once relative to an `.i`-ndex. #' #' @inheritParams slide_index #' #' @template param-x-y #' @template param-l #' @template param-before-after-slide-index #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide_index2()`}{ #' #' * `vec_size(slide_index2(.x, .y)) == vec_size_common(.x, .y)` #' #' * `vec_ptype(slide_index2(.x, .y)) == list()` #' #' } #' #' \subsection{`slide_index2_vec()` and `slide_index2_*()` variants}{ #' #' * `vec_size(slide_index2_vec(.x, .y)) == vec_size_common(.x, .y)` #' #' * `vec_size(slide_index2_vec(.x, .y)[[1]]) == 1L` #' #' * `vec_ptype(slide_index2_vec(.x, .y, .ptype = ptype)) == ptype` #' #' } #' #' \subsection{`pslide_index()`}{ #' #' * `vec_size(pslide_index(.l)) == vec_size_common(!!! .l)` #' #' * `vec_ptype(pslide_index(.l)) == list()` #' #' } #' #' \subsection{`pslide_index_vec()` and `pslide_index_*()` variants}{ #' #' * `vec_size(pslide_index_vec(.l)) == vec_size_common(!!! .l)` #' #' * `vec_size(pslide_index_vec(.l)[[1]]) == 1L` #' #' * `vec_ptype(pslide_index_vec(.l, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' # Notice that `i` is an irregular index! #' x <- 1:5 #' y <- 6:10 #' i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) #' #' # When we slide over `i` looking back 1 day, the irregularity is respected. #' # When there is a gap in dates, only 2 values are returned (one from #' # `x` and one from `y`), otherwise, 4 values are returned. #' slide_index2(x, y, i, ~c(.x, .y), .before = 1) #' #' @seealso [slide2()], [hop_index2()], [slide_index()] #' @export slide_index2 <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index2_impl( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_index2 #' @export slide_index2_vec <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- slide_index2_impl( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide_index2_vec_direct <- function(.x, .y, .i, .f, ..., .before, .after, .complete, .ptype) { slide_index2_impl( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_index2 #' @export slide_index2_dbl <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index2_vec_direct( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_index2 #' @export slide_index2_int <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index2_vec_direct( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_index2 #' @export slide_index2_lgl <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index2_vec_direct( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_index2 #' @export slide_index2_chr <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { slide_index2_vec_direct( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide_index2 #' @export slide_index2_dfr <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide_index2( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide_index2 #' @export slide_index2_dfc <- function(.x, .y, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide_index2( .x, .y, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide_index2_impl <- function(.x, .y, .i, .f, ..., .before, .after, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) vec_assert(.y) .f <- as_function(.f) # TODO - more efficiently? reuse .x/.y rather than recycle args <- vec_recycle_common(.x, .y) f_call <- expr(.f(.x, .y, ...)) type <- -2L slide_index_common( x = args, i = .i, f_call = f_call, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/hop-index-common.R0000644000176200001440000000271614024427556015260 0ustar liggesusershop_index_common <- function(x, i, starts, stops, f_call, ptype, constrain, atomic, env, type) { x_size <- compute_size(x, type) i_size <- vec_size(i) if (i_size != x_size) { stop_index_incompatible_size(i_size, x_size, ".i") } check_index_cannot_be_na(i, ".i") check_index_must_be_ascending(i, ".i") check_endpoints_cannot_be_na(starts, ".starts") check_endpoints_must_be_ascending(starts, ".starts") check_endpoints_cannot_be_na(stops, ".stops") check_endpoints_must_be_ascending(stops, ".stops") # `i` is known to be ascending, # so we can detect uniques very quickly with `vec_unrep()` unrep <- vec_unrep(i) i <- unrep$key peer_sizes <- unrep$times starts <- vec_cast(starts, i, x_arg = ".starts", to_arg = ".i") stops <- vec_cast(stops, i, x_arg = ".stops", to_arg = ".i") size <- vec_size_common(starts, stops) args <- vec_recycle_common(starts = starts, stops = stops, .size = size) args <- compute_combined_ranks(i = i, !!!args) i <- args$i starts <- args$starts stops <- args$stops .Call( hop_index_common_impl, x, i, starts, stops, f_call, ptype, env, peer_sizes, type, constrain, atomic, size ) } slider/R/slide2.R0000644000176200001440000001713313704076252013255 0ustar liggesusers#' Slide over multiple inputs simultaneously #' #' These are variants of [slide()] that iterate over multiple inputs in #' parallel. They are parallel in the sense that each input is processed in #' parallel with the others, not in the sense of multicore computing. These #' functions work similarly to `map2()` and `pmap()` from purrr. #' #' @inheritParams slide #' #' @template param-x-y #' @template param-l #' @template param-before-after-slide #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide2()`}{ #' #' * `vec_size(slide2(.x, .y)) == vec_size_common(.x, .y)` #' #' * `vec_ptype(slide2(.x, .y)) == list()` #' #' } #' #' \subsection{`slide2_vec()` and `slide2_*()` variants}{ #' #' * `vec_size(slide2_vec(.x, .y)) == vec_size_common(.x, .y)` #' #' * `vec_size(slide2_vec(.x, .y)[[1]]) == 1L` #' #' * `vec_ptype(slide2_vec(.x, .y, .ptype = ptype)) == ptype` #' #' } #' #' \subsection{`pslide()`}{ #' #' * `vec_size(pslide(.l)) == vec_size_common(!!! .l)` #' #' * `vec_ptype(pslide(.l)) == list()` #' #' } #' #' \subsection{`pslide_vec()` and `pslide_*()` variants}{ #' #' * `vec_size(pslide_vec(.l)) == vec_size_common(!!! .l)` #' #' * `vec_size(pslide_vec(.l)[[1]]) == 1L` #' #' * `vec_ptype(pslide_vec(.l, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' # Slide along two inputs at once #' slide2(1:4, 5:8, ~list(.x, .y), .before = 2) #' #' # Or, for more than two, use `pslide()` #' pslide(list(1:4, 5:8, 9:12), ~list(.x, .y, ..3), .before = 2) #' #' # You can even slide along the rows of multiple data frames of #' # equal size at once #' set.seed(16) #' x <- data.frame(a = rnorm(5), b = rnorm(5)) #' y <- data.frame(c = letters[1:5], d = letters[6:10]) #' #' row_return <- function(x_rows, y_rows) { #' if (sum(x_rows$a) < 0) { #' x_rows #' } else { #' y_rows #' } #' } #' #' slide2(x, y, row_return, .before = 1, .after = 2) #' #' @seealso [slide()], [slide_index2()], [hop_index2()] #' @export slide2 <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide2_impl( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide2 #' @export slide2_vec <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL) { out <- slide2_impl( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide2_vec_direct <- function(.x, .y, .f, ..., .before, .after, .step, .complete, .ptype) { slide2_impl( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide2 #' @export slide2_dbl <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide2_vec_direct( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = double() ) } #' @rdname slide2 #' @export slide2_int <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide2_vec_direct( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = integer() ) } #' @rdname slide2 #' @export slide2_lgl <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide2_vec_direct( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = logical() ) } #' @rdname slide2 #' @export slide2_chr <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { slide2_vec_direct( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide2 #' @export slide2_dfr <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide2( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide2 #' @export slide2_dfc <- function(.x, .y, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide2( .x, .y, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide2_impl <- function(.x, .y, .f, ..., .before, .after, .step, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) vec_assert(.y) # TODO - Do more efficiently internally by reusing rather than recycling # https://github.com/tidyverse/purrr/blob/e4d553989e3d18692ebeeedb334b6223ae9ea294/src/map.c#L129 # But use `vec_size_common()` to check sizes and get `.size` args <- vec_recycle_common(.x, .y) .f <- as_function(.f) f_call <- expr(.f(.x, .y, ...)) type <- -2L params <- list( type, .constrain, .atomic, .before, .after, .step, .complete ) slide_common( x = args, f_call = f_call, ptype = .ptype, env = environment(), params = params ) } slider/R/hop2.R0000644000176200001440000000565113656610221012741 0ustar liggesusers#' Hop along multiple inputs simultaneously #' #' `hop2()` and `phop()` represent the combination #' of [slide2()] and [pslide()] with [hop()], allowing you to iterate #' over multiple vectors at once, hopping along them using boundaries defined #' by `.starts` and `.stops`. #' #' @inheritParams hop #' #' @template param-x-y #' @template param-l #' @template param-starts-stops-hop #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`hop2()`}{ #' #' * `vec_size(hop2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(hop2(.x, .y, .starts, .stops)) == list()` #' #' } #' #' \subsection{`hop2_vec()`}{ #' #' * `vec_size(hop2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(hop2_vec(.x, .y, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(hop2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' \subsection{`phop()`}{ #' #' * `vec_size(phop(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(phop(.l, .starts, .stops)) == list()` #' #' } #' #' \subsection{`phop_vec()`}{ #' #' * `vec_size(phop_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(phop_vec(.l, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(phop_vec(.l, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' hop2(1:2, 3:4, .starts = 1, .stops = c(2, 1), ~c(x = .x, y = .y)) #' #' phop( #' list(1, 2:4, 5:7), #' .starts = c(0, 1), #' .stops = c(2, 4), #' ~c(x = ..1, y = ..2, z = ..3) #' ) #' #' @seealso [hop()], [hop_index()], [slide2()] #' @export hop2 <- function(.x, .y, .starts, .stops, .f, ...) { hop2_impl( .x, .y, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop2 #' @export hop2_vec <- function(.x, .y, .starts, .stops, .f, ..., .ptype = NULL) { out <- hop2_impl( .x, .y, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ hop2_impl <- function(.x, .y, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { vec_assert(.x) vec_assert(.y) # TODO - Do more efficiently internally by reusing rather than recycling # https://github.com/tidyverse/purrr/blob/e4d553989e3d18692ebeeedb334b6223ae9ea294/src/map.c#L129 # But use `vec_size_common()` to check sizes and get `.size` args <- vec_recycle_common(.x, .y) .f <- as_function(.f) f_call <- expr(.f(.x, .y, ...)) type <- -2L hop_common( x = args, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, env = environment(), type = type, constrain = .constrain, atomic = .atomic ) } slider/R/segment-tree.R0000644000176200001440000000013413736067057014473 0ustar liggesusers# Keep in line with `segment-tree.h` SEGMENT_TREE_FANOUT = 16 SEGMENT_TREE_FANOUT_POWER = 4 slider/R/pslide.R0000644000176200001440000001314513704076252013352 0ustar liggesusers#' @include slide2.R #' @rdname slide2 #' @export pslide <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { pslide_impl( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide2 #' @export pslide_vec <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .ptype = NULL) { out <- pslide_impl( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } pslide_vec_direct <- function(.l, .f, ..., .before, .after, .step, .complete, .ptype) { pslide_impl( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide2 #' @export pslide_dbl <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { pslide_vec_direct( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = double() ) } #' @rdname slide2 #' @export pslide_int <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { pslide_vec_direct( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = integer() ) } #' @rdname slide2 #' @export pslide_lgl <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { pslide_vec_direct( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = logical() ) } #' @rdname slide2 #' @export pslide_chr <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE) { pslide_vec_direct( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide2 #' @export pslide_dfr <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- pslide( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide2 #' @export pslide_dfc <- function(.l, .f, ..., .before = 0L, .after = 0L, .step = 1L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- pslide( .l, .f, ..., .before = .before, .after = .after, .step = .step, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ pslide_impl <- function(.l, .f, ..., .before, .after, .step, .complete, .ptype, .constrain, .atomic) { check_is_list(.l) lapply(.l, vec_assert) # TODO - Do more efficiently internally by reusing rather than recycling # https://github.com/tidyverse/purrr/blob/e4d553989e3d18692ebeeedb334b6223ae9ea294/src/map.c#L129 # But use `vec_size_common()` to check sizes and get `.size` .l <- vec_recycle_common(!!!.l) .f <- as_function(.f) type <- vec_size(.l) slicers <- lapply( seq_len(type), function(.i) { expr(.l[[!!.i]]) } ) # Ensure names of `.l` are kept so they can be spliced # into `.f` as argument names names(slicers) <- names(.l) f_call <- expr(.f(!!! slicers, ...)) params <- list( type, .constrain, .atomic, .before, .after, .step, .complete ) slide_common( x = .l, f_call = f_call, ptype = .ptype, env = environment(), params = params ) } slider/R/pslide-index.R0000644000176200001440000001354313656610221014455 0ustar liggesusers#' @include slide-index2.R #' @rdname slide_index2 #' @export pslide_index <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { pslide_index_impl( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_index2 #' @export pslide_index_vec <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- pslide_index_impl( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } pslide_index_vec_direct <- function(.l, .i, .f, ..., .before, .after, .complete, .ptype) { pslide_index_impl( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_index2 #' @export pslide_index_dbl <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { pslide_index_vec_direct( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_index2 #' @export pslide_index_int <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { pslide_index_vec_direct( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_index2 #' @export pslide_index_lgl <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { pslide_index_vec_direct( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_index2 #' @export pslide_index_chr <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE) { pslide_index_vec_direct( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @inheritParams vctrs::vec_rbind #' @rdname slide_index2 #' @export pslide_index_dfr <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- pslide_index( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @inheritParams vctrs::vec_cbind #' @rdname slide_index2 #' @export pslide_index_dfc <- function(.l, .i, .f, ..., .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- pslide_index( .l, .i, .f, ..., .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ pslide_index_impl <- function(.l, .i, .f, ..., .before, .after, .complete, .ptype, .constrain, .atomic) { check_is_list(.l) lapply(.l, vec_assert) .f <- as_function(.f) # TODO - more efficiently? reuse .x/.y rather than recycle .l <- vec_recycle_common(!!!.l) type <- vec_size(.l) slicers <- lapply( seq_len(type), function(x) { expr(.l[[!!x]]) } ) # Ensure names of `.l` are kept so they can be spliced # into `.f` as argument names names(slicers) <- names(.l) f_call <- expr(.f(!!! slicers, ...)) slide_index_common( x = .l, i = .i, f_call = f_call, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/slide-common.R0000644000176200001440000000016613641664761014467 0ustar liggesusersslide_common <- function(x, f_call, ptype, env, params) { .Call(slide_common_impl, x, f_call, ptype, env, params) } slider/R/block.R0000644000176200001440000000515413613034205013154 0ustar liggesusers#' Break a vector into blocks #' #' @description #' `block()` breaks up the `i`-ndex by `period`, and then uses that to define #' the indices to chop `x` with. #' #' For example, it can split `x` into monthly or yearly blocks. Combined with #' `purrr::map()`, it is a way to iterate over a vector in "time blocks". #' #' @details #' `block()` determines the indices to block by with [warp::warp_boundary()], #' and splits `x` by those indices using [vctrs::vec_chop()]. #' #' Like [slide()], `block()` splits data frame `x` values row wise. #' #' @inheritParams warp::warp_boundary #' #' @param x `[vector]` #' #' The vector to block. #' #' @param i `[Date / POSIXct / POSIXlt]` #' #' The datetime index to block by. #' #' There are 3 restrictions on the index: #' #' - The size of the index must match the size of `x`, they will not be #' recycled to their common size. #' #' - The index must be an _increasing_ vector, but duplicate values #' are allowed. #' #' - The index cannot have missing values. #' #' @return #' A vector fulfilling the following invariants: #' #' * `vec_size(block(x)) == vec_size(unique(warp::warp_boundary(i)))` #' #' * `vec_ptype(block(x)) == list()` #' #' * `vec_ptype(block(x)[[1]]) == vec_ptype(x)` #' #' @examples #' x <- 1:6 #' i <- as.Date("2019-01-01") + c(-2:2, 31) #' #' block(i, i, period = "year") #' #' # Data frames are split row wise #' df <- data.frame(x = x, i = i) #' block(df, i, period = "month") #' #' # Iterate over these blocks to apply a function over #' # non-overlapping period blocks. For example, to compute a #' # mean over yearly or monthly blocks. #' vapply(block(x, i, "year"), mean, numeric(1)) #' vapply(block(x, i, "month"), mean, numeric(1)) #' #' # block by every 2 months, ensuring that we start counting #' # the 1st of the 2 months from `2019-01-01` #' block(i, i, period = "month", every = 2, origin = as.Date("2019-01-01")) #' #' # Use the `origin` to instead start counting from `2018-12-01`, meaning #' # that [2018-12, 2019-01] gets bucketed together. #' block(i, i, period = "month", every = 2, origin = as.Date("2018-12-01")) #' #' @seealso [slide_period()], [slide()], [slide_index()] #' @export block <- function(x, i, period, every = 1L, origin = NULL) { vec_assert(x) check_index_incompatible_type(i, "i") check_index_cannot_be_na(i, "i") check_index_must_be_ascending(i, "i") x_size <- vec_size(x) i_size <- vec_size(i) if (x_size != i_size) { stop_index_incompatible_size(i_size, x_size, "i") } boundaries <- warp_boundary(i, period = period, every = every, origin = origin) .Call(slider_block, x, boundaries$start, boundaries$stop) } slider/R/hop-index2.R0000644000176200001440000000677413656610221014055 0ustar liggesusers#' Hop along multiple inputs simultaneously relative to an index #' #' `hop_index2()` and `phop_index()` represent the combination #' of [slide2()] and [pslide()] with [hop_index()], allowing you to iterate #' over multiple vectors at once, relative to an `.i`-ndex with #' boundaries defined by `.starts` and `.stops`. #' #' @inheritParams hop_index #' #' @template param-x-y #' @template param-l #' @template param-starts-stops-hop-index #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`hop_index2()`}{ #' #' * `vec_size(hop_index2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(hop_index2(.x, .y, .starts, .stops)) == list()` #' #' } #' #' \subsection{`hop_index2_vec()`}{ #' #' * `vec_size(hop_index2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(hop_index2_vec(.x, .y, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(hop_index2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' \subsection{`phop_index()`}{ #' #' * `vec_size(phop_index(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(phop_index(.l, .starts, .stops)) == list()` #' #' } #' #' \subsection{`phop_index_vec()`}{ #' #' * `vec_size(phop_index_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(phop_index_vec(.l, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(phop_index_vec(.l, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' # Notice that `i` is an irregular index! #' x <- 1:5 #' i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) #' #' # Manually create starts/stops. They don't have to be equally spaced, #' # and they don't have to be the same size as `.x` or `.i`. #' starts <- as.Date(c("2019-08-15", "2019-08-18")) #' stops <- as.Date(c("2019-08-16", "2019-08-23")) #' #' # The output size is equal to the common size of `.starts` and `.stops` #' hop_index2(x, i, i, starts, stops, ~data.frame(x = .x, y = .y)) #' #' @seealso [slide2()], [slide_index2()], [hop_index()] #' @export hop_index2 <- function(.x, .y, .i, .starts, .stops, .f, ...) { hop_index2_impl( .x, .y, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop_index2 #' @export hop_index2_vec <- function(.x, .y, .i, .starts, .stops, .f, ..., .ptype = NULL) { out <- hop_index2_impl( .x, .y, .i, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ hop_index2_impl <- function(.x, .y, .i, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { vec_assert(.x) vec_assert(.y) # TODO - Do more efficiently internally by reusing rather than recycling # https://github.com/tidyverse/purrr/blob/e4d553989e3d18692ebeeedb334b6223ae9ea294/src/map.c#L129 # But use `vec_size_common()` to check sizes and get `.size` args <- vec_recycle_common(.x, .y) .f <- as_function(.f) f_call <- expr(.f(.x, .y, ...)) type <- -2L hop_index_common( x = args, i = .i, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/R/hop.R0000644000176200001440000000703513656610221012655 0ustar liggesusers#' Hop #' #' @description #' `hop()` is the lower level engine that powers [slide()] (at least in theory). #' It has slightly different invariants than `slide()`, and is useful #' when you either need to hand craft boundary locations, or want to compute a #' result with a size that is different from `.x`. #' #' @details #' `hop()` is very close to being a faster version of: #' #' ``` #' map2( #' .starts, #' .stops, #' function(start, stop) { #' x_slice <- vec_slice(.x, start:stop) #' .f(x_slice, ...) #' } #' ) #' ``` #' #' Because of this, [hop_index()] is often the more useful function. `hop()` #' mainly exists for API completeness. #' #' The main difference is that the start and stop values make up ranges of #' _possible_ locations along `.x`, and it is not enforced that these locations #' actually exist along `.x`. As an example, with `hop()` you can do the #' following, which would be an error with `vec_slice()` because `0L` is #' out of bounds. #' #' ``` #' hop(c("a", "b"), .starts = 0L, .stops = 1L, ~.x) #' #> [[1]] #' #> [1] "a" #' ``` #' #' `hop()` allows these out of bounds values to be fully compatible with #' `slide()`. It is always possible to construct a `hop()` call from a `slide()` #' call. For example, the following are equivalent: #' #' ``` #' slide(1:2, ~.x, .before = 1) #' #' hop(1:2, .starts = c(0, 1), .stops = c(1, 2), ~.x) #' #' #> [[1]] #' #> [1] 1 #' #> #' #> [[2]] #' #> [1] 1 2 #' ``` #' #' @inheritParams slide #' #' @template param-starts-stops-hop #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`hop()`}{ #' #' * `vec_size(hop(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_ptype(hop(.x, .starts, .stops)) == list()` #' #' } #' #' \subsection{`hop_vec()`}{ #' #' * `vec_size(hop_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` #' #' * `vec_size(hop_vec(.x, .starts, .stops)[[1]]) == 1L` #' #' * `vec_ptype(hop_vec(.x, .starts, .stops, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' # `hop()` let's you manually specify locations to apply `.f` at. #' hop(1:3, .starts = c(1, 3), .stops = 3, ~.x) #' #' # `hop()`'s start/stop locations are allowed to be out of bounds relative #' # to the size of `.x`. #' hop( #' mtcars, #' .starts = c(-1, 3), #' .stops = c(2, 6), #' ~.x #' ) #' #' @seealso [hop2()], [hop_index()], [slide()] #' @export hop <- function(.x, .starts, .stops, .f, ...) { hop_impl( .x, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop #' @export hop_vec <- function(.x, .starts, .stops, .f, ..., .ptype = NULL) { out <- hop_impl( .x, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ hop_impl <- function(.x, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { vec_assert(.x) .f <- as_function(.f) f_call <- expr(.f(.x, ...)) type <- -1L hop_common( x = .x, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, env = environment(), type = type, constrain = .constrain, atomic = .atomic ) } slider/R/phop.R0000644000176200001440000000314713656610221013035 0ustar liggesusers#' @include hop2.R #' @rdname hop2 #' @export phop <- function(.l, .starts, .stops, .f, ...) { phop_impl( .l, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname hop2 #' @export phop_vec <- function(.l, .starts, .stops, .f, ..., .ptype = NULL) { out <- phop_impl( .l, .starts, .stops, .f, ..., .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } # ------------------------------------------------------------------------------ phop_impl <- function(.l, .starts, .stops, .f, ..., .ptype, .constrain, .atomic) { check_is_list(.l) lapply(.l, vec_assert) .f <- as_function(.f) # TODO - more efficiently? reuse elements rather than recycle .l <- vec_recycle_common(!!!.l) type <- vec_size(.l) slicers <- lapply( seq_len(type), function(x) { expr(.l[[!!x]]) } ) # Ensure names of `.l` are kept so they can be spliced # into `.f` as argument names names(slicers) <- names(.l) f_call <- expr(.f(!!! slicers, ...)) hop_common( x = .l, starts = .starts, stops = .stops, f_call = f_call, ptype = .ptype, env = environment(), type = type, constrain = .constrain, atomic = .atomic ) } slider/R/conditions.R0000644000176200001440000002146114067407063014244 0ustar liggesuserscheck_index_incompatible_type <- function(i, i_arg = "i") { is_datelike <- inherits(i, c("Date", "POSIXt")) if (is_datelike) { return(invisible(i)) } stop_index_incompatible_type(i, i_arg) } stop_index_incompatible_type <- function(i, i_arg = "i") { stop_index( i_class = class(i), i_arg = i_arg, class = "slider_error_index_incompatible_type" ) } #' @export cnd_header.slider_error_index_incompatible_type <- function(cnd, ...) { glue_data(cnd, "`{i_arg}` has an incorrect type.") } #' @export cnd_body.slider_error_index_incompatible_type <- function(cnd, ...) { glue_data_bullets( cnd, x = "It must inherit from Date, POSIXct, or POSIXlt, not {paste0(i_class, collapse = '/')}." ) } # ------------------------------------------------------------------------------ check_endpoints_must_be_ascending <- function(endpoints, endpoints_arg) { locations <- compute_non_ascending_locations(endpoints) if (identical(locations, integer())) { return(invisible(endpoints)) } stop_endpoints_must_be_ascending(locations, endpoints_arg) } stop_endpoints_must_be_ascending <- function(locations, endpoints_arg) { stop_endpoints( locations = locations, endpoints_arg = endpoints_arg, class = "slider_error_endpoints_must_be_ascending" ) } #' @export cnd_header.slider_error_endpoints_must_be_ascending <- function(cnd, ...) { glue_data(cnd, "`{endpoints_arg}` must be in ascending order.") } #' @export cnd_body.slider_error_endpoints_must_be_ascending <- function(cnd, ...) { glue_data_bullets( cnd, i = "It is not ascending at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ check_generated_endpoints_cannot_be_na <- function(endpoints, by_arg) { na_indicators <- vec_equal_na(endpoints) if (any(na_indicators)) { na_locations <- which(na_indicators) stop_generated_endpoints_cannot_be_na(na_locations, by_arg) } invisible(endpoints) } stop_generated_endpoints_cannot_be_na <- function(locations, by_arg) { stop_endpoints( locations = locations, by_arg = by_arg, class = "slider_error_generated_endpoints_cannot_be_na" ) } #' @export cnd_header.slider_error_generated_endpoints_cannot_be_na <- function(cnd, ...) { glue_data(cnd, "Endpoints generated by `{by_arg}` cannot be `NA`.") } #' @export cnd_body.slider_error_generated_endpoints_cannot_be_na <- function(cnd, ...) { glue_data_bullets( cnd, i = "They are `NA` at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ check_generated_endpoints_must_be_ascending <- function(endpoints, by_arg) { locations <- compute_non_ascending_locations(endpoints) if (identical(locations, integer())) { return(invisible(endpoints)) } stop_generated_endpoints_must_be_ascending(locations, by_arg) } stop_generated_endpoints_must_be_ascending <- function(locations, by_arg) { stop_endpoints( locations = locations, by_arg = by_arg, class = "slider_error_generated_endpoints_must_be_ascending" ) } #' @export cnd_header.slider_error_generated_endpoints_must_be_ascending <- function(cnd, ...) { glue_data(cnd, "Endpoints generated by `{by_arg}` must be in ascending order.") } #' @export cnd_body.slider_error_generated_endpoints_must_be_ascending <- function(cnd, ...) { glue_data_bullets( cnd, i = "They are not ascending at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ check_generated_endpoints_incompatible_size <- function(endpoints, size, by_arg) { endpoints_size <- vec_size(endpoints) if (endpoints_size == size) { return(invisible(endpoints)) } stop_generated_endpoints_incompatible_size(endpoints_size, size, by_arg) } stop_generated_endpoints_incompatible_size <- function(endpoints_size, size, by_arg) { stop_endpoints( endpoints_size = endpoints_size, size = size, by_arg = by_arg, class = "slider_error_generated_endpoints_incompatible_size" ) } #' @export cnd_header.slider_error_generated_endpoints_incompatible_size <- function(cnd, ...) { glue_data(cnd, "Endpoints generated by `{by_arg}` have an incorrect size.") } #' @export cnd_body.slider_error_generated_endpoints_incompatible_size <- function(cnd, ...) { glue_data_bullets( cnd, i = "They must have size {size}, not {endpoints_size}." ) } # ------------------------------------------------------------------------------ check_endpoints_cannot_be_na <- function(endpoints, endpoints_arg) { na_indicators <- vec_equal_na(endpoints) if (any(na_indicators)) { na_locations <- which(na_indicators) stop_endpoints_cannot_be_na(na_locations, endpoints_arg) } invisible(endpoints) } stop_endpoints_cannot_be_na <- function(locations, endpoints_arg) { stop_endpoints( locations = locations, endpoints_arg = endpoints_arg, class = "slider_error_endpoints_cannot_be_na" ) } #' @export cnd_header.slider_error_endpoints_cannot_be_na <- function(cnd, ...) { glue_data(cnd, "`{endpoints_arg}` cannot be `NA`.") } #' @export cnd_body.slider_error_endpoints_cannot_be_na <- function(cnd, ...) { glue_data_bullets( cnd, i = "It is `NA` at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ check_index_must_be_ascending <- function(i, i_arg = "i") { locations <- compute_non_ascending_locations(i) if (identical(locations, integer())) { return(invisible(i)) } stop_index_must_be_ascending(locations, i_arg) } stop_index_must_be_ascending <- function(locations, i_arg = "i") { stop_index( locations = locations, i_arg = i_arg, class = "slider_error_index_must_be_ascending" ) } #' @export cnd_header.slider_error_index_must_be_ascending <- function(cnd, ...) { glue_data(cnd, "`{i_arg}` must be in ascending order.") } #' @export cnd_body.slider_error_index_must_be_ascending <- function(cnd, ...) { glue_data_bullets( cnd, i = "It is not ascending at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ check_index_cannot_be_na <- function(i, i_arg = "i") { na_indicators <- vec_equal_na(i) if (any(na_indicators)) { na_locations <- which(na_indicators) stop_index_cannot_be_na(na_locations, i_arg) } invisible(i) } stop_index_cannot_be_na <- function(locations, i_arg = "i") { stop_index( locations = locations, i_arg = i_arg, class = "slider_error_index_cannot_be_na" ) } #' @export cnd_header.slider_error_index_cannot_be_na <- function(cnd, ...) { glue_data(cnd, "`{i_arg}` cannot be `NA`.") } #' @export cnd_body.slider_error_index_cannot_be_na <- function(cnd, ...) { glue_data_bullets( cnd, i = "It is `NA` at locations: {collapse_locations(locations)}." ) } # ------------------------------------------------------------------------------ stop_index_incompatible_size <- function(i_size, size, i_arg = "i") { stop_index( i_size = i_size, size = size, i_arg = i_arg, class = "slider_error_index_incompatible_size" ) } #' @export cnd_header.slider_error_index_incompatible_size <- function(cnd, ...) { glue_data(cnd, "`{i_arg}` has an incorrect size.") } #' @export cnd_body.slider_error_index_incompatible_size <- function(cnd, ...) { glue_data_bullets(cnd, x = "It must have size {size}, not {i_size}.") } # ------------------------------------------------------------------------------ stop_endpoints <- function(message = NULL, class = character(), ...) { stop_slider(message, class = c(class, "slider_error_endpoints"), ...) } # ------------------------------------------------------------------------------ stop_index <- function(message = NULL, class = character(), ...) { stop_slider(message, class = c(class, "slider_error_index"), ...) } # ------------------------------------------------------------------------------ stop_slider <- function(message = NULL, class = character(), ...) { abort(message, class = c(class, "slider_error"), ...) } # ------------------------------------------------------------------------------ collapse_locations <- function(locations) { glue_collapse(locations, sep = ", ", width = 30L) } glue_data_bullets <- function (.data, ..., .env = caller_env()) { glue_data_env <- function(...) glue_data(.data, ..., .envir = .env) format_error_bullets(map_chr(chr(...), glue_data_env)) } map_chr <- function(x, f) { vapply(x, f, character(1)) } is_sorted <- function(x) { !is.unsorted(x) } compute_non_ascending_locations <- function(x) { order <- vec_order(x, direction = "asc") if (is_sorted(order)) { return(integer()) } problems <- which(diff(order) < 0L) locations <- order[problems] locations } slider/R/slide-period.R0000644000176200001440000002425313656610221014450 0ustar liggesusers#' Slide relative to an index chunked by period #' #' @description #' `slide_period()` breaks up the `.i`-ndex by `.period`, and then uses that #' to define the indices to slide over `.x` with. #' #' It can be useful for, say, sliding over daily data in monthly chunks. #' #' The underlying engine for breaking up `.i` is [warp::warp_distance()]. #' If you need more information about the `.period` types, that is the best #' place to look. #' #' @inheritParams slide #' @inheritParams warp::warp_distance #' #' @template param-before-after-slide #' #' @param .i `[Date / POSIXct / POSIXlt]` #' #' A datetime index to break into periods. #' #' There are 3 restrictions on the index: #' #' - The size of the index must match the size of `.x`, they will not be #' recycled to their common size. #' #' - The index must be an _increasing_ vector, but duplicate values #' are allowed. #' #' - The index cannot have missing values. #' #' @return #' A vector fulfilling the following invariants: #' #' \subsection{`slide_period()`}{ #' #' * `vec_size(slide_period(.x)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_ptype(slide_period(.x)) == list()` #' #' } #' #' \subsection{`slide_period_vec()` and `slide_period_*()` variants}{ #' #' * `vec_size(slide_period_vec(.x)) == vec_size(unique(warp::warp_distance(.i)))` #' #' * `vec_size(slide_period_vec(.x)[[1]]) == 1L` #' #' * `vec_ptype(slide_period_vec(.x, .ptype = ptype)) == ptype` #' #' } #' #' @examples #' i <- as.Date("2019-01-28") + 0:5 #' #' # Split `i` into 2-day periods to apply `.f` to #' slide_period(i, i, "day", identity, .every = 2) #' #' # Or into 1-month periods #' slide_period(i, i, "month", identity) #' #' # Now select: #' # - The current 2-day period #' # - Plus 1 2-day period before the current one #' slide_period(i, i, "day", identity, .every = 2, .before = 1) #' #' # Alter the `origin` to control the reference date for #' # how the 2-day groups are formed #' origin <- as.Date("2019-01-29") #' slide_period(i, i, "day", identity, .every = 2, .origin = origin) #' #' # This can be useful for, say, monthly averages #' daily_sales <- c(2, 5, 3, 6, 9, 4) #' slide_period_dbl(daily_sales, i, "month", mean) #' #' # If you need the index, slide over and return a data frame #' sales_df <- data.frame(i = i, sales = daily_sales) #' #' slide_period_dfr( #' sales_df, #' sales_df$i, #' "month", #' ~data.frame( #' i = max(.x$i), #' sales = mean(.x$sales) #' ) #' ) #' #' # One of the most unique features about `slide_period()` is that it is #' # aware of how far apart elements of `.i` are in the `.period` you are #' # interested in. For example, if you do a monthly slide with `i2`, selecting #' # the current month and 1 month before it, then it will recognize that #' # `2019-02-01` and `2019-04-01` are not beside each other, and it won't #' # group them together. #' i2 <- as.Date(c("2019-01-01", "2019-02-01", "2019-04-01", "2019-05-01")) #' #' slide_period(i2, i2, "month", identity, .before = 1) #' #' @seealso [block()], [slide()], [slide_index()] #' @export slide_period <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period_impl( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = FALSE ) } #' @rdname slide_period #' @export slide_period_vec <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .ptype = NULL) { out <- slide_period_impl( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = list(), .constrain = FALSE, .atomic = TRUE ) vec_simplify(out, .ptype) } slide_period_vec_direct <- function(.x, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype) { slide_period_impl( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = .ptype, .constrain = TRUE, .atomic = TRUE ) } #' @rdname slide_period #' @export slide_period_dbl <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period_vec_direct( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = double() ) } #' @rdname slide_period #' @export slide_period_int <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period_vec_direct( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = integer() ) } #' @rdname slide_period #' @export slide_period_lgl <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period_vec_direct( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = logical() ) } #' @rdname slide_period #' @export slide_period_chr <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE) { slide_period_vec_direct( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete, .ptype = character() ) } #' @rdname slide_period #' @export slide_period_dfr <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .names_to = rlang::zap(), .name_repair = c("unique", "universal", "check_unique")) { out <- slide_period( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_rbind(!!!out, .names_to = .names_to, .name_repair = .name_repair) } #' @rdname slide_period #' @export slide_period_dfc <- function(.x, .i, .period, .f, ..., .every = 1L, .origin = NULL, .before = 0L, .after = 0L, .complete = FALSE, .size = NULL, .name_repair = c("unique", "universal", "check_unique", "minimal")) { out <- slide_period( .x, .i, .period, .f, ..., .every = .every, .origin = .origin, .before = .before, .after = .after, .complete = .complete ) vec_cbind(!!!out, .size = .size, .name_repair = .name_repair) } # ------------------------------------------------------------------------------ slide_period_impl <- function(.x, .i, .period, .f, ..., .every, .origin, .before, .after, .complete, .ptype, .constrain, .atomic) { vec_assert(.x) .f <- as_function(.f) f_call <- expr(.f(.x, ...)) type <- -1L slide_period_common( x = .x, i = .i, period = .period, f_call = f_call, every = .every, origin = .origin, before = .before, after = .after, complete = .complete, ptype = .ptype, constrain = .constrain, atomic = .atomic, env = environment(), type = type ) } slider/NEWS.md0000644000176200001440000001002014067412671012633 0ustar liggesusers# slider 0.2.2 * Updated internal usage of `vec_order()` to prepare for a breaking change in vctrs (#153). # slider 0.2.1 * Fixed a C alignment issue detected by CRAN's USBAN machine related to allocating vectors of `long double`. * Fixed a test that relied too strongly on the size of the C type, `long double`, which can vary across platforms (#147). * Fixed an out of sync vignette entry (#148). # slider 0.2.0 * New family of very fast specialized sliding functions: - `slide_sum()`, `slide_index_sum()`: for rolling sums - `slide_mean()`, `slide_index_mean()`: for rolling averages - `slide_prod()`, `slide_index_prod()`: for rolling products - `slide_min()`, `slide_index_min()`: for rolling minimums - `slide_max()`, `slide_index_max()`: for rolling maximums - `slide_any()`, `slide_index_any()`: for rolling any - `slide_all()`, `slide_index_all()`: for rolling all * The `slide_index_*()` family now allows `.before` and `.after` to be functions of 1 argument (the index) that compute the boundaries of the sliding window. This can be extremely useful when the default, which computes `.i - .before` and `.i + .after`, is not applicable or correct for your needs. One use case is to set `.before = ~.x %m-% months(1)` rather than `.before = months(1)` to perform a 1 month rolling window in a way that won't generate `NA` values on invalid dates (like 1 month before 2019-03-31) (#139). * The `slide_index_*()` family has undergone some internal changes to make it more compatible with custom vctrs classes that could be provided as the index (`.i`), such as the date-time classes in the clock package (#133, #130). * For the `slide_index_*()` family, it is now required that `.i - .before` and `.i + .after` be castable to `.i` by `vctrs::vec_cast()`. Similarly, for the `hop_index_*()` family, `.starts` and `.stops` must both be castable to `.i` (#132). * New vignette, `vignette("tsibble")`, explaining how to transition from tsibble to slider (#128). * `vignette("rowwise")` has been updated to use `cur_data()` from dplyr 1.0.0, which makes it significantly easier to do rolling operations on data frames (like rolling regressions) using slider in a dplyr pipeline. # slider 0.1.5 * `slide_period()` and friends have slightly better handling of size zero input when `.complete = TRUE` (#111). * Better error messages for `NA` input with `.before`, `.after`, `.step` and `.complete` have been added (#110). * A few instances of possibly unsafe C protection usage have been fixed (#112). * Tests have been updated to use only numeric values in the `vctrs::new_date()` constructor (#113). # slider 0.1.4 * As a followup to a change in slider 0.1.3, edge cases with size zero input in `hop()` have also been fixed. * C code has been refactored to be less reliant on vctrs internals. # slider 0.1.3 * Updated to stay compatible with vctrs 0.3.0. * A few edge cases with size zero input in the index functions have been fixed. * The default for the `.names_to` argument of `*_dfr()` variants has been updated to `rlang::zap()` to match the default of the function it is passed on to, `vctrs::vec_rbind()`. * All `*_vec()` variants now maintain size stability when auto-simplifying (i.e. when `.ptype = NULL`) (#78, #93). * `hop()` and its variants no longer place the names of `.x` on the output. Because there is no _size_ guarantee on the output, the size of `.x` can be different than the size of the output, meaning that the names might not line up. This also affects `slide_period()`, which is implemented using a `hop()` variant (#75). * With data frames containing row names, `slide()` and its variants now copy those row names onto the output. This is an implicit benefit from vctrs gaining better support for data frame row names. # slider 0.1.2 * Updated to stay compatible with the latest version of vctrs. # slider 0.1.1 * Fixed a "multiple definition" C issue when compiling with gcc10. # slider 0.1.0 * Added a `NEWS.md` file to track changes to the package. slider/MD50000644000176200001440000001763614067416152012067 0ustar liggesuserse2078e2bc0a8ce4aa850f6fefad9c651 *DESCRIPTION 0578b84ee28af684bb8cefb871d81d75 *LICENSE b33ce86558e806671e40b5708b6ad0a0 *NAMESPACE acd1e5901b8e7f70c108d169305c58e0 *NEWS.md 1249d380f5086fea66746b7f2686bd47 *R/block.R 558708cdc10f333bceef5e2d0ca510cc *R/conditions.R c23305aa6be86702a6a748a4b9fe531a *R/hop-common.R d8912b272cd1560520c384c66643e72f *R/hop-index-common.R 3143c38ba99ee3d28e63722003846743 *R/hop-index.R 1f1e5e0db489f9f30bbc342fd124fc98 *R/hop-index2.R 53c2bb77303c616b6344bfa0abf91eff *R/hop.R 7f01a1b0e03a15aa9297500a5cafa8c8 *R/hop2.R 6e2c1f7131dc92bbaf8deb6169914f3c *R/names.R 73e04bb2a166dc082bb63b35590766ff *R/phop-index.R e82d9f12bd4e1e1dd1b2b6dc7ed2169a *R/phop.R d4b340ab4573b3841354bdef24e42d05 *R/pslide-index.R fa766e0d87a83cf21ba9e1434f9b7075 *R/pslide-period.R 81bb70983356963c62d444757cead880 *R/pslide.R 19d435e1716c8efbb0f8250d65946ea4 *R/segment-tree.R 41861a48a7c27d1b689d23b32f811a2d *R/slide-common.R 2bf884d530aa42e40b2ae2662f4ca6a4 *R/slide-index-common.R 2d366d00d0d80934cfe620110e77acde *R/slide-index.R 8b7aa6646174d1701a08456ed182a522 *R/slide-index2.R 96386c8a6188755480012328bb14482a *R/slide-period-common.R 1611eb3ba89f0f1995db49985fe157dc *R/slide-period.R 05640244d4bd774c99d0c438dbcb2723 *R/slide-period2.R 76f7c590d1cc55582f8673f34d340e3e *R/slide.R 72c7936f5622115e13dccf435c72602b *R/slide2.R d945f9abf51c622d84a86cf206df7bfa *R/slider-package.R 72fb2eb48abc4f6260232f907b97878e *R/summary-index.R d22e2120fce31c5e4aaa7d2590ed1751 *R/summary-slide.R ac18206b51142a519d1680900ae706a7 *R/utils.R 89127051cafa670bbddf63ec9f371cac *R/zzz.R d79cc311f531fd550406057bae8b3d51 *README.md 1620d97fd112b8155bffe9d686ebbdb5 *build/vignette.rds c902bb348921e17d2adc6ad0d4e3bd46 *inst/doc/rowwise.R 65d9e31b74708f2f7df4cd26194866bc *inst/doc/rowwise.Rmd 227c994443bf349d78d1c47c6b5ce5c8 *inst/doc/rowwise.html 33e0ff342ac1ad94ae9d4b65e85ed0c0 *inst/doc/slider.R 3f4d5c3cb728cff355f27932d4663c3a *inst/doc/slider.Rmd 3b279213a9f02981814b076eb022b860 *inst/doc/slider.html a6cf2faccca14295fde9f7b3a61499b5 *inst/doc/tsibble.R 33144b0df31528d9abcfca259fd68aa6 *inst/doc/tsibble.Rmd 9f95490838e96e43f9233c5c7ccd0769 *inst/doc/tsibble.html 3808ea3e742ba21771f69749a70f7955 *man/block.Rd ea239879d3aab4b2e9d5b16f2a81586f *man/hop.Rd 7368819fc15a1efc8cea9adacfa296bc *man/hop2.Rd 5b74724a88f44623ccd2a730ab8f2978 *man/hop_index.Rd 4dcdf4ecaa914c84b73f80ad869e0d0b *man/hop_index2.Rd 0325dd5e35944c945b1c68c03fbfb2d8 *man/slide.Rd a073bc668aecbcf1305f4ab7152bd964 *man/slide2.Rd dc4d6ea2a3f6b13c15dfe65d024a15b1 *man/slide_index.Rd 464209f6d394bc068e0afef0fff2bd66 *man/slide_index2.Rd 0ec0723db81a3401dd3872bab6bfdf6c *man/slide_period.Rd 96d92e703e0309243d21e2053e88fa50 *man/slide_period2.Rd 86228f0f7ff4906febb1844e5259799a *man/slider-package.Rd 11957b205c8e1cee35dfceccae75b788 *man/summary-index.Rd 0607092c7e1bdd02edb49289e6da2a88 *man/summary-slide.Rd 8231f231e8406c1b77fe7f2fb5dd1525 *src/align.h 8e9878aee641609ed85aab7667fba552 *src/assign.h f1e2d9e3c49e97df39bec8cc84e068d0 *src/block.c 783d05521c02b401a9b4a49c9a951fc3 *src/hop.c 2af76a63924dc34a2c1c1aa62a3ccb72 *src/index.c 59eb9dc2e9b7ad4760e3fe0805779006 *src/index.h d17729d6bc0dd7df757af23da2c79dd7 *src/init.c 009562271e0da070c562df74a1d73643 *src/names.c e4c83c50f325cecf1fb028850ab6e527 *src/opts-slide.h e6be6295a94bfead936cf29167e951aa *src/params.c e5e26cfe46159f06f12a7633151edae0 *src/params.h a53bbb4dbfc4ed972d3c58b61b230147 *src/segment-tree.c a4125ba6c9260f30a8ec491f43bf5c29 *src/segment-tree.h b2524cb888f5bed10843392a03dfa552 *src/slide-period.c cbd3b964cfc3b92d0d6caf564356cd97 *src/slide.c 90918eaec9a04fefafdae2d227aba694 *src/slider-vctrs-private.c e42b641f3453229fdc8080cbeb0d0f97 *src/slider-vctrs-private.h 53844a47bf7e378f19a670150d601a85 *src/slider-vctrs-public.c 6c84b9657293512de884703afeb7f351 *src/slider-vctrs-public.h 370318fa4c31232bcebe06db7f2f17ec *src/slider-vctrs.h bc7141cb8a5ac85669975cb3d3910642 *src/slider.h 7dd31e1f676274fc6a217b09c9a95852 *src/summary-core-align.cpp b5b6a656c62fa12fa455496bd7c1a964 *src/summary-core-align.h cd542eaf25b89949022f596b7517e9c8 *src/summary-core-types.h 8d31e20a2a3d5795eeb2b9e9696f272d *src/summary-core.h d9491d063c982ecddfcad0f56984b189 *src/summary-index.c 010e3465c92fc22d71dbdb686c504272 *src/summary-slide.c 626f1690782cbb5ef03fae9c51b1bf51 *src/utils.c 5b8d884491335d7c9bdec852cf52c733 *src/utils.h 0264186f741b48b49c1a7797ac11823c *tests/testthat.R acef9c88d883bcb5496b908092e84165 *tests/testthat/_snaps/slide-index.md d160851b0cfb91ce9c4e045fd47b997d *tests/testthat/helper-date.R f422bbabfe49c8b9bb3bfee7d857c4fb *tests/testthat/helper-long-double.R 72976e4cab278491398cbff0274bfa3d *tests/testthat/helper-s3.R 7a0a0883a7e458674d938216c82de871 *tests/testthat/output/test-stop-endpoints-cannot-be-na-1.txt e127d029349a94f8e94588eb76471800 *tests/testthat/output/test-stop-endpoints-must-be-ascending-1.txt 28ef16f730457f0044a82059d794cae4 *tests/testthat/output/test-stop-generated-endpoints-cannot-be-na-1.txt 5beff90ebd9524598b898f8b2eed115e *tests/testthat/output/test-stop-index-cannot-be-na-1.txt 7eb73ba85ee4a16d297bbf996645e41d *tests/testthat/output/test-stop-index-cannot-be-na-2.txt 7ceb9ef75dfc1dfe71de93804c487045 *tests/testthat/output/test-stop-index-incompatible-size-1.txt 1507a799886c2d70c6cd864a0c76aa73 *tests/testthat/output/test-stop-index-incompatible-type-1.txt 0559b4ddb312d3077bffc9e857cd3fd3 *tests/testthat/output/test-stop-index-incompatible-type-2.txt fc54a50ac9c343e862ea89726d3ea670 *tests/testthat/output/test-stop-index-must-be-ascending-1.txt ab82bc08096ece0a660a57bae129238c *tests/testthat/test-block.R 13183dca635aefa943664103486a310d *tests/testthat/test-conditions.R 88f3a9361a2dd1ef111947c451b5ffad *tests/testthat/test-hop-index-vec.R 5993779552c62c9bf774e191f5aae4de *tests/testthat/test-hop-index.R 9f5adf17f6439ae9564802b9882b081f *tests/testthat/test-hop-index2-vec.R 9b1e2ccf5fc6ca54d46141549b43d973 *tests/testthat/test-hop-index2.R 45f34cdb6bd27e875119fc0631c5ec8c *tests/testthat/test-hop-vec.R 030ff902fa4e2fa7a8593db833072fd6 *tests/testthat/test-hop.R af3a6b0ed9dcbf75a73cf2d9a93e5715 *tests/testthat/test-hop2-vec.R 27bae5d1fd044ee46cb911ffcf7f5d95 *tests/testthat/test-hop2.R c05385c68179d68ac277b3416c675e28 *tests/testthat/test-phop-index-vec.R c0b5ce51b5a3d47df18252fd07b47d82 *tests/testthat/test-phop-index.R ed623f8cd47cc8a1e9cb0f27fc9c5d26 *tests/testthat/test-phop-vec.R 6347c446438009f9cf24f6bb503ef738 *tests/testthat/test-phop.R 888225d714d47f3b88e8b908aa92015d *tests/testthat/test-pslide-index-vec.R 1d66f7ca961b59f41cc127f422d23c92 *tests/testthat/test-pslide-index.R 81d6fb33268ae7812e812638f6bc46d9 *tests/testthat/test-pslide-period-vec.R ff0e6ec6afae46ad5c1246c16e5a3d60 *tests/testthat/test-pslide-period.R 45db3a7603c2f6325d72fc11987686b5 *tests/testthat/test-pslide-vec.R 64d81049e651dc8c52476b969db7211c *tests/testthat/test-pslide.R 089ff3b34235419f348e0eb713e8e30f *tests/testthat/test-slide-index-vec.R 43751df3711a8d8f791e85f03ea4e3b0 *tests/testthat/test-slide-index.R 2d1b7a2095849f8ad49193278111be4a *tests/testthat/test-slide-index2-vec.R abad5b78b8a0d5782d6d524ec8a4af3c *tests/testthat/test-slide-index2.R 8ea161800ce2c6d09921e4b09120ad01 *tests/testthat/test-slide-period-vec.R 9bd5c756b17033db36758e122d715691 *tests/testthat/test-slide-period.R 5c5aebf75740f52038c4d24b867d9d0d *tests/testthat/test-slide-period2-vec.R fadf782b3929d497944d810e20a24d35 *tests/testthat/test-slide-period2.R f36fbc6deba5202f97c014a35f195a18 *tests/testthat/test-slide-vec.R 2462ff024fec4e0f363457af81352429 *tests/testthat/test-slide.R faa5c4d41767f4e06196e2b0f0a7e77b *tests/testthat/test-slide2-vec.R 2357225f062406180a829eb810291c00 *tests/testthat/test-slide2.R 5241b55279ef5232fb2f754872c28699 *tests/testthat/test-summary-index.R 669b9a78a2f19b1f2315d7ca6a67600c *tests/testthat/test-summary-slide.R a064d5864bc34bc4d428af5427b14f2f *tests/testthat/test-utils.R 65d9e31b74708f2f7df4cd26194866bc *vignettes/rowwise.Rmd 3f4d5c3cb728cff355f27932d4663c3a *vignettes/slider.Rmd 33144b0df31528d9abcfca259fd68aa6 *vignettes/tsibble.Rmd slider/inst/0000755000176200001440000000000014067413470012517 5ustar liggesusersslider/inst/doc/0000755000176200001440000000000014067413470013264 5ustar liggesusersslider/inst/doc/tsibble.Rmd0000644000176200001440000001301714024427556015361 0ustar liggesusers--- title: "Converting from tsibble" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Converting from tsibble} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) # Turn off all evaluation! knitr::opts_chunk$set(eval = FALSE) ``` The [tsibble](https://tsibble.tidyverts.org/) package is where the name `slide()` originated. It contained original implementations of `slide()` and friends, along with variations like `tile()` and `stretch()`, all of which have been superceded by slider. As of tsibble 1.0.0, those functions have been completely removed in favor of using slider. The goal of this vignette is to explain how to transition from tsibble to slider. ## slide() tsibble's `.size` and `.align` arguments are roughly equivalent to using `.before` and `.after` in slider. In tsibble, you'd specify the full width of the window with `.size`, and then you'd specify how to construct that window by `.align`ing yourself to the left, right, or center. In slider, you always start at the "current" element, and then specify how many elements `.before` and `.after` the current element that you want in the window. The width of the window in slider terms could be computed as `.after - .before + 1`. ```{r} x <- 1:3 # The current element, and 1 before it slider::slide(x, identity, .before = 1, .complete = TRUE) #> [[1]] #> NULL #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 2 3 ``` ```{r} # Window size of 2, assume the current element is the right side of the window tsibble::slide(x, identity, .size = 2, .align = "right") #> [[1]] #> [1] NA #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 2 3 ``` We also have to set the `.complete` argument of slider's `slide()` to `TRUE`, as by default slider allows partial windows, but tsibble's version does not. The equivalent argument to this in tsibble is `.partial` (note that they are interpreted inversely of each other). There is no `.fill` equivalent in slider. slider always uses the vctrs definition of a missing value (a typed `NA` for most vectors, a `NULL` for lists). This is why the slider result above has a `NULL`, while the tsibble result used an `NA` (the default `.fill` value in tsibble). Specifying windows using `.before` and `.after` might first feel a bit unnatural to a tsibble or zoo user, but it is generally more flexible. You can generate irregular windows that aren't possible with tsibble, like: ```{r} # The current element, along with 1 before and 3 after (if they exist) slider::slide(1:6, identity, .before = 1, .after = 3) #> [[1]] #> [1] 1 2 3 4 #> #> [[2]] #> [1] 1 2 3 4 5 #> #> [[3]] #> [1] 2 3 4 5 6 #> #> [[4]] #> [1] 3 4 5 6 #> #> [[5]] #> [1] 4 5 6 #> #> [[6]] #> [1] 5 6 ``` As you will see in the next section, expanding windows are easy to create by setting `.before` or `.after` to `Inf`. This syntax also translates naturally to `slide_index()`, where the bounds of the window are (by default) computed as `.i - .before` and `.i + .after`, which often cannot be expressed by a single window size value. ## tile() Tiling uses non-overlapping windows. For example, this segments `x` into 4 non-overlapping buckets, where as many buckets as possible have a window size of 3. ```{r} x <- 1:10 tsibble::tile(x, identity, .size = 3) #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> [1] 4 5 6 #> #> [[3]] #> [1] 7 8 9 #> #> [[4]] #> [1] 10 ``` There is no direct equivalent to this in slider, but you can get close with `slide()`. `tile()` seems to left-align the index, so we need the current element plus two `.after` it. Since this is a non-overlapping window, we want to `.step` forward by the size of the window, three. ```{r} result <- slider::slide(x, identity, .after = 2, .step = 3) result #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> NULL #> #> [[3]] #> NULL #> #> [[4]] #> [1] 4 5 6 #> #> [[5]] #> NULL #> #> [[6]] #> NULL #> #> [[7]] #> [1] 7 8 9 #> #> [[8]] #> NULL #> #> [[9]] #> NULL #> #> [[10]] #> [1] 10 ``` This isn't exactly the same, as `slide()` is guaranteed to be size-stable, returning an object with the same size as `.x`. However, if you `purrr::compact()` the result to drop the `NULL` values, then they are equivalent. ```{r} purrr::compact(result) #> [[1]] #> [1] 1 2 3 #> #> [[2]] #> [1] 4 5 6 #> #> [[3]] #> [1] 7 8 9 #> #> [[4]] #> [1] 10 ``` ## stretch() To construct expanding windows with tsibble, you've probably used `stretch()`. This fixes an initial window size, and then expands to add more observations without dropping any. ```{r} x <- 1:4 tsibble::stretch(x, identity) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` With slider, you can set `.before = Inf` to select the current element plus all elements before this one. ```{r} slider::slide(x, identity, .before = Inf) #> [[1]] #> [1] 1 #> #> [[2]] #> [1] 1 2 #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` `stretch()` allows you to set `.init` to fix an initial minimum window size: ```{r} tsibble::stretch(x, identity, .init = 3) #> [[1]] #> [1] NA #> #> [[2]] #> [1] NA #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` There isn't a direct equivalent of this in slider, but your function could return `NULL` if the current window size didn't hold enough elements: ```{r} identity3 <- function(x) { if (length(x) < 3) { NULL } else { x } } slider::slide(x, identity3, .before = Inf) #> [[1]] #> NULL #> #> [[2]] #> NULL #> #> [[3]] #> [1] 1 2 3 #> #> [[4]] #> [1] 1 2 3 4 ``` slider/inst/doc/rowwise.Rmd0000644000176200001440000001461213716771323015437 0ustar liggesusers--- title: "Row-wise iteration with slider" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Row-wise iteration with slider} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(slider) library(dplyr, warn.conflicts = FALSE) ``` slider is implemented with a new convention that began in vctrs, treating a data frame as a vector of rows. This makes `slide()` a _row-wise iterator_ over a data frame, which can be useful for solving some previously tricky problems in the tidyverse. The point of this vignette is to go through a few examples of a row-oriented workflow. The examples are adapted from [Jenny Bryan's talk of row-oriented workflows with purrr](https://github.com/jennybc/row-oriented-workflows), to show how this workflow is improved with `slide()`. ## Row-wise iteration Let's first explore using `slide()` as a row wise iterator in general. We'll start with this simple data frame. ```{r} example <- tibble( x = 1:4, y = letters[1:4] ) example ``` If we were to pass the `x` column to `slide()`, it would iterate over that using the window specified by `.before`, `.after`, and `.complete`. The defaults are similar to `purrr::map()`. ```{r} slide(example$x, ~.x) slide(example$x, ~.x, .before = 2) ``` When applied to the entire `example` data frame, `map()` treats it as a list and iterates over the columns. `slide()`, on the other hand, iterates over rows. This is consistent with the vctrs idea of _size_, which is the length of an atomic vector, but the number of rows of a data frame or matrix. `slide()` always returns an object with the same _size_ as its input. Because the number of rows in `example` is 4, the output size is 4 and you get one row per element in the output. ```{r} slide(example, ~.x) ``` You can still use the other arguments to `slide()` to control the window size. ```{r} # Current row + 2 before slide(example, ~.x, .before = 2) # Center aligned, with no partial results slide(example, ~.x, .before = 1, .after = 1, .complete = TRUE) ``` Often, using `slide()` with its defaults will be enough, as it is common to iterate over just one row at a time. ## Varying parameter combinations A nice use of a tibble is as a structured way to store parameter combinations. For example, we could store multiple rows of parameter combinations where each row could be supplied to `runif()` to generate different types of uniform random variables. ```{r} parameters <- tibble( n = 1:3, min = c(0, 10, 100), max = c(1, 100, 1000) ) parameters ``` With `slide()` you can pass these parameters on to `runif()` by iterating over `parameters` row-wise. This gives you access to the data frame of the current row through `.x`. Because it is a data frame, you have access to each column by name. Notice how there is no restriction that the columns of the data frame be the same as the argument names of `runif()`. ```{r} set.seed(123) slide(parameters, ~runif(.x$n, .x$min, .x$max)) ``` This can also be done with `purrr::pmap()`, but you either have to name the `parameters` tibble with the same column names as the function you are calling, or you have to access each column positionally as `..1`, `..3`, etc. A third alternative that works nicely here is to use `rowwise()` before calling `mutate()`. Just remember to wrap the result of `runif()` in a `list()`! ```{r} parameters %>% rowwise() %>% mutate(random = list(runif(n, min, max))) ``` ## Sliding inside a mutate() For these examples, we will consider a `company` data set containing the `day` a sale was made, the number of calls, `n_calls`, that were placed on that day, and the number of `sales` that resulted from those calls. ```{r} company <- tibble( day = rep(c(1, 2), each = 5), sales = sample(100, 10), n_calls = sales + sample(1000, 10) ) company ``` When `slide()`-ing inside of a `mutate()` call, there are a few scenarios that can arise. First, you might want to slide over a single column. This is easy enough in both the un-grouped and grouped case. ```{r} company %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) company %>% group_by(day) %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) ``` If you need to apply a sliding function that takes a data frame as input to slide over, then you'll need some way to access the "current" data frame that `mutate()` is acting on. As of dplyr 1.0.0, you can access this with `cur_data()`. When there is only 1 group, the current data frame is the input itself, but when there are multiple groups `cur_data()` returns the data frame corresponding to the current group that is being worked on. As an example, imagine you want to fit a rolling linear model predicting sales from the number of calls. The most robust way to do this in a `mutate()` is to use `cur_data()` to access the data frame to slide over. Since `slide()` iterates row-wise, `.x` corresponds to the current slice of the current data frame. ```{r} company %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` When you group by `day`, `cur_data()` will first correspond to all rows where `day == 1`, and then where `day == 2`. Notice how the output has two clumps of `NULL`s, proving that the rolling regressions "restarted" between groups. ```{r} company %>% group_by(day) %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` In the past, you might have used `.` in place of `cur_data()`. This `.` is actually from the magrittr `%>%`, not from dplyr, and has a few issues. The biggest one is that it won't work with grouped data frames, it will always return the entire data set rather than the current group's data frame. The other issue is that, even with un-grouped data frames, you can't take advantage of the sequential nature of how `mutate()` evaluates expressions. For example, the following doesn't work because `.` corresponds to `company` without the updated `log_sales` column. ```{r, error=TRUE} company %>% mutate( log_sales = log10(sales), regressions = slide( .x = ., .f = ~lm(log_sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ``` slider/inst/doc/rowwise.html0000644000176200001440000015116314067413467015666 0ustar liggesusers Row-wise iteration with slider

Row-wise iteration with slider

library(slider)
library(dplyr, warn.conflicts = FALSE)

slider is implemented with a new convention that began in vctrs, treating a data frame as a vector of rows. This makes slide() a row-wise iterator over a data frame, which can be useful for solving some previously tricky problems in the tidyverse.

The point of this vignette is to go through a few examples of a row-oriented workflow. The examples are adapted from Jenny Bryan’s talk of row-oriented workflows with purrr, to show how this workflow is improved with slide().

Row-wise iteration

Let’s first explore using slide() as a row wise iterator in general. We’ll start with this simple data frame.

example <- tibble(
  x = 1:4,
  y = letters[1:4]
)

example
#> # A tibble: 4 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 2     2 b    
#> 3     3 c    
#> 4     4 d

If we were to pass the x column to slide(), it would iterate over that using the window specified by .before, .after, and .complete. The defaults are similar to purrr::map().

slide(example$x, ~.x)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 2
#> 
#> [[3]]
#> [1] 3
#> 
#> [[4]]
#> [1] 4

slide(example$x, ~.x, .before = 2)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 2 3 4

When applied to the entire example data frame, map() treats it as a list and iterates over the columns. slide(), on the other hand, iterates over rows. This is consistent with the vctrs idea of size, which is the length of an atomic vector, but the number of rows of a data frame or matrix. slide() always returns an object with the same size as its input. Because the number of rows in example is 4, the output size is 4 and you get one row per element in the output.

slide(example, ~.x)
#> [[1]]
#> # A tibble: 1 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 
#> [[2]]
#> # A tibble: 1 x 2
#>       x y    
#>   <int> <chr>
#> 1     2 b    
#> 
#> [[3]]
#> # A tibble: 1 x 2
#>       x y    
#>   <int> <chr>
#> 1     3 c    
#> 
#> [[4]]
#> # A tibble: 1 x 2
#>       x y    
#>   <int> <chr>
#> 1     4 d

You can still use the other arguments to slide() to control the window size.

# Current row + 2 before
slide(example, ~.x, .before = 2)
#> [[1]]
#> # A tibble: 1 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 
#> [[2]]
#> # A tibble: 2 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 2     2 b    
#> 
#> [[3]]
#> # A tibble: 3 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 2     2 b    
#> 3     3 c    
#> 
#> [[4]]
#> # A tibble: 3 x 2
#>       x y    
#>   <int> <chr>
#> 1     2 b    
#> 2     3 c    
#> 3     4 d

# Center aligned, with no partial results
slide(example, ~.x, .before = 1, .after = 1, .complete = TRUE)
#> [[1]]
#> NULL
#> 
#> [[2]]
#> # A tibble: 3 x 2
#>       x y    
#>   <int> <chr>
#> 1     1 a    
#> 2     2 b    
#> 3     3 c    
#> 
#> [[3]]
#> # A tibble: 3 x 2
#>       x y    
#>   <int> <chr>
#> 1     2 b    
#> 2     3 c    
#> 3     4 d    
#> 
#> [[4]]
#> NULL

Often, using slide() with its defaults will be enough, as it is common to iterate over just one row at a time.

Varying parameter combinations

A nice use of a tibble is as a structured way to store parameter combinations. For example, we could store multiple rows of parameter combinations where each row could be supplied to runif() to generate different types of uniform random variables.

parameters <- tibble(
  n = 1:3,
  min = c(0, 10, 100),
  max = c(1, 100, 1000)
)

parameters
#> # A tibble: 3 x 3
#>       n   min   max
#>   <int> <dbl> <dbl>
#> 1     1     0     1
#> 2     2    10   100
#> 3     3   100  1000

With slide() you can pass these parameters on to runif() by iterating over parameters row-wise. This gives you access to the data frame of the current row through .x. Because it is a data frame, you have access to each column by name. Notice how there is no restriction that the columns of the data frame be the same as the argument names of runif().

set.seed(123)

slide(parameters, ~runif(.x$n, .x$min, .x$max))
#> [[1]]
#> [1] 0.2875775
#> 
#> [[2]]
#> [1] 80.94746 46.80792
#> 
#> [[3]]
#> [1] 894.7157 946.4206 141.0008

This can also be done with purrr::pmap(), but you either have to name the parameters tibble with the same column names as the function you are calling, or you have to access each column positionally as ..1, ..3, etc.

A third alternative that works nicely here is to use rowwise() before calling mutate(). Just remember to wrap the result of runif() in a list()!

parameters %>%
  rowwise() %>%
  mutate(random = list(runif(n, min, max)))
#> # A tibble: 3 x 4
#> # Rowwise: 
#>       n   min   max random   
#>   <int> <dbl> <dbl> <list>   
#> 1     1     0     1 <dbl [1]>
#> 2     2    10   100 <dbl [2]>
#> 3     3   100  1000 <dbl [3]>

Sliding inside a mutate()

For these examples, we will consider a company data set containing the day a sale was made, the number of calls, n_calls, that were placed on that day, and the number of sales that resulted from those calls.

company <- tibble(
  day = rep(c(1, 2), each = 5),
  sales = sample(100, 10),
  n_calls = sales + sample(1000, 10)
)

company
#> # A tibble: 10 x 3
#>      day sales n_calls
#>    <dbl> <int>   <int>
#>  1     1    25     544
#>  2     1    90     516
#>  3     1    91     740
#>  4     1    69     835
#>  5     1    98     309
#>  6     2    57     989
#>  7     2    92     682
#>  8     2     9     602
#>  9     2    72     627
#> 10     2    26     897

When slide()-ing inside of a mutate() call, there are a few scenarios that can arise. First, you might want to slide over a single column. This is easy enough in both the un-grouped and grouped case.

company %>%
  mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE))
#> # A tibble: 10 x 4
#>      day sales n_calls sales_roll
#>    <dbl> <int>   <int>      <dbl>
#>  1     1    25     544       NA  
#>  2     1    90     516       NA  
#>  3     1    91     740       68.7
#>  4     1    69     835       83.3
#>  5     1    98     309       86  
#>  6     2    57     989       74.7
#>  7     2    92     682       82.3
#>  8     2     9     602       52.7
#>  9     2    72     627       57.7
#> 10     2    26     897       35.7

company %>%
  group_by(day) %>%
  mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE))
#> # A tibble: 10 x 4
#> # Groups:   day [2]
#>      day sales n_calls sales_roll
#>    <dbl> <int>   <int>      <dbl>
#>  1     1    25     544       NA  
#>  2     1    90     516       NA  
#>  3     1    91     740       68.7
#>  4     1    69     835       83.3
#>  5     1    98     309       86  
#>  6     2    57     989       NA  
#>  7     2    92     682       NA  
#>  8     2     9     602       52.7
#>  9     2    72     627       57.7
#> 10     2    26     897       35.7

If you need to apply a sliding function that takes a data frame as input to slide over, then you’ll need some way to access the “current” data frame that mutate() is acting on. As of dplyr 1.0.0, you can access this with cur_data(). When there is only 1 group, the current data frame is the input itself, but when there are multiple groups cur_data() returns the data frame corresponding to the current group that is being worked on.

As an example, imagine you want to fit a rolling linear model predicting sales from the number of calls. The most robust way to do this in a mutate() is to use cur_data() to access the data frame to slide over. Since slide() iterates row-wise, .x corresponds to the current slice of the current data frame.

company %>%
  mutate(
    regressions = slide(
      .x = cur_data(),
      .f = ~lm(sales ~ n_calls, .x), 
      .before = 2, 
      .complete = TRUE
    )
  )
#> # A tibble: 10 x 4
#>      day sales n_calls regressions
#>    <dbl> <int>   <int> <list>     
#>  1     1    25     544 <NULL>     
#>  2     1    90     516 <NULL>     
#>  3     1    91     740 <lm>       
#>  4     1    69     835 <lm>       
#>  5     1    98     309 <lm>       
#>  6     2    57     989 <lm>       
#>  7     2    92     682 <lm>       
#>  8     2     9     602 <lm>       
#>  9     2    72     627 <lm>       
#> 10     2    26     897 <lm>

When you group by day, cur_data() will first correspond to all rows where day == 1, and then where day == 2. Notice how the output has two clumps of NULLs, proving that the rolling regressions “restarted” between groups.

company %>%
  group_by(day) %>%
  mutate(
    regressions = slide(
      .x = cur_data(),
      .f = ~lm(sales ~ n_calls, .x), 
      .before = 2, 
      .complete = TRUE
    )
  )
#> # A tibble: 10 x 4
#> # Groups:   day [2]
#>      day sales n_calls regressions
#>    <dbl> <int>   <int> <list>     
#>  1     1    25     544 <NULL>     
#>  2     1    90     516 <NULL>     
#>  3     1    91     740 <lm>       
#>  4     1    69     835 <lm>       
#>  5     1    98     309 <lm>       
#>  6     2    57     989 <NULL>     
#>  7     2    92     682 <NULL>     
#>  8     2     9     602 <lm>       
#>  9     2    72     627 <lm>       
#> 10     2    26     897 <lm>

In the past, you might have used . in place of cur_data(). This . is actually from the magrittr %>%, not from dplyr, and has a few issues. The biggest one is that it won’t work with grouped data frames, it will always return the entire data set rather than the current group’s data frame. The other issue is that, even with un-grouped data frames, you can’t take advantage of the sequential nature of how mutate() evaluates expressions. For example, the following doesn’t work because . corresponds to company without the updated log_sales column.

company %>%
  mutate(
    log_sales = log10(sales),
    regressions = slide(
      .x = .,
      .f = ~lm(log_sales ~ n_calls, .x), 
      .before = 2, 
      .complete = TRUE
    )
  )
#> Error: Problem with `mutate()` column `regressions`.
#> ℹ `regressions = slide(...)`.
#> x variable lengths differ (found for 'n_calls')
slider/inst/doc/tsibble.R0000644000176200001440000000635314067413470015042 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) # Turn off all evaluation! knitr::opts_chunk$set(eval = FALSE) ## ----------------------------------------------------------------------------- # x <- 1:3 # # # The current element, and 1 before it # slider::slide(x, identity, .before = 1, .complete = TRUE) # #> [[1]] # #> NULL # #> # #> [[2]] # #> [1] 1 2 # #> # #> [[3]] # #> [1] 2 3 ## ----------------------------------------------------------------------------- # # Window size of 2, assume the current element is the right side of the window # tsibble::slide(x, identity, .size = 2, .align = "right") # #> [[1]] # #> [1] NA # #> # #> [[2]] # #> [1] 1 2 # #> # #> [[3]] # #> [1] 2 3 ## ----------------------------------------------------------------------------- # # The current element, along with 1 before and 3 after (if they exist) # slider::slide(1:6, identity, .before = 1, .after = 3) # #> [[1]] # #> [1] 1 2 3 4 # #> # #> [[2]] # #> [1] 1 2 3 4 5 # #> # #> [[3]] # #> [1] 2 3 4 5 6 # #> # #> [[4]] # #> [1] 3 4 5 6 # #> # #> [[5]] # #> [1] 4 5 6 # #> # #> [[6]] # #> [1] 5 6 ## ----------------------------------------------------------------------------- # x <- 1:10 # # tsibble::tile(x, identity, .size = 3) # #> [[1]] # #> [1] 1 2 3 # #> # #> [[2]] # #> [1] 4 5 6 # #> # #> [[3]] # #> [1] 7 8 9 # #> # #> [[4]] # #> [1] 10 ## ----------------------------------------------------------------------------- # result <- slider::slide(x, identity, .after = 2, .step = 3) # result # #> [[1]] # #> [1] 1 2 3 # #> # #> [[2]] # #> NULL # #> # #> [[3]] # #> NULL # #> # #> [[4]] # #> [1] 4 5 6 # #> # #> [[5]] # #> NULL # #> # #> [[6]] # #> NULL # #> # #> [[7]] # #> [1] 7 8 9 # #> # #> [[8]] # #> NULL # #> # #> [[9]] # #> NULL # #> # #> [[10]] # #> [1] 10 ## ----------------------------------------------------------------------------- # purrr::compact(result) # #> [[1]] # #> [1] 1 2 3 # #> # #> [[2]] # #> [1] 4 5 6 # #> # #> [[3]] # #> [1] 7 8 9 # #> # #> [[4]] # #> [1] 10 ## ----------------------------------------------------------------------------- # x <- 1:4 # # tsibble::stretch(x, identity) # #> [[1]] # #> [1] 1 # #> # #> [[2]] # #> [1] 1 2 # #> # #> [[3]] # #> [1] 1 2 3 # #> # #> [[4]] # #> [1] 1 2 3 4 ## ----------------------------------------------------------------------------- # slider::slide(x, identity, .before = Inf) # #> [[1]] # #> [1] 1 # #> # #> [[2]] # #> [1] 1 2 # #> # #> [[3]] # #> [1] 1 2 3 # #> # #> [[4]] # #> [1] 1 2 3 4 ## ----------------------------------------------------------------------------- # tsibble::stretch(x, identity, .init = 3) # #> [[1]] # #> [1] NA # #> # #> [[2]] # #> [1] NA # #> # #> [[3]] # #> [1] 1 2 3 # #> # #> [[4]] # #> [1] 1 2 3 4 ## ----------------------------------------------------------------------------- # identity3 <- function(x) { # if (length(x) < 3) { # NULL # } else { # x # } # } # # slider::slide(x, identity3, .before = Inf) # #> [[1]] # #> NULL # #> # #> [[2]] # #> NULL # #> # #> [[3]] # #> [1] 1 2 3 # #> # #> [[4]] # #> [1] 1 2 3 4 slider/inst/doc/slider.Rmd0000644000176200001440000002343414024644665015225 0ustar liggesusers--- title: "Getting started with slider" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Getting started with slider} %\VignetteEncoding{UTF-8} %\VignetteEngine{knitr::rmarkdown} editor_options: chunk_output_type: console --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(slider) library(dplyr, warn.conflicts = FALSE) library(lubridate, warn.conflicts = FALSE) ``` This vignette is meant to serve as an introduction to {slider}. In it, you'll learn about the three core functions in the package: `slide()`, `slide_index()`, and `slide_period()`, along with their many variants. slider is a package for rolling analysis using window functions. "Window functions" is a term that I've borrowed from SQL that means that some function is repeatedly applied to different "windows" of your data as you step through it. Typical examples of applications of window functions include rolling averages, cumulative sums, and more complex things such as rolling regressions. ## slide() To better understand window functions, we'll turn to our first core function, `slide()`. `slide()` is a bit like `purrr::map()`. You supply a vector to slide over, `.x`, and a function to apply to each window, `.f`. With those two things alone, `slide()` is almost identical to `map()`. ```{r} slide(1:4, ~.x) ``` On top of this, you can control the size and placement of the window by using the additional arguments to `slide()`. For example, you can ask for a window of size 3 containing "the current element, as well as the 2 before it" like this: ```{r} slide(1:4, ~.x, .before = 2) ``` You'll notice that the first two elements of the list contain partial or "incomplete" windows. By default, `slide()` assumes that you want to compute on these windows anyways, but if you don't care about them, you can change the `.complete` argument. ```{r} slide(1:4, ~.x, .before = 2, .complete = TRUE) ``` `slide()` is _size stable_, so you always get an output that is the same size as your input. Because of that, the partial results have been replaced by the corresponding missing value. For a list, that is `NULL`. Sometimes, changing the placement of the window is a critical part of your calculation. For example, you might want a "center alignment" where you have an equal number of values before and after the current element. To accomplish this, you can combine the `.before` argument with `.after` to get a centered window. Here we ask for a window of size 3 containing "the current element, as well as 1 element before and 1 element after". It is "centered" because in position 2 we have a complete window of the current element (2), along with one element before (1) and one after (3). ```{r} slide(1:4, ~.x, .before = 1, .after = 1) ``` `slide()` can also perform _expanding_ windows. These are the type that allow _cumulative_ operations to work. In prose, an expanding window would be "the current element, along with every element before this one". To construct this kind of window, you can set `.before` to `Inf`. ```{r} slide(1:4, ~.x, .before = Inf) ``` `slide()` is _type-stable_, meaning that it always returns an object of the same type, and the base form of `slide()` always returns a list. So far, this is all that we have used to illustrate how it works, but practically you are more likely to use one of the suffixed forms like `slide_dbl()` or `slide_int()`. For example, you might have a vector of sales data that you want to compute a 3 value moving average on. ```{r} sales_vec <- c(2, 4, 6, 2) slide_dbl(sales_vec, mean, .before = 2) ``` ## slide_index() To make things a bit more interesting, let's assume that the sales vector from the example above is also tied to some "index", like a date vector of when the sale actually occurred. ```{r} index_vec <- as.Date("2019-08-29") + c(0, 1, 5, 6) wday_vec <- as.character(wday(index_vec, label = TRUE)) company <- tibble( sales = sales_vec, index = index_vec, wday = wday_vec ) company ``` This index is increasing but irregular, meaning that we "jumped" from Friday to Tuesday because there were no sales between those dates. For the purpose of this example, let's assume that this is an online company where it is perfectly reasonable that you _could_ have sales on both Saturday and Sunday (If your use case requires that you "skip over" weekends and even holidays, you might like [{almanac}](https://github.com/DavisVaughan/almanac)). A reasonable business question to ask would be to compute a _3 day_ moving average. Is this different from the 3 value moving average we computed before? Here is the expected result, side by side with the 3 value one computed using `slide_dbl()` from before. ```{r, echo=FALSE} mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = 2) ) ``` The difference shows up in the third row, when computing the 3 day moving average looking back from Tuesday. To understand why they are different, consider what `slide_dbl()` does. It uses the `sales` column and looks at the "current row, along with two rows before it" to compute the result. When you are on row 3, this would select rows 1-3 giving the date range of `[Thu, Tue]`, which isn't 3 days. The correct answer would have been to look back 2 days from Tuesday, not 2 rows from row 3. This would have given us the date window of `[Sun, Tue]`, and only values in that range should be included in the moving average calculation for row 3. The only row in that range is row 3, so we should just be averaging the single value of `6` to get our result. `slide_dbl()` doesn't give us what we want because it is _unaware of the index column_. It just looks back a set number of values. What we need is a function that "knows" about the `index` and can adjust accordingly. For that, you can use `slide_index(.x, .i, .f, ...)` which has a `.i` argument to pass an index vector through. To understand how `slide_index()` works, take a look at the following comparison to `slide()`. For illustration, the current window of the weekday vector is printed out. Notice that in position 3, `slide()` gives us the "wrong" result of Thursday, Friday and Tuesday, because it just looks back 2 values. ```{r} wday_vec slide(wday_vec, ~.x, .before = 2) ``` On the other hand, `slide_index()` can be "aware" of the irregular index vector. By passing it through as `.i`, and by swapping a look back period of 2 for the lubridate object of `days(2)`, the start of the range is computed as `.i - days(2)`, which correctly computes a date window of `[Sun, Tue]` for the third element, so that we only capture Tuesday in the window. ```{r} slide_index(wday_vec, index_vec, ~.x, .before = days(2)) ``` Knowing this, we can swap out `slide_dbl()` for `slide_index_dbl()` to see how to correctly compute our 3 day rolling average. ```{r} mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = days(2)) ) ``` ## slide_period() With `slide_index()`, we always returned a vector of the same size as `.x`, and the idea was to build indices to slice `.x` with using "the current element of `.i` + some number of elements before/after it". `slide_period()` works a bit differently. It first breaks `.i` up into "time blocks" by some period (like monthly), and then uses those blocks to define how to slide over `.x`. To see an example, let's expand out our `company` sales data frame. ```{r} big_index_vec <- c( as.Date("2019-08-30") + 0:4, as.Date("2019-11-30") + 0:4 ) big_sales_vec <- c(2, 4, 6, 2, 8, 10, 9, 3, 5, 2) big_company <- tibble( sales = big_sales_vec, index = big_index_vec ) big_company ``` Now say we want to compute the monthly sales, and just return 1 value per month. Since we have 4 months, we should get 4 values back. What we really want to do here is break the `index` up into "time blocks" of 1 month, and then slide over those. That's what `slide_period()` does. ```{r} slide_period(big_company, big_company$index, "month", ~.x) ``` Since this returns 4 values, and not the same number of values as there are in `.x`, it won't fit naturally in a `mutate()` or `summarise()` statement. I find the easiest way to do this is to create a helper function that takes a data frame and returns one with the summary result for one time block, and then call that with `slide_period_dfr()`. ```{r} monthly_summary <- function(data) { summarise(data, index = max(index), sales = sum(sales)) } slide_period_dfr( big_company, big_company$index, "month", monthly_summary ) ``` Now you might be thinking, "I can do that with dplyr and lubridate!", and you'd be right: ```{r} big_company %>% mutate(monthly = floor_date(index, "month")) %>% group_by(monthly) %>% summarise(sales = sum(sales)) ``` But here is where things get interesting! Now what if we want to compute those monthly sales, but we want the time blocks to be made of the "current month block, plus 1 month block before it". For example, for the month of `2019-09`, it would include `2019-08` and `2019-09` together in the rolling summary. There isn't an easy way to do this in dplyr alone. With slider, there are two ways to do this. The first is with `slide_period_dfr()`, and it is as easy as adding `.before = 1`, to select the current month block and 1 before it. ```{r} slide_period_dfr( big_company, big_company$index, "month", monthly_summary, .before = 1 ) ``` Depending on your use case, you might want to append these results as a new column in `big_company`. To do this, we can instead go back to using `floor_date()` to generate monthly groupings, and slide over them using `slide_index_dbl()` with a lookback period of 1 month. ```{r} big_company %>% mutate( monthly = floor_date(index, "month"), sales_summary = slide_index_dbl(sales, monthly, sum, .before = months(1)) ) ``` slider/inst/doc/slider.html0000644000176200001440000015306314067413470015444 0ustar liggesusers Getting started with slider

Getting started with slider

library(slider)
library(dplyr, warn.conflicts = FALSE)
library(lubridate, warn.conflicts = FALSE)

This vignette is meant to serve as an introduction to {slider}. In it, you’ll learn about the three core functions in the package: slide(), slide_index(), and slide_period(), along with their many variants.

slider is a package for rolling analysis using window functions. “Window functions” is a term that I’ve borrowed from SQL that means that some function is repeatedly applied to different “windows” of your data as you step through it. Typical examples of applications of window functions include rolling averages, cumulative sums, and more complex things such as rolling regressions.

slide()

To better understand window functions, we’ll turn to our first core function, slide(). slide() is a bit like purrr::map(). You supply a vector to slide over, .x, and a function to apply to each window, .f. With those two things alone, slide() is almost identical to map().

slide(1:4, ~.x)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 2
#> 
#> [[3]]
#> [1] 3
#> 
#> [[4]]
#> [1] 4

On top of this, you can control the size and placement of the window by using the additional arguments to slide(). For example, you can ask for a window of size 3 containing “the current element, as well as the 2 before it” like this:

slide(1:4, ~.x, .before = 2)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 2 3 4

You’ll notice that the first two elements of the list contain partial or “incomplete” windows. By default, slide() assumes that you want to compute on these windows anyways, but if you don’t care about them, you can change the .complete argument.

slide(1:4, ~.x, .before = 2, .complete = TRUE)
#> [[1]]
#> NULL
#> 
#> [[2]]
#> NULL
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 2 3 4

slide() is size stable, so you always get an output that is the same size as your input. Because of that, the partial results have been replaced by the corresponding missing value. For a list, that is NULL.

Sometimes, changing the placement of the window is a critical part of your calculation. For example, you might want a “center alignment” where you have an equal number of values before and after the current element. To accomplish this, you can combine the .before argument with .after to get a centered window. Here we ask for a window of size 3 containing “the current element, as well as 1 element before and 1 element after”. It is “centered” because in position 2 we have a complete window of the current element (2), along with one element before (1) and one after (3).

slide(1:4, ~.x, .before = 1, .after = 1)
#> [[1]]
#> [1] 1 2
#> 
#> [[2]]
#> [1] 1 2 3
#> 
#> [[3]]
#> [1] 2 3 4
#> 
#> [[4]]
#> [1] 3 4

slide() can also perform expanding windows. These are the type that allow cumulative operations to work. In prose, an expanding window would be “the current element, along with every element before this one”. To construct this kind of window, you can set .before to Inf.

slide(1:4, ~.x, .before = Inf)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 1 2 3 4

slide() is type-stable, meaning that it always returns an object of the same type, and the base form of slide() always returns a list. So far, this is all that we have used to illustrate how it works, but practically you are more likely to use one of the suffixed forms like slide_dbl() or slide_int(). For example, you might have a vector of sales data that you want to compute a 3 value moving average on.

sales_vec <- c(2, 4, 6, 2)

slide_dbl(sales_vec, mean, .before = 2)
#> [1] 2 3 4 4

slide_index()

To make things a bit more interesting, let’s assume that the sales vector from the example above is also tied to some “index”, like a date vector of when the sale actually occurred.

index_vec <- as.Date("2019-08-29") + c(0, 1, 5, 6)
wday_vec <- as.character(wday(index_vec, label = TRUE))

company <- tibble(
  sales = sales_vec,
  index = index_vec,
  wday = wday_vec
)

company
#> # A tibble: 4 x 3
#>   sales index      wday 
#>   <dbl> <date>     <chr>
#> 1     2 2019-08-29 Thu  
#> 2     4 2019-08-30 Fri  
#> 3     6 2019-09-03 Tue  
#> 4     2 2019-09-04 Wed

This index is increasing but irregular, meaning that we “jumped” from Friday to Tuesday because there were no sales between those dates. For the purpose of this example, let’s assume that this is an online company where it is perfectly reasonable that you could have sales on both Saturday and Sunday (If your use case requires that you “skip over” weekends and even holidays, you might like {almanac}).

A reasonable business question to ask would be to compute a 3 day moving average. Is this different from the 3 value moving average we computed before? Here is the expected result, side by side with the 3 value one computed using slide_dbl() from before.

#> # A tibble: 4 x 5
#>   sales index      wday  roll_val roll_day
#>   <dbl> <date>     <chr>    <dbl>    <dbl>
#> 1     2 2019-08-29 Thu          2        2
#> 2     4 2019-08-30 Fri          3        3
#> 3     6 2019-09-03 Tue          4        6
#> 4     2 2019-09-04 Wed          4        4

The difference shows up in the third row, when computing the 3 day moving average looking back from Tuesday. To understand why they are different, consider what slide_dbl() does. It uses the sales column and looks at the “current row, along with two rows before it” to compute the result. When you are on row 3, this would select rows 1-3 giving the date range of [Thu, Tue], which isn’t 3 days. The correct answer would have been to look back 2 days from Tuesday, not 2 rows from row 3. This would have given us the date window of [Sun, Tue], and only values in that range should be included in the moving average calculation for row 3. The only row in that range is row 3, so we should just be averaging the single value of 6 to get our result.

slide_dbl() doesn’t give us what we want because it is unaware of the index column. It just looks back a set number of values. What we need is a function that “knows” about the index and can adjust accordingly. For that, you can use slide_index(.x, .i, .f, ...) which has a .i argument to pass an index vector through.

To understand how slide_index() works, take a look at the following comparison to slide(). For illustration, the current window of the weekday vector is printed out. Notice that in position 3, slide() gives us the “wrong” result of Thursday, Friday and Tuesday, because it just looks back 2 values.

wday_vec
#> [1] "Thu" "Fri" "Tue" "Wed"

slide(wday_vec, ~.x, .before = 2)
#> [[1]]
#> [1] "Thu"
#> 
#> [[2]]
#> [1] "Thu" "Fri"
#> 
#> [[3]]
#> [1] "Thu" "Fri" "Tue"
#> 
#> [[4]]
#> [1] "Fri" "Tue" "Wed"

On the other hand, slide_index() can be “aware” of the irregular index vector. By passing it through as .i, and by swapping a look back period of 2 for the lubridate object of days(2), the start of the range is computed as .i - days(2), which correctly computes a date window of [Sun, Tue] for the third element, so that we only capture Tuesday in the window.

slide_index(wday_vec, index_vec, ~.x, .before = days(2))
#> [[1]]
#> [1] "Thu"
#> 
#> [[2]]
#> [1] "Thu" "Fri"
#> 
#> [[3]]
#> [1] "Tue"
#> 
#> [[4]]
#> [1] "Tue" "Wed"

Knowing this, we can swap out slide_dbl() for slide_index_dbl() to see how to correctly compute our 3 day rolling average.

mutate(
  company, 
  roll_val = slide_dbl(sales, mean, .before = 2),
  roll_day = slide_index_dbl(sales, index, mean, .before = days(2))
)
#> # A tibble: 4 x 5
#>   sales index      wday  roll_val roll_day
#>   <dbl> <date>     <chr>    <dbl>    <dbl>
#> 1     2 2019-08-29 Thu          2        2
#> 2     4 2019-08-30 Fri          3        3
#> 3     6 2019-09-03 Tue          4        6
#> 4     2 2019-09-04 Wed          4        4

slide_period()

With slide_index(), we always returned a vector of the same size as .x, and the idea was to build indices to slice .x with using “the current element of .i + some number of elements before/after it”. slide_period() works a bit differently. It first breaks .i up into “time blocks” by some period (like monthly), and then uses those blocks to define how to slide over .x.

To see an example, let’s expand out our company sales data frame.

big_index_vec <- c(
  as.Date("2019-08-30") + 0:4,
  as.Date("2019-11-30") + 0:4
)

big_sales_vec <- c(2, 4, 6, 2, 8, 10, 9, 3, 5, 2)

big_company <- tibble(
  sales = big_sales_vec,
  index = big_index_vec
)

big_company
#> # A tibble: 10 x 2
#>    sales index     
#>    <dbl> <date>    
#>  1     2 2019-08-30
#>  2     4 2019-08-31
#>  3     6 2019-09-01
#>  4     2 2019-09-02
#>  5     8 2019-09-03
#>  6    10 2019-11-30
#>  7     9 2019-12-01
#>  8     3 2019-12-02
#>  9     5 2019-12-03
#> 10     2 2019-12-04

Now say we want to compute the monthly sales, and just return 1 value per month. Since we have 4 months, we should get 4 values back. What we really want to do here is break the index up into “time blocks” of 1 month, and then slide over those. That’s what slide_period() does.

slide_period(big_company, big_company$index, "month", ~.x)
#> [[1]]
#> # A tibble: 2 x 2
#>   sales index     
#>   <dbl> <date>    
#> 1     2 2019-08-30
#> 2     4 2019-08-31
#> 
#> [[2]]
#> # A tibble: 3 x 2
#>   sales index     
#>   <dbl> <date>    
#> 1     6 2019-09-01
#> 2     2 2019-09-02
#> 3     8 2019-09-03
#> 
#> [[3]]
#> # A tibble: 1 x 2
#>   sales index     
#>   <dbl> <date>    
#> 1    10 2019-11-30
#> 
#> [[4]]
#> # A tibble: 4 x 2
#>   sales index     
#>   <dbl> <date>    
#> 1     9 2019-12-01
#> 2     3 2019-12-02
#> 3     5 2019-12-03
#> 4     2 2019-12-04

Since this returns 4 values, and not the same number of values as there are in .x, it won’t fit naturally in a mutate() or summarise() statement. I find the easiest way to do this is to create a helper function that takes a data frame and returns one with the summary result for one time block, and then call that with slide_period_dfr().

monthly_summary <- function(data) {
  summarise(data, index = max(index), sales = sum(sales))
}

slide_period_dfr(
  big_company,
  big_company$index,
  "month",
  monthly_summary
)
#> # A tibble: 4 x 2
#>   index      sales
#>   <date>     <dbl>
#> 1 2019-08-31     6
#> 2 2019-09-03    16
#> 3 2019-11-30    10
#> 4 2019-12-04    19

Now you might be thinking, “I can do that with dplyr and lubridate!”, and you’d be right:

big_company %>%
  mutate(monthly = floor_date(index, "month")) %>%
  group_by(monthly) %>%
  summarise(sales = sum(sales))
#> # A tibble: 4 x 2
#>   monthly    sales
#>   <date>     <dbl>
#> 1 2019-08-01     6
#> 2 2019-09-01    16
#> 3 2019-11-01    10
#> 4 2019-12-01    19

But here is where things get interesting! Now what if we want to compute those monthly sales, but we want the time blocks to be made of the “current month block, plus 1 month block before it”. For example, for the month of 2019-09, it would include 2019-08 and 2019-09 together in the rolling summary. There isn’t an easy way to do this in dplyr alone. With slider, there are two ways to do this.

The first is with slide_period_dfr(), and it is as easy as adding .before = 1, to select the current month block and 1 before it.

slide_period_dfr(
  big_company,
  big_company$index,
  "month",
  monthly_summary,
  .before = 1
)
#> # A tibble: 4 x 2
#>   index      sales
#>   <date>     <dbl>
#> 1 2019-08-31     6
#> 2 2019-09-03    22
#> 3 2019-11-30    10
#> 4 2019-12-04    29

Depending on your use case, you might want to append these results as a new column in big_company. To do this, we can instead go back to using floor_date() to generate monthly groupings, and slide over them using slide_index_dbl() with a lookback period of 1 month.

big_company %>%
  mutate(
    monthly = floor_date(index, "month"),
    sales_summary = slide_index_dbl(sales, monthly, sum, .before = months(1))
  )
#> # A tibble: 10 x 4
#>    sales index      monthly    sales_summary
#>    <dbl> <date>     <date>             <dbl>
#>  1     2 2019-08-30 2019-08-01             6
#>  2     4 2019-08-31 2019-08-01             6
#>  3     6 2019-09-01 2019-09-01            22
#>  4     2 2019-09-02 2019-09-01            22
#>  5     8 2019-09-03 2019-09-01            22
#>  6    10 2019-11-30 2019-11-01            10
#>  7     9 2019-12-01 2019-12-01            29
#>  8     3 2019-12-02 2019-12-01            29
#>  9     5 2019-12-03 2019-12-01            29
#> 10     2 2019-12-04 2019-12-01            29
slider/inst/doc/rowwise.R0000644000176200001440000000513314067413466015115 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(slider) library(dplyr, warn.conflicts = FALSE) ## ----------------------------------------------------------------------------- example <- tibble( x = 1:4, y = letters[1:4] ) example ## ----------------------------------------------------------------------------- slide(example$x, ~.x) slide(example$x, ~.x, .before = 2) ## ----------------------------------------------------------------------------- slide(example, ~.x) ## ----------------------------------------------------------------------------- # Current row + 2 before slide(example, ~.x, .before = 2) # Center aligned, with no partial results slide(example, ~.x, .before = 1, .after = 1, .complete = TRUE) ## ----------------------------------------------------------------------------- parameters <- tibble( n = 1:3, min = c(0, 10, 100), max = c(1, 100, 1000) ) parameters ## ----------------------------------------------------------------------------- set.seed(123) slide(parameters, ~runif(.x$n, .x$min, .x$max)) ## ----------------------------------------------------------------------------- parameters %>% rowwise() %>% mutate(random = list(runif(n, min, max))) ## ----------------------------------------------------------------------------- company <- tibble( day = rep(c(1, 2), each = 5), sales = sample(100, 10), n_calls = sales + sample(1000, 10) ) company ## ----------------------------------------------------------------------------- company %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) company %>% group_by(day) %>% mutate(sales_roll = slide_dbl(sales, mean, .before = 2, .complete = TRUE)) ## ----------------------------------------------------------------------------- company %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ## ----------------------------------------------------------------------------- company %>% group_by(day) %>% mutate( regressions = slide( .x = cur_data(), .f = ~lm(sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) ## ---- error=TRUE-------------------------------------------------------------- company %>% mutate( log_sales = log10(sales), regressions = slide( .x = ., .f = ~lm(log_sales ~ n_calls, .x), .before = 2, .complete = TRUE ) ) slider/inst/doc/slider.R0000644000176200001440000000643614067413467014710 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(slider) library(dplyr, warn.conflicts = FALSE) library(lubridate, warn.conflicts = FALSE) ## ----------------------------------------------------------------------------- slide(1:4, ~.x) ## ----------------------------------------------------------------------------- slide(1:4, ~.x, .before = 2) ## ----------------------------------------------------------------------------- slide(1:4, ~.x, .before = 2, .complete = TRUE) ## ----------------------------------------------------------------------------- slide(1:4, ~.x, .before = 1, .after = 1) ## ----------------------------------------------------------------------------- slide(1:4, ~.x, .before = Inf) ## ----------------------------------------------------------------------------- sales_vec <- c(2, 4, 6, 2) slide_dbl(sales_vec, mean, .before = 2) ## ----------------------------------------------------------------------------- index_vec <- as.Date("2019-08-29") + c(0, 1, 5, 6) wday_vec <- as.character(wday(index_vec, label = TRUE)) company <- tibble( sales = sales_vec, index = index_vec, wday = wday_vec ) company ## ---- echo=FALSE-------------------------------------------------------------- mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = 2) ) ## ----------------------------------------------------------------------------- wday_vec slide(wday_vec, ~.x, .before = 2) ## ----------------------------------------------------------------------------- slide_index(wday_vec, index_vec, ~.x, .before = days(2)) ## ----------------------------------------------------------------------------- mutate( company, roll_val = slide_dbl(sales, mean, .before = 2), roll_day = slide_index_dbl(sales, index, mean, .before = days(2)) ) ## ----------------------------------------------------------------------------- big_index_vec <- c( as.Date("2019-08-30") + 0:4, as.Date("2019-11-30") + 0:4 ) big_sales_vec <- c(2, 4, 6, 2, 8, 10, 9, 3, 5, 2) big_company <- tibble( sales = big_sales_vec, index = big_index_vec ) big_company ## ----------------------------------------------------------------------------- slide_period(big_company, big_company$index, "month", ~.x) ## ----------------------------------------------------------------------------- monthly_summary <- function(data) { summarise(data, index = max(index), sales = sum(sales)) } slide_period_dfr( big_company, big_company$index, "month", monthly_summary ) ## ----------------------------------------------------------------------------- big_company %>% mutate(monthly = floor_date(index, "month")) %>% group_by(monthly) %>% summarise(sales = sum(sales)) ## ----------------------------------------------------------------------------- slide_period_dfr( big_company, big_company$index, "month", monthly_summary, .before = 1 ) ## ----------------------------------------------------------------------------- big_company %>% mutate( monthly = floor_date(index, "month"), sales_summary = slide_index_dbl(sales, monthly, sum, .before = months(1)) ) slider/inst/doc/tsibble.html0000644000176200001440000010521014067413470015575 0ustar liggesusers Converting from tsibble

Converting from tsibble

The tsibble package is where the name slide() originated. It contained original implementations of slide() and friends, along with variations like tile() and stretch(), all of which have been superceded by slider. As of tsibble 1.0.0, those functions have been completely removed in favor of using slider. The goal of this vignette is to explain how to transition from tsibble to slider.

slide()

tsibble’s .size and .align arguments are roughly equivalent to using .before and .after in slider. In tsibble, you’d specify the full width of the window with .size, and then you’d specify how to construct that window by .aligning yourself to the left, right, or center. In slider, you always start at the “current” element, and then specify how many elements .before and .after the current element that you want in the window. The width of the window in slider terms could be computed as .after - .before + 1.

x <- 1:3

# The current element, and 1 before it
slider::slide(x, identity, .before = 1, .complete = TRUE)
#> [[1]]
#> NULL
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 2 3
# Window size of 2, assume the current element is the right side of the window
tsibble::slide(x, identity, .size = 2, .align = "right")
#> [[1]]
#> [1] NA
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 2 3

We also have to set the .complete argument of slider’s slide() to TRUE, as by default slider allows partial windows, but tsibble’s version does not. The equivalent argument to this in tsibble is .partial (note that they are interpreted inversely of each other).

There is no .fill equivalent in slider. slider always uses the vctrs definition of a missing value (a typed NA for most vectors, a NULL for lists). This is why the slider result above has a NULL, while the tsibble result used an NA (the default .fill value in tsibble).

Specifying windows using .before and .after might first feel a bit unnatural to a tsibble or zoo user, but it is generally more flexible. You can generate irregular windows that aren’t possible with tsibble, like:

# The current element, along with 1 before and 3 after (if they exist)
slider::slide(1:6, identity, .before = 1, .after = 3)
#> [[1]]
#> [1] 1 2 3 4
#> 
#> [[2]]
#> [1] 1 2 3 4 5
#> 
#> [[3]]
#> [1] 2 3 4 5 6
#> 
#> [[4]]
#> [1] 3 4 5 6
#> 
#> [[5]]
#> [1] 4 5 6
#> 
#> [[6]]
#> [1] 5 6

As you will see in the next section, expanding windows are easy to create by setting .before or .after to Inf.

This syntax also translates naturally to slide_index(), where the bounds of the window are (by default) computed as .i - .before and .i + .after, which often cannot be expressed by a single window size value.

tile()

Tiling uses non-overlapping windows. For example, this segments x into 4 non-overlapping buckets, where as many buckets as possible have a window size of 3.

x <- 1:10

tsibble::tile(x, identity, .size = 3)
#> [[1]]
#> [1] 1 2 3
#> 
#> [[2]]
#> [1] 4 5 6
#> 
#> [[3]]
#> [1] 7 8 9
#> 
#> [[4]]
#> [1] 10

There is no direct equivalent to this in slider, but you can get close with slide(). tile() seems to left-align the index, so we need the current element plus two .after it. Since this is a non-overlapping window, we want to .step forward by the size of the window, three.

result <- slider::slide(x, identity, .after = 2, .step = 3)
result
#> [[1]]
#> [1] 1 2 3
#> 
#> [[2]]
#> NULL
#> 
#> [[3]]
#> NULL
#> 
#> [[4]]
#> [1] 4 5 6
#> 
#> [[5]]
#> NULL
#> 
#> [[6]]
#> NULL
#> 
#> [[7]]
#> [1] 7 8 9
#> 
#> [[8]]
#> NULL
#> 
#> [[9]]
#> NULL
#> 
#> [[10]]
#> [1] 10

This isn’t exactly the same, as slide() is guaranteed to be size-stable, returning an object with the same size as .x. However, if you purrr::compact() the result to drop the NULL values, then they are equivalent.

purrr::compact(result)
#> [[1]]
#> [1] 1 2 3
#> 
#> [[2]]
#> [1] 4 5 6
#> 
#> [[3]]
#> [1] 7 8 9
#> 
#> [[4]]
#> [1] 10

stretch()

To construct expanding windows with tsibble, you’ve probably used stretch(). This fixes an initial window size, and then expands to add more observations without dropping any.

x <- 1:4

tsibble::stretch(x, identity)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 1 2 3 4

With slider, you can set .before = Inf to select the current element plus all elements before this one.

slider::slide(x, identity, .before = Inf)
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 1 2
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 1 2 3 4

stretch() allows you to set .init to fix an initial minimum window size:

tsibble::stretch(x, identity, .init = 3)
#> [[1]]
#> [1] NA
#> 
#> [[2]]
#> [1] NA
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 1 2 3 4

There isn’t a direct equivalent of this in slider, but your function could return NULL if the current window size didn’t hold enough elements:

identity3 <- function(x) {
  if (length(x) < 3) {
    NULL
  } else {
    x
  }
}

slider::slide(x, identity3, .before = Inf)
#> [[1]]
#> NULL
#> 
#> [[2]]
#> NULL
#> 
#> [[3]]
#> [1] 1 2 3
#> 
#> [[4]]
#> [1] 1 2 3 4