├── air.toml ├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ ├── format-suggest.yaml │ ├── test-coverage.yaml │ ├── R-CMD-check.yaml │ ├── rhub.yaml │ └── pr-commands.yaml ├── revdep ├── README.md ├── failures.md ├── problems.md ├── .gitignore ├── email.yml └── cran.md ├── src ├── .gitignore ├── slider-vctrs-public.c ├── slider-vctrs.h ├── summary-core-types.h ├── slider-vctrs-public.h ├── summary-core-align.h ├── slider.h ├── slider-vctrs-private.h ├── summary-core-align.cpp ├── block.c ├── params.h ├── slider-vctrs-private.c ├── align.h ├── segment-tree.h ├── slide-period.c ├── index.h ├── utils.h ├── opts-slide.h ├── init.c ├── assign.h └── hop.c ├── vignettes └── .gitignore ├── LICENSE ├── cran-comments.md ├── tests ├── testthat.R └── testthat │ ├── helper-date.R │ ├── helper-long-double.R │ ├── _snaps │ ├── slide-index2.md │ ├── pslide-index.md │ ├── pslide-period.md │ ├── slide-period2.md │ ├── slide2.md │ ├── phop-index.md │ ├── phop.md │ ├── pslide.md │ ├── hop2-vec.md │ ├── slide2-vec.md │ ├── pslide-index-vec.md │ ├── slide-index2-vec.md │ ├── pslide-vec.md │ ├── hop-index2-vec.md │ ├── phop-index-vec.md │ ├── phop-vec.md │ ├── hop-index2.md │ ├── summary-slide.md │ ├── block.md │ ├── summary-index.md │ ├── hop-vec.md │ ├── conditions.md │ ├── hop-index-vec.md │ ├── slide-vec.md │ ├── slide-index-vec.md │ ├── pslide-period-vec.md │ ├── slide-period-vec.md │ ├── slide-period2-vec.md │ ├── slide.md │ ├── hop.md │ └── hop-index.md │ ├── test-utils.R │ ├── helper-s3.R │ ├── test-slide-index2.R │ ├── test-slide2.R │ ├── test-pslide-period.R │ ├── test-hop2.R │ ├── test-pslide-index.R │ ├── test-slide-period2.R │ ├── test-block.R │ ├── test-phop-index.R │ ├── test-hop-index2.R │ ├── test-pslide.R │ ├── test-hop2-vec.R │ ├── test-phop.R │ ├── test-phop-vec.R │ ├── test-conditions.R │ ├── test-hop-index2-vec.R │ ├── test-arithmetic.R │ ├── test-hop-vec.R │ ├── test-phop-index-vec.R │ └── test-hop.R ├── .vscode ├── extensions.json └── settings.json ├── .gitignore ├── R ├── segment-tree.R ├── slide-common.R ├── zzz.R ├── slider-package.R ├── hop-common.R ├── phop.R ├── phop-index.R ├── hop-index-common.R ├── block.R ├── hop2.R ├── hop-index2.R ├── hop.R ├── utils.R ├── slide-period-common.R ├── arithmetic.R └── hop-index.R ├── man-roxygen ├── param-x-y.R ├── param-l.R ├── param-starts-stops-hop.R ├── param-before-after-slide.R ├── param-starts-stops-hop-index.R └── param-before-after-slide-index.R ├── codecov.yml ├── .Rbuildignore ├── slider.Rproj ├── man ├── slider-package.Rd ├── index-arithmetic.Rd ├── block.Rd ├── hop2.Rd └── hop.Rd ├── LICENSE.md ├── DESCRIPTION ├── _pkgdown.yml └── NAMESPACE /air.toml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Revdeps 2 | 3 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /revdep/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2025 2 | COPYRIGHT HOLDER: slider authors 3 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | There are no known problems with this release. 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(slider) 3 | 4 | test_check("slider") 5 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": [ 3 | "Posit.air-vscode" 4 | ] 5 | } 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | docs 5 | inst/doc 6 | compile_commands.json 7 | .cache 8 | -------------------------------------------------------------------------------- /tests/testthat/helper-date.R: -------------------------------------------------------------------------------- 1 | new_date <- function(x = double()) { 2 | vctrs::new_date(as.double(x)) 3 | } 4 | -------------------------------------------------------------------------------- /R/segment-tree.R: -------------------------------------------------------------------------------- 1 | # Keep in line with `segment-tree.h` 2 | SEGMENT_TREE_FANOUT = 16 3 | SEGMENT_TREE_FANOUT_POWER = 4 4 | -------------------------------------------------------------------------------- /revdep/.gitignore: -------------------------------------------------------------------------------- 1 | checks 2 | library 3 | checks.noindex 4 | library.noindex 5 | data.sqlite 6 | *.html 7 | cloud.noindex 8 | -------------------------------------------------------------------------------- /man-roxygen/param-x-y.R: -------------------------------------------------------------------------------- 1 | #' @param .x,.y `[vector]` 2 | #' 3 | #' Vectors to iterate over. Vectors of size 1 will be recycled. 4 | -------------------------------------------------------------------------------- /src/slider-vctrs-public.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void slider_initialize_vctrs_public(void) { 4 | vctrs_init_api(); 5 | } 6 | -------------------------------------------------------------------------------- /revdep/email.yml: -------------------------------------------------------------------------------- 1 | release_date: ??? 2 | rel_release_date: ??? 3 | my_news_url: ??? 4 | release_version: ??? 5 | release_details: ??? 6 | -------------------------------------------------------------------------------- /R/slide-common.R: -------------------------------------------------------------------------------- 1 | slide_common <- function(x, f_call, ptype, env, params) { 2 | .Call(slide_common_impl, x, f_call, ptype, env, params) 3 | } 4 | -------------------------------------------------------------------------------- /src/slider-vctrs.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_VCTRS_H 2 | #define SLIDER_VCTRS_H 3 | 4 | #include "slider-vctrs-public.h" 5 | #include "slider-vctrs-private.h" 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /revdep/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 7 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 4 | 5 | * We saw 0 new problems 6 | * We failed to check 0 packages 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/helper-long-double.R: -------------------------------------------------------------------------------- 1 | skip_if_no_long_double <- function() { 2 | skip_if( 3 | condition = .Machine$sizeof.longdouble <= 8L, 4 | message = "`long double` is less than or equal to `double` on this platform." 5 | ) 6 | } 7 | -------------------------------------------------------------------------------- /src/summary-core-types.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_SUMMARY_CORE_TYPES 2 | #define SLIDER_SUMMARY_CORE_TYPES 3 | 4 | #include // uintptr_t 5 | 6 | struct mean_state_t { 7 | long double sum; 8 | uint64_t count; 9 | }; 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /src/slider-vctrs-public.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_VCTRS_PUBLIC_H 2 | #define SLIDER_VCTRS_PUBLIC_H 3 | 4 | #include "slider.h" 5 | #include 6 | 7 | static inline R_len_t vec_size(SEXP x) { 8 | return short_vec_size(x); 9 | } 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "[r]": { 3 | "editor.formatOnSave": true, 4 | "editor.defaultFormatter": "Posit.air-vscode" 5 | }, 6 | "[quarto]": { 7 | "editor.formatOnSave": true, 8 | "editor.defaultFormatter": "quarto.quarto" 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /man-roxygen/param-l.R: -------------------------------------------------------------------------------- 1 | #' @param .l `[list]` 2 | #' 3 | #' A list of vectors. The length of `.l` determines the 4 | #' number of arguments that `.f` will be called with. If `.l` has names, 5 | #' they will be used as named arguments to `.f`. Elements of `.l` with size 6 | #' 1 will be recycled. 7 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # nocov start 2 | 3 | .onLoad <- function(libname, pkgname) { 4 | # Load vctrs namespace for access to C callables 5 | requireNamespace("vctrs", quietly = TRUE) 6 | 7 | # Initialize slider C globals 8 | .Call(slider_initialize, ns_env("slider")) 9 | 10 | run_on_load() 11 | } 12 | 13 | # nocov end 14 | -------------------------------------------------------------------------------- /src/summary-core-align.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_SUMMARY_CORE_ALIGN 2 | #define SLIDER_SUMMARY_CORE_ALIGN 3 | 4 | #include // size_t 5 | 6 | extern "C" { 7 | 8 | #include "summary-core-types.h" 9 | 10 | size_t align_of_long_double(void); 11 | size_t align_of_mean_state_t(void); 12 | 13 | } // extern "C" 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^slider\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^README\.Rmd$ 4 | ^LICENSE\.md$ 5 | ^\.travis\.yml$ 6 | ^codecov\.yml$ 7 | ^_pkgdown\.yml$ 8 | ^docs$ 9 | ^pkgdown$ 10 | ^\.github$ 11 | ^man-roxygen$ 12 | ^cran-comments\.md$ 13 | ^CRAN-RELEASE$ 14 | ^revdep$ 15 | ^CRAN-SUBMISSION$ 16 | ^compile_commands\.json$ 17 | ^\.cache$ 18 | ^\.vscode$ 19 | ^[.]?air[.]toml$ 20 | -------------------------------------------------------------------------------- /man-roxygen/param-starts-stops-hop.R: -------------------------------------------------------------------------------- 1 | #' @param .starts,.stops `[integer]` 2 | #' 3 | #' Vectors of boundary locations that make up the windows to bucket `.x` with. 4 | #' Both `.starts` and `.stops` will be recycled to their common size, and 5 | #' that common size will be the size of the result. Both vectors should be 6 | #' integer locations along `.x`, but out-of-bounds values are allowed. 7 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-index2.md: -------------------------------------------------------------------------------- 1 | # empty input returns a list, but after the index size check 2 | 3 | Code 4 | (expect_error(slide_index2(integer(), integer(), 1, ~.x), class = "slider_error_index_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `slide_index2()`: 9 | ! `.i` must have size 0, not 1. 10 | 11 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide-index.md: -------------------------------------------------------------------------------- 1 | # empty input returns a list, but after the index size check 2 | 3 | Code 4 | (expect_error(pslide_index(list(integer(), integer()), 1, ~.x), class = "slider_error_index_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `pslide_index()`: 9 | ! `.i` must have size 0, not 1. 10 | 11 | -------------------------------------------------------------------------------- /src/slider.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_H 2 | #define SLIDER_H 3 | 4 | #define R_NO_REMAP 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include // uint64_t 11 | 12 | // Definitions -------------------------------------------------- 13 | 14 | #define PSLIDE_EMPTY 0 15 | #define SLIDE -1 16 | #define SLIDE2 -2 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide-period.md: -------------------------------------------------------------------------------- 1 | # empty input returns a list, but after the index size check 2 | 3 | Code 4 | (expect_error(pslide_period(list(integer(), integer()), i, "day", ~.x), class = "slider_error_index_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `pslide_period()`: 9 | ! `.i` must have size 0, not 1. 10 | 11 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | test_that("`is_unbounded()` returns `FALSE` for classed objects", { 2 | # We only care about checking if an exact literal `Inf` is supplied. 3 | # We don't want to call `is.infinite()` on any object, as vctrs classes 4 | # don't support `is.infinite()` by default and error if `is.infinite()` 5 | # is called. 6 | x <- structure(Inf, class = "foobar") 7 | expect_false(is_unbounded(x)) 8 | }) 9 | -------------------------------------------------------------------------------- /man-roxygen/param-before-after-slide.R: -------------------------------------------------------------------------------- 1 | #' @param .before,.after `[integer(1) / Inf]` 2 | #' 3 | #' The number of values before or after the current element to 4 | #' include in the sliding window. Set to `Inf` to select all elements 5 | #' before or after the current element. Negative values are allowed, which 6 | #' allows you to "look forward" from the current element if used as the 7 | #' `.before` value, or "look backwards" if used as `.after`. 8 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-period2.md: -------------------------------------------------------------------------------- 1 | # empty input returns a list, but after the index size check 2 | 3 | Code 4 | (expect_error(slide_period2(.x = integer(), .y = integer(), .i = structure(0, 5 | class = "Date"), .period = "day", .f = ~.x), class = "slider_error_index_incompatible_size") 6 | ) 7 | Output 8 | 9 | Error in `slide_period2()`: 10 | ! `.i` must have size 0, not 1. 11 | 12 | -------------------------------------------------------------------------------- /src/slider-vctrs-private.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_VCTRS_PRIVATE_H 2 | #define SLIDER_VCTRS_PRIVATE_H 3 | 4 | #include "slider.h" 5 | 6 | // Experimental non-public vctrs functions 7 | extern SEXP (*vec_cast)(SEXP, SEXP); 8 | extern SEXP (*vec_chop)(SEXP, SEXP); 9 | extern SEXP (*vec_slice_impl)(SEXP, SEXP); 10 | extern SEXP (*vec_names)(SEXP); 11 | extern SEXP (*compact_seq)(R_len_t, R_len_t, bool); 12 | extern void (*init_compact_seq)(int*, R_len_t, R_len_t, bool); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /slider.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /tests/testthat/helper-s3.R: -------------------------------------------------------------------------------- 1 | foobar <- function(x = list()) { 2 | structure(x, class = "slider_foobar") 3 | } 4 | 5 | local_methods <- function(..., .frame = caller_env()) { 6 | local_bindings(..., .env = global_env(), .frame = .frame) 7 | } 8 | 9 | local_c_foobar <- function(frame = caller_env()) { 10 | local_methods(.frame = frame, c.slider_foobar = function(...) { 11 | signal("", class = "slider_c_foobar") 12 | xs <- list(...) 13 | xs <- lapply(xs, unclass) 14 | out <- list_unchop(xs) 15 | foobar(out) 16 | }) 17 | } 18 | -------------------------------------------------------------------------------- /man-roxygen/param-starts-stops-hop-index.R: -------------------------------------------------------------------------------- 1 | #' @param .starts,.stops `[vector]` 2 | #' 3 | #' Vectors of boundary values that make up the windows to bucket `.i` with. 4 | #' Both `.starts` and `.stops` will be recycled to their common size, and 5 | #' that common size will be the size of the result. Both vectors will be cast 6 | #' to the type of `.i` using [vctrs::vec_cast()]. These boundaries are both 7 | #' _inclusive_, meaning that the slice of `.x` that will be used in each call 8 | #' to `.f` is where `.i >= start & .i <= stop` returns `TRUE`. 9 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide2.md: -------------------------------------------------------------------------------- 1 | # Recycling is carried out using tidyverse recycling rules 2 | 3 | Code 4 | (expect_error(slide2(x0, x2, ~.x), class = "vctrs_error_incompatible_size")) 5 | Output 6 | 7 | Error in `slide2()`: 8 | ! Can't recycle `.x` (size 0) to match `.y` (size 2). 9 | Code 10 | (expect_error(slide2(x2, x3, ~.x), class = "vctrs_error_incompatible_size")) 11 | Output 12 | 13 | Error in `slide2()`: 14 | ! Can't recycle `.x` (size 2) to match `.y` (size 3). 15 | 16 | -------------------------------------------------------------------------------- /src/summary-core-align.cpp: -------------------------------------------------------------------------------- 1 | #include "summary-core-align.h" 2 | 3 | extern "C" { 4 | 5 | /* 6 | * `alignof()` is C++11 specific, so this single compilation unit requires 7 | * C++11 (which is guaranteed by recent R versions now), and we call these 8 | * helpers from C in `summary-core.h`. 9 | * 10 | * Technically `alignof()` is also in C11, but it is unclear how well R supports 11 | * that. 12 | */ 13 | 14 | size_t align_of_long_double(void) { 15 | return alignof(long double); 16 | } 17 | 18 | size_t align_of_mean_state_t(void) { 19 | return alignof(struct mean_state_t); 20 | } 21 | 22 | } // extern "C" 23 | -------------------------------------------------------------------------------- /R/slider-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | #' @aliases slider-package 3 | "_PACKAGE" 4 | 5 | # The following block is used by usethis to automatically manage 6 | # roxygen namespace tags. Modify with care! 7 | ## usethis namespace: start 8 | #' @import rlang 9 | #' @import vctrs 10 | #' @importFrom warp warp_boundary 11 | #' @importFrom warp warp_distance 12 | #' @useDynLib slider, .registration = TRUE 13 | ## usethis namespace: end 14 | NULL 15 | 16 | # So errors from helpers like 17 | # `check_generated_endpoints_cannot_be_na(NA, ".before")` 18 | # don't show both `!` and `i` for the first bullet. 19 | on_load(local_use_cli()) 20 | -------------------------------------------------------------------------------- /src/block.c: -------------------------------------------------------------------------------- 1 | #include "slider.h" 2 | #include "slider-vctrs.h" 3 | 4 | // [[ export() ]] 5 | SEXP slider_block(SEXP x, SEXP starts, SEXP stops) { 6 | R_xlen_t size = Rf_xlength(starts); 7 | 8 | double* p_starts = REAL(starts); 9 | double* p_stops = REAL(stops); 10 | 11 | SEXP indices = PROTECT(Rf_allocVector(VECSXP, size)); 12 | 13 | for (R_xlen_t i = 0; i < size; ++i) { 14 | int start = p_starts[i]; 15 | int stop = p_stops[i]; 16 | int size = stop - start + 1; 17 | 18 | SEXP seq = compact_seq(start - 1, size, true); 19 | SET_VECTOR_ELT(indices, i, seq); 20 | } 21 | 22 | SEXP out = PROTECT(vec_chop(x, indices)); 23 | 24 | UNPROTECT(2); 25 | return out; 26 | } 27 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/phop-index.md: -------------------------------------------------------------------------------- 1 | # empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first 2 | 3 | Code 4 | (expect_error(phop_index(list(), integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `phop_index()`: 9 | ! Can't recycle `.starts` (size 3) to match `.stops` (size 2). 10 | Code 11 | (expect_error(phop_index(list(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") 12 | ) 13 | Output 14 | 15 | Error in `phop_index()`: 16 | ! Can't convert `.stops` to match type of `.i` . 17 | 18 | -------------------------------------------------------------------------------- /src/params.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_PARAMS_H 2 | #define SLIDER_PARAMS_H 3 | 4 | #include "slider.h" 5 | 6 | int validate_type(SEXP x); 7 | bool validate_constrain(SEXP x); 8 | bool validate_atomic(SEXP x); 9 | int validate_before(SEXP x, bool* before_unbounded, bool dot); 10 | int validate_after(SEXP x, bool* after_unbounded, bool dot); 11 | int validate_step(SEXP x, bool dot); 12 | int validate_complete(SEXP x, bool dot); 13 | int validate_na_rm(SEXP x, bool dot); 14 | 15 | void check_double_negativeness(int before, int after, bool before_positive, bool after_positive); 16 | void check_after_negativeness(int after, int before, bool after_positive, bool before_unbounded); 17 | void check_before_negativeness(int before, int after, bool before_positive, bool after_unbounded); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /tests/testthat/test-slide-index2.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | expect_equal(slide_index2(integer(), integer(), integer(), ~.x), list()) 3 | expect_equal(slide_index2(integer(), 1, integer(), ~.x), list()) 4 | expect_equal(slide_index2(1, integer(), integer(), ~.x), list()) 5 | 6 | expect_snapshot({ 7 | (expect_error( 8 | slide_index2(integer(), integer(), 1, ~.x), 9 | class = "slider_error_index_incompatible_size" 10 | )) 11 | }) 12 | }) 13 | 14 | test_that("slide_index2() forces arguments in the same way as base R / map2()", { 15 | f_slide <- slide_index2(1:2, 1:2, 1:2, function(i, j) function(x) x + i + j) 16 | f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) 17 | 18 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 19 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 20 | }) 21 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/phop.md: -------------------------------------------------------------------------------- 1 | # Recycling is carried out using tidyverse recycling rules 2 | 3 | Code 4 | (expect_error(phop(list(x0, x2), 1, 1, ~.x), class = "vctrs_error_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `phop()`: 9 | ! Can't recycle `.l[[1]]` (size 0) to match `.l[[2]]` (size 2). 10 | 11 | --- 12 | 13 | Code 14 | (expect_error(phop(list(x2, x3), 1:3, 1:3, ~.x), class = "vctrs_error_incompatible_size") 15 | ) 16 | Output 17 | 18 | Error in `phop()`: 19 | ! Can't recycle `.l[[1]]` (size 2) to match `.l[[2]]` (size 3). 20 | 21 | # phop() requires a list-like input 22 | 23 | Code 24 | phop(1:5, ~.x) 25 | Condition 26 | Error in `phop()`: 27 | ! `.l` must be a list, not an integer vector. 28 | 29 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide.md: -------------------------------------------------------------------------------- 1 | # Recycling is carried out using tidyverse recycling rules 2 | 3 | Code 4 | (expect_error(pslide(list(x0, x2), ~.x), class = "vctrs_error_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `pslide()`: 9 | ! Can't recycle `.l[[1]]` (size 0) to match `.l[[2]]` (size 2). 10 | 11 | --- 12 | 13 | Code 14 | (expect_error(pslide(list(x2, x3), ~.x), class = "vctrs_error_incompatible_size") 15 | ) 16 | Output 17 | 18 | Error in `pslide()`: 19 | ! Can't recycle `.l[[1]]` (size 2) to match `.l[[2]]` (size 3). 20 | 21 | # pslide() requires a list-like input 22 | 23 | Code 24 | pslide(1:5, ~.x) 25 | Condition 26 | Error in `pslide()`: 27 | ! `.l` must be a list, not an integer vector. 28 | 29 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop2-vec.md: -------------------------------------------------------------------------------- 1 | # hop2_vec() errors if it can't simplify 2 | 3 | Code 4 | hop2_vec(1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL) 5 | Condition 6 | Error in `hop2_vec()`: 7 | ! Can't combine `out[[1]]` and `out[[2]]` . 8 | 9 | # `.ptype = NULL` validates that element lengths are 1 10 | 11 | Code 12 | hop2_vec(1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 13 | 1:2 14 | } else { 15 | 1 16 | }, .ptype = NULL) 17 | Condition 18 | Error: 19 | i In index: 1 20 | ! The result of `.f` must have size 1, not 2. 21 | 22 | --- 23 | 24 | Code 25 | hop2_vec(1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 26 | NULL 27 | } else { 28 | 2 29 | }, .ptype = NULL) 30 | Condition 31 | Error: 32 | i In index: 1 33 | ! The result of `.f` must have size 1, not 0. 34 | 35 | -------------------------------------------------------------------------------- /tests/testthat/test-slide2.R: -------------------------------------------------------------------------------- 1 | test_that("Recycling is carried out using tidyverse recycling rules", { 2 | x0 <- integer() 3 | x1 <- 1L 4 | x2 <- c(2L, 2L) 5 | x3 <- c(3L, 3L, 3L) 6 | 7 | expect_equal(slide2(x0, x0, ~.x), list()) 8 | expect_equal(slide2(x0, x1, ~.x), list()) 9 | expect_equal(slide2(x1, x1, ~.x), list(x1)) 10 | expect_equal(slide2(x1, x2, ~.x), list(x1, x1)) 11 | 12 | expect_snapshot({ 13 | (expect_error(slide2(x0, x2, ~.x), class = "vctrs_error_incompatible_size")) 14 | (expect_error(slide2(x2, x3, ~.x), class = "vctrs_error_incompatible_size")) 15 | }) 16 | }) 17 | 18 | test_that("slide2() forces arguments in the same way as base R / map2()", { 19 | f_slide <- slide2(1:2, 1:2, function(i, j) function(x) x + i + j) 20 | f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) 21 | 22 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 23 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 24 | }) 25 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide2-vec.md: -------------------------------------------------------------------------------- 1 | # slide2_vec() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(slide2_vec(1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type") 5 | ) 6 | Output 7 | 8 | Error in `slide2_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | # slide2_*() errors if it can't cast 12 | 13 | Code 14 | (expect_error(slide2_int(1:2, 1:2, fn), class = "vctrs_error_incompatible_type") 15 | ) 16 | Output 17 | 18 | Error: 19 | ! Can't convert to . 20 | 21 | # slide2_chr() cannot coerce 22 | 23 | Code 24 | (expect_error(slide2_chr(1, 1, ~ .x + .y), class = "vctrs_error_incompatible_type") 25 | ) 26 | Output 27 | 28 | Error: 29 | ! Can't convert to . 30 | 31 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide-index-vec.md: -------------------------------------------------------------------------------- 1 | # pslide_index_*() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(pslide_index_vec(list(1:2, 1:2), 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type") 5 | ) 6 | Output 7 | 8 | Error in `pslide_index_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | Code 11 | (expect_error(pslide_index_int(list(1:2, 1:2), 1:2, fn), class = "vctrs_error_incompatible_type") 12 | ) 13 | Output 14 | 15 | Error: 16 | ! Can't convert to . 17 | 18 | # pslide_index_chr() cannot coerce 19 | 20 | Code 21 | (expect_error(pslide_index_chr(list(1, 1), 1, ~ .x + .y), class = "vctrs_error_incompatible_type") 22 | ) 23 | Output 24 | 25 | Error: 26 | ! Can't convert to . 27 | 28 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-index2-vec.md: -------------------------------------------------------------------------------- 1 | # slide_index2_*() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(slide_index2_vec(1:2, 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type") 5 | ) 6 | Output 7 | 8 | Error in `slide_index2_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | --- 12 | 13 | Code 14 | (expect_error(slide_index2_int(1:2, 1:2, 1:2, fn), class = "vctrs_error_incompatible_type") 15 | ) 16 | Output 17 | 18 | Error: 19 | ! Can't convert to . 20 | 21 | # slide_index2_chr() cannot coerce 22 | 23 | Code 24 | (expect_error(slide_index2_chr(1, 1, 1, ~.x), class = "vctrs_error_incompatible_type") 25 | ) 26 | Output 27 | 28 | Error: 29 | ! Can't convert to . 30 | 31 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide-vec.md: -------------------------------------------------------------------------------- 1 | # pslide_vec() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(pslide_vec(list(1:2, 1:2), fn, .ptype = NULL), class = "vctrs_error_incompatible_type") 5 | ) 6 | Output 7 | 8 | Error in `pslide_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | # pslide_*() errors if it can't cast 12 | 13 | Code 14 | (expect_error(pslide_int(list(1:2, 1:2), fn), class = "vctrs_error_incompatible_type") 15 | ) 16 | Output 17 | 18 | Error: 19 | ! Can't convert to . 20 | 21 | # pslide_chr() cannot coerce 22 | 23 | Code 24 | (expect_error(pslide_chr(list(1, 1), ~ .x + .y), class = "vctrs_error_incompatible_type") 25 | ) 26 | Output 27 | 28 | Error: 29 | ! Can't convert to . 30 | 31 | -------------------------------------------------------------------------------- /man/slider-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/slider-package.R 3 | \docType{package} 4 | \name{slider-package} 5 | \alias{slider} 6 | \alias{slider-package} 7 | \title{slider: Sliding Window Functions} 8 | \description{ 9 | 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. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/r-lib/slider} 15 | \item \url{https://slider.r-lib.org} 16 | \item Report bugs at \url{https://github.com/r-lib/slider/issues} 17 | } 18 | 19 | } 20 | \author{ 21 | \strong{Maintainer}: Davis Vaughan \email{davis@posit.co} 22 | 23 | Other contributors: 24 | \itemize{ 25 | \item Posit Software, PBC (\href{https://ror.org/03wc8by49}{ROR}) [copyright holder, funder] 26 | } 27 | 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /tests/testthat/test-pslide-period.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | i <- new_date() 3 | 4 | expect_equal(pslide_period(list(integer(), integer()), i, "day", ~.x), list()) 5 | expect_equal(pslide_period(list(integer(), 1), i, "day", ~.x), list()) 6 | expect_equal(pslide_period(list(1, integer()), i, "day", ~.x), list()) 7 | 8 | i <- new_date(0) 9 | 10 | expect_snapshot({ 11 | (expect_error( 12 | pslide_period(list(integer(), integer()), i, "day", ~.x), 13 | class = "slider_error_index_incompatible_size" 14 | )) 15 | }) 16 | }) 17 | 18 | test_that("completely empty input returns a list", { 19 | expect_equal(pslide_period(list(), new_date(), "day", ~.x), list()) 20 | }) 21 | 22 | test_that("empty input works with `.complete = TRUE` (#111)", { 23 | expect_equal( 24 | pslide_period( 25 | list(integer(), integer()), 26 | new_date(), 27 | "year", 28 | ~.x, 29 | .complete = TRUE 30 | ), 31 | list() 32 | ) 33 | }) 34 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop-index2-vec.md: -------------------------------------------------------------------------------- 1 | # hop_index2_vec() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL), 5 | class = "vctrs_error_incompatible_type")) 6 | Output 7 | 8 | Error in `hop_index2_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | # `.ptype = NULL` validates that element lengths are 1 12 | 13 | Code 14 | hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 15 | 1:2 16 | } else { 17 | 1 18 | }, .ptype = NULL) 19 | Condition 20 | Error: 21 | i In index: 1 22 | ! The result of `.f` must have size 1, not 2. 23 | 24 | --- 25 | 26 | Code 27 | hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 28 | NULL 29 | } else { 30 | 2 31 | }, .ptype = NULL) 32 | Condition 33 | Error: 34 | i In index: 1 35 | ! The result of `.f` must have size 1, not 0. 36 | 37 | -------------------------------------------------------------------------------- /src/slider-vctrs-private.c: -------------------------------------------------------------------------------- 1 | #include "slider-vctrs-private.h" 2 | 3 | // Experimental non-public vctrs functions 4 | SEXP (*vec_cast)(SEXP, SEXP) = NULL; 5 | SEXP (*vec_chop)(SEXP, SEXP) = NULL; 6 | SEXP (*vec_slice_impl)(SEXP, SEXP) = NULL; 7 | SEXP (*vec_names)(SEXP) = NULL; 8 | SEXP (*compact_seq)(R_len_t, R_len_t, bool) = NULL; 9 | void (*init_compact_seq)(int*, R_len_t, R_len_t, bool) = NULL; 10 | 11 | void slider_initialize_vctrs_private(void) { 12 | // Experimental non-public vctrs functions 13 | vec_cast = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_cast"); 14 | vec_chop = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_chop"); 15 | vec_slice_impl = (SEXP (*)(SEXP, SEXP)) R_GetCCallable("vctrs", "exp_vec_slice_impl"); 16 | vec_names = (SEXP (*)(SEXP)) R_GetCCallable("vctrs", "exp_vec_names"); 17 | compact_seq = (SEXP (*)(R_len_t, R_len_t, bool)) R_GetCCallable("vctrs", "exp_short_compact_seq"); 18 | init_compact_seq = (void (*)(int*, R_len_t, R_len_t, bool)) R_GetCCallable("vctrs", "exp_short_init_compact_seq"); 19 | } 20 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/phop-index-vec.md: -------------------------------------------------------------------------------- 1 | # phop_index_vec() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, fn, .ptype = NULL), 5 | class = "vctrs_error_incompatible_type")) 6 | Output 7 | 8 | Error in `phop_index_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | # `.ptype = NULL` validates that element lengths are 1 12 | 13 | Code 14 | phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, ~ if (.x == 1L) { 15 | 1:2 16 | } else { 17 | 1 18 | }, .ptype = NULL) 19 | Condition 20 | Error: 21 | i In index: 1 22 | ! The result of `.f` must have size 1, not 2. 23 | 24 | --- 25 | 26 | Code 27 | phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, ~ if (.x == 1L) { 28 | NULL 29 | } else { 30 | 2 31 | }, .ptype = NULL) 32 | Condition 33 | Error: 34 | i In index: 1 35 | ! The result of `.f` must have size 1, not 0. 36 | 37 | -------------------------------------------------------------------------------- /tests/testthat/test-hop2.R: -------------------------------------------------------------------------------- 1 | test_that("Recycling is carried out using tidyverse recycling rules", { 2 | x0 <- integer() 3 | x1 <- 1L 4 | x2 <- c(2L, 2L) 5 | x3 <- c(3L, 3L, 3L) 6 | 7 | expect_equal(hop2(x0, x0, integer(), integer(), ~.x), list()) 8 | expect_equal(hop2(x0, x1, 1, 1, ~.x), list(integer())) 9 | expect_equal(hop2(x0, x1, integer(), integer(), ~.x), list()) 10 | expect_error( 11 | hop2(x0, x2, 1:2, 1:2, ~.x), 12 | class = "vctrs_error_incompatible_size" 13 | ) 14 | expect_equal(hop2(x1, x1, 1, 1, ~.x), list(x1)) 15 | expect_equal(hop2(x1, x2, 1:2, 1:2, ~.x), list(x1, x1)) 16 | expect_error( 17 | hop2(x2, x3, 1:2, 1:2, ~.x), 18 | class = "vctrs_error_incompatible_size" 19 | ) 20 | }) 21 | 22 | test_that("hop2() forces arguments in the same way as base R / map2()", { 23 | f_slide <- hop2(1:2, 1:2, 1:2, 1:2, function(i, j) function(x) x + i + j) 24 | f_base <- mapply(function(i, j) function(x) x + i + j, 1:2, 1:2) 25 | 26 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 27 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 28 | }) 29 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/phop-vec.md: -------------------------------------------------------------------------------- 1 | # phop_vec() errors if it can't simplify 2 | 3 | Code 4 | (expect_error(phop_vec(list(1:2, 1:2), 1:2, 1:2, fn, .ptype = NULL), class = "vctrs_error_incompatible_type") 5 | ) 6 | Output 7 | 8 | Error in `phop_vec()`: 9 | ! Can't combine `out[[1]]` and `out[[2]]` . 10 | 11 | # `.ptype = NULL` validates that element lengths are 1 12 | 13 | Code 14 | (expect_error(phop_vec(list(1:2, 1:2), 1:2, 1:2, ~ if (.x == 1L) { 15 | 1:2 16 | } else { 17 | 1 18 | }, .ptype = NULL))) 19 | Output 20 | 21 | Error: 22 | i In index: 1 23 | ! The result of `.f` must have size 1, not 2. 24 | Code 25 | (expect_error(phop_vec(list(1:2, 1:2), 1:2, 1:2, ~ if (.x == 1L) { 26 | NULL 27 | } else { 28 | 2 29 | }, .ptype = NULL))) 30 | Output 31 | 32 | Error: 33 | i In index: 1 34 | ! The result of `.f` must have size 1, not 0. 35 | 36 | -------------------------------------------------------------------------------- /tests/testthat/test-pslide-index.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | expect_equal(pslide_index(list(integer(), integer()), integer(), ~.x), list()) 3 | expect_equal(pslide_index(list(integer(), 1), integer(), ~.x), list()) 4 | expect_equal(pslide_index(list(1, integer()), integer(), ~.x), list()) 5 | 6 | expect_snapshot({ 7 | (expect_error( 8 | pslide_index(list(integer(), integer()), 1, ~.x), 9 | class = "slider_error_index_incompatible_size" 10 | )) 11 | }) 12 | }) 13 | 14 | test_that("completely empty input returns a list", { 15 | expect_equal(pslide_index(list(), integer(), ~.x), list()) 16 | }) 17 | 18 | test_that("pslide_index() forces arguments in the same way as base R / pmap()", { 19 | f_slide <- pslide_index( 20 | list(1:2, 1:2, 1:2), 21 | 1:2, 22 | function(i, j, k) function(x) x + i + j + k 23 | ) 24 | f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) 25 | 26 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 27 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 28 | }) 29 | -------------------------------------------------------------------------------- /src/align.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_ALIGN_H 2 | #define SLIDER_ALIGN_H 3 | 4 | /* 5 | * Following guidance of: 6 | * https://stackoverflow.com/questions/227897/how-to-allocate-aligned-memory-only-using-the-standard-library 7 | * 8 | * 1) Allocate enough space to shift the pointer 9 | * 2) Add to the pointer (p_x + buffer) 10 | * 3) Round down to the closest boundary using `& mask` 11 | */ 12 | 13 | #include "slider.h" 14 | #include // uintptr_t 15 | 16 | static 17 | inline 18 | SEXP 19 | aligned_allocate(R_xlen_t n_elements, 20 | size_t element_size, 21 | size_t element_align) { 22 | const size_t buffer = element_align - 1; 23 | const R_xlen_t size = n_elements * element_size + buffer; 24 | return Rf_allocVector(RAWSXP, size); 25 | } 26 | 27 | static 28 | inline 29 | void* 30 | aligned_void_deref(SEXP x, size_t element_align) { 31 | const size_t buffer = element_align - 1; 32 | uintptr_t mask = ~ (uintptr_t)buffer; 33 | uintptr_t p_x = (uintptr_t)RAW(x); 34 | uintptr_t p_aligned = (p_x + buffer) & mask; 35 | return (void*) p_aligned; 36 | } 37 | 38 | #endif 39 | -------------------------------------------------------------------------------- /R/hop-common.R: -------------------------------------------------------------------------------- 1 | hop_common <- function( 2 | x, 3 | starts, 4 | stops, 5 | f_call, 6 | ptype, 7 | env, 8 | type, 9 | constrain, 10 | atomic, 11 | slider_error_call 12 | ) { 13 | x_size <- compute_size(x, type) 14 | 15 | check_endpoints_cannot_be_na(starts, ".starts", call = slider_error_call) 16 | check_endpoints_cannot_be_na(stops, ".stops", call = slider_error_call) 17 | 18 | starts <- vec_as_subscript( 19 | starts, 20 | logical = "error", 21 | character = "error", 22 | arg = ".starts", 23 | call = slider_error_call 24 | ) 25 | stops <- vec_as_subscript( 26 | stops, 27 | logical = "error", 28 | character = "error", 29 | arg = ".stops", 30 | call = slider_error_call 31 | ) 32 | 33 | args <- vec_recycle_common( 34 | starts = starts, 35 | stops = stops, 36 | .call = slider_error_call 37 | ) 38 | 39 | starts <- args[[1L]] 40 | stops <- args[[2L]] 41 | 42 | params <- list( 43 | type = type, 44 | constrain = constrain, 45 | atomic = atomic 46 | ) 47 | 48 | .Call(hop_common_impl, x, starts, stops, f_call, ptype, env, params) 49 | } 50 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2025 slider authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop-index2.md: -------------------------------------------------------------------------------- 1 | # empty input returns a list, but after the index size check 2 | 3 | Code 4 | (expect_error(hop_index2(.x = integer(), .y = integer(), .i = 1, .starts = integer(), 5 | .stops = integer(), .f = ~.x), class = "slider_error_index_incompatible_size")) 6 | Output 7 | 8 | Error in `hop_index2()`: 9 | ! `.i` must have size 0, not 1. 10 | 11 | # empty `.x` and `.y` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first 12 | 13 | Code 14 | (expect_error(hop_index2(integer(), integer(), integer(), 1:3, 1:2, ~.x), 15 | class = "vctrs_error_incompatible_size")) 16 | Output 17 | 18 | Error in `hop_index2()`: 19 | ! Can't recycle `.starts` (size 3) to match `.stops` (size 2). 20 | Code 21 | (expect_error(hop_index2(integer(), integer(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") 22 | ) 23 | Output 24 | 25 | Error in `hop_index2()`: 26 | ! Can't convert `.stops` to match type of `.i` . 27 | 28 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/summary-slide.md: -------------------------------------------------------------------------------- 1 | # input must be castable to logical 2 | 3 | Code 4 | (expect_error(slide_all(1:5), class = "vctrs_error_cast_lossy")) 5 | Output 6 | 7 | Error: 8 | ! Can't convert from to due to loss of precision. 9 | * Locations: 2, 3, 4, 5 10 | 11 | --- 12 | 13 | Code 14 | (expect_error(slide_any(1:5), class = "vctrs_error_cast_lossy")) 15 | Output 16 | 17 | Error: 18 | ! Can't convert from to due to loss of precision. 19 | * Locations: 2, 3, 4, 5 20 | 21 | # types that can't be cast to numeric are not supported 22 | 23 | Code 24 | (expect_error(slide_sum("x"), class = "vctrs_error_incompatible_type")) 25 | Output 26 | 27 | Error: 28 | ! Can't convert to . 29 | 30 | # arrays of dimensionality >1 are not supported 31 | 32 | Code 33 | (expect_error(slide_sum(array(1:4, dim = c(2, 2)), before = 1), class = "vctrs_error_incompatible_type") 34 | ) 35 | Output 36 | 37 | Error: 38 | ! Can't convert to . 39 | Can't decrease dimensionality from 2 to 1. 40 | 41 | -------------------------------------------------------------------------------- /tests/testthat/test-slide-period2.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | expect_equal( 3 | slide_period2( 4 | .x = integer(), 5 | .y = integer(), 6 | .i = structure(numeric(), class = "Date"), 7 | .period = "day", 8 | .f = ~.x 9 | ), 10 | list() 11 | ) 12 | 13 | expect_equal( 14 | slide_period2( 15 | .x = integer(), 16 | .y = 1, 17 | .i = structure(numeric(), class = "Date"), 18 | .period = "day", 19 | .f = ~.x 20 | ), 21 | list() 22 | ) 23 | 24 | expect_equal( 25 | slide_period2( 26 | .x = 1, 27 | .y = integer(), 28 | .i = structure(numeric(), class = "Date"), 29 | .period = "day", 30 | .f = ~.x 31 | ), 32 | list() 33 | ) 34 | 35 | expect_snapshot({ 36 | (expect_error( 37 | slide_period2( 38 | .x = integer(), 39 | .y = integer(), 40 | .i = structure(0, class = "Date"), 41 | .period = "day", 42 | .f = ~.x 43 | ), 44 | class = "slider_error_index_incompatible_size" 45 | )) 46 | }) 47 | }) 48 | 49 | test_that("empty input works with `.complete = TRUE` (#111)", { 50 | expect_equal( 51 | slide_period2( 52 | integer(), 53 | integer(), 54 | new_date(), 55 | "year", 56 | ~.x, 57 | .complete = TRUE 58 | ), 59 | list() 60 | ) 61 | }) 62 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | release: 8 | types: [published] 9 | workflow_dispatch: 10 | 11 | name: pkgdown.yaml 12 | 13 | permissions: read-all 14 | 15 | jobs: 16 | pkgdown: 17 | runs-on: ubuntu-latest 18 | # Only restrict concurrency for non-PR jobs 19 | concurrency: 20 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 21 | env: 22 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 23 | permissions: 24 | contents: write 25 | steps: 26 | - uses: actions/checkout@v4 27 | 28 | - uses: r-lib/actions/setup-pandoc@v2 29 | 30 | - uses: r-lib/actions/setup-r@v2 31 | with: 32 | use-public-rspm: true 33 | 34 | - uses: r-lib/actions/setup-r-dependencies@v2 35 | with: 36 | extra-packages: any::pkgdown, local::. 37 | needs: website 38 | 39 | - name: Build site 40 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 41 | shell: Rscript {0} 42 | 43 | - name: Deploy to GitHub pages 🚀 44 | if: github.event_name != 'pull_request' 45 | uses: JamesIves/github-pages-deploy-action@v4.5.0 46 | with: 47 | clean: false 48 | branch: gh-pages 49 | folder: docs 50 | -------------------------------------------------------------------------------- /man-roxygen/param-before-after-slide-index.R: -------------------------------------------------------------------------------- 1 | #' @param .before,.after `[vector(1) / function / Inf]` 2 | #' 3 | #' - If a vector of size 1, these represent the number of values before or 4 | #' after the current element of `.i` to include in the sliding window. 5 | #' Negative values are allowed, which allows you to "look forward" from the 6 | #' current element if used as the `.before` value, or "look backwards" if used 7 | #' as `.after`. Boundaries are computed from these elements as `.i - .before` 8 | #' and `.i + .after`. Any object that can be added or subtracted from `.i` 9 | #' with `+` and `-` can be used. For example, a lubridate period, such as 10 | #' [lubridate::weeks()]. 11 | #' 12 | #' - If `Inf`, this selects all elements before or after the current element. 13 | #' 14 | #' - If a function, or a one-sided formula which can be coerced to a function, 15 | #' it is applied to `.i` to compute the boundaries. Note that this function 16 | #' will only be applied to the _unique_ values of `.i`, so it should not rely 17 | #' on the original length of `.i` in any way. This is useful for applying a 18 | #' complex arithmetic operation that can't be expressed with a single `-` or 19 | #' `+` operation. One example would be to use [lubridate::add_with_rollback()] 20 | #' to avoid invalid dates at the end of the month. 21 | #' 22 | #' The ranges that result from applying `.before` and `.after` have the same 23 | #' 3 restrictions as `.i` itself, and are cast to the type of `.i` using 24 | #' [vctrs::vec_cast()]. 25 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/block.md: -------------------------------------------------------------------------------- 1 | # `x` must be a vector 2 | 3 | Code 4 | (expect_error(block(as.name("x"), new_date(0)), class = "vctrs_error_scalar_type") 5 | ) 6 | Output 7 | 8 | Error in `block()`: 9 | ! `x` must be a vector, not a symbol. 10 | 11 | # `i` can not have `NA` values 12 | 13 | Code 14 | (expect_error(block(1:2, new_date(c(0, NA_real_))), class = "slider_error_index_cannot_be_na") 15 | ) 16 | Output 17 | 18 | Error in `block()`: 19 | i In locations: 2 20 | ! `i` can't be `NA`. 21 | 22 | # type of `i` is validated 23 | 24 | Code 25 | (expect_error(block(1, 1), class = "slider_error_index_incompatible_type")) 26 | Output 27 | 28 | Error in `block()`: 29 | ! `i` must be a , , or , not a number. 30 | 31 | # length of `i` must be identical to `x` 32 | 33 | Code 34 | (expect_error(block(c(1, 2), new_date(0)), class = "slider_error_index_incompatible_size") 35 | ) 36 | Output 37 | 38 | Error in `block()`: 39 | ! `i` must have size 2, not 1. 40 | 41 | # `i` must be ascending 42 | 43 | Code 44 | (expect_error(block(c(1, 2, 3), new_date(c(2, 1, 0))), class = "slider_error_index_must_be_ascending") 45 | ) 46 | Output 47 | 48 | Error in `block()`: 49 | i In locations: 2 and 3 50 | ! `i` must be in ascending order. 51 | 52 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/summary-index.md: -------------------------------------------------------------------------------- 1 | # input must be castable to logical 2 | 3 | Code 4 | (expect_error(slide_index_all(1:5, 1:5), class = "vctrs_error_cast_lossy")) 5 | Output 6 | 7 | Error: 8 | ! Can't convert from to due to loss of precision. 9 | * Locations: 2, 3, 4, 5 10 | 11 | --- 12 | 13 | Code 14 | (expect_error(slide_index_any(1:5, 1:5), class = "vctrs_error_cast_lossy")) 15 | Output 16 | 17 | Error: 18 | ! Can't convert from to due to loss of precision. 19 | * Locations: 2, 3, 4, 5 20 | 21 | # x and i must be the same size 22 | 23 | Code 24 | (expect_error(slide_index_sum(1, 1:3), class = "slider_error_index_incompatible_size") 25 | ) 26 | Output 27 | 28 | Error in `slide_index_sum()`: 29 | ! `i` must have size 1, not 3. 30 | 31 | # types that can't be cast to numeric are not supported 32 | 33 | Code 34 | (expect_error(slide_index_sum("x", 1), class = "vctrs_error_incompatible_type")) 35 | Output 36 | 37 | Error: 38 | ! Can't convert to . 39 | 40 | # arrays of dimensionality >1 are not supported 41 | 42 | Code 43 | (expect_error(slide_index_sum(array(1:4, dim = c(2, 2)), 1:2, before = 1), 44 | class = "vctrs_error_incompatible_type")) 45 | Output 46 | 47 | Error: 48 | ! Can't convert to . 49 | Can't decrease dimensionality from 2 to 1. 50 | 51 | -------------------------------------------------------------------------------- /tests/testthat/test-block.R: -------------------------------------------------------------------------------- 1 | test_that("block works as expected with year blocks", { 2 | i <- as.Date("2019-01-01") + c(-2:2, 31) 3 | 4 | expect_equal(block(i, i, period = "year"), list(i[1:2], i[3:6])) 5 | }) 6 | 7 | test_that("block works as expected with month blocks", { 8 | i <- as.Date("2019-01-01") + c(-2:2, 31) 9 | 10 | expect_equal(block(i, i, period = "month"), list(i[1:2], i[3:5], i[6])) 11 | }) 12 | 13 | test_that("`x` must be a vector", { 14 | expect_snapshot({ 15 | (expect_error( 16 | block(as.name("x"), new_date(0)), 17 | class = "vctrs_error_scalar_type" 18 | )) 19 | }) 20 | }) 21 | 22 | test_that("works with empty input", { 23 | x <- numeric() 24 | i <- structure(numeric(), class = "Date") 25 | 26 | expect_equal(block(x, i, "year"), list()) 27 | }) 28 | 29 | test_that("`i` can not have `NA` values", { 30 | expect_snapshot({ 31 | (expect_error( 32 | block(1:2, new_date(c(0, NA_real_))), 33 | class = "slider_error_index_cannot_be_na" 34 | )) 35 | }) 36 | }) 37 | 38 | test_that("type of `i` is validated", { 39 | expect_snapshot({ 40 | (expect_error(block(1, 1), class = "slider_error_index_incompatible_type")) 41 | }) 42 | }) 43 | 44 | test_that("length of `i` must be identical to `x`", { 45 | expect_snapshot({ 46 | (expect_error( 47 | block(c(1, 2), new_date(0)), 48 | class = "slider_error_index_incompatible_size" 49 | )) 50 | }) 51 | }) 52 | 53 | test_that("`i` must be ascending", { 54 | expect_snapshot({ 55 | (expect_error( 56 | block(c(1, 2, 3), new_date(c(2, 1, 0))), 57 | class = "slider_error_index_must_be_ascending" 58 | )) 59 | }) 60 | }) 61 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | hop_vec(1:2, 1, 1, ~ c(.x, 1)) 5 | Condition 6 | Error: 7 | i In index: 1 8 | ! The result of `.f` must have size 1, not 2. 9 | 10 | # inner type can be restricted with list_of 11 | 12 | Code 13 | (expect_error(hop_vec(1:2, 1:2, 1:2, ~ if (.x == 1L) { 14 | list_of(1) 15 | } else { 16 | list_of("hi") 17 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 18 | ) 19 | Output 20 | 21 | Error in `hop_vec()`: 22 | ! Can't convert `..1` to . 23 | 24 | # `.ptype = NULL` fails if no common type is found 25 | 26 | Code 27 | (expect_error(hop_vec(1:2, 1:2, 1:2, ~ ifelse(.x == 1L, "hello", 1), .ptype = NULL), 28 | class = "vctrs_error_incompatible_type")) 29 | Output 30 | 31 | Error in `hop_vec()`: 32 | ! Can't combine `out[[1]]` and `out[[2]]` . 33 | 34 | # `.ptype = NULL` validates that element lengths are 1 35 | 36 | Code 37 | hop_vec(1:2, 1:2, 1:2, ~ if (.x == 1L) { 38 | 1:2 39 | } else { 40 | 1 41 | }, .ptype = NULL) 42 | Condition 43 | Error: 44 | i In index: 1 45 | ! The result of `.f` must have size 1, not 2. 46 | 47 | --- 48 | 49 | Code 50 | hop_vec(1:2, 1:2, 1:2, ~ if (.x == 1L) { 51 | NULL 52 | } else { 53 | 2 54 | }, .ptype = NULL) 55 | Condition 56 | Error: 57 | i In index: 1 58 | ! The result of `.f` must have size 1, not 0. 59 | 60 | -------------------------------------------------------------------------------- /tests/testthat/test-phop-index.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | expect_equal( 3 | phop_index( 4 | list(integer(), integer()), 5 | integer(), 6 | integer(), 7 | integer(), 8 | ~.x 9 | ), 10 | list() 11 | ) 12 | expect_equal( 13 | phop_index(list(integer(), 1), integer(), integer(), integer(), ~.x), 14 | list() 15 | ) 16 | expect_equal( 17 | phop_index(list(1, integer()), integer(), integer(), integer(), ~.x), 18 | list() 19 | ) 20 | 21 | expect_error( 22 | phop_index(list(integer(), integer()), 1, integer(), integer(), ~.x), 23 | class = "slider_error_index_incompatible_size" 24 | ) 25 | }) 26 | 27 | test_that("completely empty input returns a list", { 28 | expect_equal(phop_index(list(), integer(), integer(), integer(), ~.x), list()) 29 | }) 30 | 31 | test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` ptype", { 32 | expect_equal(phop_index(list(), integer(), 1:2, 2:3, ~2), list(2, 2)) 33 | }) 34 | 35 | test_that("can't access non-existant `.x` with empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`", { 36 | # Note: Error message seems platform dependent 37 | expect_error(phop_index(list(), integer(), 1:2, 2:3, ~.x)) 38 | }) 39 | 40 | test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { 41 | expect_snapshot({ 42 | (expect_error( 43 | phop_index(list(), integer(), 1:3, 1:2, ~.x), 44 | class = "vctrs_error_incompatible_size" 45 | )) 46 | (expect_error( 47 | phop_index(list(), integer(), 1, "x", ~.x), 48 | class = "vctrs_error_incompatible_type" 49 | )) 50 | }) 51 | }) 52 | -------------------------------------------------------------------------------- /R/phop.R: -------------------------------------------------------------------------------- 1 | #' @include hop2.R 2 | #' @rdname hop2 3 | #' @export 4 | phop <- function(.l, .starts, .stops, .f, ...) { 5 | phop_impl( 6 | .l, 7 | .starts, 8 | .stops, 9 | .f, 10 | ..., 11 | .ptype = list(), 12 | .constrain = FALSE, 13 | .atomic = FALSE 14 | ) 15 | } 16 | 17 | #' @rdname hop2 18 | #' @export 19 | phop_vec <- function(.l, .starts, .stops, .f, ..., .ptype = NULL) { 20 | out <- phop_impl( 21 | .l, 22 | .starts, 23 | .stops, 24 | .f, 25 | ..., 26 | .ptype = list(), 27 | .constrain = FALSE, 28 | .atomic = TRUE 29 | ) 30 | 31 | vec_simplify(out, .ptype) 32 | } 33 | 34 | # ------------------------------------------------------------------------------ 35 | 36 | phop_impl <- function( 37 | .l, 38 | .starts, 39 | .stops, 40 | .f, 41 | ..., 42 | .ptype, 43 | .constrain, 44 | .atomic, 45 | .slider_error_call = caller_env() 46 | ) { 47 | .l <- slider_check_list(.l, call = .slider_error_call) 48 | list_check_all_vectors(.l, call = .slider_error_call) 49 | 50 | .f <- as_function(.f, call = .slider_error_call) 51 | 52 | .l <- vec_recycle_common(!!!.l, .arg = ".l", .call = .slider_error_call) 53 | 54 | type <- vec_size(.l) 55 | 56 | slicers <- lapply( 57 | seq_len(type), 58 | function(x) { 59 | expr(.l[[!!x]]) 60 | } 61 | ) 62 | 63 | # Ensure names of `.l` are kept so they can be spliced 64 | # into `.f` as argument names 65 | names(slicers) <- names(.l) 66 | 67 | f_call <- expr(.f(!!!slicers, ...)) 68 | 69 | hop_common( 70 | x = .l, 71 | starts = .starts, 72 | stops = .stops, 73 | f_call = f_call, 74 | ptype = .ptype, 75 | env = environment(), 76 | type = type, 77 | constrain = .constrain, 78 | atomic = .atomic, 79 | slider_error_call = .slider_error_call 80 | ) 81 | } 82 | -------------------------------------------------------------------------------- /tests/testthat/test-hop-index2.R: -------------------------------------------------------------------------------- 1 | test_that("empty input returns a list, but after the index size check", { 2 | expect_equal( 3 | hop_index2( 4 | .x = integer(), 5 | .y = integer(), 6 | .i = integer(), 7 | .starts = integer(), 8 | .stops = integer(), 9 | .f = ~.x 10 | ), 11 | list() 12 | ) 13 | 14 | expect_equal( 15 | hop_index2( 16 | .x = integer(), 17 | .y = 1, 18 | .i = integer(), 19 | .starts = integer(), 20 | .stops = integer(), 21 | .f = ~.x 22 | ), 23 | list() 24 | ) 25 | 26 | expect_equal( 27 | hop_index2( 28 | .x = 1, 29 | .y = integer(), 30 | .i = integer(), 31 | .starts = integer(), 32 | .stops = integer(), 33 | .f = ~.x 34 | ), 35 | list() 36 | ) 37 | 38 | expect_snapshot( 39 | (expect_error( 40 | hop_index2( 41 | .x = integer(), 42 | .y = integer(), 43 | .i = 1, 44 | .starts = integer(), 45 | .stops = integer(), 46 | .f = ~.x 47 | ), 48 | class = "slider_error_index_incompatible_size" 49 | )) 50 | ) 51 | }) 52 | 53 | test_that("empty `.x` and `.y` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` empty ptype", { 54 | expect_equal( 55 | hop_index2(integer(), integer(), integer(), 1:2, 2:3, ~.x), 56 | list(integer(), integer()) 57 | ) 58 | }) 59 | 60 | test_that("empty `.x` and `.y` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { 61 | expect_snapshot({ 62 | (expect_error( 63 | hop_index2(integer(), integer(), integer(), 1:3, 1:2, ~.x), 64 | class = "vctrs_error_incompatible_size" 65 | )) 66 | (expect_error( 67 | hop_index2(integer(), integer(), integer(), 1, "x", ~.x), 68 | class = "vctrs_error_incompatible_type" 69 | )) 70 | }) 71 | }) 72 | -------------------------------------------------------------------------------- /.github/workflows/format-suggest.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/posit-dev/setup-air/tree/main/examples 2 | 3 | on: 4 | # Using `pull_request_target` over `pull_request` for elevated `GITHUB_TOKEN` 5 | # privileges, otherwise we can't set `pull-requests: write` when the pull 6 | # request comes from a fork, which is our main use case (external contributors). 7 | # 8 | # `pull_request_target` runs in the context of the target branch (`main`, usually), 9 | # rather than in the context of the pull request like `pull_request` does. Due 10 | # to this, we must explicitly checkout `ref: ${{ github.event.pull_request.head.sha }}`. 11 | # This is typically frowned upon by GitHub, as it exposes you to potentially running 12 | # untrusted code in a context where you have elevated privileges, but they explicitly 13 | # call out the use case of reformatting and committing back / commenting on the PR 14 | # as a situation that should be safe (because we aren't actually running the untrusted 15 | # code, we are just treating it as passive data). 16 | # https://securitylab.github.com/resources/github-actions-preventing-pwn-requests/ 17 | pull_request_target: 18 | 19 | name: format-suggest.yaml 20 | 21 | jobs: 22 | format-suggest: 23 | name: format-suggest 24 | runs-on: ubuntu-latest 25 | 26 | permissions: 27 | # Required to push suggestion comments to the PR 28 | pull-requests: write 29 | 30 | steps: 31 | - uses: actions/checkout@v4 32 | with: 33 | ref: ${{ github.event.pull_request.head.sha }} 34 | 35 | - name: Install 36 | uses: posit-dev/setup-air@v1 37 | 38 | - name: Format 39 | run: air format . 40 | 41 | - name: Suggest 42 | uses: reviewdog/action-suggester@v1 43 | with: 44 | level: error 45 | fail_level: error 46 | tool_name: air 47 | -------------------------------------------------------------------------------- /tests/testthat/test-pslide.R: -------------------------------------------------------------------------------- 1 | test_that("An empty list() results in empty `ptype` returned", { 2 | expect_equal(pslide(list(), ~.x), list()) 3 | expect_equal(pslide_dbl(list(), ~.x), numeric()) 4 | expect_equal(pslide_vec(list(), ~.x, .ptype = 1:5), integer()) 5 | }) 6 | 7 | test_that("Recycling is carried out using tidyverse recycling rules", { 8 | x0 <- integer() 9 | x1 <- 1L 10 | x2 <- c(2L, 2L) 11 | x3 <- c(3L, 3L, 3L) 12 | 13 | expect_equal(pslide(list(x0, x0), ~.x), list()) 14 | expect_equal(pslide(list(x0, x1), ~.x), list()) 15 | expect_snapshot( 16 | (expect_error( 17 | pslide(list(x0, x2), ~.x), 18 | class = "vctrs_error_incompatible_size" 19 | )) 20 | ) 21 | expect_equal(pslide(list(x1, x1), ~.x), list(x1)) 22 | expect_equal(pslide(list(x1, x2), ~.x), list(x1, x1)) 23 | expect_snapshot( 24 | (expect_error( 25 | pslide(list(x2, x3), ~.x), 26 | class = "vctrs_error_incompatible_size" 27 | )) 28 | ) 29 | }) 30 | 31 | test_that("pslide() can iterate over a data frame", { 32 | x <- data.frame(x = 1:5, y = 6:10) 33 | expect_equal(pslide(x, ~ .x + .y), as.list(x$x + x$y)) 34 | }) 35 | 36 | test_that("pslide() can iterate over a data frame with a data frame column", { 37 | x <- data.frame(c1 = 1:2) 38 | x$x <- x 39 | 40 | expect_equal( 41 | pslide(x, ~ list(...)), 42 | list(as.list(vec_slice(x, 1)), as.list(vec_slice(x, 2))) 43 | ) 44 | }) 45 | 46 | test_that("pslide() requires a list-like input", { 47 | expect_snapshot(error = TRUE, pslide(1:5, ~.x)) 48 | }) 49 | 50 | test_that("pslide() forces arguments in the same way as base R / pmap()", { 51 | f_slide <- pslide( 52 | list(1:2, 1:2, 1:2), 53 | function(i, j, k) function(x) x + i + j + k 54 | ) 55 | f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) 56 | 57 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 58 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 59 | }) 60 | -------------------------------------------------------------------------------- /R/phop-index.R: -------------------------------------------------------------------------------- 1 | #' @include hop-index2.R 2 | #' @rdname hop_index2 3 | #' @export 4 | phop_index <- function(.l, .i, .starts, .stops, .f, ...) { 5 | phop_index_impl( 6 | .l, 7 | .i, 8 | .starts, 9 | .stops, 10 | .f, 11 | ..., 12 | .ptype = list(), 13 | .constrain = FALSE, 14 | .atomic = FALSE 15 | ) 16 | } 17 | 18 | #' @rdname hop_index2 19 | #' @export 20 | phop_index_vec <- function(.l, .i, .starts, .stops, .f, ..., .ptype = NULL) { 21 | out <- phop_index_impl( 22 | .l, 23 | .i, 24 | .starts, 25 | .stops, 26 | .f, 27 | ..., 28 | .ptype = list(), 29 | .constrain = FALSE, 30 | .atomic = TRUE 31 | ) 32 | 33 | vec_simplify(out, .ptype) 34 | } 35 | 36 | # ------------------------------------------------------------------------------ 37 | 38 | phop_index_impl <- function( 39 | .l, 40 | .i, 41 | .starts, 42 | .stops, 43 | .f, 44 | ..., 45 | .ptype, 46 | .constrain, 47 | .atomic, 48 | .slider_error_call = caller_env() 49 | ) { 50 | .l <- slider_check_list(.l, call = .slider_error_call) 51 | list_check_all_vectors(.l, call = .slider_error_call) 52 | 53 | .f <- as_function(.f, call = .slider_error_call) 54 | 55 | .l <- vec_recycle_common(!!!.l, .arg = ".l", .call = .slider_error_call) 56 | 57 | type <- vec_size(.l) 58 | 59 | slicers <- lapply( 60 | seq_len(type), 61 | function(x) { 62 | expr(.l[[!!x]]) 63 | } 64 | ) 65 | 66 | # Ensure names of `.l` are kept so they can be spliced 67 | # into `.f` as argument names 68 | names(slicers) <- names(.l) 69 | 70 | f_call <- expr(.f(!!!slicers, ...)) 71 | 72 | hop_index_common( 73 | x = .l, 74 | i = .i, 75 | starts = .starts, 76 | stops = .stops, 77 | f_call = f_call, 78 | ptype = .ptype, 79 | constrain = .constrain, 80 | atomic = .atomic, 81 | env = environment(), 82 | type = type, 83 | slider_error_call = .slider_error_call 84 | ) 85 | } 86 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions.md: -------------------------------------------------------------------------------- 1 | # output is verified 2 | 3 | Code 4 | check_index_incompatible_type(1, ".i") 5 | Condition 6 | Error: 7 | ! `.i` must be a , , or , not a number. 8 | 9 | --- 10 | 11 | Code 12 | check_endpoints_must_be_ascending(c(1, 2, 1, 3, 4, 2), ".starts") 13 | Condition 14 | Error: 15 | i In locations: 3 and 6 16 | ! `.starts` must be in ascending order. 17 | 18 | --- 19 | 20 | Code 21 | check_generated_endpoints_cannot_be_na(c(NA, 1, NA), ".before") 22 | Condition 23 | Error: 24 | i In locations: 1 and 3 25 | ! Endpoints generated by `.before` can't be `NA`. 26 | 27 | --- 28 | 29 | Code 30 | check_endpoints_cannot_be_na(c(NA, 1, NA), ".starts") 31 | Condition 32 | Error: 33 | i In locations: 1 and 3 34 | ! `.starts` can't be `NA`. 35 | 36 | --- 37 | 38 | Code 39 | check_index_must_be_ascending(c(1, 2, 1, 4, 5, 3), ".i") 40 | Condition 41 | Error: 42 | i In locations: 3 and 6 43 | ! `.i` must be in ascending order. 44 | 45 | --- 46 | 47 | Code 48 | check_index_cannot_be_na(c(NA, 1, NA), ".i") 49 | Condition 50 | Error: 51 | i In locations: 1 and 3 52 | ! `.i` can't be `NA`. 53 | 54 | --- 55 | 56 | Code 57 | stop_index_incompatible_size(1, 2, ".i") 58 | Condition 59 | Error: 60 | ! `.i` must have size 2, not 1. 61 | 62 | # class names are collapsed 63 | 64 | Code 65 | check_index_incompatible_type(x, ".i") 66 | Condition 67 | Error: 68 | ! `.i` must be a , , or , not a object. 69 | 70 | # trimming works 71 | 72 | Code 73 | check_index_cannot_be_na(rep(NA, 100), ".i") 74 | Condition 75 | Error: 76 | i In locations: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, ..., 99, and 100 77 | ! `.i` can't be `NA`. 78 | 79 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: slider 2 | Title: Sliding Window Functions 3 | Version: 0.3.3.9000 4 | Authors@R: c( 5 | person("Davis", "Vaughan", , "davis@posit.co", role = c("aut", "cre")), 6 | person("Posit Software, PBC", role = c("cph", "fnd"), 7 | comment = c(ROR = "03wc8by49")) 8 | ) 9 | Description: Provides type-stable rolling window functions over any R data 10 | type. Cumulative and expanding windows are also supported. For more 11 | advanced usage, an index can be used as a secondary vector that 12 | defines how sliding windows are to be created. 13 | License: MIT + file LICENSE 14 | URL: https://github.com/r-lib/slider, https://slider.r-lib.org 15 | BugReports: https://github.com/r-lib/slider/issues 16 | Depends: 17 | R (>= 4.0.0) 18 | Imports: 19 | cli (>= 3.6.1), 20 | rlang (>= 1.1.1), 21 | vctrs (>= 0.6.3), 22 | warp 23 | Suggests: 24 | covr, 25 | dplyr (>= 1.0.0), 26 | knitr, 27 | lubridate, 28 | rmarkdown, 29 | testthat (>= 3.0.0) 30 | LinkingTo: 31 | vctrs (>= 0.6.3) 32 | VignetteBuilder: 33 | knitr 34 | Config/build/compilation-database: true 35 | Config/Needs/website: tidyverse/tidytemplate 36 | Config/testthat/edition: 3 37 | Config/usethis/last-upkeep: 2025-11-13 38 | Encoding: UTF-8 39 | Roxygen: list(markdown = TRUE) 40 | RoxygenNote: 7.3.3 41 | Collate: 42 | 'arithmetic.R' 43 | 'block.R' 44 | 'conditions.R' 45 | 'hop-common.R' 46 | 'hop-index-common.R' 47 | 'hop-index.R' 48 | 'hop-index2.R' 49 | 'hop.R' 50 | 'hop2.R' 51 | 'phop-index.R' 52 | 'phop.R' 53 | 'slide-index2.R' 54 | 'pslide-index.R' 55 | 'slide-period2.R' 56 | 'pslide-period.R' 57 | 'slide2.R' 58 | 'pslide.R' 59 | 'segment-tree.R' 60 | 'slide-common.R' 61 | 'slide-index-common.R' 62 | 'slide-index.R' 63 | 'slide-period-common.R' 64 | 'slide-period.R' 65 | 'slide.R' 66 | 'slider-package.R' 67 | 'summary-index.R' 68 | 'summary-slide.R' 69 | 'utils.R' 70 | 'zzz.R' 71 | -------------------------------------------------------------------------------- /tests/testthat/test-hop2-vec.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # hop2_vec 3 | 4 | test_that("hop2_vec() works", { 5 | expect_identical(hop2_vec(1L, 1L, 1, 1, ~ .x + .y), 2L) 6 | }) 7 | 8 | test_that("hop2_vec() doesn't retains names of x (#75)", { 9 | expect_named(hop2_vec(c(x = 1L), c(y = 1L), 1, 1, ~ .x + .y), NULL) 10 | }) 11 | 12 | test_that("hop2_vec() can simplify automatically", { 13 | expect_identical(hop2_vec(1, 2, 1, 1, ~ .x + .y, .ptype = NULL), 3) 14 | }) 15 | 16 | test_that("hop2_vec() errors if it can't simplify", { 17 | fn <- function(x, y) { 18 | if (x == 1L) { 19 | 1 20 | } else { 21 | "hi" 22 | } 23 | } 24 | expect_snapshot(error = TRUE, hop2_vec(1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL)) 25 | }) 26 | 27 | # ------------------------------------------------------------------------------ 28 | # .ptype 29 | 30 | test_that("`.ptype = NULL` validates that element lengths are 1", { 31 | expect_snapshot(error = TRUE, { 32 | hop2_vec( 33 | 1:2, 34 | 1:2, 35 | 1:2, 36 | 1:2, 37 | ~ if (.x == 1L) { 38 | 1:2 39 | } else { 40 | 1 41 | }, 42 | .ptype = NULL 43 | ) 44 | }) 45 | expect_snapshot(error = TRUE, { 46 | hop2_vec( 47 | 1:2, 48 | 1:2, 49 | 1:2, 50 | 1:2, 51 | ~ if (.x == 1L) { 52 | NULL 53 | } else { 54 | 2 55 | }, 56 | .ptype = NULL 57 | ) 58 | }) 59 | }) 60 | 61 | test_that("`hop2_vec()` falls back to `c()` method as required", { 62 | local_c_foobar() 63 | 64 | expect_identical( 65 | hop2_vec(1:3, 1:3, 1:3, 1:3, ~ foobar(.x), .ptype = foobar(integer())), 66 | foobar(1:3) 67 | ) 68 | expect_condition( 69 | hop2_vec(1:3, 1:3, 1:3, 1:3, ~ foobar(.x), .ptype = foobar(integer())), 70 | class = "slider_c_foobar" 71 | ) 72 | 73 | expect_identical(hop2_vec(1:3, 1:3, 1:3, 1:3, ~ foobar(.x)), foobar(1:3)) 74 | expect_condition( 75 | hop2_vec(1:3, 1:3, 1:3, 1:3, ~ foobar(.x)), 76 | class = "slider_c_foobar" 77 | ) 78 | }) 79 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | 8 | name: test-coverage.yaml 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | test-coverage: 14 | runs-on: ubuntu-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | 18 | steps: 19 | - uses: actions/checkout@v4 20 | 21 | - uses: r-lib/actions/setup-r@v2 22 | with: 23 | use-public-rspm: true 24 | 25 | - uses: r-lib/actions/setup-r-dependencies@v2 26 | with: 27 | extra-packages: any::covr, any::xml2 28 | needs: coverage 29 | 30 | - name: Test coverage 31 | run: | 32 | cov <- covr::package_coverage( 33 | quiet = FALSE, 34 | clean = FALSE, 35 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 36 | ) 37 | print(cov) 38 | covr::to_cobertura(cov) 39 | shell: Rscript {0} 40 | 41 | - uses: codecov/codecov-action@v5 42 | with: 43 | # Fail if error if not on PR, or if on PR and token is given 44 | fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} 45 | files: ./cobertura.xml 46 | plugins: noop 47 | disable_search: true 48 | token: ${{ secrets.CODECOV_TOKEN }} 49 | 50 | - name: Show testthat output 51 | if: always() 52 | run: | 53 | ## -------------------------------------------------------------------- 54 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 55 | shell: bash 56 | 57 | - name: Upload test results 58 | if: failure() 59 | uses: actions/upload-artifact@v4 60 | with: 61 | name: coverage-test-failures 62 | path: ${{ runner.temp }}/package 63 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | 12 | name: R-CMD-check.yaml 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | R-CMD-check: 18 | runs-on: ${{ matrix.config.os }} 19 | 20 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 21 | 22 | strategy: 23 | fail-fast: false 24 | matrix: 25 | config: 26 | - {os: macos-latest, r: 'release'} 27 | 28 | - {os: windows-latest, r: 'release'} 29 | # use 4.0 or 4.1 to check with rtools40's older compiler 30 | - {os: windows-latest, r: 'oldrel-4'} 31 | 32 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 33 | - {os: ubuntu-latest, r: 'release'} 34 | - {os: ubuntu-latest, r: 'oldrel-1'} 35 | - {os: ubuntu-latest, r: 'oldrel-2'} 36 | - {os: ubuntu-latest, r: 'oldrel-3'} 37 | - {os: ubuntu-latest, r: 'oldrel-4'} 38 | 39 | env: 40 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 41 | R_KEEP_PKG_SOURCE: yes 42 | 43 | steps: 44 | - uses: actions/checkout@v4 45 | 46 | - uses: r-lib/actions/setup-pandoc@v2 47 | 48 | - uses: r-lib/actions/setup-r@v2 49 | with: 50 | r-version: ${{ matrix.config.r }} 51 | http-user-agent: ${{ matrix.config.http-user-agent }} 52 | use-public-rspm: true 53 | 54 | - uses: r-lib/actions/setup-r-dependencies@v2 55 | with: 56 | extra-packages: any::rcmdcheck 57 | needs: check 58 | 59 | - uses: r-lib/actions/check-r-package@v2 60 | with: 61 | upload-snapshots: true 62 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 63 | -------------------------------------------------------------------------------- /R/hop-index-common.R: -------------------------------------------------------------------------------- 1 | hop_index_common <- function( 2 | x, 3 | i, 4 | starts, 5 | stops, 6 | f_call, 7 | ptype, 8 | constrain, 9 | atomic, 10 | env, 11 | type, 12 | slider_error_call 13 | ) { 14 | x_size <- compute_size(x, type) 15 | i_size <- vec_size(i) 16 | 17 | if (i_size != x_size) { 18 | stop_index_incompatible_size(i_size, x_size, ".i", call = slider_error_call) 19 | } 20 | 21 | check_index_cannot_be_na(i, ".i", call = slider_error_call) 22 | check_index_must_be_ascending(i, ".i", call = slider_error_call) 23 | 24 | check_endpoints_cannot_be_na(starts, ".starts", call = slider_error_call) 25 | check_endpoints_must_be_ascending(starts, ".starts", call = slider_error_call) 26 | 27 | check_endpoints_cannot_be_na(stops, ".stops", call = slider_error_call) 28 | check_endpoints_must_be_ascending(stops, ".stops", call = slider_error_call) 29 | 30 | # `i` is known to be ascending, 31 | # so we can detect uniques very quickly with `vec_unrep()` 32 | unrep <- vec_unrep(i) 33 | i <- unrep$key 34 | peer_sizes <- unrep$times 35 | 36 | starts <- vec_cast( 37 | starts, 38 | i, 39 | x_arg = ".starts", 40 | to_arg = ".i", 41 | call = slider_error_call 42 | ) 43 | stops <- vec_cast( 44 | stops, 45 | i, 46 | x_arg = ".stops", 47 | to_arg = ".i", 48 | call = slider_error_call 49 | ) 50 | 51 | size <- vec_size_common( 52 | .starts = starts, 53 | .stops = stops, 54 | .call = slider_error_call 55 | ) 56 | args <- vec_recycle_common( 57 | .starts = starts, 58 | .stops = stops, 59 | .size = size, 60 | .call = slider_error_call 61 | ) 62 | starts <- args$.starts 63 | stops <- args$.stops 64 | 65 | args <- compute_combined_ranks(i = i, starts = starts, stops = stops) 66 | i <- args$i 67 | starts <- args$starts 68 | stops <- args$stops 69 | 70 | .Call( 71 | hop_index_common_impl, 72 | x, 73 | i, 74 | starts, 75 | stops, 76 | f_call, 77 | ptype, 78 | env, 79 | peer_sizes, 80 | type, 81 | constrain, 82 | atomic, 83 | size 84 | ) 85 | } 86 | -------------------------------------------------------------------------------- /src/segment-tree.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_SEGMENT_TREE 2 | #define SLIDER_SEGMENT_TREE 3 | 4 | #include "slider.h" 5 | 6 | #define SEGMENT_TREE_FANOUT 16 7 | #define SEGMENT_TREE_FANOUT_POWER 4 8 | 9 | struct segment_tree { 10 | const void* p_leaves; 11 | 12 | SEXP p_level; 13 | void** p_p_level; 14 | 15 | SEXP nodes; 16 | void* p_nodes; 17 | 18 | void* p_state; 19 | 20 | uint64_t n_leaves; 21 | uint64_t n_levels; 22 | uint64_t n_nodes; 23 | 24 | void (*state_reset)(void* p_state); 25 | void (*state_finalize)(void* p_state, void* p_result); 26 | 27 | void* (*nodes_increment)(void* p_nodes); 28 | 29 | void (*aggregate_from_leaves)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest); 30 | void (*aggregate_from_nodes)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest); 31 | }; 32 | 33 | #define PROTECT_SEGMENT_TREE(p_tree, p_n) do { \ 34 | PROTECT((p_tree)->p_level); \ 35 | PROTECT((p_tree)->nodes); \ 36 | *(p_n) += 2; \ 37 | } while(0) 38 | 39 | 40 | struct segment_tree new_segment_tree(uint64_t n_leaves, 41 | const void* p_leaves, 42 | void* p_state, 43 | void (*state_reset)(void* p_state), 44 | void (*state_finalize)(void* p_state, void* p_result), 45 | void* (*nodes_increment)(void* p_nodes), 46 | SEXP (*nodes_initialize)(uint64_t n), 47 | void* (*nodes_void_deref)(SEXP nodes), 48 | void (*aggregate_from_leaves)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest), 49 | void (*aggregate_from_nodes)(const void* p_source, uint64_t begin, uint64_t end, void* p_dest)); 50 | 51 | void segment_tree_aggregate(const struct segment_tree* p_tree, 52 | uint64_t begin, 53 | uint64_t end, 54 | void* p_result); 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /tests/testthat/test-phop.R: -------------------------------------------------------------------------------- 1 | test_that("Empty starts/stops results in empty `ptype` returned", { 2 | expect_equal(phop(list(1), integer(), integer(), ~.x), list()) 3 | expect_equal( 4 | phop_vec(list(1), integer(), integer(), ~.x, .ptype = integer()), 5 | integer() 6 | ) 7 | }) 8 | 9 | test_that("Recycling is carried out using tidyverse recycling rules", { 10 | x0 <- integer() 11 | x1 <- 1L 12 | x2 <- c(2L, 2L) 13 | x3 <- c(3L, 3L, 3L) 14 | 15 | expect_equal(phop(list(x0, x0), integer(), integer(), ~.x), list()) 16 | expect_equal(phop(list(x0, x0), 1, 1, ~.x), list(integer())) 17 | expect_equal(phop(list(x0, x1), integer(), integer(), ~.x), list()) 18 | expect_equal(phop(list(x0, x1), 1, 1, ~.x), list(integer())) 19 | expect_snapshot( 20 | (expect_error( 21 | phop(list(x0, x2), 1, 1, ~.x), 22 | class = "vctrs_error_incompatible_size" 23 | )) 24 | ) 25 | expect_equal(phop(list(x1, x1), 1, 1, ~.x), list(x1)) 26 | expect_equal(phop(list(x1, x2), 1:2, 1:2, ~.x), list(x1, x1)) 27 | expect_snapshot( 28 | (expect_error( 29 | phop(list(x2, x3), 1:3, 1:3, ~.x), 30 | class = "vctrs_error_incompatible_size" 31 | )) 32 | ) 33 | }) 34 | 35 | test_that("phop() can iterate over a data frame", { 36 | x <- data.frame(x = 1:5, y = 6:10) 37 | expect_equal(phop(x, 1:5, 1:5, ~ .x + .y), as.list(x$x + x$y)) 38 | }) 39 | 40 | test_that("phop() can iterate over a data frame with a data frame column", { 41 | x <- data.frame(c1 = 1:2) 42 | x$x <- x 43 | 44 | expect_equal( 45 | phop(x, 1:2, 1:2, ~ list(...)), 46 | list(as.list(vec_slice(x, 1)), as.list(vec_slice(x, 2))) 47 | ) 48 | }) 49 | 50 | test_that("phop() requires a list-like input", { 51 | expect_snapshot(error = TRUE, phop(1:5, ~.x)) 52 | }) 53 | 54 | test_that("phop() forces arguments in the same way as base R / pmap()", { 55 | f_slide <- phop( 56 | list(1:2, 1:2, 1:2), 57 | 1:2, 58 | 1:2, 59 | function(i, j, k) function(x) x + i + j + k 60 | ) 61 | f_base <- mapply(function(i, j, k) function(x) x + i + j + k, 1:2, 1:2, 1:2) 62 | 63 | expect_equal(f_slide[[1]](0), f_base[[1]](0)) 64 | expect_equal(f_slide[[2]](0), f_base[[2]](0)) 65 | }) 66 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop-index-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | (expect_error(hop_index_vec(1, 1, 1, 1, ~ c(.x, 1)))) 5 | Output 6 | 7 | Error: 8 | i In index: 1 9 | ! The result of `.f` must have size 1, not 2. 10 | 11 | # inner type can be restricted with list_of 12 | 13 | Code 14 | (expect_error(hop_index_vec(1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 15 | list_of(1) 16 | } else { 17 | list_of("hi") 18 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 19 | ) 20 | Output 21 | 22 | Error in `hop_index_vec()`: 23 | ! Can't convert `..1` to . 24 | 25 | # `.ptype = NULL` fails if no common type is found 26 | 27 | Code 28 | (expect_error(hop_index_vec(1:2, 1:2, 1:2, 1:2, ~ ifelse(.x == 1L, "hello", 1), 29 | .ptype = NULL), class = "vctrs_error_incompatible_type")) 30 | Output 31 | 32 | Error in `hop_index_vec()`: 33 | ! Can't combine `out[[1]]` and `out[[2]]` . 34 | 35 | # `.ptype = NULL` validates that element lengths are 1 36 | 37 | Code 38 | (expect_error(hop_index_vec(1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 39 | 1:2 40 | } else { 41 | 1 42 | }, .ptype = NULL))) 43 | Output 44 | 45 | Error: 46 | i In index: 1 47 | ! The result of `.f` must have size 1, not 2. 48 | Code 49 | (expect_error(hop_index_vec(1:2, 1:2, 1:2, 1:2, ~ if (.x == 1L) { 50 | NULL 51 | } else { 52 | 2 53 | }, .ptype = NULL))) 54 | Output 55 | 56 | Error: 57 | i In index: 1 58 | ! The result of `.f` must have size 1, not 0. 59 | 60 | # `.ptype = NULL` errors with non recyclable starts/stops 61 | 62 | Code 63 | (expect_error(hop_index_vec(integer(), integer(), integer(), 1:2, ~.x, .ptype = NULL), 64 | class = "vctrs_error_incompatible_size")) 65 | Output 66 | 67 | Error in `hop_index_vec()`: 68 | ! Can't recycle `.starts` (size 0) to match `.stops` (size 2). 69 | 70 | -------------------------------------------------------------------------------- /man/index-arithmetic.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/arithmetic.R 3 | \name{index-arithmetic} 4 | \alias{index-arithmetic} 5 | \alias{slider_plus} 6 | \alias{slider_minus} 7 | \title{Index arithmetic} 8 | \usage{ 9 | slider_plus(x, y) 10 | 11 | slider_minus(x, y) 12 | } 13 | \arguments{ 14 | \item{x, y}{\verb{[vector]} 15 | 16 | Two vectors to add or subtract. 17 | 18 | \code{x} will always be the index, \code{.i}. 19 | 20 | For \code{slider_plus()}, \code{y} will be \code{.after}. 21 | 22 | For \code{slider_minus()}, \code{y} will be \code{.before}.} 23 | } 24 | \value{ 25 | \itemize{ 26 | \item For \code{slider_plus()}, \code{x} after adding \code{y}. 27 | \item For \code{slider_minus()}, \code{x} after subtracting \code{y}. 28 | } 29 | 30 | The result should always be the same type and size as \code{x}. 31 | } 32 | \description{ 33 | \code{slider_plus()} and \code{slider_minus()} are developer functions used to register 34 | special double dispatch methods to control how \code{.before} and \code{.after} are 35 | subtracted from and added to \code{.i}. These allow developers to overcome some of 36 | the restrictions around \code{+} and \code{-} when custom S3 types are involved. These 37 | should only be used by package authors creating new index types. 38 | \itemize{ 39 | \item \code{slider_plus()} allows you to override the default behavior of 40 | \code{.i + .after}. When writing the S3 method, \code{x} will be \code{.i}, and \code{y} will 41 | be \code{.after}. 42 | \item \code{slider_minus()} allows you to override the default behavior of 43 | \code{.i - .before}. When writing the S3 method, \code{x} will be \code{.i}, and \code{y} will 44 | be \code{.before}. 45 | } 46 | 47 | These generics are a bit special. They work similarly to 48 | \code{\link[vctrs:vec_ptype2]{vctrs::vec_ptype2()}} in that they are \emph{double dispatch} methods that 49 | dispatch off the types of both \code{x} and \code{y}. To write an S3 method for these 50 | generics, write and export an S3 method of the form: 51 | 52 | \if{html}{\out{
}}\preformatted{slider_plus.x_class.y_class <- function(x, y) \{ 53 | # My method 54 | \} 55 | }\if{html}{\out{
}} 56 | 57 | Inheritance is not considered in the method lookup, and you cannot use 58 | \code{NextMethod()} from within your method. 59 | } 60 | \examples{ 61 | slider_plus(1, 2) 62 | slider_minus(1, 2) 63 | } 64 | \keyword{internal} 65 | -------------------------------------------------------------------------------- /src/slide-period.c: -------------------------------------------------------------------------------- 1 | #include "slider.h" 2 | 3 | // ----------------------------------------------------------------------------- 4 | 5 | static SEXP compute_from(SEXP starts, double first, R_xlen_t n, bool before_unbounded); 6 | 7 | // [[ export() ]] 8 | SEXP slider_compute_from(SEXP starts, SEXP first, SEXP n, SEXP before_unbounded) { 9 | double first_ = REAL(first)[0]; 10 | 11 | // Support long vectors 12 | R_xlen_t n_; 13 | 14 | switch(TYPEOF(n)) { 15 | case REALSXP: n_ = REAL(n)[0]; break; 16 | case INTSXP: n_ = (double) INTEGER(n)[0]; break; 17 | default: Rf_errorcall(R_NilValue, "Internal error: `n` should be integer or double."); 18 | } 19 | 20 | bool before_unbounded_ = LOGICAL(before_unbounded)[0]; 21 | 22 | return compute_from(starts, first_, n_, before_unbounded_); 23 | } 24 | 25 | static SEXP compute_from(SEXP starts, double first, R_xlen_t n, bool before_unbounded) { 26 | double* p_starts = REAL(starts); 27 | 28 | R_xlen_t from = 1; 29 | 30 | if (before_unbounded) { 31 | return(Rf_ScalarReal(from)); 32 | } 33 | 34 | for (R_xlen_t i = 0; i < n; ++i) { 35 | if (first > p_starts[i]) { 36 | ++from; 37 | } else { 38 | break; 39 | } 40 | } 41 | 42 | return Rf_ScalarReal(from); 43 | } 44 | 45 | // ----------------------------------------------------------------------------- 46 | 47 | static SEXP compute_to(SEXP stops, double last, R_xlen_t n, bool after_unbounded); 48 | 49 | // [[ export() ]] 50 | SEXP slider_compute_to(SEXP stops, SEXP last, SEXP n, SEXP after_unbounded) { 51 | double last_ = REAL(last)[0]; 52 | 53 | // Support long vectors 54 | R_xlen_t n_; 55 | 56 | switch(TYPEOF(n)) { 57 | case REALSXP: n_ = REAL(n)[0]; break; 58 | case INTSXP: n_ = (double) INTEGER(n)[0]; break; 59 | default: Rf_errorcall(R_NilValue, "Internal error: `n` should be integer or double."); 60 | } 61 | 62 | bool after_unbounded_ = LOGICAL(after_unbounded)[0]; 63 | 64 | return compute_to(stops, last_, n_, after_unbounded_); 65 | } 66 | 67 | static SEXP compute_to(SEXP stops, double last, R_xlen_t n, bool after_unbounded) { 68 | double* p_stops = REAL(stops); 69 | 70 | R_xlen_t to = n; 71 | 72 | if (after_unbounded) { 73 | return(Rf_ScalarReal(to)); 74 | } 75 | 76 | for (R_xlen_t i = n - 1; i >= 0; --i) { 77 | if (last < p_stops[i]) { 78 | --to; 79 | } else { 80 | break; 81 | } 82 | } 83 | 84 | return Rf_ScalarReal(to); 85 | } 86 | -------------------------------------------------------------------------------- /tests/testthat/test-phop-vec.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # phop_vec 3 | 4 | test_that("phop_vec() works", { 5 | expect_identical(phop_vec(list(1L, 1L), 1, 1, ~ .x + .y), 2L) 6 | }) 7 | 8 | test_that("phop_vec() doesn't retains names of first input (#75)", { 9 | expect_named(phop_vec(list(c(x = 1L), c(y = 1L)), 1, 1, ~ .x + .y), NULL) 10 | }) 11 | 12 | test_that("phop_vec() can simplify automatically", { 13 | expect_identical(phop_vec(list(1, 2), 1, 1, ~ .x + .y, .ptype = NULL), 3) 14 | }) 15 | 16 | test_that("phop_vec() errors if it can't simplify", { 17 | fn <- function(x, y) { 18 | if (x == 1L) { 19 | 1 20 | } else { 21 | "hi" 22 | } 23 | } 24 | expect_snapshot({ 25 | (expect_error( 26 | phop_vec(list(1:2, 1:2), 1:2, 1:2, fn, .ptype = NULL), 27 | class = "vctrs_error_incompatible_type" 28 | )) 29 | }) 30 | }) 31 | 32 | # ------------------------------------------------------------------------------ 33 | # .ptype 34 | 35 | test_that("`.ptype = NULL` validates that element lengths are 1", { 36 | expect_snapshot({ 37 | (expect_error( 38 | phop_vec( 39 | list(1:2, 1:2), 40 | 1:2, 41 | 1:2, 42 | ~ if (.x == 1L) { 43 | 1:2 44 | } else { 45 | 1 46 | }, 47 | .ptype = NULL 48 | ) 49 | )) 50 | (expect_error( 51 | phop_vec( 52 | list(1:2, 1:2), 53 | 1:2, 54 | 1:2, 55 | ~ if (.x == 1L) { 56 | NULL 57 | } else { 58 | 2 59 | }, 60 | .ptype = NULL 61 | ) 62 | )) 63 | }) 64 | }) 65 | 66 | test_that("`phop_vec()` falls back to `c()` method as required", { 67 | local_c_foobar() 68 | 69 | expect_identical( 70 | phop_vec( 71 | list(1:3, 1:3), 72 | 1:3, 73 | 1:3, 74 | ~ foobar(.x), 75 | .ptype = foobar(integer()) 76 | ), 77 | foobar(1:3) 78 | ) 79 | expect_condition( 80 | phop_vec( 81 | list(1:3, 1:3), 82 | 1:3, 83 | 1:3, 84 | ~ foobar(.x), 85 | .ptype = foobar(integer()) 86 | ), 87 | class = "slider_c_foobar" 88 | ) 89 | 90 | expect_identical( 91 | phop_vec(list(1:3, 1:3), 1:3, 1:3, ~ foobar(.x)), 92 | foobar(1:3) 93 | ) 94 | expect_condition( 95 | phop_vec(list(1:3, 1:3), 1:3, 1:3, ~ foobar(.x)), 96 | class = "slider_c_foobar" 97 | ) 98 | }) 99 | -------------------------------------------------------------------------------- /tests/testthat/test-conditions.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # stop_index_incompatible_type() 3 | 4 | test_that("output is verified", { 5 | expect_snapshot(error = TRUE, check_index_incompatible_type(1, ".i")) 6 | }) 7 | 8 | test_that("class names are collapsed", { 9 | x <- structure(1, class = c("foo", "bar", "baz")) 10 | expect_snapshot(error = TRUE, check_index_incompatible_type(x, ".i")) 11 | }) 12 | 13 | # ------------------------------------------------------------------------------ 14 | # stop_endpoints_must_be_ascending() 15 | 16 | test_that("output is verified", { 17 | expect_snapshot(error = TRUE, { 18 | check_endpoints_must_be_ascending(c(1, 2, 1, 3, 4, 2), ".starts") 19 | }) 20 | }) 21 | 22 | # ------------------------------------------------------------------------------ 23 | # stop_generated_endpoints_cannot_be_na() 24 | 25 | test_that("output is verified", { 26 | expect_snapshot(error = TRUE, { 27 | check_generated_endpoints_cannot_be_na(c(NA, 1, NA), ".before") 28 | }) 29 | }) 30 | 31 | # ------------------------------------------------------------------------------ 32 | # stop_endpoints_cannot_be_na() 33 | 34 | test_that("output is verified", { 35 | expect_snapshot(error = TRUE, { 36 | check_endpoints_cannot_be_na(c(NA, 1, NA), ".starts") 37 | }) 38 | }) 39 | 40 | # ------------------------------------------------------------------------------ 41 | # stop_index_must_be_ascending() 42 | 43 | test_that("output is verified", { 44 | expect_snapshot(error = TRUE, { 45 | check_index_must_be_ascending(c(1, 2, 1, 4, 5, 3), ".i") 46 | }) 47 | }) 48 | 49 | test_that("not assuming strictly ascending", { 50 | expect_silent(check_index_must_be_ascending(c(1, 1))) 51 | }) 52 | 53 | # ------------------------------------------------------------------------------ 54 | # stop_index_cannot_be_na() 55 | 56 | test_that("output is verified", { 57 | expect_snapshot(error = TRUE, { 58 | check_index_cannot_be_na(c(NA, 1, NA), ".i") 59 | }) 60 | }) 61 | 62 | test_that("trimming works", { 63 | expect_snapshot(error = TRUE, { 64 | check_index_cannot_be_na(rep(NA, 100), ".i") 65 | }) 66 | }) 67 | 68 | # ------------------------------------------------------------------------------ 69 | # stop_index_incompatible_size() 70 | 71 | test_that("output is verified", { 72 | expect_snapshot(error = TRUE, { 73 | stop_index_incompatible_size(1, 2, ".i") 74 | }) 75 | }) 76 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | slide_vec(1:2, ~ c(.x, 1)) 5 | Condition 6 | Error: 7 | i In index: 1 8 | ! The result of `.f` must have size 1, not 2. 9 | 10 | --- 11 | 12 | Code 13 | slide_dbl(1:2, ~ c(.x, 1)) 14 | Condition 15 | Error: 16 | i In index: 1 17 | ! The result of `.f` must have size 1, not 2. 18 | 19 | # inner type can be restricted with list_of 20 | 21 | Code 22 | (expect_error(slide_vec(1:2, ~ if (.x == 1L) { 23 | list_of(1) 24 | } else { 25 | list_of("hi") 26 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 27 | ) 28 | Output 29 | 30 | Error in `slide_vec()`: 31 | ! Can't convert `..1` to . 32 | 33 | # inner type can be restricted 34 | 35 | Code 36 | (expect_error(slide_dbl(1:2, ~ if (.x == 1L) { 37 | 1 38 | } else { 39 | "x" 40 | }), class = "vctrs_error_incompatible_type")) 41 | Output 42 | 43 | Error: 44 | ! Can't convert to . 45 | 46 | # .ptype is respected 47 | 48 | Code 49 | (expect_error(slide_vec(1, ~ .x + 0.5, .ptype = integer()), class = "vctrs_error_cast_lossy") 50 | ) 51 | Output 52 | 53 | Error in `slide_vec()`: 54 | ! Can't convert from `out[[1]]` to due to loss of precision. 55 | * Locations: 1 56 | 57 | # `.ptype = NULL` fails if no common type is found 58 | 59 | Code 60 | (expect_error(slide_vec(1:2, ~ ifelse(.x == 1L, "hello", 1), .ptype = NULL), 61 | class = "vctrs_error_incompatible_type")) 62 | Output 63 | 64 | Error in `slide_vec()`: 65 | ! Can't combine `out[[1]]` and `out[[2]]` . 66 | 67 | # `.ptype = NULL` validates that element lengths are 1 68 | 69 | Code 70 | slide_vec(1:2, ~ if (.x == 1L) { 71 | 1:2 72 | } else { 73 | 1 74 | }, .ptype = NULL) 75 | Condition 76 | Error: 77 | i In index: 1 78 | ! The result of `.f` must have size 1, not 2. 79 | 80 | # slide_chr() cannot coerce 81 | 82 | Code 83 | (expect_error(slide_chr(1, ~.x), class = "vctrs_error_incompatible_type")) 84 | Output 85 | 86 | Error: 87 | ! Can't convert to . 88 | 89 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-index-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | slide_index_vec(1:2, 1:2, ~ c(.x, 1)) 5 | Condition 6 | Error: 7 | i In index: 1 8 | ! The result of `.f` must have size 1, not 2. 9 | 10 | --- 11 | 12 | Code 13 | slide_index_dbl(1:2, 1:2, ~ c(.x, 1)) 14 | Condition 15 | Error: 16 | i In index: 1 17 | ! The result of `.f` must have size 1, not 2. 18 | 19 | # inner type can be restricted with list_of 20 | 21 | Code 22 | (expect_error(slide_index_vec(1:2, 1:2, ~ if (.x == 1L) { 23 | list_of(1) 24 | } else { 25 | list_of("hi") 26 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 27 | ) 28 | Output 29 | 30 | Error in `slide_index_vec()`: 31 | ! Can't convert `..1` to . 32 | 33 | # type of suffixed versions can be restricted 34 | 35 | Code 36 | (expect_error(slide_index_dbl(1:2, 1:2, ~ if (.x == 1L) { 37 | 1 38 | } else { 39 | "hi" 40 | }), class = "vctrs_error_incompatible_type")) 41 | Output 42 | 43 | Error: 44 | ! Can't convert to . 45 | 46 | # .ptype is respected 47 | 48 | Code 49 | (expect_error(slide_index_vec(1, 1, ~ .x + 0.5, .ptype = integer()), class = "vctrs_error_cast_lossy") 50 | ) 51 | Output 52 | 53 | Error in `slide_index_vec()`: 54 | ! Can't convert from `out[[1]]` to due to loss of precision. 55 | * Locations: 1 56 | 57 | # `.ptype = NULL` fails if no common type is found 58 | 59 | Code 60 | (expect_error(slide_index_vec(1:2, 1:2, ~ ifelse(.x == 1L, "hello", 1), .ptype = NULL), 61 | class = "vctrs_error_incompatible_type")) 62 | Output 63 | 64 | Error in `slide_index_vec()`: 65 | ! Can't combine `out[[1]]` and `out[[2]]` . 66 | 67 | # `.ptype = NULL` validates that element lengths are 1 68 | 69 | Code 70 | slide_index_vec(1:2, 1:2, ~ if (.x == 1L) { 71 | 1:2 72 | } else { 73 | 1 74 | }, .ptype = NULL) 75 | Condition 76 | Error: 77 | i In index: 1 78 | ! The result of `.f` must have size 1, not 2. 79 | 80 | # slide_index_chr() cannot coerce 81 | 82 | Code 83 | (expect_error(slide_index_chr(1, 1, ~.x), class = "vctrs_error_incompatible_type") 84 | ) 85 | Output 86 | 87 | Error: 88 | ! Can't convert to . 89 | 90 | -------------------------------------------------------------------------------- /.github/workflows/rhub.yaml: -------------------------------------------------------------------------------- 1 | # R-hub's genetic GitHub Actions workflow file. It's canonical location is at 2 | # https://github.com/r-hub/rhub2/blob/v1/inst/workflow/rhub.yaml 3 | # You can update this file to a newer version using the rhub2 package: 4 | # 5 | # rhub2::rhub_setup() 6 | # 7 | # It is unlikely that you need to modify this file manually. 8 | 9 | name: R-hub 10 | run-name: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }} (${{ github.event.inputs.id }}) 11 | 12 | on: 13 | workflow_dispatch: 14 | inputs: 15 | config: 16 | description: 'A comma separated list of R-hub platforms to use.' 17 | type: string 18 | default: 'linux,windows,macos' 19 | name: 20 | description: 'Run name. You can leave this empty now.' 21 | type: string 22 | id: 23 | description: 'Unique ID. You can leave this empty now.' 24 | type: string 25 | 26 | jobs: 27 | 28 | setup: 29 | runs-on: ubuntu-latest 30 | outputs: 31 | containers: ${{ steps.rhub-setup.outputs.containers }} 32 | platforms: ${{ steps.rhub-setup.outputs.platforms }} 33 | 34 | steps: 35 | # NO NEED TO CHECKOUT HERE 36 | - uses: r-hub/rhub2/actions/rhub-setup@v1 37 | with: 38 | config: ${{ github.event.inputs.config }} 39 | id: rhub-setup 40 | 41 | linux-containers: 42 | needs: setup 43 | if: ${{ needs.setup.outputs.containers != '[]' }} 44 | runs-on: ubuntu-latest 45 | name: ${{ matrix.config.label }} 46 | strategy: 47 | fail-fast: false 48 | matrix: 49 | config: ${{ fromJson(needs.setup.outputs.containers) }} 50 | container: 51 | image: ${{ matrix.config.container }} 52 | 53 | steps: 54 | - uses: actions/checkout@v3 55 | - uses: r-hub/rhub2/actions/rhub-check@v1 56 | with: 57 | token: ${{ secrets.RHUB_TOKEN }} 58 | job-config: ${{ matrix.config.job-config }} 59 | 60 | other-platforms: 61 | needs: setup 62 | if: ${{ needs.setup.outputs.platforms != '[]' }} 63 | runs-on: ${{ matrix.config.os }} 64 | name: ${{ matrix.config.label }} 65 | strategy: 66 | fail-fast: false 67 | matrix: 68 | config: ${{ fromJson(needs.setup.outputs.platforms) }} 69 | 70 | steps: 71 | - uses: actions/checkout@v3 72 | - uses: r-hub/rhub2/actions/rhub-setup-r@v1 73 | with: 74 | job-config: ${{ matrix.config.job-config }} 75 | token: ${{ secrets.RHUB_TOKEN }} 76 | - uses: r-hub/rhub2/actions/rhub-check@v1 77 | with: 78 | job-config: ${{ matrix.config.job-config }} 79 | token: ${{ secrets.RHUB_TOKEN }} 80 | -------------------------------------------------------------------------------- /src/index.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_INDEX_H 2 | #define SLIDER_INDEX_H 3 | 4 | #include "slider.h" 5 | 6 | // ----------------------------------------------------------------------------- 7 | 8 | struct index_info { 9 | SEXP data; 10 | const int* p_data; 11 | int size; 12 | int last_pos; 13 | int current_start_pos; 14 | int current_stop_pos; 15 | }; 16 | 17 | #define PROTECT_INDEX_INFO(index, n) do { \ 18 | PROTECT((index)->data); \ 19 | *n += 1; \ 20 | } while (0) 21 | 22 | struct index_info new_index_info(SEXP); 23 | 24 | // ----------------------------------------------------------------------------- 25 | 26 | struct range_info { 27 | SEXP starts; 28 | SEXP stops; 29 | const int* p_starts; 30 | const int* p_stops; 31 | int size; 32 | bool start_unbounded; 33 | bool stop_unbounded; 34 | }; 35 | 36 | #define PROTECT_RANGE_INFO(range, n) do { \ 37 | PROTECT((range)->starts); \ 38 | PROTECT((range)->stops); \ 39 | *n += 2; \ 40 | } while (0) 41 | 42 | struct range_info new_range_info(SEXP, SEXP, int); 43 | 44 | // ----------------------------------------------------------------------------- 45 | 46 | struct window_info { 47 | const int* p_peer_sizes; 48 | const int* p_peer_starts; 49 | const int* p_peer_stops; 50 | SEXP seq; 51 | int* p_seq_val; 52 | }; 53 | 54 | #define PROTECT_WINDOW_INFO(window, n) do { \ 55 | PROTECT((window)->seq); \ 56 | *n += 1; \ 57 | } while (0) 58 | 59 | void fill_peer_info(const int* p_peer_sizes, 60 | int size, 61 | int* p_peer_starts, 62 | int* p_peer_stops); 63 | 64 | struct window_info new_window_info(const int* p_peer_sizes, 65 | const int* p_peer_starts, 66 | const int* p_peer_stops); 67 | 68 | int locate_peer_starts_pos(struct index_info* index, struct range_info range, int pos); 69 | int locate_peer_stops_pos(struct index_info* index, struct range_info range, int pos); 70 | 71 | void increment_window(struct window_info window, 72 | struct index_info* index, 73 | struct range_info range, 74 | int pos); 75 | 76 | // ----------------------------------------------------------------------------- 77 | 78 | int compute_min_iteration(struct index_info index, struct range_info range, bool complete); 79 | int compute_max_iteration(struct index_info index, struct range_info range, bool complete); 80 | 81 | // ----------------------------------------------------------------------------- 82 | #endif 83 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://slider.r-lib.org 2 | 3 | template: 4 | package: tidytemplate 5 | bootstrap: 5 6 | 7 | includes: 8 | in_header: | 9 | 10 | 11 | 12 | development: 13 | mode: auto 14 | 15 | reference: 16 | - title: Slide family 17 | desc: | 18 | The `slide(.x, .f)` functions are similar to `purrr::map(.x, .f)`. Both 19 | iterate over `.x`, applying `.f` as they go. The difference is that 20 | `slide()` moves over `.x` in sliding windows, rather than one element at 21 | a time. The return value size is always the same size as `.x`, and the 22 | type is defined by the function suffix. 23 | contents: 24 | - slide 25 | - slide2 26 | - summary-slide 27 | 28 | - title: Slide index family 29 | desc: | 30 | These functions iterate over `.x` using sliding windows defined with a 31 | secondary index vector, `.i`. The windows are constructed by "looking back" 32 | and "looking forward" a certain number of periods from each element of `.i`. 33 | This is useful for constructing irregular sliding windows, such as sliding 34 | with a look back period of two months when you have daily data. In that 35 | example, not all months have the same number of days, and some months might 36 | be missing data, so a fixed window size wouldn't be useful. 37 | contents: 38 | - slide_index 39 | - slide_index2 40 | - summary-index 41 | 42 | - title: Slide period family 43 | desc: | 44 | These functions work by iterating over `.x` in "period blocks", such as 45 | one month blocks of data. The blocks are defined using a combination of 46 | a secondary date-like index vector, `.i`, and a period to block by. 47 | contents: 48 | - slide_period 49 | - slide_period2 50 | 51 | - title: Hop family 52 | desc: | 53 | These functions are lower level versions of their `slide()` equivalents. 54 | They allow you to manually construct the boundaries to slide with, and 55 | are useful if you need more flexibility than what `slide()` provides. 56 | contents: 57 | - hop 58 | - hop2 59 | - hop_index 60 | - hop_index2 61 | 62 | - title: Block 63 | desc: | 64 | `block()` breaks `.x` into its "period blocks". The blocks are defined 65 | using a combination of a secondary date-like index vector, `.i`, and a 66 | period to block by. The return value is always a list, and the elements 67 | of the list are slices of `.x`. 68 | contents: 69 | - block 70 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/pslide-period-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | pslide_period_vec(list(1:2, 1:2), new_date(c(1, 2)), "day", ~ c(.x, .y)) 5 | Condition 6 | Error: 7 | i In index: 1 8 | ! The result of `.f` must have size 1, not 2. 9 | 10 | --- 11 | 12 | Code 13 | pslide_period_int(list(1:2, 1:2), new_date(c(1, 2)), "day", ~ c(.x, .y)) 14 | Condition 15 | Error: 16 | i In index: 1 17 | ! The result of `.f` must have size 1, not 2. 18 | 19 | # inner type can be restricted with list_of 20 | 21 | Code 22 | (expect_error(pslide_period_vec(list(1:2, 1:2), new_date(c(1, 2)), "day", 23 | ~ if (.x == 1L) { 24 | list_of(1) 25 | } else { 26 | list_of("hi") 27 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 28 | ) 29 | Output 30 | 31 | Error in `pslide_period_vec()`: 32 | ! Can't convert `..1` to . 33 | 34 | # type can be restricted 35 | 36 | Code 37 | (expect_error(pslide_period_int(list(1:2, 1:2), new_date(c(1, 2)), "day", 38 | ~ if (.x == 1L) { 39 | 1L 40 | } else { 41 | "hi" 42 | }), class = "vctrs_error_incompatible_type")) 43 | Output 44 | 45 | Error: 46 | ! Can't convert to . 47 | 48 | # `.ptype = NULL` fails if no common type is found 49 | 50 | Code 51 | (expect_error(pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", 52 | ~ ifelse(.x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type") 53 | ) 54 | Output 55 | 56 | Error in `pslide_period_vec()`: 57 | ! Can't combine `out[[1]]` and `out[[2]]` . 58 | 59 | # `.ptype = NULL` validates that element lengths are 1 60 | 61 | Code 62 | pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", ~ if (.x == 1L) { 63 | 1:2 64 | } else { 65 | 1 66 | }, .ptype = NULL) 67 | Condition 68 | Error: 69 | i In index: 1 70 | ! The result of `.f` must have size 1, not 2. 71 | 72 | --- 73 | 74 | Code 75 | pslide_period_vec(list(1:2, 1:2), new_date(c(0, 1)), "day", ~ if (.x == 1L) { 76 | NULL 77 | } else { 78 | 1 79 | }, .ptype = NULL) 80 | Condition 81 | Error: 82 | i In index: 1 83 | ! The result of `.f` must have size 1, not 0. 84 | 85 | # pslide_period_chr() cannot coerce 86 | 87 | Code 88 | (expect_error(pslide_period_chr(list(1, 1), new_date(0), "day", ~.x), class = "vctrs_error_incompatible_type") 89 | ) 90 | Output 91 | 92 | Error: 93 | ! Can't convert to . 94 | 95 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: pr-commands.yaml 8 | 9 | permissions: read-all 10 | 11 | jobs: 12 | document: 13 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 14 | name: document 15 | runs-on: ubuntu-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | permissions: 19 | contents: write 20 | steps: 21 | - uses: actions/checkout@v4 22 | 23 | - uses: r-lib/actions/pr-fetch@v2 24 | with: 25 | repo-token: ${{ secrets.GITHUB_TOKEN }} 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::roxygen2 34 | needs: pr-document 35 | 36 | - name: Document 37 | run: roxygen2::roxygenise() 38 | shell: Rscript {0} 39 | 40 | - name: commit 41 | run: | 42 | git config --local user.name "$GITHUB_ACTOR" 43 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 44 | git add man/\* NAMESPACE 45 | git commit -m 'Document' 46 | 47 | - uses: r-lib/actions/pr-push@v2 48 | with: 49 | repo-token: ${{ secrets.GITHUB_TOKEN }} 50 | 51 | style: 52 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 53 | name: style 54 | runs-on: ubuntu-latest 55 | env: 56 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 57 | permissions: 58 | contents: write 59 | steps: 60 | - uses: actions/checkout@v4 61 | 62 | - uses: r-lib/actions/pr-fetch@v2 63 | with: 64 | repo-token: ${{ secrets.GITHUB_TOKEN }} 65 | 66 | - uses: r-lib/actions/setup-r@v2 67 | 68 | - name: Install dependencies 69 | run: install.packages("styler") 70 | shell: Rscript {0} 71 | 72 | - name: Style 73 | run: styler::style_pkg() 74 | shell: Rscript {0} 75 | 76 | - name: commit 77 | run: | 78 | git config --local user.name "$GITHUB_ACTOR" 79 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 80 | git add \*.R 81 | git commit -m 'Style' 82 | 83 | - uses: r-lib/actions/pr-push@v2 84 | with: 85 | repo-token: ${{ secrets.GITHUB_TOKEN }} 86 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-period-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | (expect_error(slide_period_vec(1:2, new_date(c(1, 2)), "day", ~ c(.x, 1)))) 5 | Output 6 | 7 | Error: 8 | i In index: 1 9 | ! The result of `.f` must have size 1, not 2. 10 | Code 11 | (expect_error(slide_period_dbl(1:2, new_date(c(1, 2)), "day", ~ c(.x, 1)))) 12 | Output 13 | 14 | Error: 15 | i In index: 1 16 | ! The result of `.f` must have size 1, not 2. 17 | 18 | # inner type can be restricted with list_of 19 | 20 | Code 21 | (expect_error(slide_period_vec(1:2, new_date(c(1, 2)), "day", ~ if (.x == 1L) { 22 | list_of(1) 23 | } else { 24 | list_of("hi") 25 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 26 | ) 27 | Output 28 | 29 | Error in `slide_period_vec()`: 30 | ! Can't convert `..1` to . 31 | 32 | # type can be restricted 33 | 34 | Code 35 | (expect_error(slide_period_dbl(1:2, new_date(c(1, 2)), "day", ~ if (.x == 1L) { 36 | 1 37 | } else { 38 | "hi" 39 | }), class = "vctrs_error_incompatible_type")) 40 | Output 41 | 42 | Error: 43 | ! Can't convert to . 44 | 45 | # .ptype is respected 46 | 47 | Code 48 | (expect_error(slide_period_vec(1, new_date(0), "day", ~ .x + 0.5, .ptype = integer()), 49 | class = "vctrs_error_cast_lossy")) 50 | Output 51 | 52 | Error in `slide_period_vec()`: 53 | ! Can't convert from `out[[1]]` to due to loss of precision. 54 | * Locations: 1 55 | 56 | # `.ptype = NULL` fails if no common type is found 57 | 58 | Code 59 | (expect_error(slide_period_vec(1:2, new_date(c(0, 1)), "day", ~ ifelse(.x == 1L, 60 | "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type")) 61 | Output 62 | 63 | Error in `slide_period_vec()`: 64 | ! Can't combine `out[[1]]` and `out[[2]]` . 65 | 66 | # `.ptype = NULL` validates that element lengths are 1 67 | 68 | Code 69 | (expect_error(slide_period_vec(1:2, new_date(c(0, 1)), "day", ~ if (.x == 1L) { 70 | 1:2 71 | } else { 72 | 1 73 | }, .ptype = NULL))) 74 | Output 75 | 76 | Error: 77 | i In index: 1 78 | ! The result of `.f` must have size 1, not 2. 79 | Code 80 | (expect_error(slide_period_vec(1:2, new_date(c(0, 1)), "day", ~ if (.x == 1L) { 81 | NULL 82 | } else { 83 | 1 84 | }, .ptype = NULL))) 85 | Output 86 | 87 | Error: 88 | i In index: 1 89 | ! The result of `.f` must have size 1, not 0. 90 | 91 | -------------------------------------------------------------------------------- /tests/testthat/test-hop-index2-vec.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # hop_index2_vec 3 | 4 | test_that("hop_index2_vec() works", { 5 | expect_identical(hop_index2_vec(1L, 1L, 1, 1, 1, ~ .x + .y), 2L) 6 | }) 7 | 8 | test_that("hop_index2_vec() doesn't retains names of x (#75)", { 9 | expect_named(hop_index2_vec(c(x = 1L), c(y = 1L), 1, 1, 1, ~ .x + .y), NULL) 10 | }) 11 | 12 | test_that("hop_index2_vec() can simplify automatically", { 13 | expect_identical(hop_index2_vec(1, 2, 1, 1, 1, ~ .x + .y, .ptype = NULL), 3) 14 | }) 15 | 16 | test_that("hop_index2_vec() errors if it can't simplify", { 17 | fn <- function(x, y) { 18 | if (x == 1L) { 19 | 1 20 | } else { 21 | "hi" 22 | } 23 | } 24 | 25 | expect_snapshot({ 26 | (expect_error( 27 | hop_index2_vec(1:2, 1:2, 1:2, 1:2, 1:2, fn, .ptype = NULL), 28 | class = "vctrs_error_incompatible_type" 29 | )) 30 | }) 31 | }) 32 | 33 | # ------------------------------------------------------------------------------ 34 | # .ptype 35 | 36 | test_that("`.ptype = NULL` validates that element lengths are 1", { 37 | expect_snapshot(error = TRUE, { 38 | hop_index2_vec( 39 | 1:2, 40 | 1:2, 41 | 1:2, 42 | 1:2, 43 | 1:2, 44 | ~ if (.x == 1L) { 45 | 1:2 46 | } else { 47 | 1 48 | }, 49 | .ptype = NULL 50 | ) 51 | }) 52 | expect_snapshot(error = TRUE, { 53 | hop_index2_vec( 54 | 1:2, 55 | 1:2, 56 | 1:2, 57 | 1:2, 58 | 1:2, 59 | ~ if (.x == 1L) { 60 | NULL 61 | } else { 62 | 2 63 | }, 64 | .ptype = NULL 65 | ) 66 | }) 67 | }) 68 | 69 | test_that("size 0 `.starts` / `.stops` returns size 0 `.ptype`", { 70 | expect_identical( 71 | hop_index2_vec(1:5, 1:5, 1:5, integer(), integer(), ~.x, .ptype = NULL), 72 | NULL 73 | ) 74 | expect_identical( 75 | hop_index2_vec(1:5, 1:5, 1:5, integer(), integer(), ~.x, .ptype = double()), 76 | double() 77 | ) 78 | }) 79 | 80 | test_that("`hop_index2_vec()` falls back to `c()` method as required", { 81 | local_c_foobar() 82 | 83 | expect_identical( 84 | hop_index2_vec( 85 | 1:3, 86 | 1:3, 87 | 1:3, 88 | 1:3, 89 | 1:3, 90 | ~ foobar(.x), 91 | .ptype = foobar(integer()) 92 | ), 93 | foobar(1:3) 94 | ) 95 | expect_condition( 96 | hop_index2_vec( 97 | 1:3, 98 | 1:3, 99 | 1:3, 100 | 1:3, 101 | 1:3, 102 | ~ foobar(.x), 103 | .ptype = foobar(integer()) 104 | ), 105 | class = "slider_c_foobar" 106 | ) 107 | 108 | expect_identical( 109 | hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~ foobar(.x)), 110 | foobar(1:3) 111 | ) 112 | expect_condition( 113 | hop_index2_vec(1:3, 1:3, 1:3, 1:3, 1:3, ~ foobar(.x)), 114 | class = "slider_c_foobar" 115 | ) 116 | }) 117 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(slider_minus,slider_test_class.double) 4 | S3method(slider_plus,slider_test_class.double) 5 | export(block) 6 | export(hop) 7 | export(hop2) 8 | export(hop2_vec) 9 | export(hop_index) 10 | export(hop_index2) 11 | export(hop_index2_vec) 12 | export(hop_index_vec) 13 | export(hop_vec) 14 | export(phop) 15 | export(phop_index) 16 | export(phop_index_vec) 17 | export(phop_vec) 18 | export(pslide) 19 | export(pslide_chr) 20 | export(pslide_dbl) 21 | export(pslide_dfc) 22 | export(pslide_dfr) 23 | export(pslide_index) 24 | export(pslide_index_chr) 25 | export(pslide_index_dbl) 26 | export(pslide_index_dfc) 27 | export(pslide_index_dfr) 28 | export(pslide_index_int) 29 | export(pslide_index_lgl) 30 | export(pslide_index_vec) 31 | export(pslide_int) 32 | export(pslide_lgl) 33 | export(pslide_period) 34 | export(pslide_period_chr) 35 | export(pslide_period_dbl) 36 | export(pslide_period_dfc) 37 | export(pslide_period_dfr) 38 | export(pslide_period_int) 39 | export(pslide_period_lgl) 40 | export(pslide_period_vec) 41 | export(pslide_vec) 42 | export(slide) 43 | export(slide2) 44 | export(slide2_chr) 45 | export(slide2_dbl) 46 | export(slide2_dfc) 47 | export(slide2_dfr) 48 | export(slide2_int) 49 | export(slide2_lgl) 50 | export(slide2_vec) 51 | export(slide_all) 52 | export(slide_any) 53 | export(slide_chr) 54 | export(slide_dbl) 55 | export(slide_dfc) 56 | export(slide_dfr) 57 | export(slide_index) 58 | export(slide_index2) 59 | export(slide_index2_chr) 60 | export(slide_index2_dbl) 61 | export(slide_index2_dfc) 62 | export(slide_index2_dfr) 63 | export(slide_index2_int) 64 | export(slide_index2_lgl) 65 | export(slide_index2_vec) 66 | export(slide_index_all) 67 | export(slide_index_any) 68 | export(slide_index_chr) 69 | export(slide_index_dbl) 70 | export(slide_index_dfc) 71 | export(slide_index_dfr) 72 | export(slide_index_int) 73 | export(slide_index_lgl) 74 | export(slide_index_max) 75 | export(slide_index_mean) 76 | export(slide_index_min) 77 | export(slide_index_prod) 78 | export(slide_index_sum) 79 | export(slide_index_vec) 80 | export(slide_int) 81 | export(slide_lgl) 82 | export(slide_max) 83 | export(slide_mean) 84 | export(slide_min) 85 | export(slide_period) 86 | export(slide_period2) 87 | export(slide_period2_chr) 88 | export(slide_period2_dbl) 89 | export(slide_period2_dfc) 90 | export(slide_period2_dfr) 91 | export(slide_period2_int) 92 | export(slide_period2_lgl) 93 | export(slide_period2_vec) 94 | export(slide_period_chr) 95 | export(slide_period_dbl) 96 | export(slide_period_dfc) 97 | export(slide_period_dfr) 98 | export(slide_period_int) 99 | export(slide_period_lgl) 100 | export(slide_period_vec) 101 | export(slide_prod) 102 | export(slide_sum) 103 | export(slide_vec) 104 | export(slider_minus) 105 | export(slider_plus) 106 | import(rlang) 107 | import(vctrs) 108 | importFrom(warp,warp_boundary) 109 | importFrom(warp,warp_distance) 110 | useDynLib(slider, .registration = TRUE) 111 | -------------------------------------------------------------------------------- /R/block.R: -------------------------------------------------------------------------------- 1 | #' Break a vector into blocks 2 | #' 3 | #' @description 4 | #' `block()` breaks up the `i`-ndex by `period`, and then uses that to define 5 | #' the indices to chop `x` with. 6 | #' 7 | #' For example, it can split `x` into monthly or yearly blocks. Combined with 8 | #' `purrr::map()`, it is a way to iterate over a vector in "time blocks". 9 | #' 10 | #' @details 11 | #' `block()` determines the indices to block by with [warp::warp_boundary()], 12 | #' and splits `x` by those indices using [vctrs::vec_chop()]. 13 | #' 14 | #' Like [slide()], `block()` splits data frame `x` values row wise. 15 | #' 16 | #' @inheritParams warp::warp_boundary 17 | #' 18 | #' @param x `[vector]` 19 | #' 20 | #' The vector to block. 21 | #' 22 | #' @param i `[Date / POSIXct / POSIXlt]` 23 | #' 24 | #' The datetime index to block by. 25 | #' 26 | #' There are 3 restrictions on the index: 27 | #' 28 | #' - The size of the index must match the size of `x`, they will not be 29 | #' recycled to their common size. 30 | #' 31 | #' - The index must be an _increasing_ vector, but duplicate values 32 | #' are allowed. 33 | #' 34 | #' - The index cannot have missing values. 35 | #' 36 | #' @return 37 | #' A vector fulfilling the following invariants: 38 | #' 39 | #' * `vec_size(block(x)) == vec_size(unique(warp::warp_boundary(i)))` 40 | #' 41 | #' * `vec_ptype(block(x)) == list()` 42 | #' 43 | #' * `vec_ptype(block(x)[[1]]) == vec_ptype(x)` 44 | #' 45 | #' @examples 46 | #' x <- 1:6 47 | #' i <- as.Date("2019-01-01") + c(-2:2, 31) 48 | #' 49 | #' block(i, i, period = "year") 50 | #' 51 | #' # Data frames are split row wise 52 | #' df <- data.frame(x = x, i = i) 53 | #' block(df, i, period = "month") 54 | #' 55 | #' # Iterate over these blocks to apply a function over 56 | #' # non-overlapping period blocks. For example, to compute a 57 | #' # mean over yearly or monthly blocks. 58 | #' vapply(block(x, i, "year"), mean, numeric(1)) 59 | #' vapply(block(x, i, "month"), mean, numeric(1)) 60 | #' 61 | #' # block by every 2 months, ensuring that we start counting 62 | #' # the 1st of the 2 months from `2019-01-01` 63 | #' block(i, i, period = "month", every = 2, origin = as.Date("2019-01-01")) 64 | #' 65 | #' # Use the `origin` to instead start counting from `2018-12-01`, meaning 66 | #' # that [2018-12, 2019-01] gets bucketed together. 67 | #' block(i, i, period = "month", every = 2, origin = as.Date("2018-12-01")) 68 | #' 69 | #' @seealso [slide_period()], [slide()], [slide_index()] 70 | #' @export 71 | block <- function(x, i, period, every = 1L, origin = NULL) { 72 | vec_assert(x) 73 | 74 | check_index_incompatible_type(i, "i") 75 | check_index_cannot_be_na(i, "i") 76 | check_index_must_be_ascending(i, "i") 77 | 78 | x_size <- vec_size(x) 79 | i_size <- vec_size(i) 80 | 81 | if (x_size != i_size) { 82 | stop_index_incompatible_size(i_size, x_size, "i") 83 | } 84 | 85 | boundaries <- warp_boundary( 86 | i, 87 | period = period, 88 | every = every, 89 | origin = origin 90 | ) 91 | 92 | .Call(slider_block, x, boundaries$start, boundaries$stop) 93 | } 94 | -------------------------------------------------------------------------------- /src/utils.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_UTILS_H 2 | #define SLIDER_UTILS_H 3 | 4 | #include "slider.h" 5 | 6 | #define PROTECT_N(x, n) (++*n, PROTECT(x)) 7 | 8 | #define r_int Rf_ScalarInteger 9 | 10 | static inline int min(int x, int y) { 11 | return x < y ? x : y; 12 | } 13 | static inline int max(int x, int y) { 14 | return x > y ? x : y; 15 | } 16 | 17 | static inline R_xlen_t min_size(R_xlen_t x, R_xlen_t y) { 18 | return x < y ? x : y; 19 | } 20 | static inline R_xlen_t max_size(R_xlen_t x, R_xlen_t y) { 21 | return x > y ? x : y; 22 | } 23 | 24 | static inline uint64_t min_u64(uint64_t x, uint64_t y) { 25 | return x < y ? x : y; 26 | } 27 | 28 | static inline SEXP r_lst_get(SEXP x, int i) { 29 | return VECTOR_ELT(x, i); 30 | } 31 | 32 | static inline int r_scalar_int_get(SEXP x) { 33 | return INTEGER(x)[0]; 34 | } 35 | 36 | static inline int r_scalar_lgl_get(SEXP x) { 37 | return LOGICAL(x)[0]; 38 | } 39 | 40 | static inline const char* r_scalar_chr_get(SEXP x) { 41 | return CHAR(STRING_ELT(x, 0)); 42 | } 43 | 44 | static inline bool p_int_any_gt(const int* p_x, const int* p_y, R_xlen_t size) { 45 | for (R_xlen_t i = 0; i < size; ++i) { 46 | if (p_x[i] > p_y[i]) { 47 | return true; 48 | } 49 | } 50 | return false; 51 | } 52 | 53 | __attribute__((noreturn)) static inline void never_reached(const char* fn) { 54 | Rf_errorcall(R_NilValue, "Internal error: Reached the unreachable in `%s()`.", fn); 55 | } 56 | 57 | extern SEXP strings_before; 58 | extern SEXP strings_after; 59 | extern SEXP strings_step; 60 | extern SEXP strings_complete; 61 | extern SEXP strings_na_rm; 62 | extern SEXP strings_dot_before; 63 | extern SEXP strings_dot_after; 64 | extern SEXP strings_dot_step; 65 | extern SEXP strings_dot_complete; 66 | extern SEXP strings_dot_na_rm; 67 | 68 | extern SEXP syms_dot_x; 69 | extern SEXP syms_dot_y; 70 | extern SEXP syms_dot_l; 71 | 72 | extern SEXP slider_shared_empty_lgl; 73 | extern SEXP slider_shared_empty_int; 74 | extern SEXP slider_shared_empty_dbl; 75 | 76 | extern SEXP slider_shared_na_lgl; 77 | 78 | extern SEXP slider_ns_env; 79 | 80 | SEXP slider_init(SEXPTYPE type, R_xlen_t size); 81 | 82 | void list_fill(SEXP x, SEXP value); 83 | 84 | void stop_not_all_size_one(int iteration, int size); 85 | 86 | void check_slide_starts_not_past_stops(SEXP starts, 87 | SEXP stops, 88 | const int* p_starts, 89 | const int* p_stops, 90 | R_xlen_t size); 91 | void check_hop_starts_not_past_stops(SEXP starts, 92 | SEXP stops, 93 | const int* p_starts, 94 | const int* p_stops, 95 | R_xlen_t size); 96 | 97 | int compute_size(SEXP x, int type); 98 | int compute_force(int type); 99 | 100 | SEXP slider_names(SEXP x, int type); 101 | 102 | SEXP make_slice_container(int type); 103 | void slice_and_update_env(SEXP x, SEXP window, SEXP env, int type, SEXP container); 104 | 105 | #endif 106 | -------------------------------------------------------------------------------- /tests/testthat/test-arithmetic.R: -------------------------------------------------------------------------------- 1 | test_that("`slider_plus(x, y)` uses `x + y` as a fallback", { 2 | x <- 1:3 3 | y <- 2L 4 | expect_identical(slider_plus(x, y), x + y) 5 | 6 | x <- as.Date("2019-01-01") + 0:2 7 | y <- 2L 8 | expect_identical(slider_plus(x, y), x + y) 9 | 10 | x <- as.POSIXct(c("2019-01-01", "2019-01-02"), tz = "UTC") 11 | y <- as.difftime(2L, units = "mins") 12 | expect_identical(slider_plus(x, y), x + y) 13 | }) 14 | 15 | test_that("`slider_minus(x, y)` uses `x - y` as a fallback", { 16 | x <- 1:3 17 | y <- 2L 18 | expect_identical(slider_minus(x, y), x - y) 19 | 20 | x <- as.Date("2019-01-01") + 0:2 21 | y <- 2L 22 | expect_identical(slider_minus(x, y), x - y) 23 | 24 | x <- as.POSIXct(c("2019-01-01", "2019-01-02"), tz = "UTC") 25 | y <- as.difftime(2L, units = "mins") 26 | expect_identical(slider_minus(x, y), x - y) 27 | }) 28 | 29 | test_that("can register package methods for and ", { 30 | x <- new_slider_test_class(c(1, 2, 3)) 31 | 32 | # Fallback on integer arithmetic 33 | expect_identical(slider_plus(x, 2L), new_slider_test_class(c(3, 4, 5))) 34 | expect_identical(slider_minus(x, 2L), new_slider_test_class(c(-1, 0, 1))) 35 | 36 | # Registered method for double arithmetic that multiplies `y` by `2` first 37 | expect_identical(slider_plus(x, 2), new_slider_test_class(c(5, 6, 7))) 38 | expect_identical(slider_minus(x, 2), new_slider_test_class(c(-3, -2, -1))) 39 | }) 40 | 41 | test_that("`slide_index()` uses the methods", { 42 | i_base <- c(1, 2, 3, 4, 5, 6, 7, 8) 43 | i_custom <- new_slider_test_class(i_base) 44 | x <- seq_along(i_base) 45 | 46 | # `.before` gets multiplied by `2` before subtraction from `i_custom` in 47 | # `slider_minus.slider_test_class.double()` 48 | before <- 2 49 | expect_identical( 50 | slide_index(x, i_custom, identity, .before = before), 51 | slide_index(x, i_base, identity, .before = before * 2) 52 | ) 53 | 54 | # `.after` gets multiplied by `2` before addition to `i_custom` in 55 | # `slider_plus.slider_test_class.double()` 56 | after <- 2 57 | expect_identical( 58 | slide_index(x, i_custom, identity, .after = after), 59 | slide_index(x, i_base, identity, .after = after * 2) 60 | ) 61 | }) 62 | 63 | test_that("can register global methods for and ", { 64 | local_methods( 65 | slider_plus.slider_foobar.slider_foobar = function(x, y) { 66 | foobar((x + y) * 2L) 67 | }, 68 | slider_minus.slider_foobar.slider_foobar = function(x, y) { 69 | foobar((x - y) * 2L) 70 | } 71 | ) 72 | 73 | x <- foobar(1:3) 74 | y <- foobar(2L) 75 | 76 | expect_identical(slider_plus(x, y), foobar(c(6L, 8L, 10L))) 77 | expect_identical(slider_minus(x, y), foobar(c(-2L, 0L, 2L))) 78 | }) 79 | 80 | test_that("can register global methods for and ", { 81 | local_methods( 82 | slider_plus.slider_foobar.double = function(x, y) { 83 | foobar((x + y) * 3) 84 | }, 85 | slider_minus.slider_foobar.double = function(x, y) { 86 | foobar((x - y) * 3) 87 | } 88 | ) 89 | 90 | x <- foobar(1:3) 91 | y <- 2 92 | 93 | expect_identical(slider_plus(x, y), foobar(c(9, 12, 15))) 94 | expect_identical(slider_minus(x, y), foobar(c(-3, 0, 3))) 95 | }) 96 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide-period2-vec.md: -------------------------------------------------------------------------------- 1 | # size of each `.f` result must be 1 2 | 3 | Code 4 | slide_period2_vec(1:2, 1:2, new_date(c(1, 2)), "day", ~ c(.x, .y)) 5 | Condition 6 | Error: 7 | i In index: 1 8 | ! The result of `.f` must have size 1, not 2. 9 | 10 | --- 11 | 12 | Code 13 | slide_period2_int(1:2, 1:2, new_date(c(1, 2)), "day", ~ c(.x, .y)) 14 | Condition 15 | Error: 16 | i In index: 1 17 | ! The result of `.f` must have size 1, not 2. 18 | 19 | # inner type can be restricted with list_of 20 | 21 | Code 22 | (expect_error(slide_period2_vec(1:2, 1:2, new_date(c(1, 2)), "day", ~ if (.x == 23 | 1L) { 24 | list_of(1) 25 | } else { 26 | list_of("hi") 27 | }, .ptype = list_of(.ptype = double())), class = "vctrs_error_incompatible_type") 28 | ) 29 | Output 30 | 31 | Error in `slide_period2_vec()`: 32 | ! Can't convert `..1` to . 33 | 34 | # type can be restricted 35 | 36 | Code 37 | (expect_error(slide_period2_int(1:2, 1:2, new_date(c(1, 2)), "day", ~ if (.x == 38 | 1L) { 39 | 1L 40 | } else { 41 | "hi" 42 | }), class = "vctrs_error_incompatible_type")) 43 | Output 44 | 45 | Error: 46 | ! Can't convert to . 47 | 48 | # .ptype is respected 49 | 50 | Code 51 | (expect_error(slide_period2_vec(1, 1, new_date(0), "day", ~ .x + 0.5, .ptype = integer()), 52 | class = "vctrs_error_cast_lossy")) 53 | Output 54 | 55 | Error in `slide_period2_vec()`: 56 | ! Can't convert from `out[[1]]` to due to loss of precision. 57 | * Locations: 1 58 | 59 | # `.ptype = NULL` fails if no common type is found 60 | 61 | Code 62 | (expect_error(slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~ ifelse( 63 | .x == 1L, "hello", 1), .ptype = NULL), class = "vctrs_error_incompatible_type") 64 | ) 65 | Output 66 | 67 | Error in `slide_period2_vec()`: 68 | ! Can't combine `out[[1]]` and `out[[2]]` . 69 | 70 | # `.ptype = NULL` validates that element lengths are 1 71 | 72 | Code 73 | slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~ if (.x == 1L) { 74 | 1:2 75 | } else { 76 | 1 77 | }, .ptype = NULL) 78 | Condition 79 | Error: 80 | i In index: 1 81 | ! The result of `.f` must have size 1, not 2. 82 | 83 | --- 84 | 85 | Code 86 | slide_period2_vec(1:2, 1:2, new_date(c(0, 1)), "day", ~ if (.x == 1L) { 87 | NULL 88 | } else { 89 | 1 90 | }, .ptype = NULL) 91 | Condition 92 | Error: 93 | i In index: 1 94 | ! The result of `.f` must have size 1, not 0. 95 | 96 | # slide_period2_chr() cannot coerce 97 | 98 | Code 99 | (expect_error(slide_period2_chr(1, 1, new_date(0), "day", ~.x), class = "vctrs_error_incompatible_type") 100 | ) 101 | Output 102 | 103 | Error: 104 | ! Can't convert to . 105 | 106 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/slide.md: -------------------------------------------------------------------------------- 1 | # error if negative .before's abs() is > .after 2 | 3 | Code 4 | slide(1:5, identity, .before = -1) 5 | Condition 6 | Error: 7 | ! When `.before` (-1) is negative, its absolute value (1) can't be greater than `.after` (0). 8 | 9 | # both .before and .after cannot be negative 10 | 11 | Code 12 | slide(1:5, identity, .before = -1, .after = -1) 13 | Condition 14 | Error: 15 | ! `.before` (-1) and `.after` (-1) can't both be negative. 16 | 17 | # error if negative .after's abs() is > .before 18 | 19 | Code 20 | slide(1:5, identity, .after = -1) 21 | Condition 22 | Error: 23 | ! When `.after` (-1) is negative, its absolute value (1) can't be greater than `.before` (0). 24 | 25 | # cannot use invalid .before 26 | 27 | Code 28 | slide(1, identity, .before = c(1, 2)) 29 | Condition 30 | Error: 31 | ! `.before` must have size 1, not 2. 32 | 33 | --- 34 | 35 | Code 36 | (expect_error(slide(1, identity, .before = "x"), class = "vctrs_error_incompatible_type") 37 | ) 38 | Output 39 | 40 | Error: 41 | ! Can't convert to . 42 | 43 | # cannot use invalid .after 44 | 45 | Code 46 | slide(1, identity, .after = c(1, 2)) 47 | Condition 48 | Error: 49 | ! `.after` must have size 1, not 2. 50 | 51 | --- 52 | 53 | Code 54 | (expect_error(slide(1, identity, .after = "x"), class = "vctrs_error_incompatible_type") 55 | ) 56 | Output 57 | 58 | Error: 59 | ! Can't convert to . 60 | 61 | # cannot use invalid .step 62 | 63 | Code 64 | slide(1, identity, .step = -1) 65 | Condition 66 | Error: 67 | ! `.step` must be at least 1, not -1. 68 | 69 | --- 70 | 71 | Code 72 | slide(1, identity, .step = 0) 73 | Condition 74 | Error: 75 | ! `.step` must be at least 1, not 0. 76 | 77 | --- 78 | 79 | Code 80 | slide(1, identity, .step = c(1, 2)) 81 | Condition 82 | Error: 83 | ! `.step` must have size 1, not 2. 84 | 85 | --- 86 | 87 | Code 88 | (expect_error(slide(1, identity, .step = "x"), class = "vctrs_error_incompatible_type") 89 | ) 90 | Output 91 | 92 | Error: 93 | ! Can't convert to . 94 | 95 | # cannot use invalid .complete 96 | 97 | Code 98 | slide(1, identity, .complete = c(TRUE, TRUE)) 99 | Condition 100 | Error: 101 | ! `.complete` must have size 1, not 2. 102 | 103 | --- 104 | 105 | Code 106 | (expect_error(slide(1, identity, .complete = "hi"), class = "vctrs_error_incompatible_type") 107 | ) 108 | Output 109 | 110 | Error: 111 | ! Can't convert to . 112 | 113 | # `error_call` and `.error_call` args aren't swallowed 114 | 115 | Code 116 | slide(1, fn, error_call = call("foo")) 117 | Condition 118 | Error in `foo()`: 119 | ! hi 120 | 121 | --- 122 | 123 | Code 124 | slide(1, fn_dot, .error_call = call("foo")) 125 | Condition 126 | Error in `foo()`: 127 | ! hi 128 | 129 | -------------------------------------------------------------------------------- /src/opts-slide.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_OPTS_SLIDE_H 2 | #define SLIDER_OPTS_SLIDE_H 3 | 4 | #include "slider.h" 5 | #include "params.h" 6 | 7 | // ----------------------------------------------------------------------------- 8 | 9 | struct slide_opts { 10 | int before; 11 | bool before_unbounded; 12 | bool before_positive; 13 | 14 | int after; 15 | bool after_unbounded; 16 | bool after_positive; 17 | 18 | int step; 19 | bool complete; 20 | }; 21 | 22 | static inline struct slide_opts new_slide_opts(SEXP before, SEXP after, SEXP step, SEXP complete, bool dot) { 23 | bool c_before_unbounded = false; 24 | bool c_after_unbounded = false; 25 | 26 | int c_before = validate_before(before, &c_before_unbounded, dot); 27 | bool c_before_positive = c_before >= 0; 28 | 29 | int c_after = validate_after(after, &c_after_unbounded, dot); 30 | bool c_after_positive = c_after >= 0; 31 | 32 | check_double_negativeness(c_before, c_after, c_before_positive, c_after_positive); 33 | check_before_negativeness(c_before, c_after, c_before_positive, c_after_unbounded); 34 | check_after_negativeness(c_after, c_before, c_after_positive, c_before_unbounded); 35 | 36 | int c_step = validate_step(step, dot); 37 | bool c_complete = validate_complete(complete, dot); 38 | 39 | return (struct slide_opts) { 40 | .before = c_before, 41 | .before_unbounded = c_before_unbounded, 42 | .before_positive = c_before_positive, 43 | .after = c_after, 44 | .after_unbounded = c_after_unbounded, 45 | .after_positive = c_after_positive, 46 | .step = c_step, 47 | .complete = c_complete 48 | }; 49 | } 50 | 51 | // ----------------------------------------------------------------------------- 52 | 53 | struct iter_opts { 54 | R_xlen_t iter_min; 55 | R_xlen_t iter_max; 56 | R_xlen_t iter_step; 57 | 58 | R_xlen_t start; 59 | R_xlen_t start_step; 60 | 61 | R_xlen_t stop; 62 | R_xlen_t stop_step; 63 | 64 | R_xlen_t size; 65 | }; 66 | 67 | static inline struct iter_opts new_iter_opts(struct slide_opts opts, R_xlen_t size) { 68 | R_xlen_t iter_min = 0; 69 | R_xlen_t iter_max = size; 70 | R_xlen_t iter_step = opts.step; 71 | 72 | // Iteration adjustment 73 | if (opts.complete) { 74 | if (opts.before_positive) { 75 | iter_min += opts.before; 76 | } 77 | if (opts.after_positive) { 78 | iter_max -= opts.after; 79 | } 80 | } 81 | 82 | // Forward adjustment to match the number of iterations 83 | R_xlen_t offset = 0; 84 | if (opts.complete && opts.before_positive) { 85 | offset = opts.before; 86 | } 87 | 88 | R_xlen_t start; 89 | R_xlen_t start_step; 90 | if (opts.before_unbounded) { 91 | start = 0; 92 | start_step = 0; 93 | } else { 94 | start = offset - opts.before; 95 | start_step = opts.step; 96 | } 97 | 98 | R_xlen_t stop; 99 | R_xlen_t stop_step; 100 | if (opts.after_unbounded) { 101 | stop = size - 1; 102 | stop_step = 0; 103 | } else { 104 | stop = offset + opts.after; 105 | stop_step = opts.step; 106 | } 107 | 108 | return (struct iter_opts) { 109 | .iter_min = iter_min, 110 | .iter_max = iter_max, 111 | .iter_step = iter_step, 112 | .start = start, 113 | .start_step = start_step, 114 | .stop = stop, 115 | .stop_step = stop_step, 116 | .size = size 117 | }; 118 | } 119 | 120 | // ----------------------------------------------------------------------------- 121 | #endif 122 | -------------------------------------------------------------------------------- /R/hop2.R: -------------------------------------------------------------------------------- 1 | #' Hop along multiple inputs simultaneously 2 | #' 3 | #' `hop2()` and `phop()` represent the combination 4 | #' of [slide2()] and [pslide()] with [hop()], allowing you to iterate 5 | #' over multiple vectors at once, hopping along them using boundaries defined 6 | #' by `.starts` and `.stops`. 7 | #' 8 | #' @inheritParams hop 9 | #' 10 | #' @template param-x-y 11 | #' @template param-l 12 | #' @template param-starts-stops-hop 13 | #' 14 | #' @return 15 | #' A vector fulfilling the following invariants: 16 | #' 17 | #' \subsection{`hop2()`}{ 18 | #' 19 | #' * `vec_size(hop2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` 20 | #' 21 | #' * `vec_ptype(hop2(.x, .y, .starts, .stops)) == list()` 22 | #' 23 | #' } 24 | #' 25 | #' \subsection{`hop2_vec()`}{ 26 | #' 27 | #' * `vec_size(hop2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` 28 | #' 29 | #' * `vec_size(hop2_vec(.x, .y, .starts, .stops)[[1]]) == 1L` 30 | #' 31 | #' * `vec_ptype(hop2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype` 32 | #' 33 | #' } 34 | #' 35 | #' \subsection{`phop()`}{ 36 | #' 37 | #' * `vec_size(phop(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` 38 | #' 39 | #' * `vec_ptype(phop(.l, .starts, .stops)) == list()` 40 | #' 41 | #' } 42 | #' 43 | #' \subsection{`phop_vec()`}{ 44 | #' 45 | #' * `vec_size(phop_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` 46 | #' 47 | #' * `vec_size(phop_vec(.l, .starts, .stops)[[1]]) == 1L` 48 | #' 49 | #' * `vec_ptype(phop_vec(.l, .starts, .stops, .ptype = ptype)) == ptype` 50 | #' 51 | #' } 52 | #' 53 | #' @examples 54 | #' hop2(1:2, 3:4, .starts = 1, .stops = c(2, 1), ~c(x = .x, y = .y)) 55 | #' 56 | #' phop( 57 | #' list(1, 2:4, 5:7), 58 | #' .starts = c(0, 1), 59 | #' .stops = c(2, 4), 60 | #' ~c(x = ..1, y = ..2, z = ..3) 61 | #' ) 62 | #' 63 | #' @seealso [hop()], [hop_index()], [slide2()] 64 | #' @export 65 | hop2 <- function(.x, .y, .starts, .stops, .f, ...) { 66 | hop2_impl( 67 | .x, 68 | .y, 69 | .starts, 70 | .stops, 71 | .f, 72 | ..., 73 | .ptype = list(), 74 | .constrain = FALSE, 75 | .atomic = FALSE 76 | ) 77 | } 78 | 79 | #' @rdname hop2 80 | #' @export 81 | hop2_vec <- function(.x, .y, .starts, .stops, .f, ..., .ptype = NULL) { 82 | out <- hop2_impl( 83 | .x, 84 | .y, 85 | .starts, 86 | .stops, 87 | .f, 88 | ..., 89 | .ptype = list(), 90 | .constrain = FALSE, 91 | .atomic = TRUE 92 | ) 93 | 94 | vec_simplify(out, .ptype) 95 | } 96 | 97 | # ------------------------------------------------------------------------------ 98 | 99 | hop2_impl <- function( 100 | .x, 101 | .y, 102 | .starts, 103 | .stops, 104 | .f, 105 | ..., 106 | .ptype, 107 | .constrain, 108 | .atomic, 109 | .slider_error_call = caller_env() 110 | ) { 111 | vec_assert(.x, call = .slider_error_call) 112 | vec_assert(.y, call = .slider_error_call) 113 | 114 | args <- vec_recycle_common(.x = .x, .y = .y, .call = .slider_error_call) 115 | 116 | .f <- as_function(.f, call = .slider_error_call) 117 | 118 | f_call <- expr(.f(.x, .y, ...)) 119 | 120 | type <- -2L 121 | 122 | hop_common( 123 | x = args, 124 | starts = .starts, 125 | stops = .stops, 126 | f_call = f_call, 127 | ptype = .ptype, 128 | env = environment(), 129 | type = type, 130 | constrain = .constrain, 131 | atomic = .atomic, 132 | slider_error_call = .slider_error_call 133 | ) 134 | } 135 | -------------------------------------------------------------------------------- /man/block.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/block.R 3 | \name{block} 4 | \alias{block} 5 | \title{Break a vector into blocks} 6 | \usage{ 7 | block(x, i, period, every = 1L, origin = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{\verb{[vector]} 11 | 12 | The vector to block.} 13 | 14 | \item{i}{\verb{[Date / POSIXct / POSIXlt]} 15 | 16 | The datetime index to block by. 17 | 18 | There are 3 restrictions on the index: 19 | \itemize{ 20 | \item The size of the index must match the size of \code{x}, they will not be 21 | recycled to their common size. 22 | \item The index must be an \emph{increasing} vector, but duplicate values 23 | are allowed. 24 | \item The index cannot have missing values. 25 | }} 26 | 27 | \item{period}{\verb{[character(1)]} 28 | 29 | A string defining the period to group by. Valid inputs can be roughly 30 | broken into: 31 | \itemize{ 32 | \item \code{"year"}, \code{"quarter"}, \code{"month"}, \code{"week"}, \code{"day"} 33 | \item \code{"hour"}, \code{"minute"}, \code{"second"}, \code{"millisecond"} 34 | \item \code{"yweek"}, \code{"mweek"} 35 | \item \code{"yday"}, \code{"mday"} 36 | }} 37 | 38 | \item{every}{\verb{[positive integer(1)]} 39 | 40 | The number of periods to group together. 41 | 42 | For example, if the period was set to \code{"year"} with an every value of \code{2}, 43 | then the years 1970 and 1971 would be placed in the same group.} 44 | 45 | \item{origin}{\verb{[Date(1) / POSIXct(1) / POSIXlt(1) / NULL]} 46 | 47 | The reference date time value. The default when left as \code{NULL} is the 48 | epoch time of \verb{1970-01-01 00:00:00}, \emph{in the time zone of the index}. 49 | 50 | This is generally used to define the anchor time to count from, which is 51 | relevant when the every value is \verb{> 1}.} 52 | } 53 | \value{ 54 | A vector fulfilling the following invariants: 55 | \itemize{ 56 | \item \code{vec_size(block(x)) == vec_size(unique(warp::warp_boundary(i)))} 57 | \item \code{vec_ptype(block(x)) == list()} 58 | \item \code{vec_ptype(block(x)[[1]]) == vec_ptype(x)} 59 | } 60 | } 61 | \description{ 62 | \code{block()} breaks up the \code{i}-ndex by \code{period}, and then uses that to define 63 | the indices to chop \code{x} with. 64 | 65 | For example, it can split \code{x} into monthly or yearly blocks. Combined with 66 | \code{purrr::map()}, it is a way to iterate over a vector in "time blocks". 67 | } 68 | \details{ 69 | \code{block()} determines the indices to block by with \code{\link[warp:warp_boundary]{warp::warp_boundary()}}, 70 | and splits \code{x} by those indices using \code{\link[vctrs:vec_chop]{vctrs::vec_chop()}}. 71 | 72 | Like \code{\link[=slide]{slide()}}, \code{block()} splits data frame \code{x} values row wise. 73 | } 74 | \examples{ 75 | x <- 1:6 76 | i <- as.Date("2019-01-01") + c(-2:2, 31) 77 | 78 | block(i, i, period = "year") 79 | 80 | # Data frames are split row wise 81 | df <- data.frame(x = x, i = i) 82 | block(df, i, period = "month") 83 | 84 | # Iterate over these blocks to apply a function over 85 | # non-overlapping period blocks. For example, to compute a 86 | # mean over yearly or monthly blocks. 87 | vapply(block(x, i, "year"), mean, numeric(1)) 88 | vapply(block(x, i, "month"), mean, numeric(1)) 89 | 90 | # block by every 2 months, ensuring that we start counting 91 | # the 1st of the 2 months from `2019-01-01` 92 | block(i, i, period = "month", every = 2, origin = as.Date("2019-01-01")) 93 | 94 | # Use the `origin` to instead start counting from `2018-12-01`, meaning 95 | # that [2018-12, 2019-01] gets bucketed together. 96 | block(i, i, period = "month", every = 2, origin = as.Date("2018-12-01")) 97 | 98 | } 99 | \seealso{ 100 | \code{\link[=slide_period]{slide_period()}}, \code{\link[=slide]{slide()}}, \code{\link[=slide_index]{slide_index()}} 101 | } 102 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | /* .Call calls */ 7 | extern SEXP slide_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP); 8 | extern SEXP hop_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 9 | extern SEXP slide_index_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 10 | extern SEXP hop_index_common_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 11 | extern SEXP slider_block(SEXP, SEXP, SEXP); 12 | extern SEXP slider_compute_from(SEXP, SEXP, SEXP, SEXP); 13 | extern SEXP slider_compute_to(SEXP, SEXP, SEXP, SEXP); 14 | extern SEXP slider_sum(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 15 | extern SEXP slider_mean(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 16 | extern SEXP slider_prod(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 17 | extern SEXP slider_min(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 18 | extern SEXP slider_max(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 19 | extern SEXP slider_all(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 20 | extern SEXP slider_any(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 21 | extern SEXP slider_index_sum_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 22 | extern SEXP slider_index_mean_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 23 | extern SEXP slider_index_prod_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 24 | extern SEXP slider_index_min_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 25 | extern SEXP slider_index_max_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 26 | extern SEXP slider_index_all_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 27 | extern SEXP slider_index_any_core(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); 28 | 29 | // Defined below 30 | SEXP slider_initialize(SEXP); 31 | 32 | static const R_CallMethodDef CallEntries[] = { 33 | {"slide_common_impl", (DL_FUNC) &slide_common_impl, 5}, 34 | {"hop_common_impl", (DL_FUNC) &hop_common_impl, 7}, 35 | {"slide_index_common_impl", (DL_FUNC) &slide_index_common_impl, 13}, 36 | {"hop_index_common_impl", (DL_FUNC) &hop_index_common_impl, 12}, 37 | {"slider_block", (DL_FUNC) &slider_block, 3}, 38 | {"slider_compute_from", (DL_FUNC) &slider_compute_from, 4}, 39 | {"slider_compute_to", (DL_FUNC) &slider_compute_to, 4}, 40 | {"slider_sum", (DL_FUNC) &slider_sum, 6}, 41 | {"slider_mean", (DL_FUNC) &slider_mean, 6}, 42 | {"slider_prod", (DL_FUNC) &slider_prod, 6}, 43 | {"slider_min", (DL_FUNC) &slider_min, 6}, 44 | {"slider_max", (DL_FUNC) &slider_max, 6}, 45 | {"slider_all", (DL_FUNC) &slider_all, 6}, 46 | {"slider_any", (DL_FUNC) &slider_any, 6}, 47 | {"slider_index_sum_core", (DL_FUNC) &slider_index_sum_core, 7}, 48 | {"slider_index_mean_core", (DL_FUNC) &slider_index_mean_core, 7}, 49 | {"slider_index_prod_core", (DL_FUNC) &slider_index_prod_core, 7}, 50 | {"slider_index_min_core", (DL_FUNC) &slider_index_min_core, 7}, 51 | {"slider_index_max_core", (DL_FUNC) &slider_index_max_core, 7}, 52 | {"slider_index_all_core", (DL_FUNC) &slider_index_all_core, 7}, 53 | {"slider_index_any_core", (DL_FUNC) &slider_index_any_core, 7}, 54 | {"slider_initialize", (DL_FUNC) &slider_initialize, 1}, 55 | {NULL, NULL, 0} 56 | }; 57 | 58 | void R_init_slider(DllInfo *dll) 59 | { 60 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 61 | R_useDynamicSymbols(dll, FALSE); 62 | } 63 | 64 | // slider-vctrs-private.c 65 | void slider_initialize_vctrs_private(void); 66 | 67 | // slider-vctrs-public.c 68 | void slider_initialize_vctrs_public(void); 69 | 70 | // utils.c 71 | void slider_initialize_utils(SEXP); 72 | 73 | SEXP slider_initialize(SEXP ns) { 74 | slider_initialize_vctrs_private(); 75 | slider_initialize_vctrs_public(); 76 | slider_initialize_utils(ns); 77 | return R_NilValue; 78 | } 79 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop.md: -------------------------------------------------------------------------------- 1 | # .starts must be before .stops 2 | 3 | Code 4 | (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity))) 5 | Output 6 | 7 | Error: 8 | i In locations: 1 and 2 9 | i In the ranges generated by `.starts` and `.stops`: 10 | ! The start of the range can't be after the end of the range. 11 | Code 12 | (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity))) 13 | Output 14 | 15 | Error: 16 | i In locations: 1 and 2 17 | i In the ranges generated by `.starts` and `.stops`: 18 | ! The start of the range can't be after the end of the range. 19 | 20 | # empty `.x`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first 21 | 22 | Code 23 | (expect_error(hop(integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") 24 | ) 25 | Output 26 | 27 | Error in `hop()`: 28 | ! Can't recycle `starts` (size 3) to match `stops` (size 2). 29 | Code 30 | (expect_error(hop(integer(), 1, "x", ~.x), class = "vctrs_error_subscript_type") 31 | ) 32 | Output 33 | 34 | Error in `hop()`: 35 | ! Can't subset elements with `.stops`. 36 | x `.stops` must be numeric, not the string "x". 37 | 38 | # .starts must not contain NA values 39 | 40 | Code 41 | (expect_error(hop(1:2, c(1, NA), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") 42 | ) 43 | Output 44 | 45 | Error in `hop()`: 46 | i In locations: 2 47 | ! `.starts` can't be `NA`. 48 | Code 49 | (expect_error(hop(1:2, c(NA, 1), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") 50 | ) 51 | Output 52 | 53 | Error in `hop()`: 54 | i In locations: 1 55 | ! `.starts` can't be `NA`. 56 | 57 | # .stops must not contain NA values 58 | 59 | Code 60 | (expect_error(hop(1:2, 1:2, c(1, NA), identity), class = "slider_error_endpoints_cannot_be_na") 61 | ) 62 | Output 63 | 64 | Error in `hop()`: 65 | i In locations: 2 66 | ! `.stops` can't be `NA`. 67 | Code 68 | (expect_error(hop(1:2, 1:2, c(NA, 1), identity), class = "slider_error_endpoints_cannot_be_na") 69 | ) 70 | Output 71 | 72 | Error in `hop()`: 73 | i In locations: 1 74 | ! `.stops` can't be `NA`. 75 | 76 | # recycling is used for .starts/.stops 77 | 78 | Code 79 | expect_error(hop(1:2, 1:2, 1:3, ~.x), class = "vctrs_error_incompatible_size") 80 | 81 | # `.starts` and `.stops` must be integerish 82 | 83 | Code 84 | (expect_error(hop(1, "x", 1, identity), class = "vctrs_error_subscript_type")) 85 | Output 86 | 87 | Error in `hop()`: 88 | ! Can't subset elements with `.starts`. 89 | x `.starts` must be numeric, not the string "x". 90 | Code 91 | (expect_error(hop(1, 1, "x", identity), class = "vctrs_error_subscript_type")) 92 | Output 93 | 94 | Error in `hop()`: 95 | ! Can't subset elements with `.stops`. 96 | x `.stops` must be numeric, not the string "x". 97 | 98 | # `error_call` and `.error_call` args aren't swallowed 99 | 100 | Code 101 | hop(1, 1, 1, fn, error_call = call("foo")) 102 | Condition 103 | Error in `foo()`: 104 | ! hi 105 | 106 | --- 107 | 108 | Code 109 | hop(1, 1, 1, fn_dot, .error_call = call("foo")) 110 | Condition 111 | Error in `foo()`: 112 | ! hi 113 | 114 | -------------------------------------------------------------------------------- /R/hop-index2.R: -------------------------------------------------------------------------------- 1 | #' Hop along multiple inputs simultaneously relative to an index 2 | #' 3 | #' `hop_index2()` and `phop_index()` represent the combination 4 | #' of [slide2()] and [pslide()] with [hop_index()], allowing you to iterate 5 | #' over multiple vectors at once, relative to an `.i`-ndex with 6 | #' boundaries defined by `.starts` and `.stops`. 7 | #' 8 | #' @inheritParams hop_index 9 | #' 10 | #' @template param-x-y 11 | #' @template param-l 12 | #' @template param-starts-stops-hop-index 13 | #' 14 | #' @return 15 | #' A vector fulfilling the following invariants: 16 | #' 17 | #' \subsection{`hop_index2()`}{ 18 | #' 19 | #' * `vec_size(hop_index2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` 20 | #' 21 | #' * `vec_ptype(hop_index2(.x, .y, .starts, .stops)) == list()` 22 | #' 23 | #' } 24 | #' 25 | #' \subsection{`hop_index2_vec()`}{ 26 | #' 27 | #' * `vec_size(hop_index2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)` 28 | #' 29 | #' * `vec_size(hop_index2_vec(.x, .y, .starts, .stops)[[1]]) == 1L` 30 | #' 31 | #' * `vec_ptype(hop_index2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype` 32 | #' 33 | #' } 34 | #' 35 | #' \subsection{`phop_index()`}{ 36 | #' 37 | #' * `vec_size(phop_index(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` 38 | #' 39 | #' * `vec_ptype(phop_index(.l, .starts, .stops)) == list()` 40 | #' 41 | #' } 42 | #' 43 | #' \subsection{`phop_index_vec()`}{ 44 | #' 45 | #' * `vec_size(phop_index_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)` 46 | #' 47 | #' * `vec_size(phop_index_vec(.l, .starts, .stops)[[1]]) == 1L` 48 | #' 49 | #' * `vec_ptype(phop_index_vec(.l, .starts, .stops, .ptype = ptype)) == ptype` 50 | #' 51 | #' } 52 | #' 53 | #' @examples 54 | #' # Notice that `i` is an irregular index! 55 | #' x <- 1:5 56 | #' i <- as.Date("2019-08-15") + c(0:1, 4, 6, 7) 57 | #' 58 | #' # Manually create starts/stops. They don't have to be equally spaced, 59 | #' # and they don't have to be the same size as `.x` or `.i`. 60 | #' starts <- as.Date(c("2019-08-15", "2019-08-18")) 61 | #' stops <- as.Date(c("2019-08-16", "2019-08-23")) 62 | #' 63 | #' # The output size is equal to the common size of `.starts` and `.stops` 64 | #' hop_index2(x, i, i, starts, stops, ~data.frame(x = .x, y = .y)) 65 | #' 66 | #' @seealso [slide2()], [slide_index2()], [hop_index()] 67 | #' @export 68 | hop_index2 <- function(.x, .y, .i, .starts, .stops, .f, ...) { 69 | hop_index2_impl( 70 | .x, 71 | .y, 72 | .i, 73 | .starts, 74 | .stops, 75 | .f, 76 | ..., 77 | .ptype = list(), 78 | .constrain = FALSE, 79 | .atomic = FALSE 80 | ) 81 | } 82 | 83 | #' @rdname hop_index2 84 | #' @export 85 | hop_index2_vec <- function( 86 | .x, 87 | .y, 88 | .i, 89 | .starts, 90 | .stops, 91 | .f, 92 | ..., 93 | .ptype = NULL 94 | ) { 95 | out <- hop_index2_impl( 96 | .x, 97 | .y, 98 | .i, 99 | .starts, 100 | .stops, 101 | .f, 102 | ..., 103 | .ptype = list(), 104 | .constrain = FALSE, 105 | .atomic = TRUE 106 | ) 107 | 108 | vec_simplify(out, .ptype) 109 | } 110 | 111 | # ------------------------------------------------------------------------------ 112 | 113 | hop_index2_impl <- function( 114 | .x, 115 | .y, 116 | .i, 117 | .starts, 118 | .stops, 119 | .f, 120 | ..., 121 | .ptype, 122 | .constrain, 123 | .atomic, 124 | .slider_error_call = caller_env() 125 | ) { 126 | vec_assert(.x, call = .slider_error_call) 127 | vec_assert(.y, call = .slider_error_call) 128 | 129 | args <- vec_recycle_common(.x = .x, .y = .y, .call = .slider_error_call) 130 | 131 | .f <- as_function(.f, call = .slider_error_call) 132 | 133 | f_call <- expr(.f(.x, .y, ...)) 134 | 135 | type <- -2L 136 | 137 | hop_index_common( 138 | x = args, 139 | i = .i, 140 | starts = .starts, 141 | stops = .stops, 142 | f_call = f_call, 143 | ptype = .ptype, 144 | constrain = .constrain, 145 | atomic = .atomic, 146 | env = environment(), 147 | type = type, 148 | slider_error_call = .slider_error_call 149 | ) 150 | } 151 | -------------------------------------------------------------------------------- /R/hop.R: -------------------------------------------------------------------------------- 1 | #' Hop 2 | #' 3 | #' @description 4 | #' `hop()` is the lower level engine that powers [slide()] (at least in theory). 5 | #' It has slightly different invariants than `slide()`, and is useful 6 | #' when you either need to hand craft boundary locations, or want to compute a 7 | #' result with a size that is different from `.x`. 8 | #' 9 | #' @details 10 | #' `hop()` is very close to being a faster version of: 11 | #' 12 | #' ``` 13 | #' map2( 14 | #' .starts, 15 | #' .stops, 16 | #' function(start, stop) { 17 | #' x_slice <- vec_slice(.x, start:stop) 18 | #' .f(x_slice, ...) 19 | #' } 20 | #' ) 21 | #' ``` 22 | #' 23 | #' Because of this, [hop_index()] is often the more useful function. `hop()` 24 | #' mainly exists for API completeness. 25 | #' 26 | #' The main difference is that the start and stop values make up ranges of 27 | #' _possible_ locations along `.x`, and it is not enforced that these locations 28 | #' actually exist along `.x`. As an example, with `hop()` you can do the 29 | #' following, which would be an error with `vec_slice()` because `0L` is 30 | #' out of bounds. 31 | #' 32 | #' ``` 33 | #' hop(c("a", "b"), .starts = 0L, .stops = 1L, ~.x) 34 | #' #> [[1]] 35 | #' #> [1] "a" 36 | #' ``` 37 | #' 38 | #' `hop()` allows these out of bounds values to be fully compatible with 39 | #' `slide()`. It is always possible to construct a `hop()` call from a `slide()` 40 | #' call. For example, the following are equivalent: 41 | #' 42 | #' ``` 43 | #' slide(1:2, ~.x, .before = 1) 44 | #' 45 | #' hop(1:2, .starts = c(0, 1), .stops = c(1, 2), ~.x) 46 | #' 47 | #' #> [[1]] 48 | #' #> [1] 1 49 | #' #> 50 | #' #> [[2]] 51 | #' #> [1] 1 2 52 | #' ``` 53 | #' 54 | #' @inheritParams slide 55 | #' 56 | #' @template param-starts-stops-hop 57 | #' 58 | #' @return 59 | #' A vector fulfilling the following invariants: 60 | #' 61 | #' \subsection{`hop()`}{ 62 | #' 63 | #' * `vec_size(hop(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` 64 | #' 65 | #' * `vec_ptype(hop(.x, .starts, .stops)) == list()` 66 | #' 67 | #' } 68 | #' 69 | #' \subsection{`hop_vec()`}{ 70 | #' 71 | #' * `vec_size(hop_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` 72 | #' 73 | #' * `vec_size(hop_vec(.x, .starts, .stops)[[1]]) == 1L` 74 | #' 75 | #' * `vec_ptype(hop_vec(.x, .starts, .stops, .ptype = ptype)) == ptype` 76 | #' 77 | #' } 78 | #' 79 | #' @examples 80 | #' # `hop()` let's you manually specify locations to apply `.f` at. 81 | #' hop(1:3, .starts = c(1, 3), .stops = 3, ~.x) 82 | #' 83 | #' # `hop()`'s start/stop locations are allowed to be out of bounds relative 84 | #' # to the size of `.x`. 85 | #' hop( 86 | #' mtcars, 87 | #' .starts = c(-1, 3), 88 | #' .stops = c(2, 6), 89 | #' ~.x 90 | #' ) 91 | #' 92 | #' @seealso [hop2()], [hop_index()], [slide()] 93 | #' @export 94 | hop <- function(.x, .starts, .stops, .f, ...) { 95 | hop_impl( 96 | .x, 97 | .starts, 98 | .stops, 99 | .f, 100 | ..., 101 | .ptype = list(), 102 | .constrain = FALSE, 103 | .atomic = FALSE 104 | ) 105 | } 106 | 107 | #' @rdname hop 108 | #' @export 109 | hop_vec <- function(.x, .starts, .stops, .f, ..., .ptype = NULL) { 110 | out <- hop_impl( 111 | .x, 112 | .starts, 113 | .stops, 114 | .f, 115 | ..., 116 | .ptype = list(), 117 | .constrain = FALSE, 118 | .atomic = TRUE 119 | ) 120 | 121 | vec_simplify(out, .ptype) 122 | } 123 | 124 | # ------------------------------------------------------------------------------ 125 | 126 | hop_impl <- function( 127 | .x, 128 | .starts, 129 | .stops, 130 | .f, 131 | ..., 132 | .ptype, 133 | .constrain, 134 | .atomic, 135 | .slider_error_call = caller_env() 136 | ) { 137 | vec_assert(.x, call = .slider_error_call) 138 | 139 | .f <- as_function(.f, call = .slider_error_call) 140 | 141 | f_call <- expr(.f(.x, ...)) 142 | 143 | type <- -1L 144 | 145 | hop_common( 146 | x = .x, 147 | starts = .starts, 148 | stops = .stops, 149 | f_call = f_call, 150 | ptype = .ptype, 151 | env = environment(), 152 | type = type, 153 | constrain = .constrain, 154 | atomic = .atomic, 155 | slider_error_call = .slider_error_call 156 | ) 157 | } 158 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | is_unbounded <- function(x) { 2 | identical(x, Inf) 3 | } 4 | 5 | slider_check_list <- function(x, arg = caller_arg(x), call = caller_env()) { 6 | out <- slider_compat_list(x) 7 | vec_check_list(out, arg = arg, call = call) 8 | out 9 | } 10 | 11 | slider_compat_list <- function(x) { 12 | if (is.data.frame(x)) { 13 | # For compatibility, `pslide()`, `phop()`, and friends allow data frames 14 | slider_new_list(x) 15 | } else { 16 | x 17 | } 18 | } 19 | 20 | slider_new_list <- function(x) { 21 | if (!is_list(x)) { 22 | abort("`x` must be a VECSXP.", .internal = TRUE) 23 | } 24 | 25 | names <- names(x) 26 | if (is.null(names)) { 27 | attributes(x) <- NULL 28 | } else { 29 | attributes(x) <- list(names = names) 30 | } 31 | 32 | x 33 | } 34 | 35 | # Thrown to here from C 36 | stop_not_all_size_one <- function(iteration, size) { 37 | message <- c( 38 | "i" = cli::format_inline("In index: {iteration}"), 39 | "!" = cli::format_inline("The result of `.f` must have size 1, not {size}.") 40 | ) 41 | 42 | # TODO: Use correct `call` passed through C 43 | abort(message, call = NULL) 44 | } 45 | 46 | # Thrown to here from C 47 | stop_slide_start_past_stop <- function(starts, stops) { 48 | start_after_stop <- vec_compare(starts, stops) == 1L 49 | locations <- which(start_after_stop) 50 | 51 | message <- c( 52 | "i" = cli::format_inline("In locations: {locations}"), 53 | "i" = "In the ranges generated by `.before` and `.after`:", 54 | "!" = "The start of the range can't be after the end of the range." 55 | ) 56 | 57 | # TODO: Use correct `call` passed through C 58 | abort(message, call = NULL) 59 | } 60 | 61 | # Thrown to here from C 62 | stop_hop_start_past_stop <- function(starts, stops) { 63 | start_after_stop <- vec_compare(starts, stops) == 1L 64 | locations <- which(start_after_stop) 65 | 66 | message <- c( 67 | "i" = cli::format_inline("In locations: {locations}"), 68 | "i" = "In the ranges generated by `.starts` and `.stops`:", 69 | "!" = "The start of the range can't be after the end of the range." 70 | ) 71 | 72 | # TODO: Use correct `call` passed through C 73 | abort(message, call = NULL) 74 | } 75 | 76 | compute_size <- function(x, type) { 77 | SLIDE <- -1L 78 | PSLIDE_EMPTY <- 0L 79 | 80 | if (type == SLIDE) { 81 | vec_size(x) 82 | } else if (type == PSLIDE_EMPTY) { 83 | 0L 84 | } else { 85 | vec_size(x[[1L]]) 86 | } 87 | } 88 | 89 | # Unconditionally use only the names from `.x` on the output when simplifying. 90 | # Ensures that the following are aligned: 91 | # 92 | # slide_vec(c(x = 1), ~c(y = 2)) 93 | # purrr::map_dbl(c(x = 1), ~c(y = 2)) 94 | # 95 | # slide_vec(1, ~c(y = 2)) 96 | # purrr::map_dbl(1, ~c(y = 2)) 97 | vec_simplify <- function( 98 | x, 99 | ptype, 100 | error_arg = caller_arg(x), 101 | error_call = caller_env() 102 | ) { 103 | names <- vec_names(x) 104 | unnamed <- vec_set_names(x, NULL) 105 | 106 | out <- list_unchop( 107 | x = unnamed, 108 | ptype = ptype, 109 | error_arg = error_arg, 110 | error_call = error_call 111 | ) 112 | 113 | vec_set_names(out, names) 114 | } 115 | 116 | compute_combined_ranks <- function(...) { 117 | args <- list2(...) 118 | 119 | # TODO: Ideally we'd set `name_spec = zap()` to drop names from both `args` 120 | # and its elements for performance, but that doesn't work for non-vctrs types. 121 | # https://github.com/r-lib/vctrs/issues/1106 122 | combined <- list_unchop(unname(args)) 123 | 124 | # Expected that there are no missing values in `combined`. 125 | # Incomplete rows do get ranked, with missing values coming last. 126 | ranks <- vec_rank(combined, ties = "dense") 127 | 128 | n_args <- length(args) 129 | sizes <- list_sizes(args) 130 | indices <- vector("list", n_args) 131 | 132 | current_start <- 1L 133 | for (i in seq_len(n_args)) { 134 | next_start <- current_start + sizes[[i]] 135 | current_stop <- next_start - 1L 136 | indices[[i]] <- seq2(current_start, current_stop) 137 | current_start <- next_start 138 | } 139 | 140 | out <- vec_chop(ranks, indices) 141 | names(out) <- names(args) 142 | 143 | out 144 | } 145 | -------------------------------------------------------------------------------- /R/slide-period-common.R: -------------------------------------------------------------------------------- 1 | slide_period_common <- function( 2 | x, 3 | i, 4 | period, 5 | f_call, 6 | every, 7 | origin, 8 | before, 9 | after, 10 | complete, 11 | ptype, 12 | constrain, 13 | atomic, 14 | env, 15 | type, 16 | slider_error_call 17 | ) { 18 | check_index_incompatible_type(i, ".i", call = slider_error_call) 19 | check_index_cannot_be_na(i, ".i", call = slider_error_call) 20 | check_index_must_be_ascending(i, ".i", call = slider_error_call) 21 | 22 | before_unbounded <- is_unbounded(before) 23 | after_unbounded <- is_unbounded(after) 24 | 25 | before <- check_slide_period_before( 26 | before, 27 | before_unbounded, 28 | call = slider_error_call 29 | ) 30 | after <- check_slide_period_after( 31 | after, 32 | after_unbounded, 33 | call = slider_error_call 34 | ) 35 | complete <- check_slide_period_complete(complete, call = slider_error_call) 36 | 37 | groups <- warp_distance( 38 | i, 39 | period = period, 40 | every = every, 41 | origin = origin 42 | ) 43 | 44 | unique <- unique(groups) 45 | 46 | starts <- unique - before 47 | stops <- unique + after 48 | 49 | size_unique <- length(unique) 50 | 51 | size_front <- 0L 52 | size_back <- 0L 53 | 54 | if (complete && size_unique != 0L) { 55 | first <- unique[[1]] 56 | last <- unique[[size_unique]] 57 | 58 | from <- compute_from(starts, first, size_unique, before_unbounded) 59 | to <- compute_to(stops, last, size_unique, after_unbounded) 60 | 61 | size_front <- from - 1L 62 | size_back <- size_unique - to 63 | 64 | # Only slice if we have to 65 | # Important to use seq2()! Could have `from > to` 66 | if (from != 1L || to != size_unique) { 67 | starts <- starts[seq2(from, to)] 68 | stops <- stops[seq2(from, to)] 69 | } 70 | } 71 | 72 | out <- hop_index_common( 73 | x = x, 74 | i = groups, 75 | starts = starts, 76 | stops = stops, 77 | f_call = f_call, 78 | ptype = ptype, 79 | constrain = constrain, 80 | atomic = atomic, 81 | env = env, 82 | type = type, 83 | slider_error_call = slider_error_call 84 | ) 85 | 86 | if (!complete) { 87 | return(out) 88 | } 89 | 90 | # Initialize with `NA`, not `NULL`, for size stability when auto-simplifying 91 | if (atomic && !constrain) { 92 | front <- vec_init_unspecified_list(n = size_front) 93 | back <- vec_init_unspecified_list(n = size_back) 94 | } else { 95 | front <- vec_init(ptype, n = size_front) 96 | back <- vec_init(ptype, n = size_back) 97 | } 98 | 99 | out <- vec_c(front, out, back, .error_call = slider_error_call) 100 | 101 | out 102 | } 103 | 104 | compute_from <- function(starts, first, n, before_unbounded) { 105 | .Call(slider_compute_from, starts, first, n, before_unbounded) 106 | } 107 | 108 | compute_to <- function(stops, last, n, after_unbounded) { 109 | .Call(slider_compute_to, stops, last, n, after_unbounded) 110 | } 111 | 112 | check_slide_period_before <- function(x, unbounded, call = caller_env()) { 113 | vec_assert(x, size = 1L, arg = ".before", call = call) 114 | 115 | if (unbounded) { 116 | return(x) 117 | } 118 | 119 | x <- vec_cast(x, integer(), x_arg = ".before", call = call) 120 | 121 | if (is.na(x)) { 122 | abort("`.before` can't be `NA`.", call = call) 123 | } 124 | 125 | x 126 | } 127 | 128 | check_slide_period_after <- function(x, unbounded, call = caller_env()) { 129 | vec_assert(x, size = 1L, arg = ".after", call = call) 130 | 131 | if (unbounded) { 132 | return(x) 133 | } 134 | 135 | x <- vec_cast(x, integer(), x_arg = ".after", call = call) 136 | 137 | if (is.na(x)) { 138 | abort("`.after` can't be `NA`.", call = call) 139 | } 140 | 141 | x 142 | } 143 | 144 | check_slide_period_complete <- function(x, call = caller_env()) { 145 | vec_assert(x, size = 1L, arg = ".complete", call = call) 146 | 147 | x <- vec_cast(x, logical(), x_arg = ".complete", call = call) 148 | 149 | if (is.na(x)) { 150 | abort("`.complete` can't be `NA`.", call = call) 151 | } 152 | 153 | x 154 | } 155 | 156 | vec_init_unspecified_list <- function(n) { 157 | rep_len(list(NA), n) 158 | } 159 | -------------------------------------------------------------------------------- /src/assign.h: -------------------------------------------------------------------------------- 1 | #ifndef SLIDER_ASSIGN_H 2 | #define SLIDER_ASSIGN_H 3 | 4 | #include "slider.h" 5 | #include "slider-vctrs.h" 6 | 7 | // ----------------------------------------------------------------------------- 8 | 9 | #define ASSIGN_ONE(CONST_DEREF) do { \ 10 | elt = vec_cast(elt, ptype); \ 11 | p_out[i] = CONST_DEREF(elt)[0]; \ 12 | } while (0) 13 | 14 | #define ASSIGN_ONE_BARRIER(CONST_DEREF, SET) do { \ 15 | elt = vec_cast(elt, ptype); \ 16 | SET(out, i, CONST_DEREF(elt)[0]); \ 17 | } while (0) 18 | 19 | // For lists, we don't care what the `elt` is, we just assign it 20 | #define ASSIGN_ONE_LIST(SET) do { \ 21 | SET(out, i, elt); \ 22 | } while (0) 23 | 24 | static inline void assign_one_dbl(double* p_out, R_len_t i, SEXP elt, SEXP ptype) { 25 | ASSIGN_ONE(REAL_RO); 26 | } 27 | static inline void assign_one_int(int* p_out, R_len_t i, SEXP elt, SEXP ptype) { 28 | ASSIGN_ONE(INTEGER_RO); 29 | } 30 | static inline void assign_one_lgl(int* p_out, R_len_t i, SEXP elt, SEXP ptype) { 31 | ASSIGN_ONE(LOGICAL_RO); 32 | } 33 | static inline void assign_one_chr(SEXP out, R_len_t i, SEXP elt, SEXP ptype) { 34 | ASSIGN_ONE_BARRIER(STRING_PTR_RO, SET_STRING_ELT); 35 | } 36 | static inline void assign_one_lst(SEXP out, R_len_t i, SEXP elt, SEXP ptype) { 37 | ASSIGN_ONE_LIST(SET_VECTOR_ELT); 38 | } 39 | 40 | #undef ASSIGN_ONE 41 | #undef ASSIGN_ONE_BARRIER 42 | #undef ASSIGN_ONE_LIST 43 | 44 | // ----------------------------------------------------------------------------- 45 | 46 | #define ASSIGN_LOCS(CTYPE, CONST_DEREF) do { \ 47 | elt = PROTECT(vec_cast(elt, ptype)); \ 48 | const CTYPE value = CONST_DEREF(elt)[0]; \ 49 | \ 50 | for (R_len_t i = 0; i < size; ++i) { \ 51 | p_out[start] = value; \ 52 | ++start; \ 53 | } \ 54 | \ 55 | UNPROTECT(1); \ 56 | } while (0) 57 | 58 | #define ASSIGN_LOCS_BARRIER(CTYPE, CONST_DEREF, SET) do { \ 59 | elt = PROTECT(vec_cast(elt, ptype)); \ 60 | const CTYPE value = CONST_DEREF(elt)[0]; \ 61 | \ 62 | for (R_len_t i = 0; i < size; ++i) { \ 63 | SET(out, start, value); \ 64 | ++start; \ 65 | } \ 66 | \ 67 | UNPROTECT(1); \ 68 | } while (0) 69 | 70 | // For lists, we don't care what the `elt` is, we just assign it 71 | #define ASSIGN_LOCS_LIST(SET) do { \ 72 | for (R_len_t i = 0; i < size; ++i) { \ 73 | SET(out, start, elt); \ 74 | ++start; \ 75 | } \ 76 | } while (0) 77 | 78 | static inline void assign_locs_dbl(double* p_out, int start, int size, SEXP elt, SEXP ptype) { 79 | ASSIGN_LOCS(double, REAL_RO); 80 | } 81 | static inline void assign_locs_int(int* p_out, int start, int size, SEXP elt, SEXP ptype) { 82 | ASSIGN_LOCS(int, INTEGER_RO); 83 | } 84 | static inline void assign_locs_lgl(int* p_out, int start, int size, SEXP elt, SEXP ptype) { 85 | ASSIGN_LOCS(int, LOGICAL_RO); 86 | } 87 | static inline void assign_locs_chr(SEXP out, int start, int size, SEXP elt, SEXP ptype) { 88 | ASSIGN_LOCS_BARRIER(SEXP, STRING_PTR_RO, SET_STRING_ELT); 89 | } 90 | static inline void assign_locs_lst(SEXP out, int start, int size, SEXP elt, SEXP ptype) { 91 | ASSIGN_LOCS_LIST(SET_VECTOR_ELT); 92 | } 93 | 94 | #undef ASSIGN_LOCS 95 | #undef ASSIGN_LOCS_BARRIER 96 | #undef ASSIGN_LOCS_LIST 97 | 98 | // ----------------------------------------------------------------------------- 99 | 100 | #endif 101 | -------------------------------------------------------------------------------- /tests/testthat/test-hop-vec.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # type / size strict-ness 3 | 4 | test_that("size of each `.f` result must be 1", { 5 | expect_snapshot(error = TRUE, hop_vec(1:2, 1, 1, ~ c(.x, 1))) 6 | }) 7 | 8 | test_that("inner type is allowed to be different", { 9 | expect_equal( 10 | hop_vec( 11 | 1:2, 12 | 1:2, 13 | 1:2, 14 | ~ if (.x == 1L) { 15 | list(1) 16 | } else { 17 | list("hi") 18 | }, 19 | .ptype = list() 20 | ), 21 | list(1, "hi") 22 | ) 23 | }) 24 | 25 | test_that("inner type can be restricted with list_of", { 26 | expect_snapshot({ 27 | (expect_error( 28 | hop_vec( 29 | 1:2, 30 | 1:2, 31 | 1:2, 32 | ~ if (.x == 1L) { 33 | list_of(1) 34 | } else { 35 | list_of("hi") 36 | }, 37 | .ptype = list_of(.ptype = double()) 38 | ), 39 | class = "vctrs_error_incompatible_type" 40 | )) 41 | }) 42 | }) 43 | 44 | # ------------------------------------------------------------------------------ 45 | # .ptype 46 | 47 | test_that(".ptype is respected", { 48 | expect_equal(hop_vec(1, 1, 1, ~.x), 1) 49 | expect_equal(hop_vec(1, 1, 1, ~.x, .ptype = int()), 1L) 50 | expect_error( 51 | hop_vec(1, 1, 1, ~ .x + .5, .ptype = integer()), 52 | class = "vctrs_error_cast_lossy" 53 | ) 54 | }) 55 | 56 | test_that("`.ptype = NULL` results in 'guessed' .ptype", { 57 | expect_equal( 58 | hop_vec(1, 1, 1, ~.x, .ptype = NULL), 59 | hop_vec(1, 1, 1, ~.x, .ptype = dbl()) 60 | ) 61 | }) 62 | 63 | test_that("`.ptype = NULL` fails if no common type is found", { 64 | expect_snapshot({ 65 | (expect_error( 66 | hop_vec(1:2, 1:2, 1:2, ~ ifelse(.x == 1L, "hello", 1), .ptype = NULL), 67 | class = "vctrs_error_incompatible_type" 68 | )) 69 | }) 70 | }) 71 | 72 | test_that("`.ptype = NULL` validates that element lengths are 1", { 73 | expect_snapshot(error = TRUE, { 74 | hop_vec( 75 | 1:2, 76 | 1:2, 77 | 1:2, 78 | ~ if (.x == 1L) { 79 | 1:2 80 | } else { 81 | 1 82 | }, 83 | .ptype = NULL 84 | ) 85 | }) 86 | expect_snapshot(error = TRUE, { 87 | hop_vec( 88 | 1:2, 89 | 1:2, 90 | 1:2, 91 | ~ if (.x == 1L) { 92 | NULL 93 | } else { 94 | 2 95 | }, 96 | .ptype = NULL 97 | ) 98 | }) 99 | }) 100 | 101 | test_that("`.ptype = NULL` returns `NULL` with size 0 `.x`", { 102 | expect_equal( 103 | hop_vec(integer(), integer(), integer(), ~.x, .ptype = NULL), 104 | NULL 105 | ) 106 | }) 107 | 108 | test_that(".ptypes with a vec_proxy() are restored to original type", { 109 | expect_s3_class( 110 | hop_vec(Sys.Date() + 1:5, 1:5, 1:5, ~.x, .ptype = as.POSIXlt(Sys.Date())), 111 | "POSIXlt" 112 | ) 113 | }) 114 | 115 | test_that("can return a matrix and rowwise bind the results together", { 116 | mat <- matrix(1, ncol = 2) 117 | expect_equal( 118 | hop_vec(1:5, 1:5, 1:5, ~mat, .ptype = mat), 119 | rbind(mat, mat, mat, mat, mat) 120 | ) 121 | }) 122 | 123 | test_that("`hop_vec()` falls back to `c()` method as required", { 124 | local_c_foobar() 125 | 126 | expect_identical( 127 | hop_vec(1:3, 1:3, 1:3, ~ foobar(.x), .ptype = foobar(integer())), 128 | foobar(1:3) 129 | ) 130 | expect_condition( 131 | hop_vec(1:3, 1:3, 1:3, ~ foobar(.x), .ptype = foobar(integer())), 132 | class = "slider_c_foobar" 133 | ) 134 | 135 | expect_identical(hop_vec(1:3, 1:3, 1:3, ~ foobar(.x)), foobar(1:3)) 136 | expect_condition( 137 | hop_vec(1:3, 1:3, 1:3, ~ foobar(.x)), 138 | class = "slider_c_foobar" 139 | ) 140 | }) 141 | 142 | # ------------------------------------------------------------------------------ 143 | # input names 144 | 145 | test_that("names exist on inner sliced elements", { 146 | names <- letters[1:5] 147 | x <- set_names(1:5, names) 148 | exp <- as.list(names) 149 | expect_equal(hop_vec(x, 1:5, 1:5, ~ list(names(.x))), exp) 150 | }) 151 | 152 | test_that("names are never placed on the output", { 153 | x <- set_names(1:5, letters[1:5]) 154 | expect_null(names(hop_vec(x, 1:5, 1:5, ~.x))) 155 | expect_null(names(hop_vec(x, 1:5, 1:5, ~.x, .ptype = int()))) 156 | }) 157 | -------------------------------------------------------------------------------- /man/hop2.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hop2.R, R/phop.R 3 | \name{hop2} 4 | \alias{hop2} 5 | \alias{hop2_vec} 6 | \alias{phop} 7 | \alias{phop_vec} 8 | \title{Hop along multiple inputs simultaneously} 9 | \usage{ 10 | hop2(.x, .y, .starts, .stops, .f, ...) 11 | 12 | hop2_vec(.x, .y, .starts, .stops, .f, ..., .ptype = NULL) 13 | 14 | phop(.l, .starts, .stops, .f, ...) 15 | 16 | phop_vec(.l, .starts, .stops, .f, ..., .ptype = NULL) 17 | } 18 | \arguments{ 19 | \item{.x, .y}{\verb{[vector]} 20 | 21 | Vectors to iterate over. Vectors of size 1 will be recycled.} 22 | 23 | \item{.starts, .stops}{\verb{[integer]} 24 | 25 | Vectors of boundary locations that make up the windows to bucket \code{.x} with. 26 | Both \code{.starts} and \code{.stops} will be recycled to their common size, and 27 | that common size will be the size of the result. Both vectors should be 28 | integer locations along \code{.x}, but out-of-bounds values are allowed.} 29 | 30 | \item{.f}{\verb{[function / formula]} 31 | 32 | If a \strong{function}, it is used as is. 33 | 34 | If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There 35 | are three ways to refer to the arguments: 36 | \itemize{ 37 | \item For a single argument function, use \code{.} 38 | \item For a two argument function, use \code{.x} and \code{.y} 39 | \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc 40 | } 41 | 42 | This syntax allows you to create very compact anonymous functions.} 43 | 44 | \item{...}{Additional arguments passed on to the mapped function.} 45 | 46 | \item{.ptype}{\verb{[vector(0) / NULL]} 47 | 48 | A prototype corresponding to the type of the output. 49 | 50 | If \code{NULL}, the default, the output type is determined by computing the 51 | common type across the results of the calls to \code{.f}. 52 | 53 | If supplied, the result of each call to \code{.f} will be cast to that type, 54 | and the final output will have that type. 55 | 56 | If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be 57 | supplied. This is a way to make production code demand fixed types.} 58 | 59 | \item{.l}{\verb{[list]} 60 | 61 | A list of vectors. The length of \code{.l} determines the 62 | number of arguments that \code{.f} will be called with. If \code{.l} has names, 63 | they will be used as named arguments to \code{.f}. Elements of \code{.l} with size 64 | 1 will be recycled.} 65 | } 66 | \value{ 67 | A vector fulfilling the following invariants: 68 | 69 | \subsection{\code{hop2()}}{ 70 | \itemize{ 71 | \item \code{vec_size(hop2(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} 72 | \item \code{vec_ptype(hop2(.x, .y, .starts, .stops)) == list()} 73 | } 74 | 75 | } 76 | 77 | \subsection{\code{hop2_vec()}}{ 78 | \itemize{ 79 | \item \code{vec_size(hop2_vec(.x, .y, .starts, .stops)) == vec_size_common(.starts, .stops)} 80 | \item \code{vec_size(hop2_vec(.x, .y, .starts, .stops)[[1]]) == 1L} 81 | \item \code{vec_ptype(hop2_vec(.x, .y, .starts, .stops, .ptype = ptype)) == ptype} 82 | } 83 | 84 | } 85 | 86 | \subsection{\code{phop()}}{ 87 | \itemize{ 88 | \item \code{vec_size(phop(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} 89 | \item \code{vec_ptype(phop(.l, .starts, .stops)) == list()} 90 | } 91 | 92 | } 93 | 94 | \subsection{\code{phop_vec()}}{ 95 | \itemize{ 96 | \item \code{vec_size(phop_vec(.l, .starts, .stops)) == vec_size_common(.starts, .stops)} 97 | \item \code{vec_size(phop_vec(.l, .starts, .stops)[[1]]) == 1L} 98 | \item \code{vec_ptype(phop_vec(.l, .starts, .stops, .ptype = ptype)) == ptype} 99 | } 100 | 101 | } 102 | } 103 | \description{ 104 | \code{hop2()} and \code{phop()} represent the combination 105 | of \code{\link[=slide2]{slide2()}} and \code{\link[=pslide]{pslide()}} with \code{\link[=hop]{hop()}}, allowing you to iterate 106 | over multiple vectors at once, hopping along them using boundaries defined 107 | by \code{.starts} and \code{.stops}. 108 | } 109 | \examples{ 110 | hop2(1:2, 3:4, .starts = 1, .stops = c(2, 1), ~c(x = .x, y = .y)) 111 | 112 | phop( 113 | list(1, 2:4, 5:7), 114 | .starts = c(0, 1), 115 | .stops = c(2, 4), 116 | ~c(x = ..1, y = ..2, z = ..3) 117 | ) 118 | 119 | } 120 | \seealso{ 121 | \code{\link[=hop]{hop()}}, \code{\link[=hop_index]{hop_index()}}, \code{\link[=slide2]{slide2()}} 122 | } 123 | -------------------------------------------------------------------------------- /tests/testthat/test-phop-index-vec.R: -------------------------------------------------------------------------------- 1 | # ------------------------------------------------------------------------------ 2 | # phop_index_vec 3 | 4 | test_that("phop_index_vec() works", { 5 | expect_identical(phop_index_vec(list(1L, 1L), 1, 1, 1, ~ .x + .y), 2L) 6 | }) 7 | 8 | test_that("phop_index_vec() doesn't retains names of first input (#75)", { 9 | expect_named( 10 | phop_index_vec(list(c(x = 1L), c(y = 1L)), 1, 1, 1, ~ .x + .y), 11 | NULL 12 | ) 13 | }) 14 | 15 | test_that("phop_index_vec() can simplify automatically", { 16 | expect_identical( 17 | phop_index_vec(list(1, 2), 1, 1, 1, ~ .x + .y, .ptype = NULL), 18 | 3 19 | ) 20 | }) 21 | 22 | test_that("phop_index_vec() errors if it can't simplify", { 23 | fn <- function(x, y) { 24 | if (x == 1L) { 25 | 1 26 | } else { 27 | "hi" 28 | } 29 | } 30 | expect_snapshot({ 31 | (expect_error( 32 | phop_index_vec(list(1:2, 1:2), 1:2, 1:2, 1:2, fn, .ptype = NULL), 33 | class = "vctrs_error_incompatible_type" 34 | )) 35 | }) 36 | }) 37 | 38 | test_that("completely empty input returns ptype", { 39 | expect_equal( 40 | phop_index_vec(list(), integer(), integer(), integer(), ~.x), 41 | NULL 42 | ) 43 | expect_equal( 44 | phop_index_vec( 45 | list(), 46 | integer(), 47 | integer(), 48 | integer(), 49 | ~.x, 50 | .ptype = list() 51 | ), 52 | list() 53 | ) 54 | expect_equal( 55 | phop_index_vec( 56 | list(), 57 | integer(), 58 | integer(), 59 | integer(), 60 | ~.x, 61 | .ptype = int() 62 | ), 63 | int() 64 | ) 65 | }) 66 | 67 | test_that("empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops` returns size `n` ptype", { 68 | expect_identical( 69 | phop_index_vec(list(), integer(), 1:2, 2:3, ~2, .ptype = int()), 70 | c(2L, 2L) 71 | ) 72 | expect_identical( 73 | phop_index_vec(list(), integer(), 1:2, 2:3, ~2, .ptype = NULL), 74 | c(2, 2) 75 | ) 76 | }) 77 | 78 | test_that("can't access non-existant `.x` with empty `.l` and `.i`, but size `n > 0` `.starts` and `.stops`", { 79 | # Note: Error message seems platform dependent 80 | expect_error(phop_index_vec(list(), integer(), 1:2, 2:3, ~.x, .ptype = int())) 81 | }) 82 | 83 | # ------------------------------------------------------------------------------ 84 | # .ptype 85 | 86 | test_that("`.ptype = NULL` validates that element lengths are 1", { 87 | expect_snapshot(error = TRUE, { 88 | phop_index_vec( 89 | list(1:2, 1:2), 90 | 1:2, 91 | 1:2, 92 | 1:2, 93 | ~ if (.x == 1L) { 94 | 1:2 95 | } else { 96 | 1 97 | }, 98 | .ptype = NULL 99 | ) 100 | }) 101 | expect_snapshot(error = TRUE, { 102 | phop_index_vec( 103 | list(1:2, 1:2), 104 | 1:2, 105 | 1:2, 106 | 1:2, 107 | ~ if (.x == 1L) { 108 | NULL 109 | } else { 110 | 2 111 | }, 112 | .ptype = NULL 113 | ) 114 | }) 115 | }) 116 | 117 | test_that("size 0 `.starts` / `.stops` returns size 0 `.ptype`", { 118 | expect_identical( 119 | phop_index_vec(list(1:5), 1:5, integer(), integer(), ~.x, .ptype = NULL), 120 | NULL 121 | ) 122 | expect_identical( 123 | phop_index_vec( 124 | list(1:5), 125 | 1:5, 126 | integer(), 127 | integer(), 128 | ~.x, 129 | .ptype = double() 130 | ), 131 | double() 132 | ) 133 | }) 134 | 135 | test_that("`phop_index_vec()` falls back to `c()` method as required", { 136 | local_c_foobar() 137 | 138 | expect_identical( 139 | phop_index_vec( 140 | list(1:3, 1:3), 141 | 1:3, 142 | 1:3, 143 | 1:3, 144 | ~ foobar(.x), 145 | .ptype = foobar(integer()) 146 | ), 147 | foobar(1:3) 148 | ) 149 | expect_condition( 150 | phop_index_vec( 151 | list(1:3, 1:3), 152 | 1:3, 153 | 1:3, 154 | 1:3, 155 | ~ foobar(.x), 156 | .ptype = foobar(integer()) 157 | ), 158 | class = "slider_c_foobar" 159 | ) 160 | 161 | expect_identical( 162 | phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~ foobar(.x)), 163 | foobar(1:3) 164 | ) 165 | expect_condition( 166 | phop_index_vec(list(1:3, 1:3), 1:3, 1:3, 1:3, ~ foobar(.x)), 167 | class = "slider_c_foobar" 168 | ) 169 | }) 170 | -------------------------------------------------------------------------------- /R/arithmetic.R: -------------------------------------------------------------------------------- 1 | #' Index arithmetic 2 | #' 3 | #' @description 4 | #' `slider_plus()` and `slider_minus()` are developer functions used to register 5 | #' special double dispatch methods to control how `.before` and `.after` are 6 | #' subtracted from and added to `.i`. These allow developers to overcome some of 7 | #' the restrictions around `+` and `-` when custom S3 types are involved. These 8 | #' should only be used by package authors creating new index types. 9 | #' 10 | #' * `slider_plus()` allows you to override the default behavior of 11 | #' `.i + .after`. When writing the S3 method, `x` will be `.i`, and `y` will 12 | #' be `.after`. 13 | #' 14 | #' * `slider_minus()` allows you to override the default behavior of 15 | #' `.i - .before`. When writing the S3 method, `x` will be `.i`, and `y` will 16 | #' be `.before`. 17 | #' 18 | #' These generics are a bit special. They work similarly to 19 | #' [vctrs::vec_ptype2()] in that they are _double dispatch_ methods that 20 | #' dispatch off the types of both `x` and `y`. To write an S3 method for these 21 | #' generics, write and export an S3 method of the form: 22 | #' 23 | #' ``` 24 | #' slider_plus.x_class.y_class <- function(x, y) { 25 | #' # My method 26 | #' } 27 | #' ``` 28 | #' 29 | #' Inheritance is not considered in the method lookup, and you cannot use 30 | #' `NextMethod()` from within your method. 31 | #' 32 | #' @keywords internal 33 | #' @name index-arithmetic 34 | #' 35 | #' @param x,y `[vector]` 36 | #' 37 | #' Two vectors to add or subtract. 38 | #' 39 | #' `x` will always be the index, `.i`. 40 | #' 41 | #' For `slider_plus()`, `y` will be `.after`. 42 | #' 43 | #' For `slider_minus()`, `y` will be `.before`. 44 | #' 45 | #' @returns 46 | #' * For `slider_plus()`, `x` after adding `y`. 47 | #' 48 | #' * For `slider_minus()`, `x` after subtracting `y`. 49 | #' 50 | #' The result should always be the same type and size as `x`. 51 | #' 52 | #' @examples 53 | #' slider_plus(1, 2) 54 | #' slider_minus(1, 2) 55 | NULL 56 | 57 | #' @export 58 | #' @rdname index-arithmetic 59 | slider_plus <- function(x, y) { 60 | return(slider_dispatch("slider_plus", x, y, slider_plus_default)) 61 | UseMethod("slider_plus") 62 | } 63 | 64 | #' @export 65 | #' @rdname index-arithmetic 66 | slider_minus <- function(x, y) { 67 | return(slider_dispatch("slider_minus", x, y, slider_minus_default)) 68 | UseMethod("slider_minus") 69 | } 70 | 71 | slider_plus_default <- function(x, y) { 72 | x + y 73 | } 74 | slider_minus_default <- function(x, y) { 75 | x - y 76 | } 77 | 78 | slider_dispatch <- function(generic, x, y, fn_default) { 79 | fn <- slider_method_get(generic, x, y) 80 | 81 | if (is.null(fn)) { 82 | fn_default(x, y) 83 | } else { 84 | fn(x, y) 85 | } 86 | } 87 | 88 | slider_class <- function(x) { 89 | if (is.object(x)) { 90 | out <- class(x)[[1L]] 91 | } else { 92 | # Mainly so `1` returns `"double"` not `"numeric"` 93 | # for method registration purposes 94 | out <- typeof(x) 95 | } 96 | 97 | if (!is_string(out)) { 98 | abort("Encountered object with corrupt class.", .internal = TRUE) 99 | } 100 | 101 | out 102 | } 103 | 104 | slider_method_get <- function(generic, x, y) { 105 | x_class <- slider_class(x) 106 | y_class <- slider_class(y) 107 | 108 | name <- paste0(generic, ".", x_class, ".", y_class) 109 | 110 | s3_method_get(name) 111 | } 112 | 113 | s3_method_get <- function(name) { 114 | # Try global env first in case the user registered a method interactively 115 | env <- global_env() 116 | fn <- env_get(env, name, default = NULL) 117 | 118 | if (is_function(fn)) { 119 | return(fn) 120 | } 121 | 122 | # Then try the slider S3 methods table 123 | ns <- ns_env("slider") 124 | env <- ns_methods_table(ns) 125 | fn <- env_get(env, name, default = NULL) 126 | 127 | if (is_function(fn)) { 128 | return(fn) 129 | } 130 | 131 | # Symbol not bound to the `env`, or it was bound to a non-function 132 | NULL 133 | } 134 | 135 | ns_methods_table <- function(ns) { 136 | ns$.__S3MethodsTable__. 137 | } 138 | 139 | # ------------------------------------------------------------------------------ 140 | # "Exported" methods for testing the package registration path 141 | 142 | #' @export 143 | slider_plus.slider_test_class.double <- function(x, y) { 144 | new_slider_test_class(x + (y * 2)) 145 | } 146 | 147 | #' @export 148 | slider_minus.slider_test_class.double <- function(x, y) { 149 | new_slider_test_class(x - (y * 2)) 150 | } 151 | 152 | new_slider_test_class <- function(x) { 153 | structure(x, class = "slider_test_class") 154 | } 155 | -------------------------------------------------------------------------------- /man/hop.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hop.R 3 | \name{hop} 4 | \alias{hop} 5 | \alias{hop_vec} 6 | \title{Hop} 7 | \usage{ 8 | hop(.x, .starts, .stops, .f, ...) 9 | 10 | hop_vec(.x, .starts, .stops, .f, ..., .ptype = NULL) 11 | } 12 | \arguments{ 13 | \item{.x}{\verb{[vector]} 14 | 15 | The vector to iterate over and apply \code{.f} to.} 16 | 17 | \item{.starts, .stops}{\verb{[integer]} 18 | 19 | Vectors of boundary locations that make up the windows to bucket \code{.x} with. 20 | Both \code{.starts} and \code{.stops} will be recycled to their common size, and 21 | that common size will be the size of the result. Both vectors should be 22 | integer locations along \code{.x}, but out-of-bounds values are allowed.} 23 | 24 | \item{.f}{\verb{[function / formula]} 25 | 26 | If a \strong{function}, it is used as is. 27 | 28 | If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There 29 | are three ways to refer to the arguments: 30 | \itemize{ 31 | \item For a single argument function, use \code{.} 32 | \item For a two argument function, use \code{.x} and \code{.y} 33 | \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc 34 | } 35 | 36 | This syntax allows you to create very compact anonymous functions.} 37 | 38 | \item{...}{Additional arguments passed on to the mapped function.} 39 | 40 | \item{.ptype}{\verb{[vector(0) / NULL]} 41 | 42 | A prototype corresponding to the type of the output. 43 | 44 | If \code{NULL}, the default, the output type is determined by computing the 45 | common type across the results of the calls to \code{.f}. 46 | 47 | If supplied, the result of each call to \code{.f} will be cast to that type, 48 | and the final output will have that type. 49 | 50 | If \code{getOption("vctrs.no_guessing")} is \code{TRUE}, the \code{.ptype} must be 51 | supplied. This is a way to make production code demand fixed types.} 52 | } 53 | \value{ 54 | A vector fulfilling the following invariants: 55 | 56 | \subsection{\code{hop()}}{ 57 | \itemize{ 58 | \item \code{vec_size(hop(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} 59 | \item \code{vec_ptype(hop(.x, .starts, .stops)) == list()} 60 | } 61 | 62 | } 63 | 64 | \subsection{\code{hop_vec()}}{ 65 | \itemize{ 66 | \item \code{vec_size(hop_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)} 67 | \item \code{vec_size(hop_vec(.x, .starts, .stops)[[1]]) == 1L} 68 | \item \code{vec_ptype(hop_vec(.x, .starts, .stops, .ptype = ptype)) == ptype} 69 | } 70 | 71 | } 72 | } 73 | \description{ 74 | \code{hop()} is the lower level engine that powers \code{\link[=slide]{slide()}} (at least in theory). 75 | It has slightly different invariants than \code{slide()}, and is useful 76 | when you either need to hand craft boundary locations, or want to compute a 77 | result with a size that is different from \code{.x}. 78 | } 79 | \details{ 80 | \code{hop()} is very close to being a faster version of: 81 | 82 | \if{html}{\out{
}}\preformatted{map2( 83 | .starts, 84 | .stops, 85 | function(start, stop) \{ 86 | x_slice <- vec_slice(.x, start:stop) 87 | .f(x_slice, ...) 88 | \} 89 | ) 90 | }\if{html}{\out{
}} 91 | 92 | Because of this, \code{\link[=hop_index]{hop_index()}} is often the more useful function. \code{hop()} 93 | mainly exists for API completeness. 94 | 95 | The main difference is that the start and stop values make up ranges of 96 | \emph{possible} locations along \code{.x}, and it is not enforced that these locations 97 | actually exist along \code{.x}. As an example, with \code{hop()} you can do the 98 | following, which would be an error with \code{vec_slice()} because \code{0L} is 99 | out of bounds. 100 | 101 | \if{html}{\out{
}}\preformatted{hop(c("a", "b"), .starts = 0L, .stops = 1L, ~.x) 102 | #> [[1]] 103 | #> [1] "a" 104 | }\if{html}{\out{
}} 105 | 106 | \code{hop()} allows these out of bounds values to be fully compatible with 107 | \code{slide()}. It is always possible to construct a \code{hop()} call from a \code{slide()} 108 | call. For example, the following are equivalent: 109 | 110 | \if{html}{\out{
}}\preformatted{slide(1:2, ~.x, .before = 1) 111 | 112 | hop(1:2, .starts = c(0, 1), .stops = c(1, 2), ~.x) 113 | 114 | #> [[1]] 115 | #> [1] 1 116 | #> 117 | #> [[2]] 118 | #> [1] 1 2 119 | }\if{html}{\out{
}} 120 | } 121 | \examples{ 122 | # `hop()` let's you manually specify locations to apply `.f` at. 123 | hop(1:3, .starts = c(1, 3), .stops = 3, ~.x) 124 | 125 | # `hop()`'s start/stop locations are allowed to be out of bounds relative 126 | # to the size of `.x`. 127 | hop( 128 | mtcars, 129 | .starts = c(-1, 3), 130 | .stops = c(2, 6), 131 | ~.x 132 | ) 133 | 134 | } 135 | \seealso{ 136 | \code{\link[=hop2]{hop2()}}, \code{\link[=hop_index]{hop_index()}}, \code{\link[=slide]{slide()}} 137 | } 138 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/hop-index.md: -------------------------------------------------------------------------------- 1 | # .x must be the same size as .i 2 | 3 | Code 4 | (expect_error(hop_index(1, 1:2, 1, 1, identity), class = "slider_error_index_incompatible_size") 5 | ) 6 | Output 7 | 8 | Error in `hop_index()`: 9 | ! `.i` must have size 1, not 2. 10 | 11 | # .i must be ascending 12 | 13 | Code 14 | (expect_error(hop_index(1:2, 2:1, 1:2, 1:2, identity), class = "slider_error_index_must_be_ascending") 15 | ) 16 | Output 17 | 18 | Error in `hop_index()`: 19 | i In locations: 2 20 | ! `.i` must be in ascending order. 21 | 22 | # .starts must be ascending 23 | 24 | Code 25 | (expect_error(hop_index(1:2, 1:2, 2:1, 1:2, identity), class = "slider_error_endpoints_must_be_ascending") 26 | ) 27 | Output 28 | 29 | Error in `hop_index()`: 30 | i In locations: 2 31 | ! `.starts` must be in ascending order. 32 | 33 | # .stops must be ascending 34 | 35 | Code 36 | (expect_error(hop_index(1:2, 1:2, 1:2, 2:1, identity), class = "slider_error_endpoints_must_be_ascending") 37 | ) 38 | Output 39 | 40 | Error in `hop_index()`: 41 | i In locations: 2 42 | ! `.stops` must be in ascending order. 43 | 44 | # empty `.x` and `.i`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first 45 | 46 | Code 47 | (expect_error(hop_index(integer(), integer(), 1:3, 1:2, ~.x), class = "vctrs_error_incompatible_size") 48 | ) 49 | Output 50 | 51 | Error in `hop_index()`: 52 | ! Can't recycle `.starts` (size 3) to match `.stops` (size 2). 53 | Code 54 | (expect_error(hop_index(integer(), integer(), 1, "x", ~.x), class = "vctrs_error_incompatible_type") 55 | ) 56 | Output 57 | 58 | Error in `hop_index()`: 59 | ! Can't convert `.stops` to match type of `.i` . 60 | 61 | # .i must not contain NA values 62 | 63 | Code 64 | (expect_error(hop_index(1:2, c(1, NA), 1:2, 1:2, identity), class = "slider_error_index_cannot_be_na") 65 | ) 66 | Output 67 | 68 | Error in `hop_index()`: 69 | i In locations: 2 70 | ! `.i` can't be `NA`. 71 | Code 72 | (expect_error(hop_index(1:2, c(NA, 1), 1:2, 1:2, identity), class = "slider_error_index_cannot_be_na") 73 | ) 74 | Output 75 | 76 | Error in `hop_index()`: 77 | i In locations: 1 78 | ! `.i` can't be `NA`. 79 | 80 | # .starts must not contain NA values 81 | 82 | Code 83 | (expect_error(hop_index(1:2, 1:2, c(1, NA), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") 84 | ) 85 | Output 86 | 87 | Error in `hop_index()`: 88 | i In locations: 2 89 | ! `.starts` can't be `NA`. 90 | Code 91 | (expect_error(hop_index(1:2, 1:2, c(NA, 1), 1:2, identity), class = "slider_error_endpoints_cannot_be_na") 92 | ) 93 | Output 94 | 95 | Error in `hop_index()`: 96 | i In locations: 1 97 | ! `.starts` can't be `NA`. 98 | 99 | # .stops must not contain NA values 100 | 101 | Code 102 | (expect_error(hop_index(1:2, 1:2, 1:2, c(1, NA), identity), class = "slider_error_endpoints_cannot_be_na") 103 | ) 104 | Output 105 | 106 | Error in `hop_index()`: 107 | i In locations: 2 108 | ! `.stops` can't be `NA`. 109 | Code 110 | (expect_error(hop_index(1:2, 1:2, 1:2, c(NA, 1), identity), class = "slider_error_endpoints_cannot_be_na") 111 | ) 112 | Output 113 | 114 | Error in `hop_index()`: 115 | i In locations: 1 116 | ! `.stops` can't be `NA`. 117 | 118 | # recycling is used for .starts/.stops 119 | 120 | Code 121 | (expect_error(hop_index(1:2, 1:2, 1:2, 1:3, ~.x), class = "vctrs_error_incompatible_size") 122 | ) 123 | Output 124 | 125 | Error in `hop_index()`: 126 | ! Can't recycle `.starts` (size 2) to match `.stops` (size 3). 127 | 128 | # .starts and .stops are cast to .i 129 | 130 | Code 131 | (expect_error(hop_index(1:2, i, starts, stops, ~.x), class = "vctrs_error_incompatible_type") 132 | ) 133 | Output 134 | 135 | Error in `hop_index()`: 136 | ! Can't convert `.starts` to match type of `.i` . 137 | 138 | -------------------------------------------------------------------------------- /src/hop.c: -------------------------------------------------------------------------------- 1 | #include "slider.h" 2 | #include "slider-vctrs.h" 3 | #include "utils.h" 4 | #include "params.h" 5 | #include "assign.h" 6 | 7 | // ----------------------------------------------------------------------------- 8 | 9 | #define HOP_LOOP(ASSIGN_ONE) do { \ 10 | for (R_len_t i = 0; i < size; ++i) { \ 11 | if (i % 1024 == 0) { \ 12 | R_CheckUserInterrupt(); \ 13 | } \ 14 | \ 15 | int window_start = max(p_starts[i] - 1, 0); \ 16 | int window_stop = min(p_stops[i] - 1, x_size - 1); \ 17 | int window_size = window_stop - window_start + 1; \ 18 | \ 19 | /* This can happen if both `window_start` and */ \ 20 | /* `window_stop` are outside the range of `x`. */ \ 21 | /* We return a 0-size slice of `x`. */ \ 22 | if (window_stop < window_start) { \ 23 | window_start = 0; \ 24 | window_size = 0; \ 25 | } \ 26 | \ 27 | init_compact_seq(p_window, window_start, window_size, true); \ 28 | \ 29 | slice_and_update_env(x, window, env, type, container); \ 30 | \ 31 | SEXP elt = PROTECT(R_forceAndCall(f_call, force, env)); \ 32 | \ 33 | if (atomic && vec_size(elt) != 1) { \ 34 | stop_not_all_size_one(i + 1, vec_size(elt)); \ 35 | } \ 36 | \ 37 | ASSIGN_ONE(p_out, i, elt, ptype); \ 38 | UNPROTECT(1); \ 39 | } \ 40 | } while (0) 41 | 42 | #define HOP_LOOP_ATOMIC(CTYPE, DEREF, ASSIGN_ONE) do { \ 43 | CTYPE* p_out = DEREF(out); \ 44 | HOP_LOOP(ASSIGN_ONE); \ 45 | } while (0) 46 | 47 | #define HOP_LOOP_BARRIER(ASSIGN_ONE) do { \ 48 | SEXP p_out = out; \ 49 | HOP_LOOP(ASSIGN_ONE); \ 50 | } while (0) 51 | 52 | // ----------------------------------------------------------------------------- 53 | 54 | // [[ register() ]] 55 | SEXP hop_common_impl(SEXP x, 56 | SEXP starts, 57 | SEXP stops, 58 | SEXP f_call, 59 | SEXP ptype, 60 | SEXP env, 61 | SEXP params) { 62 | 63 | const int type = validate_type(r_lst_get(params, 0)); 64 | const int force = compute_force(type); 65 | const bool constrain = validate_constrain(r_lst_get(params, 1)); 66 | const bool atomic = validate_atomic(r_lst_get(params, 2)); 67 | 68 | const R_len_t x_size = compute_size(x, type); 69 | const R_len_t size = vec_size(starts); 70 | 71 | const int* p_starts = INTEGER_RO(starts); 72 | const int* p_stops = INTEGER_RO(stops); 73 | 74 | check_hop_starts_not_past_stops(starts, stops, p_starts, p_stops, size); 75 | 76 | // The indices to slice x with 77 | SEXP window = PROTECT(compact_seq(0, 0, true)); 78 | int* p_window = INTEGER(window); 79 | 80 | // Mutable container for the results of slicing x 81 | SEXP container = PROTECT(make_slice_container(type)); 82 | 83 | SEXPTYPE out_type = TYPEOF(ptype); 84 | SEXP out = PROTECT(slider_init(out_type, size)); 85 | 86 | if (atomic && !constrain && out_type == VECSXP) { 87 | // Initialize with `NA`, not `NULL`, for size stability when auto simplifying 88 | list_fill(out, slider_shared_na_lgl); 89 | } 90 | 91 | switch (out_type) { 92 | case INTSXP: HOP_LOOP_ATOMIC(int, INTEGER, assign_one_int); break; 93 | case REALSXP: HOP_LOOP_ATOMIC(double, REAL, assign_one_dbl); break; 94 | case LGLSXP: HOP_LOOP_ATOMIC(int, LOGICAL, assign_one_lgl); break; 95 | case STRSXP: HOP_LOOP_BARRIER(assign_one_chr); break; 96 | case VECSXP: HOP_LOOP_BARRIER(assign_one_lst); break; 97 | default: never_reached("hop_common_impl"); 98 | } 99 | 100 | UNPROTECT(3); 101 | return out; 102 | } 103 | 104 | // ----------------------------------------------------------------------------- 105 | 106 | #undef HOP_LOOP 107 | #undef HOP_LOOP_ATOMIC 108 | #undef HOP_LOOP_BARRIER 109 | -------------------------------------------------------------------------------- /tests/testthat/test-hop.R: -------------------------------------------------------------------------------- 1 | test_that("trivial case works", { 2 | expect_equal( 3 | hop(1:2, 1:2, 1:2, ~.x), 4 | list(1L, 2L) 5 | ) 6 | }) 7 | 8 | test_that(".starts and .stops don't have to be ascending", { 9 | expect_equal(hop(1:5, c(2, 1), c(3, 2), identity), list(2:3, 1:2)) 10 | }) 11 | 12 | test_that(".starts must be before .stops", { 13 | expect_snapshot({ 14 | (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity))) 15 | (expect_error(hop(1:5, c(2, 3, 1), c(1, 1, 2), identity))) 16 | }) 17 | }) 18 | 19 | test_that("empty input returns a list", { 20 | expect_equal(hop(integer(), integer(), integer(), ~.x), list()) 21 | }) 22 | 23 | test_that("empty `.x`, but size `n > 0` `.starts` and `.stops` returns size `n` empty ptype", { 24 | expect_equal(hop(integer(), 1:2, 2:3, ~.x), list(integer(), integer())) 25 | }) 26 | 27 | test_that("empty `.x`, but size `n > 0` `.starts` and `.stops`: sizes and types are checked first", { 28 | expect_snapshot({ 29 | (expect_error( 30 | hop(integer(), 1:3, 1:2, ~.x), 31 | class = "vctrs_error_incompatible_size" 32 | )) 33 | (expect_error( 34 | hop(integer(), 1, "x", ~.x), 35 | class = "vctrs_error_subscript_type" 36 | )) 37 | }) 38 | }) 39 | 40 | test_that(".starts must not contain NA values", { 41 | expect_snapshot({ 42 | (expect_error( 43 | hop(1:2, c(1, NA), 1:2, identity), 44 | class = "slider_error_endpoints_cannot_be_na" 45 | )) 46 | (expect_error( 47 | hop(1:2, c(NA, 1), 1:2, identity), 48 | class = "slider_error_endpoints_cannot_be_na" 49 | )) 50 | }) 51 | }) 52 | 53 | test_that(".stops must not contain NA values", { 54 | expect_snapshot({ 55 | (expect_error( 56 | hop(1:2, 1:2, c(1, NA), identity), 57 | class = "slider_error_endpoints_cannot_be_na" 58 | )) 59 | (expect_error( 60 | hop(1:2, 1:2, c(NA, 1), identity), 61 | class = "slider_error_endpoints_cannot_be_na" 62 | )) 63 | }) 64 | }) 65 | 66 | test_that("recycling is used for .starts/.stops", { 67 | expect_equal( 68 | hop(1:2, 1, 1:2, ~.x), 69 | list( 70 | 1L, 71 | 1:2 72 | ) 73 | ) 74 | 75 | expect_equal( 76 | hop(1:2, 1:2, 2, ~.x), 77 | list( 78 | 1:2, 79 | 2L 80 | ) 81 | ) 82 | 83 | expect_snapshot({ 84 | expect_error( 85 | hop(1:2, 1:2, 1:3, ~.x), 86 | class = "vctrs_error_incompatible_size" 87 | ) 88 | }) 89 | }) 90 | 91 | test_that("0 length .starts/.stops are allowed", { 92 | expect_equal(hop(1, integer(), integer(), ~.x), list()) 93 | }) 94 | 95 | test_that("output size is the common size of .starts/.stops", { 96 | expect_equal( 97 | hop(1:5, 1, 2, ~.x), 98 | list(1:2) 99 | ) 100 | 101 | expect_equal( 102 | hop(1:2, c(1, 1, 2), c(1, 2, 2), ~.x), 103 | list(1L, 1:2, 2L) 104 | ) 105 | }) 106 | 107 | test_that("out of bounds .starts/.stops result in size-0 slices", { 108 | expect_equal( 109 | hop(1:2, 3, 4, ~.x), 110 | list(integer()) 111 | ) 112 | 113 | expect_equal( 114 | hop(1:2, c(3, 4), c(4, 6), ~.x), 115 | list(integer(), integer()) 116 | ) 117 | }) 118 | 119 | test_that("negative / 0 out of bounds .starts/.stops result in size-0 slices", { 120 | expect_equal( 121 | hop(1:2, c(-1, 4), c(0, 6), ~.x), 122 | list(integer(), integer()) 123 | ) 124 | 125 | expect_equal( 126 | hop(1:2, c(-1, 1, 4), c(0, 2, 6), ~.x), 127 | list(integer(), 1:2, integer()) 128 | ) 129 | }) 130 | 131 | test_that("duplicated .starts/.stops pairs are allowed", { 132 | expect_equal( 133 | hop(1:4, c(1, 2, 2), c(2, 2, 2), ~.x), 134 | list( 135 | 1:2, 136 | 2L, 137 | 2L 138 | ) 139 | ) 140 | }) 141 | 142 | test_that("`.starts` and `.stops` must be integerish", { 143 | expect_snapshot({ 144 | (expect_error( 145 | hop(1, "x", 1, identity), 146 | class = "vctrs_error_subscript_type" 147 | )) 148 | (expect_error( 149 | hop(1, 1, "x", identity), 150 | class = "vctrs_error_subscript_type" 151 | )) 152 | }) 153 | }) 154 | 155 | test_that("`error_call` and `.error_call` args aren't swallowed", { 156 | fn <- function(x, error_call) { 157 | abort("hi", call = error_call) 158 | } 159 | fn_dot <- function(x, .error_call) { 160 | abort("hi", call = .error_call) 161 | } 162 | 163 | expect_snapshot(error = TRUE, { 164 | hop(1, 1, 1, fn, error_call = call("foo")) 165 | }) 166 | expect_snapshot(error = TRUE, { 167 | hop(1, 1, 1, fn_dot, .error_call = call("foo")) 168 | }) 169 | }) 170 | 171 | # ------------------------------------------------------------------------------ 172 | # input names 173 | 174 | test_that("names exist on inner sliced elements", { 175 | names <- letters[1:5] 176 | x <- set_names(1:5, names) 177 | exp <- as.list(names) 178 | expect_equal(hop(x, 1:5, 1:5, ~ names(.x)), exp) 179 | }) 180 | 181 | test_that("names are never placed on the output", { 182 | x <- set_names(1:5, letters[1:5]) 183 | expect_null(names(hop(x, 1:5, 1:5, ~.x))) 184 | }) 185 | -------------------------------------------------------------------------------- /R/hop-index.R: -------------------------------------------------------------------------------- 1 | #' Hop relative to an index 2 | #' 3 | #' `hop_index()` is the lower level engine that powers [slide_index()]. It 4 | #' has slightly different invariants than `slide_index()`, and is useful when 5 | #' you either need to hand craft boundary values, or want to compute a result 6 | #' with a size that is different from `.x`. 7 | #' 8 | #' @inheritParams slide_index 9 | #' 10 | #' @template param-starts-stops-hop-index 11 | #' 12 | #' @return 13 | #' A vector fulfilling the following invariants: 14 | #' 15 | #' \subsection{`hop_index()`}{ 16 | #' 17 | #' * `vec_size(hop_index(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` 18 | #' 19 | #' * `vec_ptype(hop_index(.x, .starts, .stops)) == list()` 20 | #' 21 | #' } 22 | #' 23 | #' \subsection{`hop_index_vec()`}{ 24 | #' 25 | #' * `vec_size(hop_index_vec(.x, .starts, .stops)) == vec_size_common(.starts, .stops)` 26 | #' 27 | #' * `vec_size(hop_index_vec(.x, .starts, .stops)[[1]]) == 1L` 28 | #' 29 | #' * `vec_ptype(hop_index_vec(.x, .starts, .stops, .ptype = ptype)) == ptype` 30 | #' 31 | #' } 32 | #' 33 | #' @examples 34 | #' library(vctrs) 35 | #' library(lubridate, warn.conflicts = FALSE) 36 | #' 37 | #' # --------------------------------------------------------------------------- 38 | #' # Returning a size smaller than `.x` 39 | #' 40 | #' i <- as.Date("2019-01-25") + c(0, 1, 2, 3, 10, 20, 35, 42, 45) 41 | #' 42 | #' # slide_index() allows you to slide relative to `i` 43 | #' slide_index(i, i, ~.x, .before = weeks(1)) 44 | #' 45 | #' # But you might be more interested in coarser summaries. This groups 46 | #' # by year-month and computes 2 `.f` on 2 month windows. 47 | #' i_yearmonth <- year(i) + (month(i) - 1) / 12 48 | #' slide_index(i, i_yearmonth, ~.x, .before = 1) 49 | #' 50 | #' # ^ This works nicely when working with dplyr if you are trying to create 51 | #' # a new column in a data frame, but you'll notice that there are really only 52 | #' # 3 months, so only 3 values are being calculated. If you only want to return 53 | #' # a vector of those 3 values, you can use `hop_index()`. You'll have to 54 | #' # hand craft the boundaries, but this is a general strategy 55 | #' # I've found useful: 56 | #' first_start <- floor_date(i[1], "months") 57 | #' last_stop <- ceiling_date(i[length(i)], "months") 58 | #' dates <- seq(first_start, last_stop, "1 month") 59 | #' inner <- dates[2:(length(dates) - 1L)] 60 | #' starts <- vec_c(first_start, inner) 61 | #' stops <- vec_c(inner - 1, last_stop) 62 | #' 63 | #' hop_index(i, i, starts, stops, ~.x) 64 | #' 65 | #' # --------------------------------------------------------------------------- 66 | #' # Non-existant dates with `lubridate::months()` 67 | #' 68 | #' # Imagine you want to compute a 1 month rolling average on this 69 | #' # irregular daily data. 70 | #' i <- vec_c(as.Date("2019-02-27") + 0:3, as.Date("2019-03-27") + 0:5) 71 | #' x <- rnorm(vec_seq_along(i)) 72 | #' 73 | #' # You might try `slide_index()` like this, but you'd run into this error 74 | #' library(rlang) 75 | #' 76 | #' with_options( 77 | #' catch_cnd( 78 | #' slide_index(x, i, mean, .before = months(1)) 79 | #' ), 80 | #' rlang_backtrace_on_error = current_env() 81 | #' ) 82 | #' 83 | #' # This is because when you actually compute the `.i - .before` sequence, 84 | #' # you hit non-existant dates. i.e. `"2019-03-29" - months(1)` doesn't exist. 85 | #' i - months(1) 86 | #' 87 | #' # To get around this, lubridate provides `add_with_rollback()`, 88 | #' # and the shortcut operation `%m-%`, which subtracts the month, then rolls 89 | #' # forward/backward if it hits an `NA`. You can manually generate boundaries, 90 | #' # then provide them to `hop_index()`. 91 | #' starts <- i %m-% months(1) 92 | #' stops <- i 93 | #' 94 | #' hop_index(x, i, starts, stops, mean) 95 | #' 96 | #' hop_index(i, i, starts, stops, ~.x) 97 | #' 98 | #' @seealso [slide()], [slide_index()], [hop_index2()] 99 | #' @export 100 | hop_index <- function(.x, .i, .starts, .stops, .f, ...) { 101 | hop_index_impl( 102 | .x, 103 | .i, 104 | .starts, 105 | .stops, 106 | .f, 107 | ..., 108 | .ptype = list(), 109 | .constrain = FALSE, 110 | .atomic = FALSE 111 | ) 112 | } 113 | 114 | #' @rdname hop_index 115 | #' @export 116 | hop_index_vec <- function(.x, .i, .starts, .stops, .f, ..., .ptype = NULL) { 117 | out <- hop_index_impl( 118 | .x, 119 | .i, 120 | .starts, 121 | .stops, 122 | .f, 123 | ..., 124 | .ptype = list(), 125 | .constrain = FALSE, 126 | .atomic = TRUE 127 | ) 128 | 129 | vec_simplify(out, .ptype) 130 | } 131 | 132 | # ------------------------------------------------------------------------------ 133 | 134 | hop_index_impl <- function( 135 | .x, 136 | .i, 137 | .starts, 138 | .stops, 139 | .f, 140 | ..., 141 | .ptype, 142 | .constrain, 143 | .atomic, 144 | .slider_error_call = caller_env() 145 | ) { 146 | vec_assert(.x, call = .slider_error_call) 147 | 148 | .f <- as_function(.f, call = .slider_error_call) 149 | 150 | f_call <- expr(.f(.x, ...)) 151 | 152 | type <- -1L 153 | 154 | hop_index_common( 155 | x = .x, 156 | i = .i, 157 | starts = .starts, 158 | stops = .stops, 159 | f_call = f_call, 160 | ptype = .ptype, 161 | constrain = .constrain, 162 | atomic = .atomic, 163 | env = environment(), 164 | type = type, 165 | slider_error_call = .slider_error_call 166 | ) 167 | } 168 | --------------------------------------------------------------------------------