diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..c7ada35 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,57 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +# +# NOTE: This workflow is overkill for most R packages and +# check-standard.yaml is likely a better choice. +# usethis::use_github_action("check-standard") will install it. +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: ubuntu-latest, r: 'release'} + - {os: macos-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + - {os: ubuntu-latest, r: 'oldrel-2'} + - {os: ubuntu-latest, r: 'oldrel-3'} + - {os: ubuntu-latest, r: 'oldrel-4'} + - {os: ubuntu-latest, r: '3.6'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true diff --git a/.github/workflows/check-other.yml b/.github/workflows/check-other.yml deleted file mode 100644 index 96720d7..0000000 --- a/.github/workflows/check-other.yml +++ /dev/null @@ -1,20 +0,0 @@ -# commits can contain win, rhub or deploy text for specific actions -name: Check-win-builder -on: push -jobs: - - win-builder-checks: - runs-on: ubuntu-18.04 - container: rocker/tidyverse:latest - if: "!contains(github.event.commits[0].message, '[skip other]')" - steps: - - name: Checkout repository - uses: actions/checkout@v2 - - - name: Send package to win-builder - shell: Rscript {0} - run: | - if (!require("devtools")) install.packages('devtools', repos = 'http://cran.rstudio.com') - devtools::check_win_devel() - devtools::check_win_oldrelease() - devtools::check_win_release() diff --git a/.github/workflows/check.yml b/.github/workflows/check.yml deleted file mode 100644 index 42c185d..0000000 --- a/.github/workflows/check.yml +++ /dev/null @@ -1,96 +0,0 @@ -# commits can contain win, rhub or deploy text for specific actions -name: Check -on: push -jobs: - check-r-verse-latest: - runs-on: ubuntu-18.04 - container: rocker/verse:latest - steps: - - name: Checkout repository - uses: actions/checkout@main - - - name: Install dependencies - shell: Rscript {0} - run: | - remotes::install_deps(dependencies = TRUE) - - - name: Check 🔍 - shell: Rscript {0} - run: | - devtools::check(cran = TRUE, vignettes = TRUE) - - check-r-verse-devel: - runs-on: ubuntu-18.04 - container: rocker/verse:devel - steps: - - name: Checkout repository - uses: actions/checkout@main - - - name: Install dependencies - shell: Rscript {0} - run: | - remotes::install_deps(dependencies = TRUE) - - - name: Check 🔍 - shell: Rscript {0} - run: | - devtools::check(cran = TRUE, vignettes = TRUE) - - check-r-devel-san: - runs-on: ubuntu-18.04 - container: rocker/r-devel-san - steps: - - name: Checkout repository 🛎 - uses: actions/checkout@v2 - - - name: Install dependencies - shell: Rscript {0} - run: | - install.packages(c("Rcpp", "knitr", "rmarkdown", "tinytest", "rcmdcheck")) - - - name: Check 🔍 - shell: Rscript {0} - run: | - rcmdcheck::rcmdcheck( - args = c("--as-cran", "--ignore-vignettes"), - build_args = "--no-build-vignettes", - error_on = "warning" - ) - - check-r-devel-ubsan-clang: - runs-on: ubuntu-18.04 - container: rocker/r-devel-ubsan-clang - steps: - - name: Checkout repository 🛎 - uses: actions/checkout@v2 - - - name: Install dependencies - shell: Rscript {0} - run: | - install.packages(c("Rcpp", "knitr", "rmarkdown", "tinytest", "rcmdcheck")) - - - name: Check 🔍 - shell: Rscript {0} - run: | - rcmdcheck::rcmdcheck( - args = c("--as-cran", "--ignore-vignettes"), - build_args = "--no-build-vignettes", - error_on = "warning" - ) - - check-r-verse-3-6: - runs-on: ubuntu-18.04 - container: rocker/verse:3.6.3 - steps: - - name: Checkout repository 🛎 - uses: actions/checkout@v2 - - - name: Install dependencies - shell: Rscript {0} - run: | - remotes::install_deps(dependencies = TRUE) - - - name: Check 🔍 - shell: Rscript {0} - run: | - devtools::check(cran = TRUE, vignettes = TRUE) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..ed7650c --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,48 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + release: + types: [published] + workflow_dispatch: + +name: pkgdown + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::pkgdown, local::. + needs: website + + - name: Build site + run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) + shell: Rscript {0} + + - name: Deploy to GitHub pages 🚀 + if: github.event_name != 'pull_request' + uses: JamesIves/github-pages-deploy-action@v4.4.1 + with: + clean: false + branch: gh-pages + folder: docs diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml deleted file mode 100644 index 5d8a923..0000000 --- a/.github/workflows/release.yml +++ /dev/null @@ -1,59 +0,0 @@ -name: Main - -on: - push: - tags: - - "v*.*.*" -jobs: - pkgdown: - runs-on: ubuntu-latest - # Only restrict concurrency for non-PR jobs - concurrency: - group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} - env: - GITHUB_PAT: ${{ secrets.GH_TOKEN }} - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::pkgdown, local::. - needs: website - - - name: Build site - run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) - shell: Rscript {0} - - - name: Deploy Docs 🚀 - uses: peaceiris/actions-gh-pages@v3 - with: - github_token: ${{ secrets.GH_TOKEN }} - publish_dir: docs - - release: - name: Create Release - runs-on: ubuntu-latest - steps: - - name: Checkout code - uses: actions/checkout@v2 - - - name: Prepare release vars - run: | - echo "PKGNAME=$(sed -n 's/Package: *\([^ ]*\)/\1/p' DESCRIPTION)" >> $GITHUB_ENV - echo "PKGVERS=$(sed -n 's/Version: *\([^ ]*\)/\1/p' DESCRIPTION)" >> $GITHUB_ENV - echo "$(sed -n '2,/^$/p' NEWS.md)" > news.txt - - - name: Release - uses: softprops/action-gh-release@v1 - with: - tag_name: "v${{ env.PKGVERS }}" - name: "${{ env.PKGNAME }} ${{ env.PKGVERS }}" - body_path: news.txt - env: - GITHUB_TOKEN: ${{ secrets.GH_TOKEN }} # This token is provided by Actions, you do not need to create your own token diff --git a/.github/workflows/rhub.yaml b/.github/workflows/rhub.yaml new file mode 100644 index 0000000..ff3a268 --- /dev/null +++ b/.github/workflows/rhub.yaml @@ -0,0 +1,95 @@ +# R-hub's generic GitHub Actions workflow file. It's canonical location is at +# https://github.com/r-hub/rhub2/blob/v1/inst/workflow/rhub.yaml +# You can update this file to a newer version using the rhub2 package: +# +# rhub2::rhub_setup() +# +# It is unlikely that you need to modify this file manually. + +name: R-hub +run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}" + +on: + workflow_dispatch: + inputs: + config: + description: 'A comma separated list of R-hub platforms to use.' + type: string + default: 'linux,windows,macos' + name: + description: 'Run name. You can leave this empty now.' + type: string + id: + description: 'Unique ID. You can leave this empty now.' + type: string + +jobs: + + setup: + runs-on: ubuntu-latest + outputs: + containers: ${{ steps.rhub-setup.outputs.containers }} + platforms: ${{ steps.rhub-setup.outputs.platforms }} + + steps: + # NO NEED TO CHECKOUT HERE + - uses: r-hub/rhub2/actions/rhub-setup@v1 + with: + config: ${{ github.event.inputs.config }} + id: rhub-setup + + linux-containers: + needs: setup + if: ${{ needs.setup.outputs.containers != '[]' }} + runs-on: ubuntu-latest + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.containers) }} + container: + image: ${{ matrix.config.container }} + + steps: + - uses: r-hub/rhub2/actions/rhub-checkout@v1 + - uses: r-hub/rhub2/actions/rhub-platform-info@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/rhub2/actions/rhub-setup-deps@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/rhub2/actions/rhub-run-check@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + + other-platforms: + needs: setup + if: ${{ needs.setup.outputs.platforms != '[]' }} + runs-on: ${{ matrix.config.os }} + name: ${{ matrix.config.label }} + strategy: + fail-fast: false + matrix: + config: ${{ fromJson(needs.setup.outputs.platforms) }} + + steps: + - uses: r-hub/rhub2/actions/rhub-checkout@v1 + - uses: r-hub/rhub2/actions/rhub-setup-r@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} + - uses: r-hub/rhub2/actions/rhub-platform-info@v1 + with: + token: ${{ secrets.RHUB_TOKEN }} + job-config: ${{ matrix.config.job-config }} + - uses: r-hub/rhub2/actions/rhub-setup-deps@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} + - uses: r-hub/rhub2/actions/rhub-run-check@v1 + with: + job-config: ${{ matrix.config.job-config }} + token: ${{ secrets.RHUB_TOKEN }} diff --git a/.github/workflows/spellcheck.yaml b/.github/workflows/spellcheck.yaml new file mode 100644 index 0000000..3f7a3e2 --- /dev/null +++ b/.github/workflows/spellcheck.yaml @@ -0,0 +1,22 @@ +name: spellcheck + +on: + push: + branches: + - main + pull_request: + branches: + - main + +jobs: + check: + runs-on: ubuntu-latest + name: Spellcheck + container: + image: rocker/tidyverse:4.1.2 + steps: + - name: Checkout repo + uses: actions/checkout@v3 + + - name: Run Spelling Check test + uses: insightsengineering/r-spellcheck-action@v2 diff --git a/DESCRIPTION b/DESCRIPTION index fad797d..1fa5c5a 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: runner Title: Running Operations for Vectors Type: Package -Version: 0.4.3 +Version: 0.4.4 Depends: R (>= 3.0) Language: en-US Encoding: UTF-8 @@ -25,6 +25,6 @@ Suggests: knitr, rmarkdown, tinytest -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr diff --git a/R/RcppExports.R b/R/RcppExports.R index 781e37a..bf1ea67 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -3,23 +3,23 @@ #' Fill NA with previous non-NA element #' -#' Fill \code{NA} with last non-NA element. +#' Fill `NA` with last non-NA element. #' @inheritParams runner -#' @param run_for_first If first elements are filled with \code{NA}, \code{run_for_first = TRUE} -#' allows to fill all initial \code{NA} with nearest non-NA value. By default -#' \code{run_for_first = TRUE} -#' @param only_within \code{NA} are replaced only if previous and next non-NA -#' values are the same. By default \code{only_within = TRUE} -#' @return vector - \code{x} containing all \code{x} elements with \code{NA} +#' @param run_for_first If first elements are filled with `NA`, `run_for_first = TRUE` +#' allows to fill all initial `NA` with nearest non-NA value. By default +#' `run_for_first = TRUE` +#' @param only_within `NA` are replaced only if previous and next non-NA +#' values are the same. By default `only_within = TRUE` +#' @return vector - `x` containing all `x` elements with `NA` #' replaced with previous non-NA element. #' @examples -#' fill_run(c(NA, NA,1:10, NA, NA), run_for_first = TRUE) -#' fill_run(c(NA, NA,1:10, NA, NA), run_for_first = TRUE) -#' fill_run(c(NA, NA,1:10, NA, NA), run_for_first = FALSE) +#' fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = TRUE) +#' fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = TRUE) +#' fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = FALSE) #' fill_run(c(NA, NA, 1, 2, NA, NA, 2, 2, NA, NA, 1, NA, NA), run_for_first = TRUE, only_within = TRUE) #' @export fill_run <- function(x, run_for_first = FALSE, only_within = FALSE) { - .Call('_runner_fill_run', PACKAGE = 'runner', x, run_for_first, only_within) + .Call("_runner_fill_run", PACKAGE = "runner", x, run_for_first, only_within) } #' Lag dependent on variable @@ -27,9 +27,9 @@ fill_run <- function(x, run_for_first = FALSE, only_within = FALSE) { #' Vector of input lagged along integer vector #' @inheritParams runner #' @inheritParams sum_run -#' @param nearest \code{logical} single value. Applied when \code{idx} is used, -#' then \code{nearest = FALSE} returns observation lagged exactly by the -#' specified number of "periods". When \code{nearest = TRUE} +#' @param nearest `logical` single value. Applied when `idx` is used, +#' then `nearest = FALSE` returns observation lagged exactly by the +#' specified number of "periods". When `nearest = TRUE` #' function returns latest observation within lag window. #' @examples #' lag_run(1:10, lag = 3) @@ -37,13 +37,13 @@ fill_run <- function(x, run_for_first = FALSE, only_within = FALSE) { #' lag_run(letters[1:10], lag = 2, idx = c(1, 1, 1, 2, 3, 4, 6, 7, 8, 10), nearest = TRUE) #' @export lag_run <- function(x, lag = 1L, idx = integer(0), nearest = FALSE) { - .Call('_runner_lag_run', PACKAGE = 'runner', x, lag, idx, nearest) + .Call("_runner_lag_run", PACKAGE = "runner", x, lag, idx, nearest) } #' Length of running windows #' -#' Number of elements in k-long window calculated on \code{idx} vector. -#' If \code{idx} is an `as.integer(date)` vector, then k=number of days in window - +#' Number of elements in k-long window calculated on `idx` vector. +#' If `idx` is an `as.integer(date)` vector, then k=number of days in window - #' then the result is number of observations within k days window. #' @inheritParams runner #' @inheritParams sum_run @@ -51,21 +51,21 @@ lag_run <- function(x, lag = 1L, idx = integer(0), nearest = FALSE) { #' length_run(k = 3, idx = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5)) #' @export length_run <- function(k = integer(1), lag = integer(1), idx = integer(0)) { - .Call('_runner_length_run', PACKAGE = 'runner', k, lag, idx) + .Call("_runner_length_run", PACKAGE = "runner", k, lag, idx) } #' Running min/max #' #' -#' \code{min_run} calculates running minimum-maximum on given \code{x} numeric -#' vector, specified \code{k} window size. +#' `min_run` calculates running minimum-maximum on given `x` numeric +#' vector, specified `k` window size. #' @inheritParams runner #' @inheritParams sum_run -#' @param metric \code{character} what to return, minimum or maximum +#' @param metric `character` what to return, minimum or maximum #' @return list. #' @export minmax_run <- function(x, metric = "min", na_rm = TRUE) { - .Call('_runner_minmax_run', PACKAGE = 'runner', x, metric, na_rm) + .Call("_runner_minmax_run", PACKAGE = "runner", x, metric, na_rm) } #' Running sum @@ -73,38 +73,38 @@ minmax_run <- function(x, metric = "min", na_rm = TRUE) { #' Running sum in specified window of numeric vector. #' @inheritParams runner #' -#' @param x \code{numeric} vector which running function is calculated on +#' @param x `numeric` vector which running function is calculated on #' -#' @param k (\code{integer}` vector or single value)\cr -#' Denoting size of the running window. If \code{k} is a single value then window -#' size is constant for all elements, otherwise if \code{length(k) == length(x)} +#' @param k (`integer`` vector or single value)\cr +#' Denoting size of the running window. If `k` is a single value then window +#' size is constant for all elements, otherwise if `length(k) == length(x)` #' different window size for each element. #' -#' @param lag (\code{integer} vector or single value)\cr -#' Denoting window lag. If \code{lag} is a single value then window lag is constant -#' for all elements, otherwise if \code{length(lag) == length(x)} different window +#' @param lag (`integer` vector or single value)\cr +#' Denoting window lag. If `lag` is a single value then window lag is constant +#' for all elements, otherwise if `length(lag) == length(x)` different window #' size for each element. Negative value shifts window forward. #' -#' @param idx (\code{integer}, \code{Date}, \code{POSIXt})\cr +#' @param idx (`integer`, `Date`, `POSIXt`)\cr #' Optional integer vector containing sorted (ascending) index of observation. -#' By default \code{idx} is index incremented by one. User can provide index with -#' varying increment and with duplicated values. If specified then \code{k} and \code{lag} -#' are depending on \code{idx}. Length of \code{idx} have to be equal of length \code{x}. +#' By default `idx` is index incremented by one. User can provide index with +#' varying increment and with duplicated values. If specified then `k` and `lag` +#' are depending on `idx`. Length of `idx` have to be equal of length `x`. #' -#' @param at (\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr +#' @param at (`integer`, `Date`, `POSIXt`, `character` vector)\cr #' Vector of any size and any value defining output data points. Values of the #' vector defines the indexes which data is computed at. #' -#' @param na_rm \code{logical} single value (default \code{na_rm = TRUE}) - -#' if \code{TRUE} sum is calculating excluding \code{NA}. +#' @param na_rm `logical` single value (default `na_rm = TRUE`) - +#' if `TRUE` sum is calculating excluding `NA`. #' #' @inheritParams runner #' -#' @return sum \code{code} vector of length equals length of \code{x}. +#' @return sum `numeric` vector of length equals length of `x`. #' @examples #' set.seed(11) #' x1 <- rnorm(15) -#' x2 <- sample(c(rep(NA, 5),rnorm(15)), 15, replace = TRUE) +#' x2 <- sample(c(rep(NA, 5), rnorm(15)), 15, replace = TRUE) #' k <- sample(1:15, 15, replace = TRUE) #' sum_run(x1) #' sum_run(x2, na_rm = TRUE) @@ -112,7 +112,7 @@ minmax_run <- function(x, metric = "min", na_rm = TRUE) { #' sum_run(x2, na_rm = TRUE, k = 4) #' @export sum_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_sum_run', PACKAGE = 'runner', x, k, lag, idx, at, na_rm, na_pad) + .Call("_runner_sum_run", PACKAGE = "runner", x, k, lag, idx, at, na_rm, na_pad) } #' Running mean @@ -120,62 +120,62 @@ sum_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = #' Running mean in specified window of numeric vector. #' @inheritParams sum_run #' @inheritParams runner -#' @return mean {numeric} vector of length equals length of \code{x}. +#' @return mean (`numeric`) vector of length equals length of `x`. #' @examples #' set.seed(11) #' x1 <- rnorm(15) -#' x2 <- sample(c(rep(NA,5), rnorm(15)), 15, replace = TRUE) +#' x2 <- sample(c(rep(NA, 5), rnorm(15)), 15, replace = TRUE) #' k <- sample(1:15, 15, replace = TRUE) #' mean_run(x1) #' mean_run(x2, na_rm = TRUE) -#' mean_run(x2, na_rm = FALSE ) -#' mean_run(x2, na_rm = TRUE, k=4) +#' mean_run(x2, na_rm = FALSE) +#' mean_run(x2, na_rm = TRUE, k = 4) #' @export mean_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_mean_run', PACKAGE = 'runner', x, k, lag, idx, at, na_rm, na_pad) + .Call("_runner_mean_run", PACKAGE = "runner", x, k, lag, idx, at, na_rm, na_pad) } #' Running maximum #' #' -#' \code{min_run} calculates running max on given \code{x} numeric vector, -#' specified \code{k} window size. +#' `min_run` calculates running max on given `x` numeric vector, +#' specified `k` window size. #' @inheritParams runner #' @inheritParams sum_run -#' @return max {numeric} vector of length equals length of \code{x}. +#' @return max (`numeric`) vector of length equals length of `x`. #' @examples #' set.seed(11) -#' x1 <- sample( c(1,2,3), 15, replace=TRUE) -#' x2 <- sample( c(NA,1,2,3), 15, replace=TRUE) -#' k <- sample( 1:4, 15, replace=TRUE) +#' x1 <- sample(c(1, 2, 3), 15, replace = TRUE) +#' x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) +#' k <- sample(1:4, 15, replace = TRUE) #' max_run(x1) # simple cumulative maximum #' max_run(x2, na_rm = TRUE) # cumulative maximum with removing NA. -#' max_run(x2, na_rm = TRUE, k=4) # maximum in 4-element window -#' max_run(x2, na_rm = FALSE, k=k) # maximum in varying k window size +#' max_run(x2, na_rm = TRUE, k = 4) # maximum in 4-element window +#' max_run(x2, na_rm = FALSE, k = k) # maximum in varying k window size #' @export max_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_max_run', PACKAGE = 'runner', x, k, lag, idx, at, na_rm, na_pad) + .Call("_runner_max_run", PACKAGE = "runner", x, k, lag, idx, at, na_rm, na_pad) } #' Running minimum #' #' -#' \code{min_run} calculates running min on given \code{x} numeric vector, specified \code{k} window size. +#' `min_run` calculates running min on given `x` numeric vector, specified `k` window size. #' @inheritParams runner #' @inheritParams sum_run -#' @return min {numeric} vector of length equals length of \code{x}. +#' @return min (`numeric`) vector of length equals length of `x`. #' @examples #' set.seed(11) #' x1 <- sample(c(1, 2, 3), 15, replace = TRUE) #' x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) -#' k <- sample(1:4, 15, replace = TRUE) +#' k <- sample(1:4, 15, replace = TRUE) #' min_run(x1) #' min_run(x2, na_rm = TRUE) #' min_run(x2, na_rm = TRUE, k = 4) #' min_run(x2, na_rm = FALSE, k = k) #' @export min_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_min_run', PACKAGE = 'runner', x, k, lag, idx, at, na_rm, na_pad) + .Call("_runner_min_run", PACKAGE = "runner", x, k, lag, idx, at, na_rm, na_pad) } #' Running streak length @@ -184,11 +184,11 @@ min_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = #' @param x {any type} vector which running function is calculated on #' @inheritParams runner #' @inheritParams sum_run -#' @return streak [numeric] vector of length equals length of \code{x} containing +#' @return streak [numeric] vector of length equals length of `x` containing #' number of consecutive occurrences. #' @examples #' set.seed(11) -#' x1 <- sample(c("a","b"), 15, replace = TRUE) +#' x1 <- sample(c("a", "b"), 15, replace = TRUE) #' x2 <- sample(c(NA_character_, "a", "b"), 15, replace = TRUE) #' k <- sample(1:4, 15, replace = TRUE) #' streak_run(x1) # simple streak run @@ -197,45 +197,44 @@ min_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = #' streak_run(x1, k = k) # streak run within varying window size specified by vector k #' @export streak_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_streak_run', PACKAGE = 'runner', x, k, lag, idx, at, na_rm, na_pad) + .Call("_runner_streak_run", PACKAGE = "runner", x, k, lag, idx, at, na_rm, na_pad) } #' Running which #' #' -#' \code{min_run} calculates running which - returns index of element where \code{x == TRUE}. +#' `min_run` calculates running which - returns index of element where `x == TRUE`. #' @inheritParams runner #' @inheritParams sum_run -#' @param which \code{character} value "first" or "last" denoting if the first or last \code{TRUE} +#' @param which `character` value "first" or "last" denoting if the first or last `TRUE` #' index is returned from the window. -#' @return integer vector of indexes of the same length as \code{x}. +#' @return integer vector of indexes of the same length as `x`. #' @examples #' set.seed(11) #' x1 <- sample(c(1, 2, 3), 15, replace = TRUE) #' x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) -#' k <- sample(1:4, 15, replace = TRUE) +#' k <- sample(1:4, 15, replace = TRUE) #' which_run(x1) #' which_run(x2, na_rm = TRUE) #' which_run(x2, na_rm = TRUE, k = 4) #' which_run(x2, na_rm = FALSE, k = k) #' @export which_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), which = "last", na_rm = TRUE, na_pad = FALSE) { - .Call('_runner_which_run', PACKAGE = 'runner', x, k, lag, idx, at, which, na_rm, na_pad) + .Call("_runner_which_run", PACKAGE = "runner", x, k, lag, idx, at, which, na_rm, na_pad) } #' List of running windows #' -#' Creates \code{list} of windows with given arguments settings. -#' Length of output \code{list} is equal +#' Creates `list` of windows with given arguments settings. +#' Length of output `list` is equal #' @inheritParams runner #' @return list of vectors (windows). Length of list is the same as -#' \code{length(x)} or \code{length(at)} if specified, and length of each -#' window is defined by \code{k} (unless window is out of range). +#' `length(x)` or `length(at)` if specified, and length of each +#' window is defined by `k` (unless window is out of range). #' @examples #' window_run(1:10, k = 3, lag = -1) #' window_run(letters[1:10], k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5)) #' @export window_run <- function(x, k = integer(0), lag = integer(1), idx = integer(0), at = integer(0), na_pad = FALSE) { - .Call('_runner_window_run', PACKAGE = 'runner', x, k, lag, idx, at, na_pad) + .Call("_runner_window_run", PACKAGE = "runner", x, k, lag, idx, at, na_pad) } - diff --git a/R/run.R b/R/run.R index cb19fd8..1fc83d4 100644 --- a/R/run.R +++ b/R/run.R @@ -8,7 +8,7 @@ #' Denoting size of the running window. If `k` is a single value then window #' size is constant for all elements, otherwise if `length(k) == length(x)` #' different window size for each element. One can also specify `k` in the same -#' way as `by` argument in \code{\link[base]{seq.POSIXt}}. +#' way as `by` argument in [base::seq.POSIXt()]. #' See 'Specifying time-intervals' in details section. #' #' @param lag (`integer` vector or single value)\cr @@ -16,7 +16,7 @@ #' for all elements, otherwise if `length(lag) == length(x)` different window #' size for each element. Negative value shifts window forward. One can also #' specify `lag` in the same way as `by` argument in -#' \code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +#' [base::seq.POSIXt()]. See 'Specifying time-intervals' in details #' section. #' #' @param idx (`integer`, `Date`, `POSIXt`)\cr @@ -35,7 +35,7 @@ #' @param at (`integer`, `Date`, `POSIXt`, `character` vector)\cr #' Vector of any size and any value defining output data points. Values of the #' vector defines the indexes which data is computed at. Can be also `POSIXt` -#' sequence increment used in `at` argument in \code{\link[base]{seq.POSIXt}}. +#' sequence increment used in `at` argument in [base::seq.POSIXt()]. #' See 'Specifying time-intervals' in details section. #' #' @param na_pad (`logical` single value)\cr @@ -52,7 +52,7 @@ #' #' @param cl (`cluster`) *experimental*\cr #' Create and pass the cluster to the `runner` function to run each window -#' calculation in parallel. See \code{\link[parallel]{makeCluster}} in details. +#' calculation in parallel. See [parallel::makeCluster()] in details. #' #' @param ... (optional)\cr #' other arguments passed to the function `f`. @@ -61,21 +61,21 @@ #' Function can apply any R function on running windows defined by `x`, #' `k`, `lag`, `idx` and `at`. Running window can be calculated #' on several ways: -#' \itemize{ -#' \item{**Cumulative windows**}{\cr +#' +#' - **Cumulative windows**\cr #' applied when user doesn't specify `k` argument or specify `k = length(x)`, #' this would mean that `k` is equal to number of available elements \cr #' \if{html}{\figure{cumulativewindows.png}{options: width="75\%" alt="Figure: cumulativewindows.png"}} #' \if{latex}{\figure{cumulativewindows.pdf}{options: width=7cm}} -#' } -#' \item{**Constant sliding windows**}{\cr +#' +#' - **Constant sliding windows** #' applied when user specify `k` as constant value keeping `idx` and #' `at` unspecified. `lag` argument shifts windows left (`lag > 0`) #' or right (`lag < 0`). \cr #' \if{html}{\figure{incrementalindex.png}{options: width="75\%" alt="Figure: incrementalindex.png"}} #' \if{latex}{\figure{incrementalindex.pdf}{options: width=7cm}} -#' } -#' \item{**Windows depending on date**}{\cr +#' +#' - **Windows depending on date**\cr #' If one specifies `idx` this would mean that output windows size might #' change in size because of unequally spaced indexes. Fox example 5-period #' window is different than 5-element window, because 5-period window might @@ -84,8 +84,8 @@ #' \cr #' \if{html}{\figure{runningdatewindows.png}{options: width="75\%" alt="Figure: runningdatewindows.png"}} #' \if{latex}{\figure{runningdatewindows.pdf}{options: width=7cm}} -#' } -#' \item{**Window at specific indices**}{\cr +#' +#' - **Window at specific indices**\cr #' `runner` by default returns vector of the same size as `x` unless one #' specifies `at` argument. Each element of `at` is an index on which runner #' calculates function - which means that output of the runner is now of @@ -96,20 +96,20 @@ #' current indices. \cr #' \if{html}{\figure{runnerat.png}{options: width="75\%" alt="Figure: runnerat.png"}} #' \if{latex}{\figure{runnerat.pdf}{options: width=7cm}} -#' } -#' } +#' +#' #' ## Specifying time-intervals #' `at` can also be specified as interval of the output defined by #' `at = ""` which results in indices sequence defined by #' `seq.POSIXt(min(idx), max(idx), by = "")`. Increment of sequence -#' is the same as in \code{\link[base]{seq.POSIXt}} function. +#' is the same as in [base::seq.POSIXt()] function. #' It's worth noting that increment interval can't be more frequent than #' interval of `idx` - for `Date` the most frequent time-unit is a `"day"`, #' for `POSIXt` a `sec`. #' #' `k` and `lag` can also be specified as using time sequence increment. #' Available time units are -#'`"sec", "min", "hour", "day", "DSTday", "week", "month", "quarter" or "year"`. +#' `"sec", "min", "hour", "day", "DSTday", "week", "month", "quarter" or "year"`. #' To increment by number of units one can also specify ` s` #' for example `lag = "-2 days"`, `k = "5 weeks"`. #' @@ -124,9 +124,9 @@ #' \cr #' Parallel windows are executed in the independent environment, which means #' that objects other than function arguments needs to be copied to the -#' parallel environment using \code{\link[parallel]{clusterExport}}`. For +#' parallel environment using [parallel::clusterExport()]. For #' example using `f = function(x) x + y + z` will result in error as -#' \code{clusterExport(cl, varlist = c("y", "z"))} needs to be called before. +#' `clusterExport(cl, varlist = c("y", "z"))` needs to be called before. #' #' @return vector with aggregated values for each window. Length of output is #' the same as `length(x)` or `length(at)` if specified. Type of the output @@ -138,17 +138,16 @@ #' @importFrom parallel clusterExport parLapply #' @export runner <- function( - x, - f = function(x) x, - k = integer(0), - lag = integer(1), - idx = integer(0), - at = integer(0), - na_pad = FALSE, - simplify = TRUE, - cl = NULL, - ... - ) { + x, + f = function(x) x, + k = integer(0), + lag = integer(1), + idx = integer(0), + at = integer(0), + na_pad = FALSE, + simplify = TRUE, + cl = NULL, + ...) { UseMethod("runner", x) } @@ -187,13 +186,15 @@ runner <- function( #' #' # number of unique values in each window (varying window size) #' runner(letters[1:10], -#' k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5), -#' f = function(x) length(unique(x))) +#' k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5), +#' f = function(x) length(unique(x)) +#' ) #' #' # concatenate only on selected windows index #' runner(letters[1:10], -#' f = function(x) paste(x, collapse = "-"), -#' at = c(1, 5, 8)) +#' f = function(x) paste(x, collapse = "-"), +#' at = c(1, 5, 8) +#' ) #' #' # 5 days mean #' idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) @@ -205,7 +206,7 @@ runner <- function( #' f = function(x) mean(x) #' ) #' -#'# 5 days mean at 4-indices +#' # 5 days mean at 4-indices #' runner::runner( #' x = 1:15, #' k = 5, @@ -215,34 +216,34 @@ runner <- function( #' f = mean #' ) #' @export -runner.default <- function( #nolint - x, - f = function(x) x, - k = integer(0), - lag = integer(1), - idx = integer(0), - at = integer(0), - na_pad = FALSE, - simplify = TRUE, - cl = NULL, - ... -) { +runner.default <- function( + # nolint + x, + f = function(x) x, + k = integer(0), + lag = integer(1), + idx = integer(0), + at = integer(0), + na_pad = FALSE, + simplify = TRUE, + cl = NULL, + ...) { if (any(is.na(k))) { - stop("Function doesn't accept NA values in k vector"); + stop("Function doesn't accept NA values in k vector") } if (any(is.na(lag))) { - stop("Function doesn't accept NA values in lag vector"); + stop("Function doesn't accept NA values in lag vector") } if (any(is.na(idx))) { - stop("Function doesn't accept NA values in idx vector"); + stop("Function doesn't accept NA values in idx vector") } if (!is(f, "function")) { stop("f should be a function") } # use POSIXt.seq - at <- .seq_at(at, idx) - k <- .k_by(k, if (length(at > 0)) at else idx, "k") + at <- .seq_at(at, idx) + k <- .k_by(k, if (length(at > 0)) at else idx, "k") lag <- .k_by(lag, if (length(at > 0)) at else idx, "lag") w <- window_run(x = x, k = k, lag = lag, idx = idx, at = at, na_pad = na_pad) @@ -250,13 +251,13 @@ runner.default <- function( #nolint answer <- if (!is.null(cl) && is(cl, "cluster")) { parLapply(cl = cl, X = w, fun = f, ...) } else { - lapply(w, function(.this_window) + lapply(w, function(.this_window) { if (length(.this_window) == 0) { NA } else { f(.this_window, ...) } - ) + }) } if (!isFALSE(simplify) && length(answer)) { @@ -306,18 +307,18 @@ runner.default <- function( #nolint #' ) #' stopCluster(cl) #' @export -runner.data.frame <- function( #nolint - x, - f = function(x) x, - k = attr(x, "k"), - lag = if (!is.null(attr(x, "lag"))) attr(x, "lag") else integer(1), - idx = attr(x, "idx"), - at = attr(x, "at"), - na_pad = if (!is.null(attr(x, "na_pad"))) attr(x, "na_pad") else FALSE, - simplify = TRUE, - cl = NULL, - ... -) { +runner.data.frame <- function( + # nolint + x, + f = function(x) x, + k = attr(x, "k"), + lag = if (!is.null(attr(x, "lag"))) attr(x, "lag") else integer(1), + idx = attr(x, "idx"), + at = attr(x, "at"), + na_pad = if (!is.null(attr(x, "na_pad"))) attr(x, "na_pad") else FALSE, + simplify = TRUE, + cl = NULL, + ...) { # Check if argument is either a colname of x or valid vector of values .check_unresolved_difftime(x, k) .check_unresolved_difftime(x, lag) @@ -325,27 +326,27 @@ runner.data.frame <- function( #nolint .check_unresolved_at(x, at) # if argument is a name of the column in x then column of x is taken - k <- .resolve_arg(x, k) + k <- .resolve_arg(x, k) lag <- .resolve_arg(x, lag) idx <- .resolve_arg(x, idx) - at <- .resolve_arg(x, at) + at <- .resolve_arg(x, at) if (any(is.na(k))) { - stop("Function doesn't accept NA values in k vector"); + stop("Function doesn't accept NA values in k vector") } if (any(is.na(lag))) { - stop("Function doesn't accept NA values in lag vector"); + stop("Function doesn't accept NA values in lag vector") } if (any(is.na(idx))) { - stop("Function doesn't accept NA values in idx vector"); + stop("Function doesn't accept NA values in idx vector") } if (!is(f, "function")) { stop("f should be a function") } # use POSIXt.seq - at <- .seq_at(at, idx) - k <- .k_by(k, if (length(at) > 0) at else idx, "k") + at <- .seq_at(at, idx) + k <- .k_by(k, if (length(at) > 0) at else idx, "k") lag <- .k_by(lag, if (length(at) > 0) at else idx, "lag") w <- window_run( @@ -370,7 +371,6 @@ runner.data.frame <- function( #nolint } } ) - } else { lapply(w, function(.this_window_idx) { if (length(.this_window_idx) == 0) { @@ -391,17 +391,16 @@ runner.data.frame <- function( #nolint #' @rdname runner #' @export runner.grouped_df <- function( - x, - f = function(x) x, - k = attr(x, "k"), - lag = if (!is.null(attr(x, "lag"))) attr(x, "lag") else integer(1), - idx = attr(x, "idx"), - at = attr(x, "at"), - na_pad = if (!is.null(attr(x, "na_pad"))) attr(x, "na_pad") else FALSE, - simplify = TRUE, - cl = NULL, - ... -) { + x, + f = function(x) x, + k = attr(x, "k"), + lag = if (!is.null(attr(x, "lag"))) attr(x, "lag") else integer(1), + idx = attr(x, "idx"), + at = attr(x, "at"), + na_pad = if (!is.null(attr(x, "na_pad"))) attr(x, "na_pad") else FALSE, + simplify = TRUE, + cl = NULL, + ...) { runner.data.frame( x = .this_group(x), f = f, @@ -428,36 +427,36 @@ runner.grouped_df <- function( #' cor(x), #' error = function(e) NA #' ) -#' }) +#' } +#' ) #' @export runner.matrix <- function( - x, - f = function(x) x, - k = integer(0), - lag = integer(1), - idx = integer(0), - at = integer(0), - na_pad = FALSE, - simplify = TRUE, - cl = NULL, - ... -) { + x, + f = function(x) x, + k = integer(0), + lag = integer(1), + idx = integer(0), + at = integer(0), + na_pad = FALSE, + simplify = TRUE, + cl = NULL, + ...) { if (any(is.na(k))) { - stop("Function doesn't accept NA values in k vector"); + stop("Function doesn't accept NA values in k vector") } if (any(is.na(lag))) { - stop("Function doesn't accept NA values in lag vector"); + stop("Function doesn't accept NA values in lag vector") } if (any(is.na(idx))) { - stop("Function doesn't accept NA values in idx vector"); + stop("Function doesn't accept NA values in idx vector") } if (!is(f, "function")) { stop("f should be a function") } # use POSIXt.seq - at <- .seq_at(at, idx) - k <- .k_by(k, if (length(at) > 0) at else idx, "k") + at <- .seq_at(at, idx) + k <- .k_by(k, if (length(at) > 0) at else idx, "k") lag <- .k_by(lag, if (length(at) > 0) at else idx, "lag") w <- window_run( @@ -469,7 +468,7 @@ runner.matrix <- function( na_pad = na_pad ) - answer <- if (!is.null(cl) && is(cl, "cluster")) { + answer <- if (!is.null(cl) && is(cl, "cluster")) { clusterExport(cl, varlist = c("x", "f"), envir = environment()) parLapply( cl = cl, @@ -487,12 +486,13 @@ runner.matrix <- function( lapply( X = w, FUN = function(.this_window_idx) { - if (length(.this_window_idx) == 0) { - NA - } else { - f(x[.this_window_idx, , drop = FALSE], ...) + if (length(.this_window_idx) == 0) { + NA + } else { + f(x[.this_window_idx, , drop = FALSE], ...) + } } - }) + ) } if (!isFALSE(simplify) && length(answer)) { simplify2array(answer, higher = (simplify == "array")) @@ -504,17 +504,16 @@ runner.matrix <- function( #' @rdname runner #' @export runner.xts <- function( - x, - f = function(x) x, - k = integer(0), - lag = integer(1), - idx = integer(0), - at = integer(0), - na_pad = FALSE, - simplify = TRUE, - cl = NULL, - ... -) { + x, + f = function(x) x, + k = integer(0), + lag = integer(1), + idx = integer(0), + at = integer(0), + na_pad = FALSE, + simplify = TRUE, + cl = NULL, + ...) { if (!identical(idx, integer(0))) { warning( "'idx' argument has been specified and will mask index diff --git a/R/run_by.R b/R/run_by.R index 0cf4b77..ee5ac7e 100644 --- a/R/run_by.R +++ b/R/run_by.R @@ -1,37 +1,37 @@ #' Set window parameters #' -#' Set window parameters for \link{runner}. This function sets the -#' attributes to \code{x} (only \code{data.frame}) object and saves user effort -#' to specify window parameters in further multiple \link{runner} calls. +#' Set window parameters for [runner()]. This function sets the +#' attributes to `x` (only `data.frame`) object and saves user effort +#' to specify window parameters in further multiple [runner()] calls. #' @inheritParams runner -#' @return x object which \link{runner} can be executed on. +#' @return x object which [runner()] can be executed on. #' @examples #' \dontrun{ #' library(dplyr) #' #' data <- data.frame( -#' index = c(2, 3, 3, 4, 5, 8, 10, 10, 13, 15), -#' a = rep(c("a", "b"), each = 5), -#' b = 1:10 +#' index = c(2, 3, 3, 4, 5, 8, 10, 10, 13, 15), +#' a = rep(c("a", "b"), each = 5), +#' b = 1:10 #' ) #' #' data %>% -#' group_by(a) %>% -#' run_by(idx = "index", k = 5) %>% -#' mutate( -#' c = runner( -#' x = ., -#' f = function(x) { -#' paste(x$b, collapse = ">") -#' } -#' ), -#' d = runner( -#' x = ., -#' f = function(x) { -#' sum(x$b) -#' } -#' ) -#' ) +#' group_by(a) %>% +#' run_by(idx = "index", k = 5) %>% +#' mutate( +#' c = runner( +#' x = ., +#' f = function(x) { +#' paste(x$b, collapse = ">") +#' } +#' ), +#' d = runner( +#' x = ., +#' f = function(x) { +#' sum(x$b) +#' } +#' ) +#' ) #' } #' @export run_by <- function(x, idx, k, lag, na_pad, at) { @@ -58,4 +58,4 @@ run_by <- function(x, idx, k, lag, na_pad, at) { if (!missing(na_pad)) attr(x, "na_pad") <- na_pad return(x) -} \ No newline at end of file +} diff --git a/R/utils.R b/R/utils.R index a3de08c..e0ff6ec 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,7 +1,7 @@ #' Validate date time character #' #' Checks if the character is a valid date time string -#' @param (`character`) can be anything but suppose to be a character. +#' @param x (`character`) can be anything but suppose to be a character. #' @return `logical(1)` denoting if all elements of the character vectors are valid #' @keywords internal .is_datetime_valid <- function(x) { @@ -19,7 +19,7 @@ #' @inheritParams runner #' @param param name of the parameter to be printed in error message #' @examples -#' k <- "1 month" +#' k <- "1 month" #' idx <- seq( #' as.POSIXct("2019-01-01 03:02:01"), #' as.POSIXct("2020-01-01 03:02:01"), @@ -71,7 +71,6 @@ } return(as.integer(idx) - from) - } else if (is(k, "difftime")) { k <- if (param == "k") { if (any(k < 0)) { @@ -98,13 +97,13 @@ #' Formats time-unit-interval to valid for runner #' -#' Formats time-unit-interval to valid for runner. User specifies \code{k} as +#' Formats time-unit-interval to valid for runner. User specifies `k` as #' positive number but this means that this interval needs to be substracted -#' from \code{idx} - because windows length extends window backwards in time. +#' from `idx` - because windows length extends window backwards in time. #' The same situation for lag. #' @param k (k or lag) object from runner to be formatted -#' @param only_positive for \code{k} is \code{TRUE}, -#' for \code{lag} is \code{FALSE} +#' @param only_positive for `k` is `TRUE`, +#' for `lag` is `FALSE` #' @examples #' runner:::.reformat_k("1 days") #' runner:::.reformat_k("day") @@ -136,12 +135,11 @@ #' @keywords internal .seq_at <- function(at, idx) { # nolint if (length(at) == 1 && - ( - (is.character(at) && .is_datetime_valid(at)) || + ( + (is.character(at) && .is_datetime_valid(at)) || is(at, "difftime") - ) - ) { - + ) + ) { if (length(idx) == 0) { stop( sprintf("`idx` can't be empty while specifying `at` as time interval") @@ -151,7 +149,7 @@ if (inherits(idx, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) { at <- if ((is.character(at) && grepl("^-", at)) || - (is(at, "difftime") && at < 0)) { + (is(at, "difftime") && at < 0)) { seq(max(idx), min(idx), by = at) } else { seq(min(idx), max(idx), by = at) @@ -191,7 +189,7 @@ #' @inheritParams runner #' @return resolved `at` #' @keywords internal -.check_unresolved_at <- function(x, at) { #nolint +.check_unresolved_at <- function(x, at) { # nolint arg_name <- deparse(substitute(at)) if (length(at) > 0) { @@ -203,7 +201,7 @@ } else if (inherits(at, c("numeric", "integer", "Date", "POSIXct", "POSIXxt", "POSIXlt"))) { NULL } else { - stop( + stop( sprintf( "`%s` is invalid, should be either: - `numeric`, `Date`, `POSIXct` or `POSIXlt` vector of any length. @@ -226,7 +224,7 @@ #' @inheritParams runner #' @return resolved `idx` #' @keywords internal -.check_unresolved_difftime <- function(x, k) { #nolint +.check_unresolved_difftime <- function(x, k) { # nolint arg_name <- deparse(substitute(k)) if (length(k) > 0) { if (length(k) == 1 && is.character(k) && k %in% names(x)) { @@ -259,7 +257,7 @@ #' @inheritParams runner #' @return resolved `idx` #' @keywords internal -.check_unresolved_index <- function(x, idx) { #nolint +.check_unresolved_index <- function(x, idx) { # nolint arg_name <- deparse(substitute(idx)) if (length(idx) > 0) { @@ -267,7 +265,7 @@ idx <- x[[idx]] } if (length(idx) == nrow(x) && - inherits(idx, c("numeric", "integer", "Date", "POSIXct", "POSIXxt", "POSIXlt"))) { + inherits(idx, c("numeric", "integer", "Date", "POSIXct", "POSIXxt", "POSIXlt"))) { NULL } else { stop( diff --git a/README.Rmd b/README.Rmd index 045cdc2..a846ae5 100755 --- a/README.Rmd +++ b/README.Rmd @@ -16,7 +16,7 @@ knitr::opts_chunk$set( # -[![Check](https://github.com/gogonzo/runner/workflows/Check/badge.svg)](https://github.com/gogonzo/runner/actions) +[![Check](https://github.com/gogonzo/runner/workflows/R-CMD-check/badge.svg)](https://github.com/gogonzo/runner/actions) [![](https://cranlogs.r-pkg.org/badges/runner)](https://CRAN.R-project.org/package=runner) [![Dependencies](https://tinyverse.netlify.com/badge/runner)](https://cran.r-project.org/package=runner) @@ -56,10 +56,10 @@ x <- data.frame( ) runner( - x, + x, lag = "1 months", - k = "4 months", - idx = x$date, + k = "4 months", + idx = x$date, f = function(x) { cor(x$a, x$b) } @@ -104,8 +104,8 @@ of backward. ![](man/figures/laggedwindowklag.png) ```{r eval=FALSE} runner( - 1:15, - k = 4, + 1:15, + k = 4, lag = 2 ) ``` @@ -125,9 +125,9 @@ ranges for each window. ```{r eval=FALSE} idx <- Sys.Date() + c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = 1:15, - k = "5 days", - lag = "1 days", + x = 1:15, + k = "5 days", + lag = "1 days", idx = idx ) ``` @@ -144,10 +144,10 @@ which gives windows in ranges enclosed in square brackets. Range for `at = 27` i ```{r eval=FALSE} idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = idx, - k = 5, - lag = 1, - idx = idx, + x = idx, + k = 5, + lag = 1, + idx = idx, at = c(18, 27, 48, 31) ) ``` @@ -168,10 +168,10 @@ matching `idx`. ```{r eval=FALSE} idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = idx, - k = 5, - lag = 1, - idx = idx, + x = idx, + k = 5, + lag = 1, + idx = idx, at = c(4, 18, 48, 51), na_pad = TRUE ) @@ -213,7 +213,7 @@ do this outside and pass it to the `runner` through `cl` argument. ```{r eval=FALSE} library(parallel) -# +# numCores <- detectCores() cl <- makeForkCluster(numCores) diff --git a/README.md b/README.md index b01bd05..1cc7261 100755 --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ -[![Check](https://github.com/gogonzo/runner/workflows/Check/badge.svg)](https://github.com/gogonzo/runner/actions) +[![Check](https://github.com/gogonzo/runner/workflows/R-CMD-check/badge.svg)](https://github.com/gogonzo/runner/actions) [![](https://cranlogs.r-pkg.org/badges/runner)](https://CRAN.R-project.org/package=runner) [![Dependencies](https://tinyverse.netlify.com/badge/runner)](https://cran.r-project.org/package=runner) @@ -45,10 +45,10 @@ x <- data.frame( ) runner( - x, + x, lag = "1 months", - k = "4 months", - idx = x$date, + k = "4 months", + idx = x$date, f = function(x) { cor(x$a, x$b) } @@ -95,8 +95,8 @@ also be negative value, which shifts window forward instead of backward. ``` r runner( - 1:15, - k = 4, + 1:15, + k = 4, lag = 2 ) ``` @@ -118,9 +118,9 @@ each window. ``` r idx <- Sys.Date() + c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = 1:15, - k = "5 days", - lag = "1 days", + x = 1:15, + k = "5 days", + lag = "1 days", idx = idx ) ``` @@ -139,10 +139,10 @@ available in current indices. ``` r idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = idx, - k = 5, - lag = 1, - idx = idx, + x = idx, + k = 5, + lag = 1, + idx = idx, at = c(18, 27, 48, 31) ) ``` @@ -164,10 +164,10 @@ depending on date. In example below two windows exceed range given by ``` r idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner( - x = idx, - k = 5, - lag = 1, - idx = idx, + x = idx, + k = 5, + lag = 1, + idx = idx, at = c(4, 18, 48, 51), na_pad = TRUE ) @@ -211,7 +211,7 @@ argument. ``` r library(parallel) -# +# numCores <- detectCores() cl <- makeForkCluster(numCores) diff --git a/appveyor.yml b/appveyor.yml deleted file mode 100755 index 1eadc91..0000000 --- a/appveyor.yml +++ /dev/null @@ -1,68 +0,0 @@ -# DO NOT CHANGE the "init" and "install" sections below - -# Download script file from GitHub -init: - ps: | - $ErrorActionPreference = "Stop" - Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" - Import-Module '..\appveyor-tool.ps1' - -install: - ps: Bootstrap - -os: Visual Studio 2015 CTP 6 - -cache: - - C:\RLibrary - -# Adapt as necessary starting from here -environment: - global: - WARNINGS_ARE_ERRORS: 1 - - matrix: - - R_VERSION: devel - GCC_PATH: mingw_32 - - - R_VERSION: devel - R_ARCH: x64 - GCC_PATH: mingw_64 - - - R_VERSION: release - R_ARCH: x64 - - - R_VERSION: stable - - - R_VERSION: patched - -matrix: - fast_finish: true - -build_script: - - travis-tool.sh install_deps - -test_script: - - travis-tool.sh run_tests - -on_failure: - - 7z a failure.zip *.Rcheck\* - - appveyor PushArtifact failure.zip - -artifacts: - - path: '*.Rcheck\**\*.log' - name: Logs - - - path: '*.Rcheck\**\*.out' - name: Logs - - - path: '*.Rcheck\**\*.fail' - name: Logs - - - path: '*.Rcheck\**\*.Rout' - name: Logs - - - path: '\*_*.tar.gz' - name: Bits - - - path: '\*_*.zip' - name: Bits diff --git a/man/dot-check_unresolved_at.Rd b/man/dot-check_unresolved_at.Rd index f0ca818..84b2208 100644 --- a/man/dot-check_unresolved_at.Rd +++ b/man/dot-check_unresolved_at.Rd @@ -12,7 +12,7 @@ \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} } \value{ diff --git a/man/dot-check_unresolved_difftime.Rd b/man/dot-check_unresolved_difftime.Rd index fbc5f64..fe6c72d 100644 --- a/man/dot-check_unresolved_difftime.Rd +++ b/man/dot-check_unresolved_difftime.Rd @@ -13,7 +13,7 @@ Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} } \value{ diff --git a/man/dot-is_datetime_valid.Rd b/man/dot-is_datetime_valid.Rd index e34a68a..42bc1eb 100644 --- a/man/dot-is_datetime_valid.Rd +++ b/man/dot-is_datetime_valid.Rd @@ -7,7 +7,7 @@ .is_datetime_valid(x) } \arguments{ -\item{(`character`)}{can be anything but suppose to be a character.} +\item{x}{(\code{character}) can be anything but suppose to be a character.} } \value{ \code{logical(1)} denoting if all elements of the character vectors are valid diff --git a/man/dot-k_by.Rd b/man/dot-k_by.Rd index 313ec0b..10966a6 100644 --- a/man/dot-k_by.Rd +++ b/man/dot-k_by.Rd @@ -11,7 +11,7 @@ Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -27,7 +27,7 @@ varying increment and with duplicated values. If specified then \code{k} and Converts k and lag from time-unit-interval to int } \examples{ -k <- "1 month" +k <- "1 month" idx <- seq( as.POSIXct("2019-01-01 03:02:01"), as.POSIXct("2020-01-01 03:02:01"), diff --git a/man/fill_run.Rd b/man/fill_run.Rd index 7dceaf5..80428aa 100755 --- a/man/fill_run.Rd +++ b/man/fill_run.Rd @@ -25,8 +25,8 @@ replaced with previous non-NA element. Fill \code{NA} with last non-NA element. } \examples{ -fill_run(c(NA, NA,1:10, NA, NA), run_for_first = TRUE) -fill_run(c(NA, NA,1:10, NA, NA), run_for_first = TRUE) -fill_run(c(NA, NA,1:10, NA, NA), run_for_first = FALSE) +fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = TRUE) +fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = TRUE) +fill_run(c(NA, NA, 1:10, NA, NA), run_for_first = FALSE) fill_run(c(NA, NA, 1, 2, NA, NA, 2, 2, NA, NA, 1, NA, NA), run_for_first = TRUE, only_within = TRUE) } diff --git a/man/lag_run.Rd b/man/lag_run.Rd index c2a4701..8cc1f10 100755 --- a/man/lag_run.Rd +++ b/man/lag_run.Rd @@ -15,7 +15,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr diff --git a/man/length_run.Rd b/man/length_run.Rd index 93cd575..3db27e0 100755 --- a/man/length_run.Rd +++ b/man/length_run.Rd @@ -11,7 +11,7 @@ length_run(k = integer(1), lag = integer(1), idx = integer(0)) Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -19,7 +19,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr diff --git a/man/max_run.Rd b/man/max_run.Rd index f16476f..6a362da 100755 --- a/man/max_run.Rd +++ b/man/max_run.Rd @@ -22,7 +22,7 @@ Input in runner custom function \code{f}.} Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -30,7 +30,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -43,7 +43,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_rm}{\code{logical} single value (default \code{na_rm = TRUE}) - @@ -54,7 +54,7 @@ Whether incomplete window should return \code{NA} (if \code{na_pad = TRUE}) Incomplete window is when some parts of the window are out of range.} } \value{ -max {numeric} vector of length equals length of \code{x}. +max (\code{numeric}) vector of length equals length of \code{x}. } \description{ \code{min_run} calculates running max on given \code{x} numeric vector, @@ -62,11 +62,11 @@ specified \code{k} window size. } \examples{ set.seed(11) -x1 <- sample( c(1,2,3), 15, replace=TRUE) -x2 <- sample( c(NA,1,2,3), 15, replace=TRUE) -k <- sample( 1:4, 15, replace=TRUE) +x1 <- sample(c(1, 2, 3), 15, replace = TRUE) +x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) +k <- sample(1:4, 15, replace = TRUE) max_run(x1) # simple cumulative maximum max_run(x2, na_rm = TRUE) # cumulative maximum with removing NA. -max_run(x2, na_rm = TRUE, k=4) # maximum in 4-element window -max_run(x2, na_rm = FALSE, k=k) # maximum in varying k window size +max_run(x2, na_rm = TRUE, k = 4) # maximum in 4-element window +max_run(x2, na_rm = FALSE, k = k) # maximum in varying k window size } diff --git a/man/mean_run.Rd b/man/mean_run.Rd index 0b4c1ab..9d3d93a 100755 --- a/man/mean_run.Rd +++ b/man/mean_run.Rd @@ -17,9 +17,7 @@ mean_run( \arguments{ \item{x}{\code{numeric} vector which running function is calculated on} -\item{k}{(\code{integer}` vector or single value)\cr -Denoting size of the running window. If \code{k} is a single value then window -size is constant for all elements, otherwise if \code{length(k) == length(x)} +\item{k}{(\verb{integer`` vector or single value)\\cr Denoting size of the running window. If }k\verb{is a single value then window size is constant for all elements, otherwise if}length(k) == length(x)` different window size for each element.} \item{lag}{(\code{integer} vector or single value)\cr @@ -45,7 +43,7 @@ Whether incomplete window should return \code{NA} (if \code{na_pad = TRUE}) Incomplete window is when some parts of the window are out of range.} } \value{ -mean {numeric} vector of length equals length of \code{x}. +mean (\code{numeric}) vector of length equals length of \code{x}. } \description{ Running mean in specified window of numeric vector. @@ -53,10 +51,10 @@ Running mean in specified window of numeric vector. \examples{ set.seed(11) x1 <- rnorm(15) -x2 <- sample(c(rep(NA,5), rnorm(15)), 15, replace = TRUE) +x2 <- sample(c(rep(NA, 5), rnorm(15)), 15, replace = TRUE) k <- sample(1:15, 15, replace = TRUE) mean_run(x1) mean_run(x2, na_rm = TRUE) -mean_run(x2, na_rm = FALSE ) -mean_run(x2, na_rm = TRUE, k=4) +mean_run(x2, na_rm = FALSE) +mean_run(x2, na_rm = TRUE, k = 4) } diff --git a/man/min_run.Rd b/man/min_run.Rd index 5ff65ef..f03d800 100755 --- a/man/min_run.Rd +++ b/man/min_run.Rd @@ -22,7 +22,7 @@ Input in runner custom function \code{f}.} Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -30,7 +30,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -43,7 +43,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_rm}{\code{logical} single value (default \code{na_rm = TRUE}) - @@ -54,7 +54,7 @@ Whether incomplete window should return \code{NA} (if \code{na_pad = TRUE}) Incomplete window is when some parts of the window are out of range.} } \value{ -min {numeric} vector of length equals length of \code{x}. +min (\code{numeric}) vector of length equals length of \code{x}. } \description{ \code{min_run} calculates running min on given \code{x} numeric vector, specified \code{k} window size. @@ -63,7 +63,7 @@ min {numeric} vector of length equals length of \code{x}. set.seed(11) x1 <- sample(c(1, 2, 3), 15, replace = TRUE) x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) -k <- sample(1:4, 15, replace = TRUE) +k <- sample(1:4, 15, replace = TRUE) min_run(x1) min_run(x2, na_rm = TRUE) min_run(x2, na_rm = TRUE, k = 4) diff --git a/man/run_by.Rd b/man/run_by.Rd index b9ef502..d4802ed 100644 --- a/man/run_by.Rd +++ b/man/run_by.Rd @@ -21,7 +21,7 @@ varying increment and with duplicated values. If specified then \code{k} and Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -29,7 +29,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_pad}{(\code{logical} single value)\cr @@ -39,43 +39,43 @@ Incomplete window is when some parts of the window are out of range.} \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} } \value{ -x object which \link{runner} can be executed on. +x object which \code{\link[=runner]{runner()}} can be executed on. } \description{ -Set window parameters for \link{runner}. This function sets the +Set window parameters for \code{\link[=runner]{runner()}}. This function sets the attributes to \code{x} (only \code{data.frame}) object and saves user effort -to specify window parameters in further multiple \link{runner} calls. +to specify window parameters in further multiple \code{\link[=runner]{runner()}} calls. } \examples{ \dontrun{ library(dplyr) data <- data.frame( - index = c(2, 3, 3, 4, 5, 8, 10, 10, 13, 15), - a = rep(c("a", "b"), each = 5), - b = 1:10 + index = c(2, 3, 3, 4, 5, 8, 10, 10, 13, 15), + a = rep(c("a", "b"), each = 5), + b = 1:10 ) data \%>\% - group_by(a) \%>\% - run_by(idx = "index", k = 5) \%>\% - mutate( - c = runner( - x = ., - f = function(x) { - paste(x$b, collapse = ">") - } - ), - d = runner( - x = ., - f = function(x) { - sum(x$b) - } - ) - ) + group_by(a) \%>\% + run_by(idx = "index", k = 5) \%>\% + mutate( + c = runner( + x = ., + f = function(x) { + paste(x$b, collapse = ">") + } + ), + d = runner( + x = ., + f = function(x) { + sum(x$b) + } + ) + ) } } diff --git a/man/runner.Rd b/man/runner.Rd index c87793a..cff3fde 100644 --- a/man/runner.Rd +++ b/man/runner.Rd @@ -101,7 +101,7 @@ By default runner returns windows as is (\verb{f = function(x)}).} Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -109,7 +109,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -122,7 +122,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_pad}{(\code{logical} single value)\cr @@ -139,7 +139,7 @@ are identical to \code{sapply}.} \item{cl}{(\code{cluster}) \emph{experimental}\cr Create and pass the cluster to the \code{runner} function to run each window -calculation in parallel. See \code{\link[parallel]{makeCluster}} in details.} +calculation in parallel. See \code{\link[parallel:makeCluster]{parallel::makeCluster()}} in details.} \item{...}{(optional)\cr other arguments passed to the function \code{f}.} @@ -157,20 +157,18 @@ Function can apply any R function on running windows defined by \code{x}, \code{k}, \code{lag}, \code{idx} and \code{at}. Running window can be calculated on several ways: \itemize{ -\item{\strong{Cumulative windows}}{\cr +\item \strong{Cumulative windows}\cr applied when user doesn't specify \code{k} argument or specify \code{k = length(x)}, this would mean that \code{k} is equal to number of available elements \cr \if{html}{\figure{cumulativewindows.png}{options: width="75\%" alt="Figure: cumulativewindows.png"}} \if{latex}{\figure{cumulativewindows.pdf}{options: width=7cm}} -} -\item{\strong{Constant sliding windows}}{\cr +\item \strong{Constant sliding windows} applied when user specify \code{k} as constant value keeping \code{idx} and \code{at} unspecified. \code{lag} argument shifts windows left (\code{lag > 0}) or right (\code{lag < 0}). \cr \if{html}{\figure{incrementalindex.png}{options: width="75\%" alt="Figure: incrementalindex.png"}} \if{latex}{\figure{incrementalindex.pdf}{options: width=7cm}} -} -\item{\strong{Windows depending on date}}{\cr +\item \strong{Windows depending on date}\cr If one specifies \code{idx} this would mean that output windows size might change in size because of unequally spaced indexes. Fox example 5-period window is different than 5-element window, because 5-period window might @@ -179,8 +177,7 @@ mean) \cr \if{html}{\figure{runningdatewindows.png}{options: width="75\%" alt="Figure: runningdatewindows.png"}} \if{latex}{\figure{runningdatewindows.pdf}{options: width=7cm}} -} -\item{\strong{Window at specific indices}}{\cr +\item \strong{Window at specific indices}\cr \code{runner} by default returns vector of the same size as \code{x} unless one specifies \code{at} argument. Each element of \code{at} is an index on which runner calculates function - which means that output of the runner is now of @@ -192,13 +189,12 @@ current indices. \cr \if{html}{\figure{runnerat.png}{options: width="75\%" alt="Figure: runnerat.png"}} \if{latex}{\figure{runnerat.pdf}{options: width=7cm}} } -} \subsection{Specifying time-intervals}{ \code{at} can also be specified as interval of the output defined by \code{at = ""} which results in indices sequence defined by \code{seq.POSIXt(min(idx), max(idx), by = "")}. Increment of sequence -is the same as in \code{\link[base]{seq.POSIXt}} function. +is the same as in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}} function. It's worth noting that increment interval can't be more frequent than interval of \code{idx} - for \code{Date} the most frequent time-unit is a \code{"day"}, for \code{POSIXt} a \code{sec}. @@ -223,7 +219,8 @@ have the edge over single-thread even if the \cr Parallel windows are executed in the independent environment, which means that objects other than function arguments needs to be copied to the -parallel environment using \code{\link[parallel]{clusterExport}}\verb{. For example using }f = function(x) x + y + z` will result in error as +parallel environment using \code{\link[parallel:clusterApply]{parallel::clusterExport()}}. For +example using \code{f = function(x) x + y + z} will result in error as \code{clusterExport(cl, varlist = c("y", "z"))} needs to be called before. } } @@ -261,13 +258,15 @@ runner( # number of unique values in each window (varying window size) runner(letters[1:10], - k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5), - f = function(x) length(unique(x))) + k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5), + f = function(x) length(unique(x)) +) # concatenate only on selected windows index runner(letters[1:10], - f = function(x) paste(x, collapse = "-"), - at = c(1, 5, 8)) + f = function(x) paste(x, collapse = "-"), + at = c(1, 5, 8) +) # 5 days mean idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) @@ -335,5 +334,6 @@ runner( cor(x), error = function(e) NA ) - }) + } +) } diff --git a/man/streak_run.Rd b/man/streak_run.Rd index f7ee738..2d81481 100755 --- a/man/streak_run.Rd +++ b/man/streak_run.Rd @@ -21,7 +21,7 @@ streak_run( Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -29,7 +29,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -42,7 +42,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_rm}{\code{logical} single value (default \code{na_rm = TRUE}) - @@ -61,7 +61,7 @@ Calculates running series of consecutive elements } \examples{ set.seed(11) -x1 <- sample(c("a","b"), 15, replace = TRUE) +x1 <- sample(c("a", "b"), 15, replace = TRUE) x2 <- sample(c(NA_character_, "a", "b"), 15, replace = TRUE) k <- sample(1:4, 15, replace = TRUE) streak_run(x1) # simple streak run diff --git a/man/sum_run.Rd b/man/sum_run.Rd index 7d41584..02ee252 100755 --- a/man/sum_run.Rd +++ b/man/sum_run.Rd @@ -17,9 +17,7 @@ sum_run( \arguments{ \item{x}{\code{numeric} vector which running function is calculated on} -\item{k}{(\code{integer}` vector or single value)\cr -Denoting size of the running window. If \code{k} is a single value then window -size is constant for all elements, otherwise if \code{length(k) == length(x)} +\item{k}{(\verb{integer`` vector or single value)\\cr Denoting size of the running window. If }k\verb{is a single value then window size is constant for all elements, otherwise if}length(k) == length(x)` different window size for each element.} \item{lag}{(\code{integer} vector or single value)\cr @@ -45,7 +43,7 @@ Whether incomplete window should return \code{NA} (if \code{na_pad = TRUE}) Incomplete window is when some parts of the window are out of range.} } \value{ -sum \code{code} vector of length equals length of \code{x}. +sum \code{numeric} vector of length equals length of \code{x}. } \description{ Running sum in specified window of numeric vector. @@ -53,7 +51,7 @@ Running sum in specified window of numeric vector. \examples{ set.seed(11) x1 <- rnorm(15) -x2 <- sample(c(rep(NA, 5),rnorm(15)), 15, replace = TRUE) +x2 <- sample(c(rep(NA, 5), rnorm(15)), 15, replace = TRUE) k <- sample(1:15, 15, replace = TRUE) sum_run(x1) sum_run(x2, na_rm = TRUE) diff --git a/man/which_run.Rd b/man/which_run.Rd index bfc8270..c96070c 100644 --- a/man/which_run.Rd +++ b/man/which_run.Rd @@ -23,7 +23,7 @@ Input in runner custom function \code{f}.} Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -31,7 +31,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -44,7 +44,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{which}{\code{character} value "first" or "last" denoting if the first or last \code{TRUE} @@ -67,7 +67,7 @@ integer vector of indexes of the same length as \code{x}. set.seed(11) x1 <- sample(c(1, 2, 3), 15, replace = TRUE) x2 <- sample(c(NA, 1, 2, 3), 15, replace = TRUE) -k <- sample(1:4, 15, replace = TRUE) +k <- sample(1:4, 15, replace = TRUE) which_run(x1) which_run(x2, na_rm = TRUE) which_run(x2, na_rm = TRUE, k = 4) diff --git a/man/window_run.Rd b/man/window_run.Rd index 48c04c0..f23ecc5 100644 --- a/man/window_run.Rd +++ b/man/window_run.Rd @@ -21,7 +21,7 @@ Input in runner custom function \code{f}.} Denoting size of the running window. If \code{k} is a single value then window size is constant for all elements, otherwise if \code{length(k) == length(x)} different window size for each element. One can also specify \code{k} in the same -way as \code{by} argument in \code{\link[base]{seq.POSIXt}}. +way as \code{by} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{lag}{(\code{integer} vector or single value)\cr @@ -29,7 +29,7 @@ Denoting window lag. If \code{lag} is a single value then window lag is constant for all elements, otherwise if \code{length(lag) == length(x)} different window size for each element. Negative value shifts window forward. One can also specify \code{lag} in the same way as \code{by} argument in -\code{\link[base]{seq.POSIXt}}. See 'Specifying time-intervals' in details +\code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{idx}{(\code{integer}, \code{Date}, \code{POSIXt})\cr @@ -42,7 +42,7 @@ varying increment and with duplicated values. If specified then \code{k} and \item{at}{(\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr Vector of any size and any value defining output data points. Values of the vector defines the indexes which data is computed at. Can be also \code{POSIXt} -sequence increment used in \code{at} argument in \code{\link[base]{seq.POSIXt}}. +sequence increment used in \code{at} argument in \code{\link[base:seq.POSIXt]{base::seq.POSIXt()}}. See 'Specifying time-intervals' in details section.} \item{na_pad}{(\code{logical} single value)\cr diff --git a/src/fill_run.cpp b/src/fill_run.cpp index e9daff6..2805f01 100755 --- a/src/fill_run.cpp +++ b/src/fill_run.cpp @@ -4,14 +4,14 @@ using namespace Rcpp; //' Fill NA with previous non-NA element //' -//' Fill \code{NA} with last non-NA element. +//' Fill `NA` with last non-NA element. //' @inheritParams runner -//' @param run_for_first If first elements are filled with \code{NA}, \code{run_for_first = TRUE} -//' allows to fill all initial \code{NA} with nearest non-NA value. By default -//' \code{run_for_first = TRUE} -//' @param only_within \code{NA} are replaced only if previous and next non-NA -//' values are the same. By default \code{only_within = TRUE} -//' @return vector - \code{x} containing all \code{x} elements with \code{NA} +//' @param run_for_first If first elements are filled with `NA`, `run_for_first = TRUE` +//' allows to fill all initial `NA` with nearest non-NA value. By default +//' `run_for_first = TRUE` +//' @param only_within `NA` are replaced only if previous and next non-NA +//' values are the same. By default `only_within = TRUE` +//' @return vector - `x` containing all `x` elements with `NA` //' replaced with previous non-NA element. //' @examples //' fill_run(c(NA, NA,1:10, NA, NA), run_for_first = TRUE) @@ -20,15 +20,23 @@ using namespace Rcpp; //' fill_run(c(NA, NA, 1, 2, NA, NA, 2, 2, NA, NA, 1, NA, NA), run_for_first = TRUE, only_within = TRUE) //' @export // [[Rcpp::export]] -SEXP fill_run(SEXP x, bool run_for_first = false, bool only_within = false) { +SEXP fill_run(SEXP x, bool run_for_first = false, bool only_within = false) +{ - switch (TYPEOF(x)) { - case INTSXP: return fill::fill_run( as(x), run_for_first, only_within); - case REALSXP: return fill::fill_run( as(x), run_for_first, only_within); - case STRSXP: return fill::fill_run( as(x), run_for_first, only_within); - case LGLSXP: return fill::fill_run( as(x), run_for_first, only_within); - case CPLXSXP: return fill::fill_run( as(x), run_for_first, only_within); - default: { + switch (TYPEOF(x)) + { + case INTSXP: + return fill::fill_run(as(x), run_for_first, only_within); + case REALSXP: + return fill::fill_run(as(x), run_for_first, only_within); + case STRSXP: + return fill::fill_run(as(x), run_for_first, only_within); + case LGLSXP: + return fill::fill_run(as(x), run_for_first, only_within); + case CPLXSXP: + return fill::fill_run(as(x), run_for_first, only_within); + default: + { stop("Invalid data type - only integer, numeric, character, factor, date vectors are possible."); } } diff --git a/src/lag_run.cpp b/src/lag_run.cpp index 0c7090b..ca72b0f 100755 --- a/src/lag_run.cpp +++ b/src/lag_run.cpp @@ -8,9 +8,9 @@ using namespace Rcpp; //' Vector of input lagged along integer vector //' @inheritParams runner //' @inheritParams sum_run -//' @param nearest \code{logical} single value. Applied when \code{idx} is used, -//' then \code{nearest = FALSE} returns observation lagged exactly by the -//' specified number of "periods". When \code{nearest = TRUE} +//' @param nearest `logical` single value. Applied when `idx` is used, +//' then `nearest = FALSE` returns observation lagged exactly by the +//' specified number of "periods". When `nearest = TRUE` //' function returns latest observation within lag window. //' @examples //' lag_run(1:10, lag = 3) @@ -21,56 +21,91 @@ using namespace Rcpp; SEXP lag_run(SEXP x, IntegerVector lag = 1, IntegerVector idx = IntegerVector(0), - bool nearest = false) { + bool nearest = false) +{ int n = Rf_length(x); checks::check_idx(idx, n, "x"); checks::check_lag(lag, n, "x"); - - if ((idx.size() == 0) && (lag.size() == 1)) { - switch (TYPEOF(x)) { - case INTSXP: return lag::lag_run11(as(x), lag(0)); - case REALSXP: return lag::lag_run11(as(x), lag(0)); - case STRSXP: return lag::lag_run11(as(x), lag(0)); - case LGLSXP: return lag::lag_run11(as(x), lag(0)); - case CPLXSXP: return lag::lag_run11(as(x), lag(0)); - default: { + if ((idx.size() == 0) && (lag.size() == 1)) + { + switch (TYPEOF(x)) + { + case INTSXP: + return lag::lag_run11(as(x), lag(0)); + case REALSXP: + return lag::lag_run11(as(x), lag(0)); + case STRSXP: + return lag::lag_run11(as(x), lag(0)); + case LGLSXP: + return lag::lag_run11(as(x), lag(0)); + case CPLXSXP: + return lag::lag_run11(as(x), lag(0)); + default: + { stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); } } - } else if ((idx.size() == 0) && (lag.size() > 1)) { - switch (TYPEOF(x)) { - case INTSXP: return lag::lag_run12(as(x), lag); - case REALSXP: return lag::lag_run12(as(x), lag); - case STRSXP: return lag::lag_run12(as(x), lag); - case LGLSXP: return lag::lag_run12(as(x), lag); - case CPLXSXP: return lag::lag_run12(as(x), lag); - default: { + } + else if ((idx.size() == 0) && (lag.size() > 1)) + { + switch (TYPEOF(x)) + { + case INTSXP: + return lag::lag_run12(as(x), lag); + case REALSXP: + return lag::lag_run12(as(x), lag); + case STRSXP: + return lag::lag_run12(as(x), lag); + case LGLSXP: + return lag::lag_run12(as(x), lag); + case CPLXSXP: + return lag::lag_run12(as(x), lag); + default: + { stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); } } - } else if ((idx.size() == n) && (lag.size() == 1)) { - switch (TYPEOF(x)) { - case INTSXP: return lag::lag_run21(as(x), lag(0), idx, nearest); - case REALSXP: return lag::lag_run21(as(x), lag(0), idx, nearest); - case STRSXP: return lag::lag_run21(as(x), lag(0), idx, nearest); - case LGLSXP: return lag::lag_run21(as(x), lag(0), idx, nearest); - case CPLXSXP: return lag::lag_run21(as(x), lag(0), idx, nearest); - default: { + } + else if ((idx.size() == n) && (lag.size() == 1)) + { + switch (TYPEOF(x)) + { + case INTSXP: + return lag::lag_run21(as(x), lag(0), idx, nearest); + case REALSXP: + return lag::lag_run21(as(x), lag(0), idx, nearest); + case STRSXP: + return lag::lag_run21(as(x), lag(0), idx, nearest); + case LGLSXP: + return lag::lag_run21(as(x), lag(0), idx, nearest); + case CPLXSXP: + return lag::lag_run21(as(x), lag(0), idx, nearest); + default: + { stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); } } - } else if ((idx.size() == n) && (lag.size() > 1)) { - switch (TYPEOF(x)) { - case INTSXP: return lag::lag_run22(as(x), lag, idx, nearest); - case REALSXP: return lag::lag_run22(as(x), lag, idx, nearest); - case STRSXP: return lag::lag_run22(as(x), lag, idx, nearest); - case LGLSXP: return lag::lag_run22(as(x), lag, idx, nearest); - case CPLXSXP: return lag::lag_run22(as(x), lag, idx, nearest); - default: { - stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); - } + } + else if ((idx.size() == n) && (lag.size() > 1)) + { + switch (TYPEOF(x)) + { + case INTSXP: + return lag::lag_run22(as(x), lag, idx, nearest); + case REALSXP: + return lag::lag_run22(as(x), lag, idx, nearest); + case STRSXP: + return lag::lag_run22(as(x), lag, idx, nearest); + case LGLSXP: + return lag::lag_run22(as(x), lag, idx, nearest); + case CPLXSXP: + return lag::lag_run22(as(x), lag, idx, nearest); + default: + { + stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); + } } } diff --git a/src/length_run.cpp b/src/length_run.cpp index f231558..9adebd5 100755 --- a/src/length_run.cpp +++ b/src/length_run.cpp @@ -4,8 +4,8 @@ using namespace Rcpp; //' Length of running windows //' -//' Number of elements in k-long window calculated on \code{idx} vector. -//' If \code{idx} is an `as.integer(date)` vector, then k=number of days in window - +//' Number of elements in k-long window calculated on `idx` vector. +//' If `idx` is an `as.integer(date)` vector, then k=number of days in window - //' then the result is number of observations within k days window. //' @inheritParams runner //' @inheritParams sum_run @@ -15,9 +15,11 @@ using namespace Rcpp; // [[Rcpp::export]] IntegerVector length_run(IntegerVector k = IntegerVector(1), IntegerVector lag = IntegerVector(1), - IntegerVector idx = IntegerVector(0)) { + IntegerVector idx = IntegerVector(0)) +{ int n = idx.size(); - if (n == 0) { + if (n == 0) + { stop("idx should be of length > 0"); } @@ -26,26 +28,39 @@ IntegerVector length_run(IntegerVector k = IntegerVector(1), checks::check_lag(lag, n, "idx"); IntegerVector res(n); - if ((k.size() == 1)) { - for (int i = 0; i < n; i++) { - for (int j = i; j >= 0; j--) { - if ((idx(i) - idx(j)) > (k(0) - 1)) { + if ((k.size() == 1)) + { + for (int i = 0; i < n; i++) + { + for (int j = i; j >= 0; j--) + { + if ((idx(i) - idx(j)) > (k(0) - 1)) + { res(i) = i - j; break; - } else if (j == 0){ + } + else if (j == 0) + { res(i) = NA_INTEGER; } } } - // IDX VARYING WINDOW ----------- - } else if((k.size() > 1)) { - for (int i = 0; i < n; i++) { - for (int j = i; j >= 0; j--) { - if ((idx(i) - idx(j)) > (k(i) - 1)) { + // IDX VARYING WINDOW ----------- + } + else if ((k.size() > 1)) + { + for (int i = 0; i < n; i++) + { + for (int j = i; j >= 0; j--) + { + if ((idx(i) - idx(j)) > (k(i) - 1)) + { res(i) = i - j; break; - } else if (j == 0) { + } + else if (j == 0) + { res(i) = NA_INTEGER; } } diff --git a/src/minmax_run.cpp b/src/minmax_run.cpp index ad45845..1911567 100644 --- a/src/minmax_run.cpp +++ b/src/minmax_run.cpp @@ -3,18 +3,19 @@ //' Running min/max //' //' -//' \code{min_run} calculates running minimum-maximum on given \code{x} numeric -//' vector, specified \code{k} window size. +//' `min_run` calculates running minimum-maximum on given `x` numeric +//' vector, specified `k` window size. //' @inheritParams runner //' @inheritParams sum_run -//' @param metric \code{character} what to return, minimum or maximum +//' @param metric `character` what to return, minimum or maximum //' @return list. //' @export // [[Rcpp::export]] Rcpp::NumericVector minmax_run( - Rcpp::NumericVector const& x, + Rcpp::NumericVector const &x, std::string metric = "min", - bool na_rm = true) { + bool na_rm = true) +{ int n = x.size(); @@ -30,25 +31,34 @@ Rcpp::NumericVector minmax_run( Rcpp::NumericVector mins = Rcpp::NumericVector(n); Rcpp::NumericVector maxes = Rcpp::NumericVector(n); - for (int i = 1; i < n; ++i) { - if (Rcpp::NumericVector::is_na(x(i)) && !na_rm) { + for (int i = 1; i < n; ++i) + { + if (Rcpp::NumericVector::is_na(x(i)) && !na_rm) + { res(i) = NA_REAL; - } else { + } + else + { prev = x(i - 1); cur = x(i); - if (prev > last_max && cur < prev) { + if (prev > last_max && cur < prev) + { last_max = prev; last_min = temp_min; temp_min = cur; - } else if (prev < last_min && cur > prev) { + } + else if (prev < last_min && cur > prev) + { last_min = prev; last_max = temp_max; temp_max = cur; } - if (cur < temp_min) temp_min = cur; - if (cur > temp_max) temp_max = cur; + if (cur < temp_min) + temp_min = cur; + if (cur > temp_max) + temp_max = cur; res(i) = (metric == "min") ? last_min : last_max; } diff --git a/src/runner.cpp b/src/runner.cpp index 2034994..f15d14b 100755 --- a/src/runner.cpp +++ b/src/runner.cpp @@ -9,13 +9,14 @@ using namespace Rcpp; template Rcpp::Vector::rtype> -run(Rcpp::Vector const& x, - Rcpp::IntegerVector const& k, - Rcpp::IntegerVector const& lag, - Rcpp::IntegerVector const& idx, - Rcpp::IntegerVector const& at, - Function const& f, - bool na_pad) { +run(Rcpp::Vector const &x, + Rcpp::IntegerVector const &k, + Rcpp::IntegerVector const &lag, + Rcpp::IntegerVector const &idx, + Rcpp::IntegerVector const &at, + Function const &f, + bool na_pad) +{ const int OTYPE = Rcpp::traits::r_sexptype_traits::rtype; int n = x.size(); @@ -23,184 +24,269 @@ run(Rcpp::Vector const& x, Rcpp::Vector res(at.size() == 0 ? n : nn); IntegerVector b(2); - if (at.size() == 0) { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { + if (at.size() == 0) + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(i), lag(i), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() > 1 && lag.size() == 1) { + } + else if (k.size() > 1 && lag.size() == 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(i), lag(0), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 0 && lag.size() > 1) { + } + else if (k.size() == 0 && lag.size() > 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(i), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 0 && lag.size() == 1) { + } + else if (k.size() == 0 && lag.size() == 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(0), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && k(0) == n && lag.size() > 1) { + } + else if (k.size() == 1 && k(0) == n && lag.size() > 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(i), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && k(0) == n && lag.size() == 1) { + } + else if (k.size() == 1 && k(0) == n && lag.size() == 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(0), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && lag.size() > 1) { + } + else if (k.size() == 1 && lag.size() > 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(0), lag(i), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && lag.size() == 1) { + } + else if (k.size() == 1 && lag.size() == 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(0), lag(0), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } - - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - - for (int i = 0; i < n; i++) { + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(i), lag(i), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else { + } + else + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(i), lag(0), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { - } else if (k.size() == 0) { - if (lag.size() > 1) { - - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, n, lag(i), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else { + } + else + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, n, lag(0), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } - } else if (k.size() == 1) { - if (lag.size() > 1) { + } + else if (k.size() == 1) + { + if (lag.size() > 1) + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(0), lag(i), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); - } - } else { + } + else + { - for (int i = 0; i < n; i++) { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(0), lag(0), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } } } - } else { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { - - for (int i = 0; i < nn; i++) { + } + else + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { + + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(i), lag(i), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() > 1 && lag.size() == 1) { + } + else if (k.size() > 1 && lag.size() == 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(i), lag(0), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 0 && lag.size() > 1) { + } + else if (k.size() == 0 && lag.size() > 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, n, lag(i), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 0 && lag.size() == 1) { + } + else if (k.size() == 0 && lag.size() == 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, n, lag(0), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && lag.size() > 1) { + } + else if (k.size() == 1 && lag.size() > 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(0), lag(i), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else if (k.size() == 1 && lag.size() == 1) { + } + else if (k.size() == 1 && lag.size() == 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(0), lag(0), n, na_pad); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - - for (int i = 0; i < nn; i++) { + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(i), lag(i), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else { + } + else + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(i), lag(0), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } - } else if (k.size() == 0) { - if (lag.size() > 1) { + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), n, lag(i), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } - } else { + } + else + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), n, lag(0), n, na_pad, true); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } } - } else if (k.size() == 1) { - if (lag.size() > 1) { + } + else if (k.size() == 1) + { + if (lag.size() > 1) + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(0), lag(i), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); - } - } else { + } + else + { - for (int i = 0; i < nn; i++) { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(0), lag(0), n, na_pad, false); res(i) = (b.size() == 0) ? Rcpp::Vector::get_na() : apply::apply(x, b, f); } @@ -209,7 +295,6 @@ run(Rcpp::Vector const& x, } } - return res; } @@ -218,14 +303,15 @@ using RcppVec = Rcpp::Vector::rtype>; template Rcpp::Vector -runner_vec(Rcpp::Vector const& x, +runner_vec(Rcpp::Vector const &x, ftype fun, - Rcpp::IntegerVector const& k, - Rcpp::IntegerVector const& lag, - Rcpp::IntegerVector const& idx, - Rcpp::IntegerVector const& at, + Rcpp::IntegerVector const &k, + Rcpp::IntegerVector const &lag, + Rcpp::IntegerVector const &idx, + Rcpp::IntegerVector const &at, bool na_rm, - bool na_pad) { + bool na_pad) +{ int n = x.size(); int nn = at.size() == 0 ? x.size() : at.size(); @@ -236,273 +322,444 @@ runner_vec(Rcpp::Vector const& x, checks::check_idx(idx, n, var); checks::check_at(at); - Rcpp::Vector res(nn); + Rcpp::Vector res(nn); IntegerVector b(2); // Simple windows------- - if (at.size() == 0) { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { - for (int i = 0; i < n; i++) { + if (at.size() == 0) + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(i), lag(i), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() > 1 && lag.size() == 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() > 1 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(i), lag(0), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 0 && lag.size() > 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() == 0 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(i), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 0 && lag.size() == 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() == 0 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, n, lag(0), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 1 && lag.size() > 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() == 1 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(0), lag(i), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 1 && lag.size() == 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() == 1 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul(i, k(0), lag(0), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(i), lag(i), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < n; i++) { + } + else + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(i), lag(0), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - } else if (k.size() == 0) { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, n, lag(i), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < n; i++) { + } + else + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, n, lag(0), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - } else { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { + } + else + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(0), lag(i), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < n; i++) { + } + else + { + for (int i = 0; i < n; i++) + { b = utils::window_ul_dl(idx, i, k(0), lag(0), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } } } - } else { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(i), lag(i), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() > 1 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() > 1 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(i), lag(0), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 0 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 0 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, n, lag(i), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 0 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 0 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, n, lag(0), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 1 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 1 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(0), lag(i), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (k.size() == 1 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 1 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul(at(i) - 1, k(0), lag(0), n, na_pad); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(i), lag(i), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (lag(0) != 0){ - for (int i = 0; i < nn; i++) { + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(i), lag(0), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < nn; i++) { + } + else + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(i), 0, n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - } else if (k.size() == 0) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), n, lag(i), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (lag(0) != 0){ - for (int i = 0; i < nn; i++) { + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), n, lag(0), n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < nn; i++) { + } + else + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), n, 0, n, na_pad, true); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } } - } else if (k.size() == 1) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { + } + else if (k.size() == 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(0), lag(i), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else if (lag(0) != 0) { - for (int i = 0; i < nn; i++) { + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(0), lag(0), n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } - } else { - for (int i = 0; i < nn; i++) { + } + else + { + for (int i = 0; i < nn; i++) + { b = utils::window_ul_at(idx, at(i), k(0), 0, n, na_pad, false); - if (b.size() == 0) { + if (b.size() == 0) + { res(i) = Rcpp::Vector::get_na(); - } else { + } + else + { res(i) = fun(x, b(1), b(0), na_rm); } } @@ -511,45 +768,42 @@ runner_vec(Rcpp::Vector const& x, } } - return res; - } - //' Running sum //' //' Running sum in specified window of numeric vector. //' @inheritParams runner //' -//' @param x \code{numeric} vector which running function is calculated on +//' @param x `numeric` vector which running function is calculated on //' -//' @param k (\code{integer}` vector or single value)\cr -//' Denoting size of the running window. If \code{k} is a single value then window -//' size is constant for all elements, otherwise if \code{length(k) == length(x)} +//' @param k (`integer`` vector or single value)\cr +//' Denoting size of the running window. If `k` is a single value then window +//' size is constant for all elements, otherwise if `length(k) == length(x)` //' different window size for each element. //' -//' @param lag (\code{integer} vector or single value)\cr -//' Denoting window lag. If \code{lag} is a single value then window lag is constant -//' for all elements, otherwise if \code{length(lag) == length(x)} different window +//' @param lag (`integer` vector or single value)\cr +//' Denoting window lag. If `lag` is a single value then window lag is constant +//' for all elements, otherwise if `length(lag) == length(x)` different window //' size for each element. Negative value shifts window forward. //' -//' @param idx (\code{integer}, \code{Date}, \code{POSIXt})\cr +//' @param idx (`integer`, `Date`, `POSIXt`)\cr //' Optional integer vector containing sorted (ascending) index of observation. -//' By default \code{idx} is index incremented by one. User can provide index with -//' varying increment and with duplicated values. If specified then \code{k} and \code{lag} -//' are depending on \code{idx}. Length of \code{idx} have to be equal of length \code{x}. +//' By default `idx` is index incremented by one. User can provide index with +//' varying increment and with duplicated values. If specified then `k` and `lag` +//' are depending on `idx`. Length of `idx` have to be equal of length `x`. //' -//' @param at (\code{integer}, \code{Date}, \code{POSIXt}, \code{character} vector)\cr +//' @param at (`integer`, `Date`, `POSIXt`, `character` vector)\cr //' Vector of any size and any value defining output data points. Values of the //' vector defines the indexes which data is computed at. //' -//' @param na_rm \code{logical} single value (default \code{na_rm = TRUE}) - -//' if \code{TRUE} sum is calculating excluding \code{NA}. +//' @param na_rm `logical` single value (default `na_rm = TRUE`) - +//' if `TRUE` sum is calculating excluding `NA`. //' //' @inheritParams runner //' -//' @return sum \code{code} vector of length equals length of \code{x}. +//' @return sum `code` vector of length equals length of `x`. //' @examples //' set.seed(11) //' x1 <- rnorm(15) @@ -568,18 +822,21 @@ Rcpp::NumericVector sum_run( IntegerVector idx = IntegerVector(0), IntegerVector at = IntegerVector(0), bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cumsum(x, na_rm); - } else { + } + else + { return runner_vec<14>(x, aggr::calc_sum, k, lag, idx, at, na_rm, na_pad); } - } //' Running mean @@ -587,7 +844,7 @@ Rcpp::NumericVector sum_run( //' Running mean in specified window of numeric vector. //' @inheritParams sum_run //' @inheritParams runner -//' @return mean {numeric} vector of length equals length of \code{x}. +//' @return mean (`numeric`) vector of length equals length of `x`. //' @examples //' set.seed(11) //' x1 <- rnorm(15) @@ -606,15 +863,19 @@ NumericVector mean_run( IntegerVector idx = IntegerVector(0), IntegerVector at = IntegerVector(0), bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cummean(x, na_rm); - } else { + } + else + { return runner_vec<14>(x, aggr::calc_mean, k, lag, idx, at, na_rm, na_pad); } } @@ -622,11 +883,11 @@ NumericVector mean_run( //' Running maximum //' //' -//' \code{min_run} calculates running max on given \code{x} numeric vector, -//' specified \code{k} window size. +//' `min_run` calculates running max on given `x` numeric vector, +//' specified `k` window size. //' @inheritParams runner //' @inheritParams sum_run -//' @return max {numeric} vector of length equals length of \code{x}. +//' @return max (`numeric`) vector of length equals length of `x`. //' @examples //' set.seed(11) //' x1 <- sample( c(1,2,3), 15, replace=TRUE) @@ -645,15 +906,19 @@ NumericVector max_run( Rcpp::IntegerVector idx = IntegerVector(0), Rcpp::IntegerVector at = IntegerVector(0), bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cummax(x, na_rm); - } else { + } + else + { return runner_vec<14>(x, aggr::calc_max, k, lag, idx, at, na_rm, na_pad); } } @@ -661,10 +926,10 @@ NumericVector max_run( //' Running minimum //' //' -//' \code{min_run} calculates running min on given \code{x} numeric vector, specified \code{k} window size. +//' `min_run` calculates running min on given `x` numeric vector, specified `k` window size. //' @inheritParams runner //' @inheritParams sum_run -//' @return min {numeric} vector of length equals length of \code{x}. +//' @return min (`numeric`) vector of length equals length of `x`. //' @examples //' set.seed(11) //' x1 <- sample(c(1, 2, 3), 15, replace = TRUE) @@ -683,15 +948,19 @@ NumericVector min_run( IntegerVector idx = IntegerVector(0), IntegerVector at = IntegerVector(0), bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cummin(x, na_rm); - } else { + } + else + { return runner_vec<14>(x, aggr::calc_min, k, lag, idx, at, na_rm, na_pad); } } @@ -702,7 +971,7 @@ NumericVector min_run( //' @param x {any type} vector which running function is calculated on //' @inheritParams runner //' @inheritParams sum_run -//' @return streak [numeric] vector of length equals length of \code{x} containing +//' @return streak [numeric] vector of length equals length of `x` containing //' number of consecutive occurrences. //' @examples //' set.seed(11) @@ -722,37 +991,53 @@ IntegerVector streak_run( Rcpp::IntegerVector idx = IntegerVector(0), Rcpp::IntegerVector at = IntegerVector(0), bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { - switch (TYPEOF(x)) { - case INTSXP: return aggr::cumstreak(as(x), lag(0), na_rm); - case REALSXP: return aggr::cumstreak(as(x), lag(0), na_rm); - case STRSXP: return aggr::cumstreak(as(x), lag(0), na_rm); - case LGLSXP: return aggr::cumstreak(as(x), lag(0), na_rm); - default: { - stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); - } + at.size() == 0) + { + switch (TYPEOF(x)) + { + case INTSXP: + return aggr::cumstreak(as(x), lag(0), na_rm); + case REALSXP: + return aggr::cumstreak(as(x), lag(0), na_rm); + case STRSXP: + return aggr::cumstreak(as(x), lag(0), na_rm); + case LGLSXP: + return aggr::cumstreak(as(x), lag(0), na_rm); + default: + { + stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); } - } else { - switch (TYPEOF(x)) { - case INTSXP: return runner_vec<13>(as(x), - aggr::calc_streak_i, - k, lag, idx, at, na_rm, na_pad); - case REALSXP: return runner_vec<13>(as(x), - aggr::calc_streak_n, - k, lag, idx, at, na_rm, na_pad); - case STRSXP: return runner_vec<13>(as(x), - aggr::calc_streak_s, - k, lag, idx, at, na_rm, na_pad); - case LGLSXP: return runner_vec<13>(as(x), - aggr::calc_streak_l, - k, lag, idx, at, na_rm, na_pad); - default: { + } + } + else + { + switch (TYPEOF(x)) + { + case INTSXP: + return runner_vec<13>(as(x), + aggr::calc_streak_i, + k, lag, idx, at, na_rm, na_pad); + case REALSXP: + return runner_vec<13>(as(x), + aggr::calc_streak_n, + k, lag, idx, at, na_rm, na_pad); + case STRSXP: + return runner_vec<13>(as(x), + aggr::calc_streak_s, + k, lag, idx, at, na_rm, na_pad); + case LGLSXP: + return runner_vec<13>(as(x), + aggr::calc_streak_l, + k, lag, idx, at, na_rm, na_pad); + default: + { stop("Invalid data type - only integer, numeric, character, factor, date, logical, complex vectors are possible."); } } @@ -764,12 +1049,12 @@ IntegerVector streak_run( //' Running which //' //' -//' \code{min_run} calculates running which - returns index of element where \code{x == TRUE}. +//' `min_run` calculates running which - returns index of element where `x == TRUE`. //' @inheritParams runner //' @inheritParams sum_run -//' @param which \code{character} value "first" or "last" denoting if the first or last \code{TRUE} +//' @param which `character` value "first" or "last" denoting if the first or last `TRUE` //' index is returned from the window. -//' @return integer vector of indexes of the same length as \code{x}. +//' @return integer vector of indexes of the same length as `x`. //' @examples //' set.seed(11) //' x1 <- sample(c(1, 2, 3), 15, replace = TRUE) @@ -789,31 +1074,41 @@ Rcpp::IntegerVector which_run( IntegerVector at = IntegerVector(0), std::string which = "last", bool na_rm = true, - bool na_pad = false) { + bool na_pad = false) +{ - if (which != "last" && which != "first") { + if (which != "last" && which != "first") + { stop("which value should be either 'first' or 'last'"); } - if (which == "first") { + if (which == "first") + { if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cumwhichf(x, na_rm); - } else { + } + else + { return runner_vec<13>(x, aggr::calc_whichf, k, lag, idx, at, na_rm, na_pad); } - - } else { + } + else + { if (k.size() == 0 && lag.size() == 1 && lag(0) == 0 && idx.size() == 0 && - at.size() == 0) { + at.size() == 0) + { return aggr::cumwhichl(x, na_rm); - } else { + } + else + { return runner_vec<13>(x, aggr::calc_whichl, k, lag, idx, at, na_rm, na_pad); } } @@ -823,310 +1118,481 @@ Rcpp::IntegerVector which_run( template Rcpp::List - window_create( - Rcpp::Vector const& x, - Rcpp::IntegerVector const& k, - Rcpp::IntegerVector const& lag, - Rcpp::IntegerVector const& idx, - Rcpp::IntegerVector const& at, - bool na_pad) { +window_create( + Rcpp::Vector const &x, + Rcpp::IntegerVector const &k, + Rcpp::IntegerVector const &lag, + Rcpp::IntegerVector const &idx, + Rcpp::IntegerVector const &at, + bool na_pad) +{ - int n = x.size(); - int nn = at.size() == 0 ? x.size() : at.size(); - std::string var = at.size() == 0 ? "x" : "at"; + int n = x.size(); + int nn = at.size() == 0 ? x.size() : at.size(); + std::string var = at.size() == 0 ? "x" : "at"; - checks::check_k(k, nn, var); - checks::check_lag(lag, nn, var); - checks::check_idx(idx, n, var); - checks::check_at(at); + checks::check_k(k, nn, var); + checks::check_lag(lag, nn, var); + checks::check_idx(idx, n, var); + checks::check_at(at); - Rcpp::List res(nn); - IntegerVector b(2); + Rcpp::List res(nn); + IntegerVector b(2); - // Simple windows------- - if (at.size() == 0) { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, k(i), lag(i), n, na_pad); - if (b.size() == 0) { + // Simple windows------- + if (at.size() == 0) + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, k(i), lag(i), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() > 1 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, k(i), lag(0), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 0 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, n, lag(i), n, na_pad, true); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 0 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, n, lag(0), n, na_pad, true); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 1 && lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, k(0), lag(i), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 1 && lag.size() == 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul(i, k(0), lag(0), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, k(i), lag(i), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() > 1 && lag.size() == 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, k(i), lag(0), n, na_pad); - if (b.size() == 0) { + } + else + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, k(i), lag(0), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 0 && lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, n, lag(i), n, na_pad, true); - if (b.size() == 0) { + } + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, n, lag(i), n, na_pad, true); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 0 && lag.size() == 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, n, lag(0), n, na_pad, true); - if (b.size() == 0) { + } + else + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, n, lag(0), n, na_pad, true); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 1 && lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, k(0), lag(i), n, na_pad); - if (b.size() == 0) { + } + } + else + { + if (lag.size() > 1) + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, k(0), lag(i), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 1 && lag.size() == 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul(i, k(0), lag(0), n, na_pad); - if (b.size() == 0) { + } + else + { + for (int i = 0; i < n; i++) + { + b = utils::window_ul_dl(idx, i, k(0), lag(0), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } } - - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, k(i), lag(i), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, k(i), lag(0), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } + } + } + } + else + { + if (idx.size() == 0) + { + if (k.size() > 1 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, k(i), lag(i), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); } - } else if (k.size() == 0) { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, n, lag(i), n, na_pad, true); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, n, lag(0), n, na_pad, true); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); } - } else { - if (lag.size() > 1) { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, k(0), lag(i), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else { - for (int i = 0; i < n; i++) { - b = utils::window_ul_dl(idx, i, k(0), lag(0), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } + } + } + else if (k.size() > 1 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, k(i), lag(0), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); } } } - } else { - if (idx.size() == 0) { - if (k.size() > 1 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, k(i), lag(i), n, na_pad); - if (b.size() == 0) { + else if (k.size() == 0 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, n, lag(i), n, na_pad, true); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 0 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, n, lag(0), n, na_pad, true); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 1 && lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, k(0), lag(i), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + else if (k.size() == 1 && lag.size() == 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul(at(i) - 1, k(0), lag(0), n, na_pad); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); + } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); + } + } + } + } + else + { + if (k.size() > 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(i), lag(i), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() > 1 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, k(i), lag(0), n, na_pad); - if (b.size() == 0) { + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(i), lag(0), n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 0 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, n, lag(i), n, na_pad, true); - if (b.size() == 0) { + } + else + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(i), 0, n, na_pad, false); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 0 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, n, lag(0), n, na_pad, true); - if (b.size() == 0) { + } + } + else if (k.size() == 0) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), n, lag(i), n, na_pad, true); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 1 && lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, k(0), lag(i), n, na_pad); - if (b.size() == 0) { + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), n, lag(0), n, na_pad, true); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 1 && lag.size() == 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul(at(i) - 1, k(0), lag(0), n, na_pad); - if (b.size() == 0) { + } + else + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), n, 0, n, na_pad, true); + if (b.size() == 0) + { res(i) = Rcpp::Vector(0); - } else { + } + else + { res(i) = listfuns::get_window(x, b(1), b(0)); } } } - - } else { - if (k.size() > 1) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(i), lag(i), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else if (lag(0) != 0){ - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(i), lag(0), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + } + else if (k.size() == 1) + { + if (lag.size() > 1) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(0), lag(i), n, na_pad, false); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); } - } else { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(i), 0, n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 0) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), n, lag(i), n, na_pad, true); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else if (lag(0) != 0){ - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), n, lag(0), n, na_pad, true); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + } + else if (lag(0) != 0) + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(0), lag(0), n, na_pad, false); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); } - } else { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), n, 0, n, na_pad, true); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); } } - } else if (k.size() == 1) { - if (lag.size() > 1) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(0), lag(i), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } - } - } else if (lag(0) != 0) { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(0), lag(0), n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + } + else + { + for (int i = 0; i < nn; i++) + { + b = utils::window_ul_at(idx, at(i), k(0), 0, n, na_pad, false); + if (b.size() == 0) + { + res(i) = Rcpp::Vector(0); } - } else { - for (int i = 0; i < nn; i++) { - b = utils::window_ul_at(idx, at(i), k(0), 0, n, na_pad, false); - if (b.size() == 0) { - res(i) = Rcpp::Vector(0); - } else { - res(i) = listfuns::get_window(x, b(1), b(0)); - } + else + { + res(i) = listfuns::get_window(x, b(1), b(0)); } } } } } - - return res; - } + return res; +} + //' List of running windows //' -//' Creates \code{list} of windows with given arguments settings. -//' Length of output \code{list} is equal +//' Creates `list` of windows with given arguments settings. +//' Length of output `list` is equal //' @inheritParams runner //' @return list of vectors (windows). Length of list is the same as -//' \code{length(x)} or \code{length(at)} if specified, and length of each -//' window is defined by \code{k} (unless window is out of range). +//' `length(x)` or `length(at)` if specified, and length of each +//' window is defined by `k` (unless window is out of range). //' @examples //' window_run(1:10, k = 3, lag = -1) //' window_run(letters[1:10], k = c(1, 2, 2, 4, 5, 5, 5, 5, 5, 5)) @@ -1137,14 +1603,21 @@ SEXP window_run(SEXP x, IntegerVector lag = IntegerVector(1), IntegerVector idx = IntegerVector(0), IntegerVector at = IntegerVector(0), - bool na_pad = false) { - - switch (TYPEOF(x)) { - case INTSXP: return window_create(as(x), k, lag, idx, at, na_pad); - case REALSXP: return window_create(as(x), k, lag, idx, at, na_pad); - case STRSXP: return window_create(as(x), k, lag, idx, at, na_pad); - case LGLSXP: return window_create(as(x), k, lag, idx, at, na_pad); - default: { + bool na_pad = false) +{ + + switch (TYPEOF(x)) + { + case INTSXP: + return window_create(as(x), k, lag, idx, at, na_pad); + case REALSXP: + return window_create(as(x), k, lag, idx, at, na_pad); + case STRSXP: + return window_create(as(x), k, lag, idx, at, na_pad); + case LGLSXP: + return window_create(as(x), k, lag, idx, at, na_pad); + default: + { stop("Invalid 'x' type - only integer, numeric, character, factor, date and logical vectors are possible."); } } diff --git a/vignettes/apply_any_r_function.Rmd b/vignettes/apply_any_r_function.Rmd index 8f76042..856e921 100644 --- a/vignettes/apply_any_r_function.Rmd +++ b/vignettes/apply_any_r_function.Rmd @@ -102,7 +102,7 @@ idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) # summarize - mean runner::runner( - x = idx, + x = idx, k = 5, # 5-days window lag = 1, idx = idx, @@ -112,7 +112,7 @@ runner::runner( # use Date or datetime sequences runner::runner( - x = idx, + x = idx, k = "5 days", # 5-days window lag = 1, idx = Sys.Date() + idx, @@ -121,7 +121,7 @@ runner::runner( # obtain window from above illustration runner::runner( - x = idx, + x = idx, k = "5 days", lag = 1, idx = Sys.Date() + idx @@ -142,7 +142,7 @@ idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) # summary runner::runner( - x = 1:15, + x = 1:15, k = 5, lag = 1, idx = idx, @@ -152,7 +152,7 @@ runner::runner( # full window runner::runner( - x = idx, + x = idx, k = 5, lag = 1, idx = idx, @@ -206,16 +206,16 @@ Both `k` and `lag` can be of `length(.) == 1`, `length(.) == length(x)` or ```{r eval=FALSE} # summarizing - concatenating runner::runner( - x = 1:10, - lag = c(-1, 2, -1, -2, 0, 0, 5, -5, -2, -3), - k = c(0, 1, 1, 1, 1, 5, 5, 5, 5, 5), + x = 1:10, + lag = c(-1, 2, -1, -2, 0, 0, 5, -5, -2, -3), + k = c(0, 1, 1, 1, 1, 5, 5, 5, 5, 5), f = paste, collapse = "," ) # full window runner::runner( - x = 1:10, + x = 1:10, lag = 1, k = c(1, 1, 1, 1, 1, 5, 5, 5, 5, 5) ) @@ -224,13 +224,15 @@ runner::runner( idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner::runner( - x = 1:15, - lag = sample(c("-2 days", "-1 days", "1 days", "2 days"), - size = 15, - replace = TRUE), - k = sample(c("5 days", "10 days", "15 days"), - size = 15, - replace = TRUE), + x = 1:15, + lag = sample(c("-2 days", "-1 days", "1 days", "2 days"), + size = 15, + replace = TRUE + ), + k = sample(c("5 days", "10 days", "15 days"), + size = 15, + replace = TRUE + ), idx = Sys.Date() + idx, f = function(x) mean(x) ) @@ -253,10 +255,10 @@ matching `idx`. idx <- c(4, 6, 7, 13, 17, 18, 18, 21, 27, 31, 37, 42, 44, 47, 48) runner::runner( - x = 1:15, - k = 5, - lag = 1, - idx = idx, + x = 1:15, + k = 5, + lag = 1, + idx = idx, at = c(4, 18, 48, 51), na_pad = TRUE, f = function(x) mean(x) @@ -274,7 +276,7 @@ parameter adapt with increasing number of observation. x <- cumsum(rnorm(40)) y <- 3 * x + rnorm(40) date <- Sys.Date() + cumsum(sample(1:3, 40, replace = TRUE)) # unequaly spaced time series -group <- rep(c("a", "b"), 20) +group <- rep(c("a", "b"), 20) df <- data.frame(date, group, y, x) @@ -313,7 +315,6 @@ library(ggplot2) summ %>% ggplot(aes(x = date, y = cumulative_mse, group = group, color = group)) + geom_line() - ``` When user executes multiple `runner` calls in `dplyr` mutate, one can also use @@ -329,26 +330,22 @@ df %>% cumulative_mse = runner( x = ., f = function(x) { - mean((residuals(lm(y ~ x, data = x))) ^ 2) + mean((residuals(lm(y ~ x, data = x)))^2) } ), - intercept = runner( x = ., f = function(x) { coefficients(lm(y ~ x, data = x))[1] } ), - slope = runner( x = ., f = function(x) { coefficients(lm(y ~ x, data = x))[2] } - ) + ) ) - - ``` ### Parallel mode diff --git a/vignettes/built-in_functions.Rmd b/vignettes/built-in_functions.Rmd index ec27360..991fb36 100644 --- a/vignettes/built-in_functions.Rmd +++ b/vignettes/built-in_functions.Rmd @@ -37,9 +37,10 @@ x <- c(1, -5, 1, -3, NA, NA, NA, 1, -1, NA, -2, 3) data.frame( x, - default = min_run(x, na_rm = TRUE), + default = min_run(x, na_rm = TRUE), k_5 = min_run(x, k = 5, na_rm = TRUE), - narm_f = min_run(x, na_rm = FALSE)) + narm_f = min_run(x, na_rm = FALSE) +) ``` In above example constant `k = 5` has been used which means that for each element, @@ -54,8 +55,10 @@ Illustration below shows two sums calculated in 5-days window span. In both case ```{r idx_run_example, echo=TRUE} x <- c(-0.5910, 0.0266, -1.5166, -1.3627, 1.1785, -0.9342, 1.3236, 0.6249) -idx <- as.Date(c("1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", - "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19")) +idx <- as.Date(c( + "1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", + "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19" +)) sum_run(x, k = 5, idx = idx) ``` @@ -65,8 +68,10 @@ Specifying `lag` argument shift of the window by number of elements or time peri ```{r lag_run_example, echo=TRUE} x <- c(-0.5910, 0.0266, -1.5166, -1.3627, 1.1785, -0.9342, 1.3236, 0.6249) -idx <- as.Date(c("1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", - "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19")) +idx <- as.Date(c( + "1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", + "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19" +)) sum_run(x, k = 5, lag = 2, idx = idx) ``` @@ -86,10 +91,11 @@ Visualization also supported with corresponding R code. ```{r} x <- c("A", "B", "A", "A", "B", "B", "B", NA, "B", "B", "A", "B") data.frame( - x, + x, s0 = streak_run(x), s1 = streak_run(x, k = 4, na_rm = FALSE), - s2 = streak_run(x, k = 4)) + s2 = streak_run(x, k = 4) +) ``` Streak is often used in sports to count number of wins or loses of the team/player. @@ -99,14 +105,17 @@ number of elements or time periods (if `idx` is specified). ```{r} x <- c("W", "W", "L", "L", "L", "W", "L", "L") -idx <- as.Date(c("2019-01-03", "2019-01-06", "2019-01-09", "2019-01-12", - "2019-01-13", "2019-01-16", "2019-01-17", "2019-01-19")) +idx <- as.Date(c( + "2019-01-03", "2019-01-06", "2019-01-09", "2019-01-12", + "2019-01-13", "2019-01-16", "2019-01-17", "2019-01-19" +)) data.frame( idx, x, streak_5d = streak_run(x, k = 5, idx = idx), - streak_5d_lag = streak_run(x, k = 5, lag = 1, idx = idx)) + streak_5d_lag = streak_run(x, k = 5, lag = 1, idx = idx) +) ``` ## Utility functions @@ -120,8 +129,10 @@ time periods (if `idx` is specified). ```{r} x <- c(-0.5910, 0.0266, -1.5166, -1.3627, 1.1785, -0.9342, 1.3236, 0.6249) -idx <- as.Date(c("1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", - "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19")) +idx <- as.Date(c( + "1970-01-03", "1970-01-06", "1970-01-09", "1970-01-12", + "1970-01-13", "1970-01-16", "1970-01-17", "1970-01-19" +)) lag_run(x, lag = 3, idx = idx) ``` @@ -143,10 +154,11 @@ windows provided in this functionality. ```{r} x <- c(NA, NA, "b", "b", "a", NA, NA, "a", "b", NA, "a", "b") -data.frame(x, - f1 = fill_run(x), - f2 = fill_run(x,run_for_first = TRUE), - f3 = fill_run(x, only_within = TRUE)) +data.frame(x, + f1 = fill_run(x), + f2 = fill_run(x, run_for_first = TRUE), + f3 = fill_run(x, only_within = TRUE) +) ``` ### Running which @@ -165,11 +177,11 @@ element of unknown value - could be `TRUE` or `FALSE`). ```{r} x <- c(T, T, T, F, NA, T, F, NA, T, F, T, F) data.frame( - x, + x, s0 = which_run(x, which = "first"), s1 = which_run(x, na_rm = FALSE, k = 5, which = "first"), - s2 = which_run(x, k = 5, which = "last")) - + s2 = which_run(x, k = 5, which = "last") +) ``` diff --git a/vignettes/runner_examples.Rmd b/vignettes/runner_examples.Rmd index c7abcd7..1f72e67 100644 --- a/vignettes/runner_examples.Rmd +++ b/vignettes/runner_examples.Rmd @@ -22,9 +22,9 @@ x <- sample(letters, 20, replace = TRUE) date <- Sys.Date() + cumsum(sample(1:5, 20, replace = TRUE)) # unequally spaced time series runner( - x, + x, k = "7 days", - idx = date, + idx = date, f = function(x) length(unique(x)) ) ``` @@ -38,9 +38,9 @@ x <- cumsum(rnorm(20)) date <- Sys.Date() + cumsum(sample(1:5, 20, replace = TRUE)) # unequaly spaced time series runner( - x, - k = "week", - idx = date, + x, + k = "week", + idx = date, f = function(x) mean(x, trim = 0.05) ) ``` @@ -53,8 +53,8 @@ library(runner) # sample data x <- cumsum(rnorm(20)) data <- data.frame( - date = Sys.Date() + cumsum(sample(1:3, 20, replace = TRUE)), # unequally spaced time series, - y = 3 * x + rnorm(20), + date = Sys.Date() + cumsum(sample(1:3, 20, replace = TRUE)), # unequally spaced time series, + y = 3 * x + rnorm(20), x = cumsum(rnorm(20)) ) @@ -88,9 +88,12 @@ library(dplyr) set.seed(3737) df <- data.frame( user_id = c(rep(27, 7), rep(11, 7)), - date = as.Date(rep(c('2016-01-01', '2016-01-03', '2016-01-05', '2016-01-07', - '2016-01-10', '2016-01-14', '2016-01-16'), 2)), - value = round(rnorm(14, 15, 5), 1)) + date = as.Date(rep(c( + "2016-01-01", "2016-01-03", "2016-01-05", "2016-01-07", + "2016-01-10", "2016-01-14", "2016-01-16" + ), 2)), + value = round(rnorm(14, 15, 5), 1) +) df %>% group_by(user_id) %>% @@ -129,14 +132,16 @@ df <- read.table(text = " user_id date category df %>% group_by(user_id) %>% mutate( - distinct_7 = runner(category, - k = "7 days", - idx = as.Date(date), - f = function(x) length(unique(x))), - distinct_14 = runner(category, - k = "14 days", - idx = as.Date(date), - f = function(x) length(unique(x))) + distinct_7 = runner(category, + k = "7 days", + idx = as.Date(date), + f = function(x) length(unique(x)) + ), + distinct_14 = runner(category, + k = "14 days", + idx = as.Date(date), + f = function(x) length(unique(x)) + ) ) ``` @@ -148,7 +153,7 @@ library(dplyr) x <- cumsum(rnorm(20)) y <- 3 * x + rnorm(20) date <- Sys.Date() + cumsum(sample(1:3, 20, replace = TRUE)) # unequaly spaced time series -group <- rep(c("a", "b"), each = 10) +group <- rep(c("a", "b"), each = 10) data.frame(date, group, y, x) %>% @@ -156,13 +161,13 @@ data.frame(date, group, y, x) %>% run_by(idx = "date", k = "5 days") %>% mutate( alpha_5 = runner( - x = ., + x = ., f = function(x) { coefficients(lm(x ~ y, x))[1] } ), beta_5 = runner( - x = ., + x = ., f = function(x) { coefficients(lm(x ~ y, x))[1] } @@ -176,34 +181,38 @@ data.frame(date, group, y, x) %>% library(runner) library(dplyr) -Date <- seq(from = as.Date("2014-01-01"), - to = as.Date("2019-12-31"), - by = 'day') +Date <- seq( + from = as.Date("2014-01-01"), + to = as.Date("2019-12-31"), + by = "day" +) market_return <- c(rnorm(2191)) AAPL <- data.frame( - Company.name = "AAPL", - Date = Date, + Company.name = "AAPL", + Date = Date, market_return = market_return ) MSFT <- data.frame( - Company.name = "MSFT", + Company.name = "MSFT", Date = Date, market_return = market_return ) df <- rbind(AAPL, MSFT) df$stock_return <- c(rnorm(4382)) -df <- df[order(df$Date),] +df <- df[order(df$Date), ] df2 <- data.frame( - Company.name2 = c(replicate(450, "AAPL"), replicate(450, "MSFT")), + Company.name2 = c(replicate(450, "AAPL"), replicate(450, "MSFT")), Event_date = sample( - seq(as.Date('2015/01/01'), - as.Date('2019/12/31'), - by = "day"), - size = 900) + seq(as.Date("2015/01/01"), + as.Date("2019/12/31"), + by = "day" + ), + size = 900 + ) ) @@ -211,8 +220,8 @@ df2 %>% group_by(Company.name2) %>% mutate( intercept = runner( - x = df[df$Company.name == Company.name2[1], ], - k = "180 days", + x = df[df$Company.name == Company.name2[1], ], + k = "180 days", lag = "5 days", idx = df$Date[df$Company.name == Company.name2[1]], at = Event_date, @@ -223,8 +232,8 @@ df2 %>% } ), slope = runner( - x = df[df$Company.name == Company.name2[1], ], - k = "180 days", + x = df[df$Company.name == Company.name2[1], ], + k = "180 days", lag = "5 days", idx = df$Date[df$Company.name == Company.name2[1]], at = Event_date,