Showing preview only (375K chars total). Download the full file or copy to clipboard to get everything.
Repository: HenrikBengtsson/future.apply
Branch: develop
Commit: ad7ae16630ac
Files: 139
Total size: 342.5 KB
Directory structure:
gitextract_3rrfdcst/
├── .Rbuildignore
├── .Rinstignore
├── .github/
│ ├── .gitignore
│ ├── ISSUE_TEMPLATE/
│ │ ├── bug_report.md
│ │ ├── config.yml
│ │ └── feature_request.md
│ └── workflows/
│ ├── R-CMD-check.yaml
│ ├── rhub.yaml
│ └── test-coverage.yaml
├── .gitignore
├── CONDUCT.md
├── CONTRIBUTING.md
├── DESCRIPTION
├── Makefile
├── NAMESPACE
├── NEWS.md
├── R/
│ ├── 000.import.R
│ ├── 001.bquote.R
│ ├── 001.import_future_functions.R
│ ├── chunking.R
│ ├── condition-handlers.R
│ ├── fold.R
│ ├── future.apply-package.R
│ ├── future_Filter.R
│ ├── future_Map.R
│ ├── future_apply.R
│ ├── future_by.R
│ ├── future_eapply.R
│ ├── future_kernapply.R
│ ├── future_lapply.R
│ ├── future_mapply.R
│ ├── future_replicate.R
│ ├── future_sapply.R
│ ├── future_tapply.R
│ ├── future_vapply.R
│ ├── future_xapply.R
│ ├── globals.R
│ ├── makeChunks.R
│ ├── options.R
│ ├── testme.R
│ ├── utils,conditions.R
│ ├── utils-debug.R
│ ├── utils.R
│ └── zzz.R
├── README.md
├── cran-comments.md
├── incl/
│ ├── OVERVIEW.md
│ ├── future_Filter.R
│ ├── future_apply.R
│ ├── future_by.R
│ ├── future_lapply.R
│ ├── future_mapply.R
│ ├── make_rng_seeds.R
│ └── random_seed_utils.R
├── inst/
│ ├── CITATION
│ ├── WORDLIST
│ └── testme/
│ ├── _epilogue/
│ │ ├── 001.undo-future.R
│ │ ├── 002.undo-state.R
│ │ ├── 090.gc.R
│ │ ├── 099.session_info.R
│ │ ├── 995.detritus-connections.R
│ │ └── 999.detritus-files.R
│ ├── _prologue/
│ │ ├── 001.load.R
│ │ ├── 002.record-state.R
│ │ ├── 030.imports.R
│ │ ├── 050.utils.R
│ │ ├── 090.context.R
│ │ ├── 090.options.R
│ │ ├── 091.envvars.R
│ │ ├── 099.future-setup.R
│ │ └── 995.detrius-connections.R
│ ├── deploy.R
│ ├── run.R
│ ├── test-fold.R
│ ├── test-future_Filter.R
│ ├── test-future_apply.R
│ ├── test-future_by.R
│ ├── test-future_eapply.R
│ ├── test-future_kernapply.R
│ ├── test-future_lapply,RNG.R
│ ├── test-future_lapply,globals.R
│ ├── test-future_lapply.R
│ ├── test-future_mapply,globals.R
│ ├── test-future_mapply.R
│ ├── test-future_replicate.R
│ ├── test-future_sapply.R
│ ├── test-future_tapply.R
│ ├── test-future_vapply.R
│ ├── test-globals,tricky2.R
│ ├── test-globals,tricky_recursive.R
│ ├── test-options,nested.R
│ ├── test-rng.R
│ ├── test-stdout.R
│ └── test-utils.R
├── man/
│ ├── fold.Rd
│ ├── future.apply.Rd
│ ├── future.apply.options.Rd
│ ├── future_apply.Rd
│ ├── future_by.Rd
│ ├── future_kernapply.Rd
│ ├── future_lapply.Rd
│ ├── future_mapply.Rd
│ └── makeChunks.Rd
├── pkgdown/
│ ├── _pkgdown.yml
│ └── _pkgdown.yml.rsp
├── revdep/
│ ├── README.md
│ ├── cran.md
│ ├── failures.md
│ ├── notes.md
│ ├── problems.md
│ ├── revdepcheck.Renviron
│ ├── revdepcheck.init.sh
│ ├── run.R
│ ├── run.pbs
│ └── run.sge
├── tests/
│ ├── incl/
│ │ ├── end.R
│ │ └── start,load-only.R
│ ├── test-fold.R
│ ├── test-future_Filter.R
│ ├── test-future_apply.R
│ ├── test-future_by.R
│ ├── test-future_eapply.R
│ ├── test-future_kernapply.R
│ ├── test-future_lapply,RNG.R
│ ├── test-future_lapply,globals.R
│ ├── test-future_lapply.R
│ ├── test-future_mapply,globals.R
│ ├── test-future_mapply.R
│ ├── test-future_replicate.R
│ ├── test-future_sapply.R
│ ├── test-future_tapply.R
│ ├── test-future_vapply.R
│ ├── test-globals,tricky2.R
│ ├── test-globals,tricky_recursive.R
│ ├── test-options,nested.R
│ ├── test-rng.R
│ ├── test-stdout.R
│ └── test-utils.R
└── vignettes/
└── future.apply-1-overview.md.rsp
================================================
FILE CONTENTS
================================================
================================================
FILE: .Rbuildignore
================================================
#----------------------------
# Git and SVN related
#----------------------------
^.svn
^.git
^.make
^INSTALL[.]md$
^OVERVIEW[.]md$
^README[.]md$
^CONDUCT[.]md$
^CONTRIBUTING[.]md$
#----------------------------
# devtools
#----------------------------
^revdep
#----------------------------
# Travis-CI et al.
#----------------------------
^[.]travis[.]yml$
^travis-tool[.]sh$
^pkg-build[.]sh$
^appveyor[.]yml$
^covr-utils.R$
^[.]covr[.]R$
^[.]covr[.]rds$
#----------------------------
# R related
#----------------------------
Rplots.pdf$
^cran-comments[.].*$
^vignettes/.*[.](pdf|PDF)$
^vignettes/.*[.](r|R)$
^vignettes/[.]install_extras$
^Makefile$
^incl
^NAMESPACE,.*[.]txt$
^nohup.*$
^[.]R
^[.]benchmark
^[.]devel
^[.]test
^[.]check
^.*[.]tar[.]gz$
#----------------------------
# Package specific
#----------------------------
^[.]BatchJobs[.]R$
^[.]future
#----------------------------
# Miscellaneous
#----------------------------
^.ghi
^.issues
^.local
^docs
^pkgdown
[.]Rdump
^\.github$
================================================
FILE: .Rinstignore
================================================
# Certain LaTeX files (e.g. bib, bst, sty) must be part of the build
# such that they are available for R CMD check. These are excluded
# from the install using .Rinstignore in the top-level directory
# such as this one.
doc/.*[.](bib|bst|sty)$
================================================
FILE: .github/.gitignore
================================================
*.html
================================================
FILE: .github/ISSUE_TEMPLATE/bug_report.md
================================================
---
name: Bug report
about: Create a report to help us improve (Please use future's 'Discussions' for Q&A)
title: ''
labels: ''
assignees: ''
---
(Please use <https://github.com/futureverse/future/discussions> for Q&A)
**Describe the bug**
A clear and concise description of what the bug is.
**Reproduce example**
A reproducible example using R code.
**Expected behavior**
A clear and concise description of what you expected to happen.
**Session information**
Please share your session information, e.g.
```r
> sessionInfo()
```
================================================
FILE: .github/ISSUE_TEMPLATE/config.yml
================================================
lank_issues_enabled: true
contact_links:
- name: Support & Discussions
url: https://github.com/futureverse/future/discussions/
about: Got a question? Something is not working? Want to share an idea?
================================================
FILE: .github/ISSUE_TEMPLATE/feature_request.md
================================================
---
name: Feature request
about: Suggest an idea for this project (Please use future's 'Discussions' for Q&A)
title: ''
labels: ''
assignees: ''
---
(Please use <https://github.com/futureverse/future/discussions> for Q&A)
**Wish or feature request**
A clear and concise description of what the problem is. For example, I would like to be able to ...
================================================
FILE: .github/workflows/R-CMD-check.yaml
================================================
on: [push, pull_request]
name: R-CMD-check
jobs:
R-CMD-check:
if: "! contains(github.event.head_commit.message, '[ci skip]')"
timeout-minutes: 30
runs-on: ${{ matrix.config.os }}
name: ${{ matrix.config.os }} (${{ matrix.config.r }}) ${{ matrix.config.label }}
strategy:
fail-fast: false
matrix:
config:
- {os: windows-latest, r: 'devel' }
- {os: windows-latest, r: 'release' }
- {os: windows-latest, r: 'oldrel' }
- {os: macOS-latest, r: 'devel' }
- {os: macOS-latest, r: 'release' }
- {os: macOS-latest, r: 'oldrel' }
- {os: ubuntu-latest, r: 'devel', strict: true, label: 'strict' }
- {os: ubuntu-latest, r: 'release' }
- {os: ubuntu-latest, r: 'oldrel' }
- {os: ubuntu-latest, r: 'oldrel-1' }
- {os: ubuntu-latest, r: 'oldrel-2' }
- {os: ubuntu-latest, r: '4.0' }
- {os: ubuntu-latest, r: 'release' , language: ko, label: ko }
- {os: ubuntu-latest, r: 'release' , globals_keepWhere: true, label: 'keepWhere' }
- {os: ubuntu-latest, r: 'release' , globals_keepWhere: false, label: '!keepWhere' }
- {os: windows-latest, r: 'devel', future_version: develop, label: 'w/ future-develop' }
- {os: ubuntu-latest, r: 'release', future_version: develop, label: 'w/ future-develop' }
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
R_KEEP_PKG_SOURCE: yes
R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
## Test in other locale (optional)
LANGUAGE: ${{ matrix.config.language }}
## R CMD check
_R_CHECK_CRAN_INCOMING_: false
_R_CHECK_MATRIX_DATA_: true
_R_CHECK_SUGGESTS_ONLY_: true
_R_CHECK_THINGS_IN_TEMP_DIR_: true
## Specific to 'rcmdcheck'
RCMDCHECK_ERROR_ON: note
## Specific to futures
R_FUTURE_RNG_ONMISUSE: error
R_FUTURE_GLOBALS_KEEPWHERE: ${{ matrix.config.globals_keepWhere }}
R_FUTURE_VERSION: ${{ matrix.config.future_version }}
R_GLOBALS_VERSION: ${{ matrix.config.globals_version }}
steps:
- uses: actions/checkout@v4
- 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
- name: Install package itself (special case)
run: |
install.packages(".", repos = NULL, type = "source") ## needed by parallel workers
shell: Rscript {0}
- name: Test with specific future version?
run: |
globals_version <- Sys.getenv("R_GLOBALS_VERSION")
if (nzchar(globals_version)) {
install.packages("remotes")
remotes::install_github("futureverse/future", ref=globals_version)
}
future_version <- Sys.getenv("R_FUTURE_VERSION")
if (nzchar(future_version)) {
install.packages("remotes")
remotes::install_github("futureverse/future", ref=future_version)
}
shell: Rscript {0}
- name: Session info
run: |
options(width = 100)
parallelly::availableCores(which = "all")
sapply(c(physical_cores = FALSE, logical_cores = TRUE), parallel::detectCores)
if (require(RhpcBLASctl, quietly=TRUE)) c(get_num_procs = get_num_procs(), get_num_cores = get_num_cores(), blas_get_num_procs = blas_get_num_procs(), omp_get_num_procs = omp_get_num_procs(), omp_get_max_threads = omp_get_max_threads())
capabilities()
pkgs <- installed.packages()[, "Package"]
sessioninfo::session_info(pkgs, include_base = TRUE)
## Verify LANGUAGE settings by generating a translatable error
cat(sprintf("LANGUAGE=%s\n", sQuote(Sys.getenv("LANGUAGE"))))
cat(sprintf("locales: %s\n", sQuote(Sys.getlocale())))
tryCatch(log("a"), error = conditionMessage)
shell: Rscript {0}
- name: Check
run: |
if ("${{ matrix.config.strict }}" == "true") {
Sys.setenv(NOT_CRAN = "true")
Sys.setenv(R_FUTURE_GLOBALENV_ONMISUSE = "error")
Sys.setenv(R_FUTURE_RNG_ONMISUSE = "error")
Sys.setenv(R_FUTURE_FUTURE_EARLYSIGNAL = "defunct")
Sys.setenv(R_FUTURE_FUTURE_LOCAL = "defunct")
Sys.setenv(R_FUTURE_FUTURE_GC = "defunct")
Sys.setenv(R_FUTURE_PLAN_EARLYSIGNAL = "defunct")
Sys.setenv(R_FUTURE_RESOLVED_RUN = "defunct")
}
if (nzchar(Sys.getenv("R_FUTURE_PLAN"))) Sys.setenv(RCMDCHECK_ERROR_ON = "error")
rcmdcheck::rcmdcheck(
args = c("--no-manual", "--as-cran"),
check_dir = "check"
)
shell: Rscript {0}
- name: Upload check results
if: failure()
uses: actions/upload-artifact@v4
with:
name: ${{ runner.os }}-r${{ matrix.config.r }}-results
path: check
================================================
FILE: .github/workflows/rhub.yaml
================================================
# R-hub's generic GitHub Actions workflow file. It's canonical location is at
# https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml
# You can update this file to a newer version using the rhub2 package:
#
# rhub::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/actions/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/actions/checkout@v1
- uses: r-hub/actions/platform-info@v1
with:
token: ${{ secrets.RHUB_TOKEN }}
job-config: ${{ matrix.config.job-config }}
- uses: r-hub/actions/setup-deps@v1
with:
token: ${{ secrets.RHUB_TOKEN }}
job-config: ${{ matrix.config.job-config }}
- uses: r-hub/actions/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/actions/checkout@v1
- uses: r-hub/actions/setup-r@v1
with:
job-config: ${{ matrix.config.job-config }}
token: ${{ secrets.RHUB_TOKEN }}
- uses: r-hub/actions/platform-info@v1
with:
token: ${{ secrets.RHUB_TOKEN }}
job-config: ${{ matrix.config.job-config }}
- uses: r-hub/actions/setup-deps@v1
with:
job-config: ${{ matrix.config.job-config }}
token: ${{ secrets.RHUB_TOKEN }}
- uses: r-hub/actions/run-check@v1
with:
job-config: ${{ matrix.config.job-config }}
token: ${{ secrets.RHUB_TOKEN }}
================================================
FILE: .github/workflows/test-coverage.yaml
================================================
on:
workflow_dispatch: # Enables manual triggering
name: test-coverage.yaml
permissions: read-all
jobs:
test-coverage:
runs-on: ubuntu-latest
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
steps:
- uses: actions/checkout@v4
- name: Assert CODECOV_TOKEN is set
run: |
if [[ -z "${{secrets.CODECOV_TOKEN}}" ]]; then
>&2 echo "::error::ERROR: 'secrets.CODECOV_TOKEN' not set"
exit 1
fi
- uses: r-lib/actions/setup-r@v2
with:
use-public-rspm: true
- uses: r-lib/actions/setup-r-dependencies@v2
with:
extra-packages: any::covr, any::xml2, any::remotes
needs: coverage
- name: Install itself
run: |
install.packages(".", repos = NULL, type = "source")
remotes::install_github("futureverse/globals", ref = "develop")
remotes::install_github("futureverse/future", ref = "develop")
shell: Rscript {0}
- name: Test coverage
run: |
cov <- covr::package_coverage(
quiet = FALSE,
clean = FALSE,
install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
)
print(cov)
covr::to_cobertura(cov)
shell: Rscript {0}
- uses: codecov/codecov-action@v4
with:
fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }}
file: ./cobertura.xml
plugin: noop
disable_search: true
token: ${{ secrets.CODECOV_TOKEN }}
- name: Upload test results
if: failure()
uses: actions/upload-artifact@v4
with:
name: coverage-test-failures
path: ${{ runner.temp }}/package
================================================
FILE: .gitignore
================================================
.Rhistory
*~
**/*~
.R
.benchmark
.check
.devel
.test
*.o
*.dll
*.Rout
.RData
*.Rproj*
*.swp
.covr.rds
.future
.ghi
.issues
.make
.local
revdep/data.sqlite
revdep/cache
revdep/checks
revdep/library
docs/
.Rdump
================================================
FILE: CONDUCT.md
================================================
# Contributor Covenant Code of Conduct
## Our Pledge
In the interest of fostering an open and welcoming environment, we as
contributors and maintainers pledge to making participation in our project and
our community a harassment-free experience for everyone, regardless of age, body
size, disability, ethnicity, gender identity and expression, level of experience,
nationality, personal appearance, race, religion, or sexual identity and
orientation.
## Our Standards
Examples of behavior that contributes to creating a positive environment
include:
* Using welcoming and inclusive language
* Being respectful of differing viewpoints and experiences
* Gracefully accepting constructive criticism
* Focusing on what is best for the community
* Showing empathy towards other community members
Examples of unacceptable behavior by participants include:
* The use of sexualized language or imagery and unwelcome sexual attention or
advances
* Trolling, insulting/derogatory comments, and personal or political attacks
* Public or private harassment
* Publishing others' private information, such as a physical or electronic
address, without explicit permission
* Other conduct which could reasonably be considered inappropriate in a
professional setting
## Our Responsibilities
Project maintainers are responsible for clarifying the standards of acceptable
behavior and are expected to take appropriate and fair corrective action in
response to any instances of unacceptable behavior.
Project maintainers have the right and responsibility to remove, edit, or
reject comments, commits, code, wiki edits, issues, and other contributions
that are not aligned to this Code of Conduct, or to ban temporarily or
permanently any contributor for other behaviors that they deem inappropriate,
threatening, offensive, or harmful.
## Scope
This Code of Conduct applies both within project spaces and in public spaces
when an individual is representing the project or its community. Examples of
representing a project or community include using an official project e-mail
address, posting via an official social media account, or acting as an appointed
representative at an online or offline event. Representation of a project may be
further defined and clarified by project maintainers.
## Enforcement
Instances of abusive, harassing, or otherwise unacceptable behavior may be
reported by contacting the project team. All
complaints will be reviewed and investigated and will result in a response that
is deemed necessary and appropriate to the circumstances. The project team is
obligated to maintain confidentiality with regard to the reporter of an incident.
Further details of specific enforcement policies may be posted separately.
Project maintainers who do not follow or enforce the Code of Conduct in good
faith may face temporary or permanent repercussions as determined by other
members of the project's leadership.
## Attribution
This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4,
available at [http://contributor-covenant.org/version/1/4][version]
[homepage]: http://contributor-covenant.org
[version]: http://contributor-covenant.org/version/1/4/
================================================
FILE: CONTRIBUTING.md
================================================
# Contributing to the 'future.apply' package
This Git repository uses the [Git Flow](https://nvie.com/posts/a-successful-git-branching-model/) branching model (the [`git flow`](https://github.com/petervanderdoes/gitflow-avh) extension is useful for this). The [`develop`](https://github.com/futureverse/future.apply/tree/develop) branch contains the latest contributions and other code that will appear in the next release, and the [`master`](https://github.com/futureverse/future.apply) branch contains the code of the latest release, which is exactly what is currently on [CRAN](https://cran.r-project.org/package=future.apply).
Contributing to this package is easy. Just send a [pull request](https://help.github.com/articles/using-pull-requests/). When you send your PR, make sure `develop` is the destination branch on the [future.apply repository](https://github.com/futureverse/future.apply). Your PR should pass `R CMD check --as-cran`, which will also be checked by <a href="https://github.com/futureverse/future.apply/actions?query=workflow%3AR-CMD-check">GitHub Actions</a> and when the PR is submitted.
We abide to the [Code of Conduct](https://www.contributor-covenant.org/version/2/0/code_of_conduct/) of Contributor Covenant.
================================================
FILE: DESCRIPTION
================================================
Package: future.apply
Version: 1.20.2-9000
Title: Apply Function to Elements in Parallel using Futures
Depends:
R (>= 3.2.0),
future (>= 1.49.0)
Imports:
globals,
parallel,
utils
Suggests:
datasets,
stats,
tools,
listenv,
R.rsp,
markdown
VignetteBuilder: R.rsp
Authors@R: c(person("Henrik", "Bengtsson",
role = c("aut", "cre", "cph"),
email = "henrikb@braju.com",
comment = c(ORCID = "0000-0002-7579-5165")),
person("R Core Team", role = c("cph", "ctb")))
Description: Implementations of apply(), by(), eapply(), lapply(), Map(), .mapply(), mapply(), replicate(), sapply(), tapply(), and vapply() that can be resolved using any future-supported backend, e.g. parallel on the local machine or distributed on a compute cluster. These future_*apply() functions come with the same pros and cons as the corresponding base-R *apply() functions but with the additional feature of being able to be processed via the future framework <doi:10.32614/RJ-2021-048>.
License: GPL (>= 2)
LazyLoad: TRUE
URL: https://future.apply.futureverse.org, https://github.com/futureverse/future.apply
BugReports: https://github.com/futureverse/future.apply/issues
Language: en-US
Encoding: UTF-8
RoxygenNote: 7.3.3
Roxygen: list(markdown = TRUE)
================================================
FILE: Makefile
================================================
include .make/Makefile
================================================
FILE: NAMESPACE
================================================
# Generated by roxygen2: do not edit by hand
S3method(future_by,data.frame)
S3method(future_by,default)
S3method(future_kernapply,default)
S3method(future_kernapply,ts)
export(future_.mapply)
export(future_Filter)
export(future_Map)
export(future_apply)
export(future_by)
export(future_eapply)
export(future_kernapply)
export(future_lapply)
export(future_mapply)
export(future_replicate)
export(future_sapply)
export(future_tapply)
export(future_vapply)
importFrom(future,Future)
importFrom(future,FutureError)
importFrom(future,FutureInterruptError)
importFrom(future,as.FutureGlobals)
importFrom(future,cancel)
importFrom(future,future)
importFrom(future,getGlobalsAndPackages)
importFrom(future,nbrOfWorkers)
importFrom(future,resolve)
importFrom(future,value)
importFrom(globals,findGlobals)
importFrom(globals,globalsByName)
importFrom(parallel,splitIndices)
importFrom(stats,end)
importFrom(stats,frequency)
importFrom(stats,kernapply)
importFrom(stats,ts)
importFrom(utils,capture.output)
importFrom(utils,globalVariables)
importFrom(utils,head)
importFrom(utils,packageVersion)
importFrom(utils,str)
================================================
FILE: NEWS.md
================================================
# Version (development version)
* ...
# Version 1.20.2 [2026-02-19]
## Miscellaneous
* This is a maintenance update with internal updates only.
# Version 1.20.1 [2025-12-08]
## Bug Fixes
* `future_apply(..., future.globals = list(...))` would produce
'Error in if (chunk_size > maxSize) { : missing value where
TRUE/FALSE needed'.
# Version 1.20.0 [2025-06-06]
## Significant changes
* All **future.apply** functions will now cancel any remaining
non-resolved futures if one of the futures produces an error, or a
user interrupt (Ctrl-C) is detected. If the backend where the
futures are running supports it, the canceled futures are also
interrupted, which results in compute resources being freed up
sooner and the **future.apply** function returning sooner.
## New Features
* Added `future_Filter()`, which is parallel version of
`base::Filter()`.
* Added `future_kernapply()`, which is parallel version of
`stats::kernapply()`.
* Now **future.apply** lets **future** take care of the generation of
parallel RNG seed. Consolidating random number generation to the
core package will allow us to add central support for custom
parallel RNG methods beyond the built-in L'Ecuyer-CMRG method.
## Deprecated and Defunct
* Specifying the function `FUN` for `future_by()` as a character
string is defunct. It should be specified as a function, e.g. `FUN
= sqrt` and ``FUN = `[[` ``, which is what `base::by()`
requires. Use of a string has been deprecated since
**future.apply** 1.10.0 (2022-11-04).
# Version 1.11.3 [2024-10-27]
## Bug Fixes
* Use of `future.seed = TRUE` could result in an error
`!any(seed_next != seed) is not TRUE` in rare cases.
# Version 1.11.2 [2024-03-27]
## Miscellaneous
* Relaxed one unit test that triggered an error on 32-bit
architectures.
# Version 1.11.1 [2023-12-19]
## Bug Fixes
* Option `future.globals.maxSize` was never passed down to parallel
workers.
* The assertion of argument `INDEX` of `future_tapply()` would fail
with another error in R (< 3.6.0), if `INDEX` was incorrect in the
first place.
# Version 1.11.0 [2023-05-20]
## Significant Changes
* `future_tapply()` now accepts data frames as input, just as
`tapply()` does in R (>= 4.3.0).
* In R (>= 4.3.0), `future_tapply(X, INDEX, ...)` now accepts `INDEX`
being a formula when `X` is a data frames, just as `tapply()` does
in R (>= 4.3.0). An error is produced if used in R (< 4.3.0).
* In R (>= 4.3.0), `future_by(X, INDICES, ...)` now accepts `INDICES`
being a formula when `X` is a data frames, just as `by()` does in
R (>= 4.3.0). An error is produced if used in R (< 4.3.0).
## New Features
* Now **future** operators such as `%globals%`, `%seed%`, and `%stdout%`
can be used to control the corresponding `future.*` arguments, e.g.
`y <- future_lapply(1:3, FUN = my_fun) %seed% TRUE` is the same as
`y <- future_lapply(1:3, FUN = my_fun, future.seed = TRUE)`.
## Bug Fixes
* Contrary to `lapply(X, ...)`, `future_lapply(X, ...)` failed to use
method-specific `[[` subsetting, if the class of `X` implemented
one. `future_mapply()` and other functions had the same problem.
The reason was that when `X` is partitioned into chunks, it would
lose the class attribute before subsetting with `[[`.
# Version 1.10.0 [2022-11-04]
## Bug Fixes
* Functions `future_eapply()`, `future_lapply()`, `future_sapply()`,
and `future_vapply()` failed if `FUN` was specified as the name of
a function rather than the function object itself,
e.g. `future_lapply(1:3, FUN = "sqrt")`.
## Deprecated and Defunct
* Specifying the function `FUN` for `future_by()` as a character
string is deprecated, because `base::by()` does not support it. It
should be specified as a function, e.g. `FUN = sqrt` and ``FUN =
`[[` ``.
# Version 1.9.1 [2022-09-07]
## Bug Fixes
* Some warnings and errors showed the wrong call.
## Miscellaneous
* Fix some HTML5 issues in help pages.
## Significant Changes
* `future_mapply()` and `future_Map()` was updated to match the new
behavior of `mapply()` and `Map()` in R (>= 4.2.0), which follows
the "max-or-0-if-any" recycling rule.
## Performance
* Now captured standard output and conditions are deleted as soon as
they have been relayed. This requires **future** (>= 1.25.0).
## Deprecated and Defunct
* Removed moot argument `future.lazy` from all functions. Regardless
of setting it to TRUE or FALSE, futures would be resolved
momentarily and always before the apply returned.
# Version 1.8.1 [2021-08-09]
## Bug Fixes
* `citEntry()` in CITATION used argument `notes` instead of `note`.
# Version 1.8.0 [2021-08-09]
## New Features
* Add argument `future.envir` to all `future_nnn()` functions, which
is passed as argument `envir` to `future()`.
* Add option `future.apply.debug` for debugging features specific to
this package. It defaults to option `future.debug`.
## Performance
* Internal `getGlobalsAndPackagesXApply()` now avoids calculating the
object size of `...` arguments if option `future.globals.maxSize`
is +Inf.
## Bug Fixes
* `f <- function(...) future_lapply(X, function(x) list(...));
f(a=1)` would produce an error on 'unused argument (a = 1)" with
the upcoming release of **future** 1.22.0.
# Version 1.7.0 [2021-01-02]
## New Features
* The automatic capturing of conditions can be disabled by specifying
`future.conditions = NULL`.
* Warnings and errors on using the RNG without specifying
`future.seed` are now tailored to the **future.apply** package.
# Version 1.6.0 [2020-06-30]
## Significant Changes
* `future_apply()` gained argument `simplify`, which is added to
R-devel (to become R 4.1.0).
## Bug Fixes
* `future_apply(X, FUN, ...)` would pass all `future.*` arguments
except `future.globals`, `future.packages`, and `future.labels` to
the `FUN` function instead of processing them locally. This would
often result in the `FUN` producing an error on "unused argument".
It also affected `future.seed` not being applied, which means for
some `FUN` functions that did not produce this error,
non-reproducible results could have been produced.
# Version 1.5.0 [2020-04-16]
## New Features
* Add `future_.mapply()` corresponding to `.mapply()` in the **base**
package.
## Bug Fixes
* `future_mapply()` would chunk up `MoreArgs` when `future.seed =
TRUE`.
# Version 1.4.0 [2020-01-06]
## New Features
* Now all `future_nnn()` functions set a label on each future that
reflects the name of the `future_nnn()` function and the index of
the chunk, e.g. `"future_lapply-3"`. The format can be controlled
by argument `future.label`.
## Performance
* The assertion of the maximum size of globals per chunk is now
significantly faster for `future_apply()`.
## Bug Fixes
* `future_lapply(X)` and `future_mapply(FUN, X)` would drop `names`
argument of the returned empty list when `length(X) == 0`.
* Package could set `.Random.seed` to NULL, instead of removing it,
which in turn would produce a warning on "'.Random.seed' is not an
integer vector but of type 'NULL', so ignored" when the next random
number generated.
# Version 1.3.0 [2019-06-17]
## New Features
* Now `future.conditions` defaults to the same as argument
`conditions` of `future::future()`. If the latter changes, this
package will follow.
* Debug messages are now prepended with a timestamp.
## Bug Fixes
* The error "sprintf(...) : 'fmt' length exceeds maximal format
length 8192" could be produced when debugging tried to report on
too many globals.
# Version 1.2.0 [2019-03-06]
## New Features
* Added `future_by()`.
## Bug Fixes
* Attributes `add` and `ignore` of argument `future.globals` were
ignored although support for them was added in **future** (>=
1.10.0).
* Validation of L'Ecuyer-CMRG RNG seeds failed in recent R devel.
# Version 1.1.0 [2019-01-16]
## Significant Changes
* Added argument `future.stdout` and `future.conditions` for
controlling whether standard output and conditions (e.g. messages
and warnings) produced during the evaluation of futures should be
captured and relayed or not. Standard output is guaranteed to be
relayed in the same order as it would when using sequential
processing. Analogously for conditions. However, standard output
is always relayed before conditions. Errors are always relayed.
Relaying of non-error conditions requires **future** (>= 1.11.0).
## New Features
* Elements can be processed in random order by setting attribute
`ordering` to `"random"` of argument `future.chunk.size` or
`future.scheduling`, e.g. `future.chunk.size = structure(TRUE,
ordering = "random")`. This can help improve load balancing in
cases where there is a correlation between processing time and
ordering of the elements. Note that the order of the returned
values is not affected when randomizing the processing order.
* Swapped order of arguments `future.lazy` and `future.seed` to be
consistent with ditto arguments of `future::future()`.
# Version 1.0.1 [2018-08-26]
## Documentation / Licence
* The license is GPL (>= 2). Previously it was documented as GPL (>=
2.1) but that is a non-existing GPL version.
## Bug Fixes
* For list objects `X` where `X != as.list(X), future_lapply(X)` did
not give the same result as `lapply(X)`. Analogously for
`future_vapply(X)`.
* `future_mapply()` could drop class attribute on elements iterated
over, because `.subset()` was used internally instead of `` `[`()
``. For instance, iteration over `Date` objects were affected.
# Version 1.0.0 [2018-06-19]
## Significant Changes
* License changed from LGPL (>= 2.1) to GPL (>= 2) to make sure it is
compatible with the source code adopted from R base's `apply()`,
`Map()`, `replicate()`, `sapply()`, and `tapply()`, which are all
GPL (>= 2).
## New Features
* Added `future_apply()`, `future_mapply()`, and `future_Map()`.
* Added argument `future.chunk.size` as an alternative to argument
`future.scheduling` for controlling the average number of elements
processed per future ("chunk"). In R 3.5.0, the **parallel**
package introduced argument `chunk.size`.
* The maximum total size of globals allowed (option
`future.globals.maxSize`) per future ("chunk") is now scaled up by
the number of elements processed by the future ("chunk") making the
protection approximately invariant to the amount of chunking
(arguments `future.scheduling` and `future.chunk.size`).
## Bug Fixes
* `future_lapply(X, ...)` did not search for globals in `X`.
* `future_vapply()` did not return the same dimension names as
`vapply()` when `FUN.VALUE` had no names but `FUN(X[[1]])` had.
## Software Quality
* Test code coverage is 100%.
# Version 0.2.0 [2018-05-01]
## New Features
* Added `future_eapply()`, `future_tapply()`, `future_vapply()`, and
`future_replicate()`.
# Version 0.1.0 [2018-01-15]
* Package submitted to CRAN.
# Version 0.0.3 [2017-12-06]
## Documentation
* Vignette now covers the basics of the package and describes its
role in the R package ecosystem together with a road map going
forward.
## Software Quality
* Added more package tests. Code coverage is currently at 100%.
# Version 0.0.2 [2017-12-06]
## Performance
* `future_lapply(x, ...)` is now much faster and more memory
efficient for large `x` vectors because it uses internal `fold()`
function that is more efficient (memory and speed) version of
`base::Reduce(f, x)`, especially when `length(x)` is large.
# Version 0.0.0-9000 [2017-08-31]
## New Features
* Added `future_sapply()`.
* Added `future_lapply()` - originally from the **future** package.
* Created package.
================================================
FILE: R/000.import.R
================================================
import_from <- function(name, mode = "function", default = NULL, package) {
ns <- getNamespace(package)
if (exists(name, mode = mode, envir = ns, inherits = FALSE)) {
get(name, mode = mode, envir = ns, inherits = FALSE)
} else if (!is.null(default)) {
default
} else {
stop(sprintf("No such '%s' %s: %s()", package, mode, name))
}
}
import_future <- function(name, mode = "function", default = NULL) {
import_from(name, mode = mode, default = default, package = "future")
}
import_base <- function(name, mode = "function", default = NULL) {
import_from(name, mode = mode, default = default, package = "base")
}
================================================
FILE: R/001.bquote.R
================================================
#' @importFrom utils globalVariables
globalVariables(c(".", ".."))
bquote_compile <- import_future("bquote_compile")
bquote_apply <- import_future("bquote_apply")
================================================
FILE: R/001.import_future_functions.R
================================================
## To be imported from 'future', if available
sQuoteLabel <- NULL
.debug <- NULL
make_rng_seeds <- import_future("make_rng_seeds")
get_random_seed <- import_future("get_random_seed")
set_random_seed <- import_future("set_random_seed")
next_random_seed <- import_future("next_random_seed")
is_valid_random_seed <- import_future("is_valid_random_seed")
is_lecyer_cmrg_seed <- import_future("is_valid_random_seed")
as_lecyer_cmrg_seed <- import_future("as_lecyer_cmrg_seed")
## Import private functions from 'future'
import_future_functions <- function() {
.debug <<- import_future(".debug", mode = "environment", default = new.env(parent = emptyenv()))
## future (>= 1.49.0)
sQuoteLabel <<- import_future("sQuoteLabel")
}
================================================
FILE: R/chunking.R
================================================
`chunkWith[[` <- function(x, subset) {
if (getOption("future.apply.chunkWith", "[[") == "[") {
return(x[subset])
}
## Make sure to preserve behavior of S3 method-specific
## `[[` subsetting like lapply() and mapply() does it
ny <- length(subset)
y <- vector("list", length = ny)
names(y) <- names(x)[subset]
for (kk in seq_len(ny)) {
idx <- subset[kk]
value <- x[[idx]]
if (is.null(value)) {
y[kk] <- list(value)
} else {
y[[kk]] <- value
}
}
y
}
================================================
FILE: R/condition-handlers.R
================================================
#' @importFrom future FutureInterruptError
onInterrupt <- function(int, fcn_name, debug = FALSE) {
if (debug) {
mdebug_push("onInterrupt() ...")
mdebug(sprintf("Received <%s>", class(int)[1]))
on.exit(mdebug_pop())
}
when <- Sys.time()
host <- Sys.info()[["nodename"]]
pid <- Sys.getpid()
msg <- sprintf("%s() interrupted at %s, while running on %s (pid %s)", fcn_name, format(when, format = "%FT%T"), sQuote(host), pid)
## By signaling the interrupt as an error, the next handler, which should
## be onError(), will take care of canceling outstanding futures
stop(FutureInterruptError(msg))
}
#' @importFrom future cancel resolve value
onError <- function(ex, futures, debug = FALSE) {
if (debug) {
mdebug_push("onError() ...")
mdebug(sprintf("Received <%s>", class(ex)[1]))
on.exit(mdebug_pop())
}
## Canceling all futures
msg <- sprintf("Caught %s. Canceling all iterations ...", class(ex)[1])
warning(msg, immediate. = TRUE, call. = FALSE)
futures <- cancel(futures)
## Make sure all workers finish before continuing
futures <- resolve(futures)
## Collect all results
for (f in futures) tryCatch(value(f), error = identity)
if (debug) mdebug(sprintf("Signaling: <%s>", class(ex)[1]))
stop(ex)
}
================================================
FILE: R/fold.R
================================================
#' Efficient Fold, Reduce, Accumulate, Combine of a Vector
#'
#' @param x A vector.
#'
#' @param f A binary function, i.e. a function take takes two arguments.
#'
#' @param left If `TRUE`, vector is combined from the left (the first element),
#' otherwise the right (the last element).
#'
#' @param unname If `TRUE`, function `f` is called as
#' \code{f(unname(y), x[[ii]])}, otherwise as \code{f(y, x[[ii]])},
#' which may introduce name `"y"`.
#'
#' @param threshold An integer (>= 2) specifying the length where the
#' recursive divide-and-conquer call will stop and incremental building of
#' the partial value is performed. Using `threshold = +Inf` will disable
#' recursive folding.
#'
#' @return A vector.
#'
#' @details
#' In order for recursive folding to give the same results as non-recursive
#' folding, binary function `f` must be _associative_ with itself, i.e.
#' \code{f(f(x[[1]], x[[2]]), x[[3]])} equals
#' \code{f(x[[1]], f(x[[2]]), x[[3]])}.
#'
#' This function is a more efficient (memory and speed) of
#' \code{\link[base:Reduce]{Reduce(f, x, right = !left, accumulate = FALSE)}},
#' especially when `x` is long.
#'
#' @keywords internal
fold <- function(x, f, left = TRUE, unname = TRUE, threshold = 1000L) {
f <- match.fun(f)
n <- length(x)
if (n == 0L) return(NULL)
if (!is.vector(x) || is.object(x)) x <- as.list(x)
if (n == 1L) return(x[[1]])
stop_if_not(length(left) == 1, is.logical(left), !is.na(left))
stop_if_not(length(threshold) == 1, is.numeric(threshold),
!is.na(threshold), threshold >= 2)
if (n >= threshold) {
## Divide and conquer, i.e. split, build the two parts, and merge
n_mid <- n %/% 2
y_left <- Recall(f = f, x = x[ 1:n_mid], left = left,
unname = unname, threshold = threshold)
y_right <- Recall(f = f, x = x[(n_mid+1L):n], left = left,
unname = unname, threshold = threshold)
y <- f(y_left, y_right)
y_left <- y_right <- NULL
} else {
## Incrementally build result vector
if (left) {
y <- x[[1L]]
if (unname) {
for (ii in 2:n)
y <- forceAndCall(n = 2L, FUN = f, unname(y), x[[ii]])
} else {
for (ii in 2:n)
y <- forceAndCall(n = 2L, FUN = f, y, x[[ii]])
}
} else {
y <- x[[n]]
if (unname) {
for (ii in (n-1):1)
y <- forceAndCall(n = 2L, FUN = f, x[[ii]], unname(y))
} else {
for (ii in (n-1):1)
y <- forceAndCall(n = 2L, FUN = f, x[[ii]], y)
}
}
}
y
}
================================================
FILE: R/future.apply-package.R
================================================
#' future.apply: Apply Function to Elements in Parallel using Futures
#'
#' The \pkg{future.apply} package provides parallel implementations of
#' common "apply" functions provided by base \R. The parallel processing
#' is performed via the \pkg{future} ecosystem, which provides a large
#' number of parallel backends, e.g. on the local machine, a remote cluster,
#' and a high-performance compute cluster.
#'
#' Currently implemented functions are:
#'
#' * [future_apply()]: a parallel version of [apply()][base::apply]
#' * [future_by()]: a parallel version of [by()][base::by]
#' * [future_eapply()]: a parallel version of [eapply()][base::lapply]
#' * [future_lapply()]: a parallel version of [lapply()][base::lapply]
#' * [future_mapply()]: a parallel version of [mapply()][base::mapply]
#' * [future_sapply()]: a parallel version of [sapply()][base::sapply]
#' * [future_tapply()]: a parallel version of [tapply()][base::tapply]
#' * [future_vapply()]: a parallel version of [vapply()][base::vapply]
#' * [future_Map()]: a parallel version of [Map()][Map]
#' * [future_replicate()]: a parallel version of [replicate()][base::replicate]
#' * [future_.mapply()]: a parallel version of [.mapply()][base::.mapply]
#'
#' Reproducibility is part of the core design, which means that perfect,
#' parallel random number generation (RNG) is supported regardless of the
#' amount of chunking, type of load balancing, and future backend being used.
#'
#' Since these `future_*()` functions have the same arguments as the
#' corresponding base \R function, start using them is often as simple as
#' renaming the function in the code. For example, after attaching the package:
#' ```r
#' library(future.apply)
#' ```
#' code such as:
#' ```r
#' x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE,FALSE,FALSE,TRUE))
#' y <- lapply(x, quantile, probs = 1:3/4)
#' ```
#' can be updated to:
#' ```r
#' y <- future_lapply(x, quantile, probs = 1:3/4)
#' ```
#'
#' The default settings in the \pkg{future} framework is to process code
#' _sequentially_. To run the above in parallel on the local machine
#' (on any operating system), use:
#' ```r
#' plan(multisession)
#' ```
#' first. That's it!
#'
#' To go back to sequential processing, use `plan(sequential)`.
#' If you have access to multiple machines on your local network, use:
#' ```r
#' plan(cluster, workers = c("n1", "n2", "n2", "n3"))
#' ```
#' This will set up four workers, one on `n1` and `n3`, and two on `n2`.
#' If you have SSH access to some remote machines, use:
#' ```r
#' plan(cluster, workers = c("m1.myserver.org", "m2.myserver.org))
#' ```
#' See the \pkg{future} package and [future::plan()] for more examples.
#'
#' The \pkg{future.batchtools} package provides support for high-performance
#' compute (HPC) cluster schedulers such as SGE, Slurm, and TORQUE / PBS.
#' For example,
#'
#' * `plan(batchtools_slurm)`:
#' Process via a Slurm scheduler job queue.
#' * `plan(batchtools_torque)`:
#' Process via a TORQUE / PBS scheduler job queue.
#'
#' This builds on top of the queuing framework that the \pkg{batchtools}
#' package provides. For more details on backend configuration, please see
#' the \pkg{future.batchtools} and \pkg{batchtools} packages.
#'
#' These are just a few examples of parallel/distributed backend for the
#' future ecosystem. For more alternatives, see the 'Reverse dependencies'
#' section on the
#' [future CRAN package page](https://cran.r-project.org/package=future).
#'
#' @author
#' Henrik Bengtsson, except for the implementations of `future_apply()`,
#' `future_Map()`, `future_replicate()`, `future_sapply()`, and
#' `future_tapply()`, which are adopted from the source code of the
#' corresponding base \R functions, which are licensed under GPL (>= 2)
#' with 'The R Core Team' as the copyright holder.
#' Because of these dependencies, the license of this package is GPL (>= 2).
#'
#' @keywords manip programming iteration
#'
#' @aliases future.apply-package
#' @name future.apply
"_PACKAGE"
================================================
FILE: R/future_Filter.R
================================================
#' @inheritParams future_mapply
#'
#' @param f A function of the arity \eqn{k} if `future_Map()` is called with
#' \eqn{k} arguments. Unary for `future_Filter()`.
#'
#' @param x A vector-like object to iterate over.
#'
#' @return
#' See [base::Filter()][Filter] for details.
#'
#' @example incl/future_Filter.R
#'
#' @author
#' The implementation of `future_Filter()` is adopted from the source code
#' of the corresponding base \R function `Filter()`, which is licensed under
#' GPL (>= 2) with 'The R Core Team' as the copyright holder.
#'
#' @rdname future_mapply
#' @export
future_Filter <- function(f, x, ...) {
f <- match.fun(f)
z <- unlist(future_lapply(x, f, ...))
if (is.null(z))
return(x[integer()])
ind <- as.logical(z)
x[which(ind)]
}
================================================
FILE: R/future_Map.R
================================================
#' @inheritParams future_mapply
#'
#' @param f A function of the arity \eqn{k} if `future_Map()` is called with
#' \eqn{k} arguments.
#'
#' @return
#' `future_Map()` is a simple wrapper to `future_mapply()` which does not
#' attempt to simplify the result.
#' See [base::Map()][Map] for details.
#'
#' @export
#'
#' @author
#' The implementation of `future_Map()` is adopted from the source code
#' of the corresponding base \R function `Map()`, which is licensed under
#' GPL (>= 2) with 'The R Core Team' as the copyright holder.
#'
#' @rdname future_mapply
future_Map <- function(f, ..., future.envir = parent.frame(), future.label = "future_Map-%d") {
f <- match.fun(f)
future_mapply(FUN = f, ..., SIMPLIFY = FALSE, future.envir = future.envir, future.label = future.label)
}
================================================
FILE: R/future_apply.R
================================================
#' Apply Functions Over Array Margins via Futures
#'
#' `future_apply()` implements [base::apply()] using future with perfect
#' replication of results, regardless of future backend used.
#' It returns a vector or array or list of values obtained by applying a
#' function to margins of an array or matrix.
#'
#' @inheritParams future_lapply
#'
#' @param X an array, including a matrix.
#'
#' @param MARGIN A vector giving the subscripts which the function will be
#' applied over. For example, for a matrix `1` indicates rows, `2` indicates
#' columns, `c(1, 2)` indicates rows and columns.
#' Where `X` has named dimnames, it can be a character vector selecting
#' dimension names.
#'
#' @param \ldots (optional) Additional arguments passed to `FUN()`, except
#' `future.*` arguments, which are passed on to [future_lapply()] used
#' internally.
#'
#' @param simplify a logical indicating whether results should be simplified
#' if possible.
#'
#' @return
#' Returns a vector or array or list of values obtained by applying a
#' function to margins of an array or matrix.
#' See [base::apply()] for details.
#'
#' @author
#' The implementation of `future_apply()` is adopted from the source code
#' of the corresponding base \R function, which is licensed under GPL (>= 2)
#' with 'The R Core Team' as the copyright holder.
#'
#' @example incl/future_apply.R
#'
#' @importFrom future nbrOfWorkers
#' @export
future_apply <- function(X, MARGIN, FUN, ..., simplify = TRUE, future.envir = parent.frame(), future.stdout = TRUE, future.conditions = "condition", future.globals = TRUE, future.packages = NULL, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL, future.label = "future_apply-%d") {
debug <- isTRUE(getOption("future.debug"))
debug <- isTRUE(getOption("future.apply.debug", debug))
FUN <- match.fun(FUN)
simplify <- isTRUE(simplify)
## Ensure that X is an array object
dl <- length(dim(X))
if(!dl) stop("dim(X) must have a positive length")
if(is.object(X))
X <- if(dl == 2L) as.matrix(X) else as.array(X)
## now record dim as coercion can change it
## (e.g. when a data frame contains a matrix).
d <- dim(X)
dn <- dimnames(X)
ds <- seq_len(dl)
## Extract the margins and associated dimnames
if (is.character(MARGIN)) {
if(is.null(dnn <- names(dn))) # names(NULL) is NULL
stop("'X' must have named dimnames")
MARGIN <- match(MARGIN, dnn)
if (anyNA(MARGIN))
stop("not all elements of 'MARGIN' are names of dimensions")
}
s.call <- ds[-MARGIN]
s.ans <- ds[MARGIN]
d.call <- d[-MARGIN]
d.ans <- d[MARGIN]
dn.call <- dn[-MARGIN]
dn.ans <- dn[MARGIN]
## dimnames(X) <- NULL
## do the calls
d2 <- prod(d.ans)
if(d2 == 0L) {
## arrays with some 0 extents: return ``empty result'' trying
## to use proper mode and dimension:
## The following is still a bit `hackish': use non-empty X
newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call), 1L))
ans <- forceAndCall(1, FUN, if(length(d.call) < 2L) newX[,1] else
array(newX[, 1L], d.call, dn.call), ...)
return(if(is.null(ans)) ans else if(length(d.ans) < 2L) ans[1L][-1L]
else array(ans, d.ans, dn.ans))
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Support %globals%, %packages%, %seed%, ...
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
opts <- getOption("future.disposable", NULL)
if (length(opts) > 0) {
for (name in names(opts)) {
var <- sprintf("future.%s", name)
assign(var, opts[[name]], envir = environment(), inherits = FALSE)
}
if (!identical(attr(opts, "dispose"), FALSE)) {
options(future.disposable = NULL)
}
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Globals and Packages
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
gp <- getGlobalsAndPackagesXApply(
FUN,
args = list(X = X, ...),
envir = environment(),
future.globals = future.globals,
future.packages = future.packages,
debug = debug
)
globals <- gp$globals
packages <- gp$packages
gp <- NULL
## Check size of global variables?
## Doing it here, on the matrix object, is much faster than doing it for
## the list elements passed to future_lapply()
oldMaxSize <- maxSize <- getOption("future.globals.maxSize")
if (is.null(maxSize) || is.finite(maxSize)) {
if (is.null(maxSize)) maxSize <- 500 * 1024^2
objectSize <- import_future("objectSize")
size <- objectSize(X)
nWorkers <- nbrOfWorkers()
chunk_size <- size / nWorkers
other_size <- attr(globals, "total_size")
## Calculate size of the 'globals', if not already done
if (is.na(other_size)) other_size <- objectSize(X)
if (is.numeric(other_size)) chunk_size <- chunk_size + other_size
if (chunk_size > maxSize) {
asIEC <- import_future("asIEC")
msg <- sprintf("The total size of %s (of class %s and type %s) is %s and the total size of the other argument is %s. With %d workers, this translates to %s per worker needed for future_apply(), which exceeds the maximum allowed size of %s (option 'future.globals.maxSize').", sQuote("X"), sQuote(class(X)[1]), sQuote(typeof(X)), asIEC(size), asIEC(other_size), nWorkers, asIEC(chunk_size), asIEC(maxSize))
if (debug) mdebug(msg)
stop(msg)
}
on.exit(options(future.globals.maxSize = oldMaxSize), add = TRUE)
options(future.globals.maxSize = +Inf)
}
newX <- aperm(X, c(s.call, s.ans))
dim(newX) <- c(prod(d.call), d2)
if(length(d.call) < 2L) {# vector
if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL))
newX <- lapply(1L:d2, FUN = function(i) newX[,i])
} else
newX <- lapply(1L:d2, FUN = function(i)
array(newX[,i], dim = d.call, dimnames = dn.call))
globals$...future.FUN <- NULL
ans <- future_lapply(
X = newX,
FUN = FUN,
...,
future.envir = future.envir,
future.stdout = future.stdout,
future.conditions = future.conditions,
future.seed = future.seed,
future.scheduling = future.scheduling,
future.chunk.size = future.chunk.size,
future.globals = globals,
future.packages = packages,
future.label = future.label
)
## answer dims and dimnames
ans.list <- !simplify || is.recursive(ans[[1L]])
l.ans <- length(ans[[1L]])
ans.names <- names(ans[[1L]])
if(!ans.list)
ans.list <- any(lengths(ans) != l.ans)
if(!ans.list && length(ans.names)) {
all.same <- vapply(ans, function(x) identical(names(x), ans.names), NA)
if (!all(all.same)) ans.names <- NULL
}
len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE))
if(length(MARGIN) == 1L && len.a == d2) {
names(ans) <- if(length(dn.ans[[1L]])) dn.ans[[1L]] # else NULL
ans
}
else if(len.a == d2)
array(ans, d.ans, dn.ans)
else if(len.a && len.a %% d2 == 0L) {
if(is.null(dn.ans)) dn.ans <- vector(mode="list", length(d.ans))
dn1 <- list(ans.names)
if(length(dn.call) && !is.null(n1 <- names(dn <- dn.call[1])) &&
nzchar(n1) && length(ans.names) == length(dn[[1]]))
names(dn1) <- n1
dn.ans <- c(dn1, dn.ans)
array(ans, c(len.a %/% d2, d.ans),
if(!is.null(names(dn.ans)) || !all(vapply(dn.ans, is.null, NA)))
dn.ans)
} else
ans
}
================================================
FILE: R/future_by.R
================================================
#' Apply a Function to a Data Frame Split by Factors via Futures
#'
#' @inheritParams future_lapply
#'
#' @param data An \R object, normally a data frame, possibly a matrix.
#'
#' @param INDICES A factor or a list of factors, each of length `nrow(data)`.
#'
#' @param FUN a function to be applied to (usually data-frame) subsets of `data`.
#'
#' @param \ldots Additional arguments pass to [future_lapply()] and
#' then to `FUN()`.
#'
#' @param simplify logical: see [base::tapply()].
#'
#' @return
#' An object of class "by", giving the results for each subset.
#' This is always a list if simplify is false, otherwise a list
#' or array (see [base::tapply()]).
#' See also [base::by()] for details.
#'
#' @example incl/future_by.R
#'
#' @details
#' Internally, `data` is grouped by `INDICES` into a list of `data`
#' subset elements which is then processed by [future_lapply()].
#' When the groups differ significantly in size, the processing time
#' may differ significantly between the groups.
#' To correct for processing-time imbalances, adjust the amount of chunking
#' via arguments `future.scheduling` and `future.chunk.size`.
#'
#' @section Note on 'stringsAsFactors':
#' The `future_by()` is modeled as closely as possible to the
#' behavior of `base::by()`. Both functions have "default" S3 methods that
#' calls `data <- as.data.frame(data)` internally. This call may in turn call
#' an S3 method for `as.data.frame()` that coerces strings to factors or not
#' depending on whether it has a `stringsAsFactors` argument and what its
#' default is.
#' For example, the S3 method of `as.data.frame()` for lists changed its
#' (effective) default from `stringsAsFactors = TRUE` to
#' `stringsAsFactors = TRUE` in R 4.0.0.
#'
#'
#' @rdname future_by
#' @export
future_by <- function(data, INDICES, FUN, ..., simplify = TRUE, future.envir = parent.frame()) {
future.envir <- force(future.envir)
UseMethod("future_by")
}
#' @export
future_by.default <- function(data, INDICES, FUN, ..., simplify = TRUE, future.envir = parent.frame()) {
ndim <- length(dim(data))
.SUBSETTER <- if (ndim == 0L) {
function(row) data[row, , drop = TRUE]
} else {
function(row) data[row, , drop = FALSE]
}
data <- as.data.frame(data)
future_by_internal(data = data, INDICES = INDICES, FUN = FUN, ...,
simplify = simplify,
.INDICES.NAME = deparse(substitute(INDICES))[1L],
.CALL = match.call(),
.SUBSETTER = .SUBSETTER,
future.envir = future.envir)
}
#' @export
future_by.data.frame <- function(data, INDICES, FUN, ..., simplify = TRUE, future.envir = parent.frame()) {
if (inherits(INDICES, "formula"))
INDICES <- .formula2varlist(INDICES, data)
future_by_internal(data = data, INDICES = INDICES, FUN = FUN, ...,
simplify = simplify,
.INDICES.NAME = deparse(substitute(INDICES))[1L],
.CALL = match.call(),
.SUBSETTER = function(row) data[row, , drop = FALSE],
future.envir = future.envir)
}
future_by_internal <- function(data, INDICES, FUN, ..., simplify = TRUE, .SUBSETTER, .CALL, .INDICES.NAME, future.envir = parent.frame(), future.label = "future_by-%d") {
fcn_name <- "future_by_internal"
debug <- isTRUE(getOption("future.debug"))
debug <- isTRUE(getOption("future.apply.debug", debug))
if (debug) {
mdebugf_push("%s() ...", fcn_name)
on.exit(mdebug_pop())
}
FUN <- future_by_match_FUN(FUN) ## to be removed /HB 2022-10-24
stop_if_not(is.function(FUN))
stop_if_not(is.function(.SUBSETTER))
if (!is.list(INDICES)) {
INDEX <- vector("list", length = 1L)
INDEX[[1L]] <- INDICES
names(INDEX) <- .INDICES.NAME
INDICES <- INDEX
INDEX <- NULL ## Not needed anymore
}
INDICES <- lapply(INDICES, FUN = as.factor)
nI <- length(INDICES)
if (!nI) stop("'INDICES' is of length zero")
nd <- nrow(data)
if (!all(lengths(INDICES) == nd)) {
stop("All elements of argument 'INDICES' must have same length as 'data'")
}
namelist <- lapply(INDICES, FUN = levels)
extent <- lengths(namelist, use.names = FALSE)
cumextent <- cumprod(extent)
if (cumextent[nI] > .Machine$integer.max)
stop("total number of levels >= 2^31")
storage.mode(cumextent) <- "integer"
ngroup <- cumextent[nI]
group <- as.integer(INDICES[[1L]])
if (nI > 1L) {
for (i in 2L:nI) {
group <- group + cumextent[i - 1L] * (as.integer(INDICES[[i]]) - 1L)
}
}
cumextent <- NULL ## Not needed anymore
levels(group) <- as.character(seq_len(ngroup))
class(group) <- "factor"
ans <- split(seq_len(nd), f = group)
names(ans) <- NULL
index <- as.logical(lengths(ans) > 0L)
group <- NULL ## Not needed anymore
grouped_data <- lapply(X = ans[index], FUN = .SUBSETTER)
ans <- future_lapply(X = grouped_data, FUN = FUN, ..., future.envir = future.envir, future.label = future.label)
grouped_data <- NULL ## Not needed anymore
ansmat <- array({
if (simplify && all(lengths(ans) == 1L)) {
ans <- unlist(ans, recursive = FALSE, use.names = FALSE)
if (!is.null(ans) && is.atomic(ans)) vector(typeof(ans)) else NA
} else {
vector("list", length = prod(extent))
}
}, dim = extent, dimnames = namelist)
if (length(ans) > 0L) ansmat[index] <- ans
ans <- NULL ## Not needed anymore
structure(ansmat,
call = .CALL,
class = "by"
)
}
future_by_match_FUN <- function(FUN) {
if (is.function(FUN)) return(FUN)
.Defunct(msg = "Specifying the function 'FUN' for future_by() as a character string is defunct in future.apply (>= 1.12.0), because base::by() does not support it. Instead, specify it as a function, e.g. FUN = sqrt and FUN = `[[`", package = .packageName)
match.fun(FUN)
}
================================================
FILE: R/future_eapply.R
================================================
#' @inheritParams future_lapply
#'
#' @param env An \R environment.
#'
#' @param all.names If `TRUE`, the function will also be applied to variables
#' that start with a period (`.`), otherwise not.
#' See [base::eapply()] for details.
#'
#' @return
#' A named (unless `USE.NAMES = FALSE`) list.
#' See [base::eapply()] for details.
#'
#' @rdname future_lapply
#' @export
future_eapply <- function(env, FUN, ..., all.names = FALSE, USE.NAMES = TRUE, future.envir = parent.frame(), future.label = "future_eapply-%d") {
FUN <- match.fun(FUN)
names <- ls(envir = env, all.names = all.names, sorted = FALSE)
X <- mget(names, envir = env, inherits = FALSE)
if (!USE.NAMES) names(X) <- NULL
future_lapply(X = X, FUN = FUN, ..., future.envir = future.envir, future.label = future.label)
}
================================================
FILE: R/future_kernapply.R
================================================
#' Apply Smoothing Kernel in Parallel
#'
#' `future_kernapply()` is a futurized version of
#' [stats::kernapply()], i.e. it computes, in parallel, the
#' convolution between an input sequence and a specific kernel.
#' Parallelization takes place over columns when `x` is a matrix,
#' including a `ts` matrix.
#'
#' @inheritParams stats::kernapply
#'
#' @returns
#' See [stats::kernapply()] for details.
#'
#' @examples
#' library(datasets)
#' library(stats)
#'
#' X <- EuStockMarkets[, 1:2]
#' k <- kernel("daniell", 50) # a long moving average
#' X_smooth <- future_kernapply(X, k = k)
#'
#' @export
future_kernapply <- function(x, ...) {
UseMethod("future_kernapply")
}
#' @rdname future_kernapply
#'
#' @importFrom stats kernapply
#' @export
future_kernapply.default <- function(x, k, circular = FALSE, ...) {
if (is.vector(x))
return(kernapply(x, k, circular = circular))
else if (is.matrix(x))
return(future_apply(x, MARGIN = 2, FUN = kernapply, k, circular = circular))
else
stop("'future_kernapply' is not available for object 'x'")
}
#' @rdname future_kernapply
#'
#' @importFrom stats kernapply end frequency ts
#' @export
future_kernapply.ts <- function(x, k, circular = FALSE, ...) {
if (!is.matrix(x))
y <- kernapply(as.vector(x), k, circular = circular)
else
y <- future_apply(x, MARGIN = 2, FUN = kernapply, k, circular = circular)
ts(y, end = end(x), frequency = frequency(x))
}
================================================
FILE: R/future_lapply.R
================================================
#' Apply a Function over a List or Vector via Futures
#'
#' `future_lapply()` implements [base::lapply()] using futures with perfect
#' replication of results, regardless of future backend used.
#' Analogously, this is true for all the other `future_nnn()` functions.
#'
#' @param X A vector-like object to iterate over.
#'
#' @param FUN A function taking at least one argument.
#'
#' @param \ldots (optional) Additional arguments passed to `FUN()`.
#' For `future_*apply()` functions and `replicate()`, any `future.*` arguments
#' part of \ldots are passed on to `future_lapply()` used internally.
#' Importantly, if this is called inside another function which also declares
#' \ldots arguments, do not forget to explicitly pass such \ldots arguments
#' down to the `future_*apply()` function too, which will then pass them on
#' to `FUN()`. See below for an example.
#'
#' @param future.envir An [environment] passed as argument `envir` to
#' [future::future()] as-is.
#'
#' @param future.stdout If `TRUE` (default), then the standard output of the
#' underlying futures is captured, and re-outputted as soon as possible.
#' If `FALSE`, any output is silenced (by sinking it to the null device
#' as it is outputted).
#' If `NA` (not recommended), output is _not_ intercepted.
#'
#' @param future.conditions A character string of conditions classes to be
#' captured and relayed. The default is the same as the `condition`
#' argument of [future::Future()].
#' To not intercept conditions, use `conditions = character(0L)`.
#' Errors are always relayed.
#'
#' @param future.globals A logical, a character vector, or a named list for
#' controlling how globals are handled. For details, see below section.
#'
#' @param future.packages (optional) a character vector specifying packages
#' to be attached in the R environment evaluating the future.
#'
#' @param future.seed A logical or an integer (of length one or seven),
#' or a list of `length(X)` with pre-generated random seeds.
#' For details, see below section.
#'
#' @param future.scheduling Average number of futures ("chunks") per worker.
#' If `0.0`, then a single future is used to process all elements
#' of `X`.
#' If `1.0` or `TRUE`, then one future per worker is used.
#' If `2.0`, then each worker will process two futures
#' (if there are enough elements in `X`).
#' If `Inf` or `FALSE`, then one future per element of
#' `X` is used.
#' Only used if `future.chunk.size` is `NULL`.
#'
#' @param future.chunk.size The average number of elements per future ("chunk").
#' If `Inf`, then all elements are processed in a single future.
#' If `NULL`, then argument `future.scheduling` is used.
#'
#' @param future.label If a character string, then each future is assigned
#' a label `sprintf(future.label, chunk_idx)`. If TRUE, then the
#' same as `future.label = "future_lapply-%d"`. If FALSE, no labels
#' are assigned.
#'
#' @return
#' For `future_lapply()`, a list with same length and names as `X`.
#' See [base::lapply()] for details.
#'
#' @section Global variables:
#' Argument `future.globals` may be used to control how globals
#' should be handled similarly to how the `globals` argument is used with
#' `future()`.
#' Since all function calls use the same set of globals, this function can do
#' any gathering of globals upfront (once), which is more efficient than if
#' it would be done for each future independently.
#' If `TRUE` (default), then globals are automatically identified and gathered.
#' If a character vector of names is specified, then those globals are gathered.
#' If a named list, then those globals are used as is.
#' In all cases, `FUN` and any \ldots arguments are automatically
#' passed as globals to each future created as they are always needed.
#'
#' @section Reproducible random number generation (RNG):
#' Unless `future.seed` is `FALSE` or `NULL`, this function guarantees to
#' generate the exact same sequence of random numbers _given the same initial
#' seed / RNG state_ - this regardless of type of futures, scheduling
#' ("chunking") strategy, and number of workers.
#'
#' RNG reproducibility is achieved by pregenerating the random seeds for all
#' iterations (over `X`) by using parallel RNG streams. In each
#' iteration, these seeds are set before calling `FUN(X[[ii]], ...)`.
#' _Note, for large `length(X)` this may introduce a large overhead._
#'
#' If `future.seed = TRUE`, then \code{\link[base:Random]{.Random.seed}}
#' is used if it holds a parallel RNG seed, otherwise one is created
#' randomly.
#'
#' If `future.seed = FALSE`, it is expected that none of the
#' `FUN(X[[ii]], ...)` function calls use random number generation.
#' If they do, then an informative warning or error is produced depending
#' on settings. See [future::future()] for more details.
#' Using `future.seed = NULL`, is like `future.seed = FALSE` but without
#' the check whether random numbers were generated or not.
#'
#' As input, `future.seed` may also take a fixed initial seed (integer),
#' either as a full parallel RNG seed, or as a seed generating such a
#' full parallel seed. This seed will be used to generated `length(X)`
#' parallel RNG streams.
#'
#' In addition to the above, it is possible to specify a pre-generated
#' sequence of RNG seeds as a list such that
#' `length(future.seed) == length(X)` and where each element is an
#' integer seed vector that can be assigned to
#' \code{\link[base:Random]{.Random.seed}}. One approach to generate a
#' set of valid RNG seeds based on fixed initial seed (here `42L`) is:
#'
#' ```r
#' seeds <- future_lapply(seq_along(X), FUN = function(x) .Random.seed,
#' future.chunk.size = Inf, future.seed = 42L)
#' ```
#'
#' **Note that `as.list(seq_along(X))` is _not_ a valid set of such
#' `.Random.seed` values.**
#'
#' In all cases but `future.seed = FALSE` and `NULL`, the RNG state of the
#' calling R processes after this function returns is guaranteed to be
#' "forwarded one step" from the RNG state that was before the call and
#' in the same way regardless of `future.seed`, `future.scheduling`
#' and future strategy used. This is done in order to guarantee that an \R
#' script calling `future_lapply()` multiple times should be numerically
#' reproducible given the same initial seed.
#'
#'
#' @section Load balancing ("chunking"):
#' Whether load balancing ("chunking") should take place or not can be
#' controlled by specifying either argument
#' `future.scheduling = <ratio>` or `future.chunk.size = <count>`.
#'
#' The value `future.chunk.size` specifies the average number of elements
#' processed per future ("chunks").
#' If `+Inf`, then all elements are processed in a single future (one worker).
#' If `NULL`, then argument `future.scheduling` is used.
#'
#' The value `future.scheduling` specifies the average number of futures
#' ("chunks") that each worker processes.
#' If `0.0`, then a single future is used to process all iterations;
#' none of the other workers are not used.
#' If `1.0` or `TRUE`, then one future per worker is used.
#' If `2.0`, then each worker will process two futures (if there are
#' enough iterations).
#' If `+Inf` or `FALSE`, then one future per iteration is used.
#' The default value is `scheduling = 1.0`.
#'
#'
#' @section Control processing order of elements:
#' Attribute `ordering` of `future.chunk.size` or `future.scheduling` can
#' be used to control the ordering the elements are iterated over, which
#' only affects the processing order and _not_ the order values are returned.
#' This attribute can take the following values:
#' * index vector - a numeric vector of length `length(X)`
#' * function - a function taking one argument which is called as
#' `ordering(length(X))` and which must return an
#' index vector of length `length(X)`, e.g.
#' `function(n) rev(seq_len(n))` for reverse ordering.
#' * `"random"` - this will randomize the ordering via random index
#' vector `sample.int(length(X))`.
#'
#' For example, `future.scheduling = structure(TRUE, ordering = "random")`.
#' _Note_, when elements are processed out of order, then captured standard
#' output and conditions are relayed in that order as well.
#'
#' @example incl/future_lapply.R
#'
#' @keywords manip programming iteration
#'
#' @importFrom globals findGlobals
#' @export
future_lapply <- local({
tmpl_expr <- bquote_compile({
"# future.apply::future_lapply(): process chunk of elements"
lapply(seq_along(...future.elements_ii), FUN = function(jj) {
...future.X_jj <- ...future.elements_ii[[jj]]
.(expr_FUN)
})
})
tmpl_expr_with_rng <- bquote_compile({
"# future.apply::future_lapply(): process chunk of elements while setting random seeds"
lapply(seq_along(...future.elements_ii), FUN = function(jj) {
...future.X_jj <- ...future.elements_ii[[jj]]
assign(".Random.seed", ...future.seeds_ii[[jj]], envir = globalenv(), inherits = FALSE)
.(expr_FUN)
})
})
function(X, FUN, ..., future.envir = parent.frame(), future.stdout = TRUE, future.conditions = "condition", future.globals = TRUE, future.packages = NULL, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL, future.label = "future_lapply-%d") {
fcn_name <- "future_lapply"
args_name <- "X"
## Coerce to as.list()?
if (!is.vector(X) || is.object(X)) X <- as.list(X)
## Nothing to do?
nX <- length(X)
if (nX == 0L) return(as.list(X))
FUN <- match.fun(FUN)
debug <- isTRUE(getOption("future.debug"))
debug <- isTRUE(getOption("future.apply.debug", debug))
if (debug) {
mdebugf_push("%s() ...", fcn_name)
on.exit(mdebug_pop())
}
## NOTE TO SELF: We'd ideally have a 'future.envir' argument also for
## this function, cf. future(). However, it's not yet clear to me how
## to do this, because we need to have globalsOf() to search for globals
## from the current environment in order to identify the globals of
## arguments 'FUN' and '...'. /HB 2017-03-10
envir <- environment()
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Future expression
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
...future.FUN <- NULL ## To please R CMD check
## Does FUN() rely on '...' being a global?
## If so, make sure to *not* pass '...' to FUN()
globals_FUN <- findGlobals(FUN, dotdotdot = "return")
if (debug) {
mdebugf("Globals in FUN(): [n=%d] %s", length(globals_FUN), commaq(globals_FUN))
}
global_dotdotdot <- ("..." %in% globals_FUN)
if (global_dotdotdot) {
## Yes; don't pass '...' to FUN()
expr_FUN <- quote({
...future.FUN(...future.X_jj)
})
if (debug) mdebugf("=> Will not pass '...' to FUN(): %s", commaq(deparse(expr_FUN)))
} else {
## No; okay to pass '...' to FUN()
expr_FUN <- quote({
...future.FUN(...future.X_jj, ...)
})
if (debug) mdebugf("=> Will pass '...' to FUN(): %s", commaq(deparse(expr_FUN)))
}
## With or without RNG?
expr <- bquote_apply(
if (is.null(future.seed) || isFALSE(future.seed) || isNA(future.seed)) {
tmpl_expr
} else {
tmpl_expr_with_rng
}
)
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Process
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
values <- future_xapply(
FUN = FUN,
nX = nX,
chunk_args = X,
args = list(...),
get_chunk = `chunkWith[[`,
expr = expr,
envir = envir,
future.envir = future.envir,
future.globals = future.globals,
future.packages = future.packages,
future.scheduling = future.scheduling,
future.chunk.size = future.chunk.size,
future.stdout = future.stdout,
future.conditions = future.conditions,
future.seed = future.seed,
future.label = future.label,
fcn_name = fcn_name,
args_name = args_name,
debug = debug
)
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Reduce
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
names(values) <- names(X)
values
}
})
================================================
FILE: R/future_mapply.R
================================================
#' Apply a Function to Multiple List or Vector Arguments
#'
#' `future_mapply()` implements [base::mapply()] using futures with perfect
#' replication of results, regardless of future backend used.
#' Analogously to `mapply()`, `future_mapply()` is a multivariate version of
#' `future_sapply()`.
#' It applies `FUN` to the first elements of each \ldots argument,
#' the second elements, the third elements, and so on.
#' Arguments are recycled if necessary.
#'
#' @inheritParams future_lapply
#'
#' @param FUN A function to apply, found via [base::match.fun()].
#'
#' @param \ldots Arguments to vectorize over, will be recycled to common
#' length, or zero if one of them is of length zero.
#'
#' @param MoreArgs A list of other arguments to `FUN`.
#'
#' @param SIMPLIFY A logical or character string; attempt to reduce the
#' result to a vector, matrix or higher dimensional array; see the simplify
#' argument of [base::sapply()].
#'
#' @param USE.NAMES A logical; use names if the first \ldots argument has
#' names, or if it is a character vector, use that character vector as the
#' names.
#'
#' @param future.globals A logical, a character vector, or a named list for
#' controlling how globals are handled.
#' For details, see [future_lapply()].
#'
#' @param future.seed A logical or an integer (of length one or seven), or
#' a list of `max(lengths(list(...)))` with pre-generated random seeds.
#' For details, see [future_lapply()].
#'
#' @return
#' `future_mapply()` returns a list, or for `SIMPLIFY = TRUE`, a vector,
#' array or list. See [base::mapply()] for details.
#'
#' @example incl/future_mapply.R
#'
#' @keywords manip programming iteration
#'
#' @export
future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE, future.envir = parent.frame(), future.stdout = TRUE, future.conditions = "condition", future.globals = TRUE, future.packages = NULL, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL, future.label = "future_mapply-%d") {
fcn_name <- "future_mapply"
args_name <- "..."
FUN <- match.fun(FUN)
dots <- list(...)
## Nothing to do?
if (length(dots) == 0L) return(list())
ns <- lengths(dots)
## Nothing to do?
## "max-or-0-if-any" recycling rule was introduced in R (>= 4.2.0)
if (any(ns == 0L)) {
if (!USE.NAMES) return(list())
values <- list()
first <- dots[[1]]
names <- names(first)
if (length(names) > 0L) {
names <- character(0L)
} else if (is.null(names) && is.character(first)) {
names <- character(0L)
}
names(values) <- names
return(values)
}
stop_if_not(all(ns > 0L))
## Recycle?
nX <- max(ns)
stretch <- which(ns < nX)
if (length(stretch) > 0L) {
for (kk in stretch) dots[[kk]] <- rep(dots[[kk]], length.out = nX)
ns <- lengths(dots)
}
stop_if_not(all(ns == nX))
stop_if_not(is.null(MoreArgs) || is.list(MoreArgs))
debug <- isTRUE(getOption("future.debug"))
debug <- isTRUE(getOption("future.apply.debug", debug))
if (debug) {
mdebugf_push("%s() ...", fcn_name)
on.exit(mdebug_pop())
}
## NOTE TO SELF: We'd ideally have a 'future.envir' argument also for
## this function, cf. future(). However, it's not yet clear to me how
## to do this, because we need to have globalsOf() to search for globals
## from the current environment in order to identify the globals of
## arguments 'FUN' and '...'. /HB 2017-03-10
envir <- future.envir
envir <- environment()
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Support %globals%, %packages%, %seed%, ...
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
opts <- getOption("future.disposable", NULL)
if (length(opts) > 0) {
for (name in names(opts)) {
var <- sprintf("future.%s", name)
assign(var, opts[[name]], envir = environment(), inherits = FALSE)
}
if (!identical(attr(opts, "dispose"), FALSE)) {
options(future.disposable = NULL)
}
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Future expression
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
...future.FUN <- NULL ## To please R CMD check
## Set .Random.seed?
if (is.null(future.seed) || isFALSE(future.seed) || isNA(future.seed)) {
expr <- quote({
args <- c(list(FUN = ...future.FUN), ...future.elements_ii, MoreArgs = list(MoreArgs), SIMPLIFY = FALSE, USE.NAMES = FALSE)
do.call(mapply, args = args)
})
} else {
expr <- quote({
...future.FUN2 <- function(..., ...future.seeds_ii_jj) {
assign(".Random.seed", ...future.seeds_ii_jj, envir = globalenv(), inherits = FALSE)
...future.FUN(...)
}
args <- c(list(FUN = ...future.FUN2), ...future.elements_ii, list(...future.seeds_ii_jj = ...future.seeds_ii), MoreArgs = list(MoreArgs), SIMPLIFY = FALSE, USE.NAMES = FALSE)
do.call(mapply, args = args)
})
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Process
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
values <- future_xapply(
FUN = FUN,
nX = nX,
chunk_args = dots,
MoreArgs = MoreArgs,
get_chunk = function(X, chunk) lapply(X, FUN = `chunkWith[[`, chunk),
expr = expr,
envir = envir,
future.envir = future.envir,
future.globals = future.globals,
future.packages = future.packages,
future.scheduling = future.scheduling,
future.chunk.size = future.chunk.size,
future.stdout = future.stdout,
future.conditions = future.conditions,
future.seed = future.seed,
future.label = future.label,
fcn_name = fcn_name,
args_name = args_name,
debug = debug
)
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Reduce
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (USE.NAMES && length(dots) > 0L) {
if (is.null(names1 <- names(dots[[1L]])) && is.character(dots[[1L]])) {
names(values) <- dots[[1L]]
} else if (!is.null(names1)) {
names(values) <- names1
}
}
if (!isFALSE(SIMPLIFY) && length(values) > 0L) {
values <- simplify2array(values, higher = (SIMPLIFY == "array"))
}
values
}
#' @param dots A list of arguments to vectorize over (vectors or lists of
#' strictly positive length, or all of zero length).
#'
#' @return
#' `future_.mapply()` returns a list. See [base::.mapply()] for details.
#'
#' @details
#' Note that [base::.mapply()], which `future_.mapply()` is modeled after
#' is listed as an "internal" function in \R despite being exported.
#'
#' @rdname future_mapply
#' @export
future_.mapply <- function(FUN, dots, MoreArgs, ..., future.label = "future_.mapply-%d") {
args <- c(
list(FUN = FUN),
dots,
list(
MoreArgs = MoreArgs,
SIMPLIFY = FALSE,
USE.NAMES = FALSE,
...,
future.label = future.label
)
)
do.call(future_mapply, args = args, envir = parent.frame())
}
================================================
FILE: R/future_replicate.R
================================================
#' @inheritParams future_lapply
#'
#' @param n The number of replicates.
#'
#' @param expr An \R expression to evaluate repeatedly.
#'
#' @return
#' `future_replicate()` is a wrapper around `future_sapply()` and return
#' simplified object according to the `simplify` argument.
#' See [base::replicate()] for details.
#' Since `future_replicate()` usually involves random number generation (RNG),
#' it uses `future.seed = TRUE` by default in order produce sound random
#' numbers regardless of future backend and number of background workers used.
#'
#' @export
#'
#' @rdname future_lapply
future_replicate <- function(n, expr, simplify = "array",
future.seed = TRUE, ...,
future.envir = parent.frame(),
future.label = "future_replicate-%d")
future_sapply(X = integer(n),
FUN = eval.parent(substitute(function(...)expr)),
simplify = simplify,
future.seed = future.seed,
...,
future.envir = future.envir,
future.label = future.label)
================================================
FILE: R/future_sapply.R
================================================
#' @inheritParams future_lapply
#'
#' @param simplify See [base::sapply()] and [base::tapply()], respectively.
#'
#' @param USE.NAMES See [base::sapply()].
#'
#' @return
#' For `future_sapply()`, a vector with same length and names as \code{X}.
#' See [base::sapply()] for details.
#'
#' @export
#'
#' @author
#' The implementations of `future_replicate()`, `future_sapply()`, and
#' `future_tapply()` are adopted from the source code of the corresponding
#' base \R functions, which are licensed under GPL (>= 2) with
#' 'The R Core Team' as the copyright holder.
#'
#' @rdname future_lapply
future_sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, future.envir = parent.frame(), future.label = "future_sapply-%d") {
FUN <- match.fun(FUN)
answer <- future_lapply(X = X, FUN = FUN, ..., future.envir = future.envir, future.label = future.label)
if (USE.NAMES && is.character(X) && is.null(names(answer)))
names(answer) <- X
if (!isFALSE(simplify) && length(answer))
simplify2array(answer, higher = (simplify == "array"))
else
answer
}
================================================
FILE: R/future_tapply.R
================================================
#' @inheritParams future_lapply
#'
#' @param X An \R object for which a \code{\link[base]{split}} method
#' exists. Typically vector-like, allowing subsetting with
#' \code{\link[base]{[}}, or a data frame.
#'
#' @param INDEX A list of one or more factors, each of same length as `X`.
#' The elements are coerced to \code{\link[base]{factor}}s by
#' \code{\link[base:as.factor]{as.factor()}}. Can also be a formula, which
#' is useful if `X` is a data frame; see the `f` argument in
#' \code{\link[base:split]{split()}} for interpretation.
#'
#' @param default See [base::tapply()].
#'
#' @return
#' `future_tapply()` returns an array with mode `"list"`, unless
#' `simplify = TRUE` (default) _and_ `FUN` returns a scalar, in which
#' case the mode of the array is the same as the returned scalars.
#' See [base::tapply()] for details.
#'
#' @rdname future_lapply
#' @export
future_tapply <- function(X, INDEX, FUN = NULL, ...,
default = NA, simplify = TRUE,
future.envir = parent.frame(),
future.label = "future_tapply-%d") {
FUN <- if (!is.null(FUN))
match.fun(FUN)
if (inherits(INDEX, "formula")) {
if (!is.data.frame(X))
stop("'X' must be a data frame when 'INDEX' is a formula")
INDEX <- .formula2varlist(INDEX, X)
}
if (!is.list(INDEX))
INDEX <- list(INDEX)
INDEX <- lapply(INDEX, FUN = as.factor)
nI <- length(INDEX)
if (!nI)
stop("'INDEX' is of length zero")
if (!is.object(X) && !all(lengths(INDEX) == length(X)))
stop("arguments must have same length")
namelist <- lapply(INDEX, FUN = levels)
extent <- lengths(namelist, use.names = FALSE)
cumextent <- cumprod(extent)
if (cumextent[nI] > .Machine$integer.max)
stop("total number of levels >= 2^31")
storage.mode(cumextent) <- "integer"
ngroup <- cumextent[nI]
group <- as.integer(INDEX[[1L]])
if (nI > 1L) {
for (i in 2L:nI) {
group <- group + cumextent[i - 1L] * (as.integer(INDEX[[i]]) - 1L)
}
}
if (is.null(FUN)) return(group)
levels(group) <- as.character(seq_len(ngroup))
class(group) <- "factor"
ans <- split(X, f = group)
names(ans) <- NULL
index <- as.logical(lengths(ans))
ans <- future_lapply(X = ans[index], FUN = FUN, ..., future.envir = future.envir, future.label = future.label)
ansmat <- array({
if (simplify && all(lengths(ans) == 1L)) {
ans <- unlist(ans, recursive = FALSE, use.names = FALSE)
if (!is.null(ans) && is.na(default) && is.atomic(ans))
vector(typeof(ans))
else
default
} else {
vector("list", prod(extent))
}
}, dim = extent, dimnames = namelist)
if (length(ans) > 0L) ansmat[index] <- ans
ansmat
}
.formula2varlist <- import_base(".formula2varlist", default = local({
if (!exists("errorCondition", mode = "function", envir = baseenv(), inherits = FALSE)) {
errorCondition <- function(message, ..., class = NULL, call = NULL) {
structure(
list(message = as.character(message), call = call, ...),
class = c(class, "error", "condition")
)
}
}
function(...) {
stop(errorCondition("future_tapply(X, INDEX, ...), where 'INDEX' is a formula, requires R (>= 4.3.0"), class = "NotSupportedByThisRVersionError")
}
}))
================================================
FILE: R/future_vapply.R
================================================
#' @inheritParams future_lapply
#'
#' @param FUN.VALUE A template for the required return value from
#' each `FUN(X[ii], ...)`.
#' Types may be promoted to a higher type within the ordering
#' logical < integer < double < complex, but not demoted.
#' See [base::vapply()] for details.
#'
#' @return
#' For `future_vapply()`, a vector with same length and names as \code{X}.
#' See [base::vapply()] for details.
#'
#' @export
#'
#' @rdname future_lapply
future_vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE, future.envir = parent.frame(), future.label = "future_vapply-%d") {
## Coerce to as.list()?
if (!is.vector(X) || is.object(X)) X <- as.list(X)
n <- length(X)
FUN <- match.fun(FUN)
stop_if_not(is.function(FUN))
stop_if_not(is.vector(FUN.VALUE) || is.array(FUN.VALUE))
type <- typeof(FUN.VALUE)
times <- length(FUN.VALUE)
dim <- dim(FUN.VALUE)
stop_if_not(is.logical(USE.NAMES), length(USE.NAMES) == 1L, !is.na(USE.NAMES))
valid_types <- switch(
type,
logical = "logical",
integer = c("logical", "integer"),
double = c("logical", "integer", "double"),
complex = c("logical", "integer", "double", "complex"),
type
)
x_FUN <- FUN
res <- future_lapply(X, FUN = function(x, ...) {
value <- x_FUN(x, ...)
if (length(value) != times) {
stopf("values must be length %d, but FUN(X[[ii]]) result is length %d",
times, length(value))
}
stop_if_not(all(dim(value) == dim), typeof(value) %in% valid_types)
value
}, ..., future.envir = future.envir, future.label = future.label)
if (!is.null(dim)) {
dim_res <- c(dim, n)
} else if (times != 1L) {
dim_res <- c(times, n)
} else {
dim_res <- NULL
}
if (USE.NAMES && length(res) > 0L) {
if (is.null(dim)) {
names_FUN.VALUE <- names(FUN.VALUE)
if (is.null(names_FUN.VALUE)) names_FUN.VALUE <- names(res[[1]])
} else {
names_FUN.VALUE <- dimnames(FUN.VALUE)
if (is.null(names_FUN.VALUE)) names_FUN.VALUE <- dimnames(res[[1]])
}
}
res <- unlist(res, use.names = FALSE)
if (is.null(res)) res <- vector(mode = type, length = 0L)
if (!is.null(dim_res)) dim(res) <- dim_res
if (USE.NAMES) {
if (is.array(res)) {
n_dim <- length(dim(res))
dimnames <- vector("list", length = n_dim)
if (is.null(dim)) {
names <- names(X)
if (!is.null(names)) dimnames[[2]] <- names
names <- names_FUN.VALUE
if (!is.null(names)) dimnames[[1]] <- names
} else {
names <- names(X)
if (!is.null(names)) dimnames[[n_dim]] <- names
names <- names_FUN.VALUE
if (!is.null(names)) dimnames[-n_dim] <- names
}
if (!all(unlist(lapply(dimnames, FUN = is.null), use.names = FALSE))) {
dimnames(res) <- dimnames
}
} else {
names(res) <- names(X)
}
}
res
}
================================================
FILE: R/future_xapply.R
================================================
#' @importFrom future cancel Future nbrOfWorkers future resolve value as.FutureGlobals getGlobalsAndPackages
future_xapply <- local({
tmpl_expr_options <- bquote_compile({
"# future.apply:::future_xapply(): preserve future option"
...future.globals.maxSize.org <- getOption("future.globals.maxSize")
if (!identical(...future.globals.maxSize.org, ...future.globals.maxSize)) {
oopts <- options(future.globals.maxSize = ...future.globals.maxSize)
on.exit(options(oopts), add = TRUE)
}
.(expr)
})
function(FUN, nX, chunk_args, args = NULL, MoreArgs = NULL, expr, envir = parent.frame(), future.envir, future.globals, future.packages, future.scheduling, future.chunk.size, future.stdout, future.conditions, future.seed, future.label, get_chunk, fcn_name = "future_xapply", args_name, ..., debug) {
if (debug) {
mdebugf_push("%s() -> future_xapply() ...", fcn_name)
on.exit(mdebug_pop())
}
stop_if_not(is.function(FUN))
stop_if_not(is.logical(future.stdout), length(future.stdout) == 1L)
stop_if_not(length(future.scheduling) == 1L, !is.na(future.scheduling),
is.numeric(future.scheduling) || is.logical(future.scheduling))
stop_if_not(length(future.label) == 1L, !is.na(future.label),
is.logical(future.label) || is.character(future.label))
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Support %globals%, %packages%, %seed%, ...
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
opts <- getOption("future.disposable", NULL)
if (length(opts) > 0) {
for (name in names(opts)) {
var <- sprintf("future.%s", name)
assign(var, opts[[name]], envir = environment(), inherits = FALSE)
}
if (!identical(attr(opts, "dispose"), FALSE)) {
options(future.disposable = NULL)
}
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Reproducible RNG (for sequential and parallel processing)
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
seeds <- make_rng_seeds(nX, seed = future.seed)
## Future expression (with or without setting the RNG state) and
## pass possibly tweaked 'future.seed' to future()
if (is.null(seeds)) {
stop_if_not(is.null(future.seed) || isFALSE(future.seed))
} else {
## If RNG seeds are used (given or generated), make sure to reset
## the RNG state afterward
oseed <- next_random_seed()
if (debug) mdebugf("Will set RNG state on exit: %s", hpaste(oseed))
on.exit(set_random_seed(oseed))
## As seed=FALSE but without the RNG check
future.seed <- NULL
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Load balancing ("chunking")
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
chunks <- makeChunks(nX,
nbrOfWorkers = nbrOfWorkers(),
future.scheduling = future.scheduling,
future.chunk.size = future.chunk.size)
if (debug) mdebugf("Number of chunks: %d", length(chunks))
## Process elements in a custom order?
ordering <- attr(chunks, "ordering")
if (!is.null(ordering)) {
if (debug) mdebugf("Index remapping (attribute 'ordering'): [n = %d] %s", length(ordering), hpaste(ordering))
chunks <- lapply(chunks, FUN = function(idxs) .subset(ordering, idxs))
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Globals and Packages
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
gp <- getGlobalsAndPackagesXApply(FUN = FUN,
args = args,
MoreArgs = MoreArgs,
envir = envir,
future.globals = future.globals,
future.packages = future.packages,
debug = debug)
packages <- gp$packages
globals <- gp$globals
scanForGlobals <- gp$scanForGlobals
gp <- NULL
## Add argument placeholders
globals_extra <- as.FutureGlobals(list(
...future.elements_ii = NULL,
...future.seeds_ii = NULL,
...future.globals.maxSize = NULL
))
attr(globals_extra, "resolved") <- TRUE
attr(globals_extra, "total_size") <- 0
globals <- c(globals, globals_extra)
## At this point a globals should be resolved and we should know their total size
## stop_if_not(attr(globals, "resolved"), !is.na(attr(globals, "total_size")))
if (debug) {
mdebugf("Globals pass to each chunk: [n=%d] %s", length(globals), commaq(names(globals)))
mstr(globals)
}
## To please R CMD check
...future.FUN <- ...future.elements_ii <- ...future.seeds_ii <-
...future.globals.maxSize <- NULL
globals.maxSize <- getOption("future.globals.maxSize")
globals.maxSize.default <- globals.maxSize
if (is.null(globals.maxSize.default)) globals.maxSize.default <- 500 * 1024^2
nchunks <- length(chunks)
if (debug) mdebugf("Number of futures (= number of chunks): %d", nchunks)
## Drop captured standard output and conditions as soon as they have
## been relayed?
if (isTRUE(future.stdout)) {
future.stdout <- structure(future.stdout, drop = TRUE)
}
if (length(future.conditions) > 0) {
future.conditions <- structure(future.conditions, drop = TRUE)
}
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## Futures
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
expr <- bquote_apply(tmpl_expr_options)
## Create labels?
if (isTRUE(future.label)) {
future.label <- sprintf("%s-%%d", fcn_name)
}
if (is.character(future.label)) {
labels <- sprintf(future.label, seq_len(nchunks))
stopifnot(length(labels) == nchunks)
} else {
labels <- NULL
}
if (debug) mdebugf("Launching %d futures (chunks) ...", nchunks)
fs <- vector("list", length = nchunks)
values <- tryCatch({
for (ii in seq_along(chunks)) {
chunk <- chunks[[ii]]
if (debug) mdebugf("Chunk #%d of %d ...", ii, length(chunks))
args_ii <- get_chunk(chunk_args, chunk)
globals_ii <- globals
## Subsetting outside future is more efficient
globals_ii[["...future.elements_ii"]] <- args_ii
packages_ii <- packages
if (scanForGlobals) {
if (debug) mdebugf(" - Finding globals in '%s' for chunk #%d ...", args_name, ii)
gp <- getGlobalsAndPackages(args_ii, envir = envir, globals = TRUE)
globals_args <- gp$globals
packages_args <- gp$packages
gp <- NULL
if (debug) {
mdebugf(" + additional globals found: [n=%d] %s",
length(globals_args), commaq(names(globals_args)))
mdebugf(" + additional namespaces needed: [n=%d] %s",
length(packages_args), commaq(packages_args))
}
## Export also globals found in arguments?
if (length(globals_args) > 0L) {
reserved <- intersect(c("...future.FUN", "...future.elements_ii",
"...future.seeds_ii"), names(globals_args))
if (length(reserved) > 0) {
stop("Detected globals in '%s' using reserved variables names: ",
args_name, commaq(reserved))
}
globals_args <- as.FutureGlobals(globals_args)
globals_ii <- unique(c(globals_ii, globals_args))
## Packages needed due to globals in arguments?
if (length(packages_args) > 0L)
packages_ii <- unique(c(packages_ii, packages_args))
}
if (debug) mdebugf(" - Finding globals in '%s' for chunk #%d ... DONE", args_name, ii)
}
args_ii <- NULL
## stop_if_not(attr(globals_ii, "resolved"))
if (!is.null(globals.maxSize)) {
globals_ii["...future.globals.maxSize"] <- list(globals.maxSize)
}
## Adjust option 'future.globals.maxSize' to account for the fact that more
## than one element is processed per future. The adjustment is done by
## scaling up the limit by the number of elements in the chunk. This is
## a "good enough" approach.
## (https://github.com/futureverse/future.apply/issues/8).
if (length(chunks) > 1L) {
options(future.globals.maxSize = length(chunks) * globals.maxSize.default)
if (debug) mdebugf(" - Adjusted option 'future.globals.maxSize': %.0f -> %d * %.0f = %.0f (bytes)", globals.maxSize.default, length(chunks), globals.maxSize.default, getOption("future.globals.maxSize"))
on.exit(options(future.globals.maxSize = globals.maxSize), add = TRUE)
}
## Using RNG seeds or not?
if (is.null(seeds)) {
if (debug) mdebug(" - seeds: <none>")
} else {
if (debug) mdebugf(" - seeds: [%d] <seeds>", length(chunk))
globals_ii[["...future.seeds_ii"]] <- seeds[chunk]
}
if (debug) {
mdebugf(" - All globals exported: [n=%d] %s",
length(globals_ii), commaq(names(globals_ii)))
}
## FIXME: Handle interrupts also here, i.e. as soon as we have
## launched the first future, we should be able to interrupt it
fs[[ii]] <- future(
expr, substitute = FALSE,
envir = future.envir,
stdout = future.stdout,
conditions = future.conditions,
globals = globals_ii, packages = packages_ii,
seed = future.seed,
label = labels[ii]
)
if (debug) {
mdebug("Created future:")
mprint(fs[[ii]])
}
## Not needed anymore
rm(list = c("chunk", "globals_ii"))
if (debug) mdebugf("Chunk #%d of %d ... DONE", ii, nchunks)
} ## for (ii ...)
if (debug) mdebugf("Launching %d futures (chunks) ... DONE", nchunks)
## 4. Resolving futures
if (debug) mdebugf("Resolving %d futures (chunks) ...", nchunks)
## Check for RngFutureCondition:s when resolving futures?
if (isFALSE(future.seed)) {
withCallingHandlers({
values <- local({
oopts <- options(future.rng.onMisuse.keepFuture = FALSE)
on.exit(options(oopts))
value(fs)
})
}, RngFutureCondition = function(cond) {
## One of "our" futures?
idx <- NULL
## Compare future UUIDs or whole futures?
uuid <- attr(cond, "uuid")
if (!is.null(uuid)) {
## (a) Future UUIDs are available
for (kk in seq_along(fs)) {
if (identical(fs[[kk]]$uuid, uuid)) idx <- kk
}
} else {
## (b) Future UUIDs are not available, use Future object?
f <- attr(cond, "future")
if (is.null(f)) return()
## Nothing to do?
if (!isFALSE(f$seed)) return() ## shouldn't really happen
for (kk in seq_along(fs)) {
if (identical(fs[[kk]], f)) idx <- kk
}
}
## Nothing more to do, i.e. not one of our futures?
if (is.null(idx)) return()
## Adjust message to give instructions relevant to this package
f <- fs[[idx]]
label <- sQuoteLabel(f)
message <- sprintf("UNRELIABLE VALUE: One of the %s iterations (%s) unexpectedly generated random numbers without declaring so. There is a risk that those random numbers are not statistically sound and the overall results might be invalid. To fix this, specify 'future.seed=TRUE'. This ensures that proper, parallel-safe random numbers are produced via a parallel RNG method. To disable this check, use 'future.seed = NULL', or set option 'future.rng.onMisuse' to \"ignore\".", sQuote(.packageName), label)
cond$message <- message
if (inherits(cond, "warning")) {
warning(cond)
invokeRestart("muffleWarning")
} else if (inherits(cond, "error")) {
stop(cond)
}
}) ## withCallingHandlers()
} else {
## value() exits early if it detects a future with an error.
## In future (>= 1.40.0), non-resolved futures will be automatically
## canceled if there's an error.
value(fs)
}
}, interrupt = function(int) {
onInterrupt(int, fcn_name = fcn_name, debug = debug)
}, error = function(e) {
onError(e, futures = fs, debug = debug)
}) ## tryCatch()
## Not needed anymore
rm(list = "fs")
if (debug) {
mdebugf(" - Number of value chunks collected: %d", length(values))
mdebugf("Resolving %d futures (chunks) ... DONE", nchunks)
}
## Sanity check
stop_if_not(length(values) == nchunks)
if (debug) mdebugf("Reducing values from %d chunks ...", nchunks)
values2 <- do.call(c, args = values)
if (debug) {
mdebugf(" - Number of values collected after concatenation: %d",
length(values2))
mdebugf(" - Number of values expected: %d", nX)
}
assert_values2(nX, values, values2, fcn_name = fcn_name, debug = debug)
values <- values2
rm(list = "values2")
## Sanity check (this may happen if the future backend is broken)
stop_if_not(length(values) == nX)
## Were elements processed in a custom order?
if (length(values) > 1L && !is.null(ordering)) {
invOrdering <- vector(mode(ordering), length = nX)
idx <- 1:nX
invOrdering[.subset(ordering, idx)] <- idx
rm(list = c("ordering", "idx"))
if (debug) mdebugf("Reverse index remapping (attribute 'ordering'): [n = %d] %s", length(invOrdering), hpaste(invOrdering))
values <- .subset(values, invOrdering)
rm(list = c("invOrdering"))
}
if (debug) mdebugf("Reducing values from %d chunks ... DONE", nchunks)
values
} ## future_xapply()
})
================================================
FILE: R/globals.R
================================================
#' @importFrom globals globalsByName
#' @importFrom future as.FutureGlobals getGlobalsAndPackages resolve
getGlobalsAndPackagesXApply <- function(FUN, args = NULL, MoreArgs = NULL, envir, future.globals = TRUE, future.packages = NULL, debug = NA) {
use_args <- !is.null(args)
if (is.na(debug)) {
debug <- isTRUE(getOption("future.debug"))
debug <- isTRUE(getOption("future.apply.debug", debug))
}
if (debug) {
mdebug_push("getGlobalsAndPackagesXApply() ...")
on.exit(mdebug_pop())
}
packages <- NULL
globals <- future.globals
scanForGlobals <- FALSE
if (is.logical(globals)) {
if (debug) mdebugf("future.globals: %s", globals)
## Gather all globals?
if (globals) {
scanForGlobals <- TRUE
expr <- do.call(call, args = c(list("FUN"),
if (use_args) args else MoreArgs))
} else {
expr <- NULL
attr(globals, "add") <- c(attr(globals, "add"),
c("FUN", if (use_args) "..." else "MoreArgs"))
}
gp <- getGlobalsAndPackages(expr, envir = envir, globals = globals)
globals <- gp$globals
packages <- gp$packages
gp <- NULL
if (debug) {
mdebugf("globals found/used: [n=%d] %s", length(globals), commaq(names(globals)))
mdebugf("needed namespaces: [n=%d] %s", length(packages), commaq(packages))
}
} else if (is.character(globals)) {
if (debug) mdebugf("future.globals: %s", commaq(globals))
globals <- unique(c(globals, "FUN", if (use_args) "..." else "MoreArgs"))
globals <- globalsByName(globals, envir = envir, mustExist = FALSE)
} else if (is.list(globals)) {
names <- names(globals)
if (debug) mdebugf("future.globals: <name-value list> with names %s", commaq(names(globals)))
if (length(globals) > 0 && is.null(names)) {
stop("Invalid argument 'future.globals'. All globals must be named")
}
} else {
stop("Invalid argument 'future.globals': ", mode(globals))
}
globals <- as.FutureGlobals(globals)
stop_if_not(inherits(globals, "FutureGlobals"))
names <- names(globals)
if (!is.element("FUN", names)) {
globals <- c(globals, FUN = FUN)
}
if (use_args) {
if (debug) mdebug("use_args: TRUE")
if (!is.element("...", names)) {
if (debug) mdebug_push("Getting '...' globals ...")
dotdotdot <- globalsByName("...", envir = envir, mustExist = TRUE)
dotdotdot <- as.FutureGlobals(dotdotdot)
dotdotdot <- resolve(dotdotdot)
if (debug) {
mdebugf("'...' content: [n=%d] %s", length(dotdotdot[[1]]), commaq(names(dotdotdot[[1]])))
mstr(dotdotdot)
}
## Recalculate the total size?
maxSize <- getOption("future.globals.maxSize")
if (is.null(maxSize) || is.finite(maxSize)) {
objectSize <- import_future("objectSize")
attr(dotdotdot, "total_size") <- objectSize(dotdotdot)
}
if (debug) mdebug_pop()
globals <- c(globals, dotdotdot)
}
} else if (!is.element("MoreArgs", names)) {
globals <- c(globals, list(MoreArgs = MoreArgs))
}
## Assert there are no reserved variables names among globals
reserved <- intersect(c("...future.FUN", "...future.elements_ii",
"...future.seeds_ii"), names)
if (length(reserved) > 0) {
stop("Detected globals using reserved variables names: ",
commaq(reserved))
}
## Avoid FUN() clash with mapply(..., FUN) below.
names <- names(globals)
names[names == "FUN"] <- "...future.FUN"
names(globals) <- names
if (debug) {
mdebugf("Globals to be used in all futures (chunks): [n=%d] %s", length(globals), commaq(names(globals)))
mstr(globals)
}
if (!is.null(future.packages)) {
stop_if_not(is.character(future.packages))
future.packages <- unique(future.packages)
stop_if_not(!anyNA(future.packages), all(nzchar(future.packages)))
packages <- unique(c(packages, future.packages))
}
if (debug) {
mdebugf("Packages to be attached in all futures: [n=%d] %s", length(packages), commaq(packages))
}
list(globals = globals, packages = packages, scanForGlobals = scanForGlobals)
} ## findGlobalsStep1()
================================================
FILE: R/makeChunks.R
================================================
#' Create Chunks of Index Vectors
#'
#' _This is an internal function._
#'
#' @param nbrOfElements (integer) Total number of elements to iterate over.
#'
#' @param nbrOfWorkers (integer) Number of workers available.
#'
#' @param future.scheduling (numeric) A strictly positive scalar.
#' Only used if argument `future.chunk.size` is `NULL`.
#'
#' @param future.chunk.size (numeric) The maximum number of elements per
#' chunk, or `NULL`. If `NULL`, then the chunk sizes are given by the
#' `future.scheduling` argument.
#'
#' @return A list of chunks, where each chunk is an integer vector of
#' unique indices \code{[1, nbrOfElements]}. The union of all chunks
#' holds `nbrOfElements` elements and equals `1:nbrOfElements`.
#' If `nbrOfElements == 0`, then an empty list is returned.
#'
#' @section Control processing order of elements:
#' Attribute `ordering` of `future.chunk.size` or `future.scheduling` can
#' be used to control the ordering the elements are iterated over, which
#' only affects the processing order _not_ the order values are returned.
#' This attribute can take the following values:
#' * index vector - a numeric vector of length `nbrOfElements` specifying
#' how elements are remapped
#' * function - a function taking one argument which is called as
#' `ordering(nbrOfElements)` and which must return an
#' index vector of length `nbrOfElements`, e.g.
#' `function(n) rev(seq_len(n))` for reverse ordering.
#' * `"random"` - this will randomize the ordering via random index
#' vector `sample.int(nbrOfElements)`.
#'
#' @importFrom parallel splitIndices
#' @keywords internal
makeChunks <- function(nbrOfElements, nbrOfWorkers,
future.scheduling = 1.0, future.chunk.size = NULL) {
stop_if_not(nbrOfElements >= 0L, nbrOfWorkers >= 1L)
## 'future.chunk.size != NULL' takes precedence over 'future.scheduling'
if (!is.null(future.chunk.size)) {
stop_if_not(length(future.chunk.size) == 1L, !is.na(future.chunk.size),
future.chunk.size > 0)
## Same definition as parallel:::staticNChunks() in R (>= 3.5.0)
nbrOfChunks <- max(1, ceiling(nbrOfElements / future.chunk.size))
## Customized ordering?
ordering <- attr(future.chunk.size, "ordering", exact = TRUE)
} else {
if (is.logical(future.scheduling)) {
stop_if_not(length(future.scheduling) == 1L, !is.na(future.scheduling))
if (future.scheduling) {
nbrOfChunks <- nbrOfWorkers
if (nbrOfChunks > nbrOfElements) nbrOfChunks <- nbrOfElements
} else {
nbrOfChunks <- nbrOfElements
}
} else {
## Treat 'future.scheduling' as the number of chunks per worker, i.e.
## the number of chunks each worker should process on average.
stop_if_not(length(future.scheduling) == 1L, !is.na(future.scheduling),
future.scheduling >= 0)
if (nbrOfWorkers > nbrOfElements) nbrOfWorkers <- nbrOfElements
nbrOfChunks <- future.scheduling * nbrOfWorkers
if (nbrOfChunks < 1L) {
nbrOfChunks <- 1L
} else if (nbrOfChunks > nbrOfElements) {
nbrOfChunks <- nbrOfElements
}
}
## Customized ordering?
ordering <- attr(future.scheduling, "ordering", exact = TRUE)
}
chunks <- splitIndices(nbrOfElements, ncl = nbrOfChunks)
## Customized ordering?
if (nbrOfElements > 1L && !is.null(ordering)) {
if (is.character(ordering) && ordering == "random") {
map <- stealth_sample.int(nbrOfElements)
} else if (is.numeric(ordering)) {
map <- ordering
} else if (is.function(ordering)) {
map <- ordering(nbrOfElements)
} else {
stopf("Unknown value of attribute %s for argument %s: %s", "ordering", if (!is.null(future.chunk.size)) "future.chunk.size" else "future.scheduling", mode(ordering))
}
if (!is.null(map)) {
## Simple validity check of "ordering". Looking for NAs, range,
## uniqueness is too expensive so skipped.
stop_if_not(length(map) == nbrOfElements)
attr(chunks, "ordering") <- map
}
}
chunks
}
================================================
FILE: R/options.R
================================================
#' Options used for future.apply
#'
#' Below are the \R options and environment variables that are used by the
#' \pkg{future.apply} package and packages enhancing it.\cr
#' \cr
#' _WARNING: Note that the names and the default values of these options may
#' change in future versions of the package. Please use with care until
#' further notice._
#'
#' For settings specific to the \pkg{future} package, see
#' [future::future.options] page.
#'
#' @section Options for debugging future.apply:
#' \describe{
#' \item{\option{future.apply.debug}:}{(logical) If `TRUE`, extensive debug messages are generated. (Default: `FALSE`)}
#' }
#'
#'
#' @section Environment variables that set R options:
#' All of the above \R \option{future.apply.*} options can be set by
#' corresponding environment variable \env{R_FUTURE_APPLY_*} _when the
#' \pkg{future.apply} package is loaded_.
#' For example, if `R_FUTURE_APPLY_DEBUG=TRUE`, then option
#' \option{future.apply.debug} is set to `TRUE` (logical).
#'
#' @examples
#' \dontrun{
#' options(future.apply.debug = TRUE)
#' }
#'
#' @seealso
#' To set \R options or environment variables when \R starts (even before the \pkg{future} package is loaded), see the \link[base]{Startup} help page. The \href{https://cran.r-project.org/package=startup}{\pkg{startup}} package provides a friendly mechanism for configuring \R's startup process.
#'
#' @aliases
#' future.apply.debug
#' R_FUTURE_APPLY_DEBUG
#'
#' @name future.apply.options
NULL
# Set an R option from an environment variable
update_package_option <- function(name, mode = "character", default = NULL, split = NULL, trim = TRUE, disallow = c("NA"), force = FALSE, debug = FALSE) {
## Nothing to do?
value <- getOption(name, NULL)
if (!force && !is.null(value)) return(getOption(name, default = default))
## name="future.plan.disallow" => env="R_FUTURE_PLAN_DISALLOW"
env <- gsub(".", "_", toupper(name), fixed = TRUE)
env <- paste("R_", env, sep = "")
env_value <- value <- Sys.getenv(env, unset = NA_character_)
## Nothing to do?
if (is.na(value)) {
if (debug) mdebugf("Environment variable %s not set", sQuote(env))
return(getOption(name, default = default))
}
if (debug) mdebugf("%s=%s", env, sQuote(value))
## Trim?
if (trim) value <- trim(value)
## Nothing to do?
if (!nzchar(value)) return(getOption(name, default = default))
## Split?
if (!is.null(split)) {
value <- strsplit(value, split = split, fixed = TRUE)
value <- unlist(value, use.names = FALSE)
if (trim) value <- trim(value)
}
## Coerce?
mode0 <- storage.mode(value)
if (mode0 != mode) {
suppressWarnings({
storage.mode(value) <- mode
})
if (debug) {
mdebugf("Coercing from %s to %s: %s", mode0, mode, commaq(value))
}
}
if (length(disallow) > 0) {
if ("NA" %in% disallow) {
if (any(is.na(value))) {
stopf("Coercing environment variable %s=%s to %s would result in missing values for option %s: %s", sQuote(env), sQuote(env_value), sQuote(mode), sQuote(name), commaq(value))
}
}
if (is.numeric(value)) {
if ("non-positive" %in% disallow) {
if (any(value <= 0, na.rm = TRUE)) {
stopf("Environment variable %s=%s specifies a non-positive value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value))
}
}
if ("negative" %in% disallow) {
if (any(value < 0, na.rm = TRUE)) {
stopf("Environment variable %s=%s specifies a negative value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value))
}
}
}
}
if (debug) {
mdebugf("=> options(%s = %s) [n=%d, mode=%s]",
dQuote(name), commaq(value),
length(value), storage.mode(value))
}
do.call(options, args = structure(list(value), names = name))
getOption(name, default = default)
}
## Set future options based on environment variables
update_package_options <- function(debug = FALSE) {
update_package_option("future.apply.chunkWith", default = "[[", debug = debug)
}
================================================
FILE: R/testme.R
================================================
## This runs 'testme' test inst/testme/test-<name>.R scripts
## Don't edit - it was autogenerated by inst/testme/deploy.R
testme <- function(name) {
path <- system.file(package = 'future.apply', 'testme', mustWork = TRUE)
Sys.setenv(R_TESTME_PATH = path)
Sys.setenv(R_TESTME_PACKAGE = 'future.apply')
Sys.setenv(R_TESTME_NAME = name)
on.exit(Sys.unsetenv('R_TESTME_NAME'))
source(file.path(path, 'run.R'))
}
================================================
FILE: R/utils,conditions.R
================================================
stopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint
msg <- sprintf(fmt, ...)
msg <- .makeMessage(msg, domain = domain)
if (is.call(call.)) {
call <- call.
} else if (isTRUE(call.)) {
call <- sys.call(which = -1L)
} else {
call <- NULL
}
cond <- simpleError(msg, call = call)
stop(cond)
}
warnf <- function(fmt, ..., call. = TRUE, immediate. = FALSE, domain = NULL) { #nolint
msg <- sprintf(fmt, ...)
## Cannot tweak 'call' when immediate. = TRUE
if (isTRUE(immediate.)) {
warning(msg, call. = call., immediate. = immediate., domain = domain)
} else {
msg <- .makeMessage(msg, domain = domain)
if (is.call(call.)) {
call <- call.
} else if (isTRUE(call.)) {
call <- sys.call(which = -1L)
} else {
call <- NULL
}
cond <- simpleWarning(msg, call = call)
warning(cond)
}
}
msgf <- function(fmt, ..., appendLF = FALSE, domain = NULL) { #nolint
message(sprintf(fmt, ...), appendLF = appendLF, domain = domain)
}
================================================
FILE: R/utils-debug.R
================================================
now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") {
## format(x, format = format) ## slower
format(as.POSIXlt(x, tz = ""), format = format)
}
debug_indent <- local({
symbols <- rep(c("|", ":", ".", "'", ",", ";", "`"), times = 10L)
function() {
depth <- length(.debug[["stack"]])
if (depth == 0) return("")
indent <- getOption("future.debug.indent", " ")
paste(paste(symbols[seq_len(depth)], indent, sep = ""), collapse = "")
}
})
if (!exists(".debug", inherits = FALSE)) .debug <- new.env(parent = emptyenv())
if (!"stack" %in% names(".debug")) .debug$stack <- list()
mdebug_push <- function(...) {
msg <- mdebug(...)
.debug$stack <- c(.debug$stack, msg)
invisible(msg)
}
mdebugf_push <- function(...) {
msg <- mdebugf(...)
.debug$stack <- c(.debug$stack, msg)
invisible(msg)
}
mdebug_pop <- function(...) {
n <- length(.debug$stack)
msg <- c(...)
if (length(msg) == 0) {
msg <- .debug$stack[n]
msg <- sprintf("%s done", msg)
}
.debug$stack <- .debug$stack[-n]
if (length(msg) == 0 || !is.na(msg)) mdebug(msg)
}
mdebugf_pop <- function(...) {
n <- length(.debug$stack)
msg <- .debug$stack[n]
.debug$stack <- .debug$stack[-n]
mdebug(sprintf("%s done", msg))
}
mdebug <- function(..., prefix = now()) {
prefix <- paste(prefix, debug_indent(), sep = "")
msg <- paste(..., sep = "")
message(sprintf("%s%s", prefix, msg))
invisible(msg)
}
mdebugf <- function(..., appendLF = TRUE, prefix = now()) {
prefix <- paste(prefix, debug_indent(), sep = "")
msg <- sprintf(...)
message(sprintf("%s%s", prefix, msg), appendLF = appendLF)
invisible(msg)
}
#' @importFrom utils capture.output
mprint <- function(..., appendLF = TRUE, prefix = now()) {
prefix <- paste(prefix, debug_indent(), sep = "")
message(paste(prefix, capture.output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
#' @importFrom utils capture.output str
mstr <- function(..., appendLF = TRUE, prefix = now()) {
prefix <- paste(prefix, debug_indent(), sep = "")
message(paste(prefix, capture.output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF)
}
================================================
FILE: R/utils.R
================================================
isFALSE <- function(x) {
is.logical(x) && length(x) == 1L && !is.na(x) && !x
}
isNA <- function(x) {
is.logical(x) && length(x) == 1L && is.na(x)
}
stop_if_not <- function(...) {
res <- list(...)
for (ii in 1L:length(res)) {
res_ii <- .subset2(res, ii)
if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) {
mc <- match.call()
call <- deparse(mc[[ii + 1]], width.cutoff = 60L)
if (length(call) > 1L) call <- paste(call[1L], "....")
stopf("%s is not TRUE", sQuote(call), call. = FALSE, domain = NA)
}
}
NULL
}
## From R.utils 2.0.2 (2015-05-23)
hpaste <- function(..., sep = "", collapse = ", ", lastCollapse = NULL, maxHead = if (missing(lastCollapse)) 3 else Inf, maxTail = if (is.finite(maxHead)) 1 else Inf, abbreviate = "...") {
if (is.null(lastCollapse)) lastCollapse <- collapse
# Build vector 'x'
x <- paste(..., sep = sep)
n <- length(x)
# Nothing todo?
if (n == 0) return(x)
if (is.null(collapse)) return(x)
# Abbreviate?
if (n > maxHead + maxTail + 1) {
head <- x[seq_len(maxHead)]
tail <- rev(rev(x)[seq_len(maxTail)])
x <- c(head, abbreviate, tail)
n <- length(x)
}
if (!is.null(collapse) && n > 1) {
if (lastCollapse == collapse) {
x <- paste(x, collapse = collapse)
} else {
xT <- paste(x[1:(n-1)], collapse = collapse)
x <- paste(xT, x[n], sep = lastCollapse)
}
}
x
} # hpaste()
trim <- function(s) sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s))
comma <- function(x, sep = ", ") paste(x, collapse = sep)
commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep)
if (getRversion() < "4.0.0") {
## When 'default' is specified, this is 30x faster than
## base::getOption(). The difference is that here we use
## use names(.Options) whereas in 'base' names(options())
## is used.
getOption <- local({
go <- base::getOption
function(x, default = NULL) {
if (missing(default) || match(x, table = names(.Options), nomatch = 0L) > 0L) go(x) else default
}
})
}
#' @importFrom future FutureError
#' @importFrom utils capture.output head str
assert_values2 <- function(nX, values, values2, fcn_name, debug = FALSE) {
if (length(values2) != nX) {
chunk_sizes <- sapply(values, FUN = length)
chunk_sizes <- table(chunk_sizes)
chunk_summary <- sprintf("%d chunks with %s elements",
chunk_sizes, names(chunk_sizes))
chunk_summary <- paste(chunk_summary, collapse = ", ")
msg <- sprintf("Unexpected error in %s(): After gathering and merging the values from %d chunks in to a list, the total number of elements (= %d) does not match the number of input elements in 'X' (= %d). There were in total %d chunks and %d elements (%s)", fcn_name, length(values), length(values2), nX, length(values), sum(chunk_sizes), chunk_summary)
if (debug) {
mdebug(msg)
mprint(chunk_sizes)
mdebug("Results before merge chunks:")
mstr(values)
mdebug("Results after merge chunks:")
mstr(values2)
}
msg <- sprintf("%s. Example of the first few values: %s", msg,
paste(capture.output(str(head(values2, 3L))),
collapse = "\\n"))
ex <- FutureError(msg)
stop(ex)
}
}
stealth_sample.int <- function(n, size = n, replace = FALSE, ...) {
oseed <- .GlobalEnv$.Random.seed
on.exit({
if (is.null(oseed)) {
rm(list = ".Random.seed", envir = .GlobalEnv, inherits = FALSE)
} else {
.GlobalEnv$.Random.seed <- oseed
}
})
sample.int(n = n, size = size, replace = replace, ...)
}
#' @importFrom utils packageVersion
future_version <- local({
ver <- NULL
function() {
if (is.null(ver)) ver <<- packageVersion("future")
ver
}
})
================================================
FILE: R/zzz.R
================================================
.package <- new.env()
## covr: skip=all
.onLoad <- function(libname, pkgname) {
.package[["version"]] <- utils::packageVersion(pkgname)
import_future_functions()
update_package_option("future.apply.debug", mode = "logical")
debug <- getOption("future.apply.debug", FALSE)
if (debug) {
envs <- Sys.getenv()
envs <- envs[grep("R_FUTURE_APPLY_", names(envs), fixed = TRUE)]
envs <- sprintf("- %s=%s", names(envs), sQuote(envs))
mdebug(paste(c("R environment variables specific to future.apply:", envs), collapse = "\n"))
}
## Set future options based on environment variables
update_package_options(debug = debug)
}
================================================
FILE: README.md
================================================
<div id="badges"><!-- pkgdown markup -->
<a href="https://CRAN.R-project.org/web/checks/check_results_future.apply.html"><img border="0" src="https://www.r-pkg.org/badges/version/future.apply" alt="CRAN check status"/></a> <a href="https://github.com/futureverse/future.apply/actions?query=workflow%3AR-CMD-check"><img border="0" src="https://github.com/futureverse/future.apply/actions/workflows/R-CMD-check.yaml/badge.svg?branch=develop" alt="R CMD check status"/></a> <a href="https://app.codecov.io/gh/futureverse/future.apply"><img border="0" src="https://codecov.io/gh/futureverse/future.apply/branch/develop/graph/badge.svg" alt="Coverage Status"/></a>
</div>
# future.apply: Apply Function to Elements in Parallel using Futures
## Introduction
The purpose of this package is to provide worry-free parallel alternatives to base-R "apply" functions, e.g. `apply()`, `lapply()`, and `vapply()`. The goal is that one should be able to replace any of these in the core with its futurized equivalent and things will just work. For example, instead of doing:
```r
library(datasets)
library(stats)
y <- lapply(mtcars, FUN = mean, trim = 0.10)
```
one can do:
```r
library(future.apply)
plan(multisession) ## Run in parallel on local computer
library(datasets)
library(stats)
y <- future_lapply(mtcars, FUN = mean, trim = 0.10)
```
Reproducibility is part of the core design, which means that perfect, parallel random number generation (RNG) is supported regardless of the amount of chunking, type of load balancing, and future backend being used. To enable parallel RNG, use argument `future.seed = TRUE`.
## Role
Where does the **[future.apply]** package fit in the software stack? You can think of it as a sibling to **[foreach]**, **[furrr]**, **[BiocParallel]**, **[plyr]**, etc. Just as **parallel** provides `parLapply()`, **foreach** provides `foreach()`, **BiocParallel** provides `bplapply()`, and **plyr** provides `llply()`, **future.apply** provides `future_lapply()`. Below is a table summarizing this idea:
<table>
<tr>
<th>Package</th>
<th>Functions</th>
<th>Backends</th>
</tr>
<tr style="vertical-align: top">
<td>
<a href="https://cran.r-project.org/package=future.apply"><strong>future.apply</strong></a><br>
<br>
</td>
<td>
Future-versions of common goto <code>*apply()</code> functions available in base R (of the <strong>base</strong> and <strong>stats</strong> packages):<br>
<code>future_apply()</code>,
<code>future_by()</code>,
<code>future_eapply()</code>,
<code>future_Filter()</code>,
<code>future_lapply()</code>,
<code>future_kernapply()</code>,
<code>future_Map()</code>,
<code>future_mapply()</code>,
<code>future_.mapply()</code>,
<code>future_replicate()</code>,
<code>future_sapply()</code>,
<code>future_tapply()</code>, and
<code>future_vapply()</code>.
<br>
<em>The following function is not implemented:</em><br>
<code>future_rapply()</code><br>
</td>
<td>
All <strong>future</strong> backends
</td>
</tr>
<tr style="vertical-align: top">
<td>
<strong>parallel</strong>
</td>
<td>
<code>mclapply()</code>, <code>mcmapply()</code>,
<code>clusterMap()</code>, <code>parApply()</code>, <code>parLapply()</code>, <code>parSapply()</code>, ...
</td>
<td>
Built-in and conditional on operating system</a>
</td>
</tr>
<tr style="vertical-align: top">
<td>
<a href="https://cran.r-project.org/package=foreach"><strong>foreach</strong></a>
</td>
<td>
<code>foreach()</code>,
<code>times()</code>
</td>
<td>
All <strong>future</strong> backends via <a href="https://cran.r-project.org/package=doFuture"><strong>doFuture</strong></a>
</td>
</tr>
<tr style="vertical-align: top">
<td>
<a href="https://cran.r-project.org/package=furrr"><strong>furrr</strong></a>
</td>
<td>
<code>future_imap()</code>,
<code>future_map()</code>,
<code>future_pmap()</code>,
<code>future_map2()</code>,
...
</td>
<td>
All <strong>future</strong> backends
</td>
</tr>
<tr style="vertical-align: top">
<td>
<a href="https://bioconductor.org/packages/release/bioc/html/BiocParallel.html"><strong>BiocParallel</strong></a>
</td>
<td>
Bioconductor's parallel mappers:<br>
<code>bpaggregate()</code>,
<code>bpiterate()</code>,
<code>bplapply()</code>, and
<code>bpvec()</code>
</td>
<td>
All <strong>future</strong> backends via <a href="https://cran.r-project.org/package=doFuture"><strong>doFuture</strong></a> (because it supports <strong>foreach</strong>) or via <a href="https://github.com/futureverse/BiocParallel.FutureParam"><strong>BiocParallel.FutureParam</strong></a> (direct BiocParallelParam support; prototype)
</td>
</tr>
<tr style="vertical-align: top">
<td>
<a href="https://cran.r-project.org/package=plyr"><strong>plyr</strong></a>
</td>
<td>
<code>**ply(..., .parallel = TRUE)</code> functions:<br>
<code>aaply()</code>,
<code>ddply()</code>,
<code>dlply()</code>,
<code>llply()</code>, ...
</td>
<td>
All <strong>future</strong> backends via <a href="https://cran.r-project.org/package=doFuture"><strong>doFuture</strong></a> (because it uses <strong>foreach</strong> internally)
</td>
</tr>
</table>
Note that, except for the built-in **parallel** package, none of these higher-level APIs implement their own parallel backends, but they rather enhance existing ones. The **foreach** framework leverages backends such as **[doParallel]**, **[doMC]** and **[doFuture]**, and the **future.apply** framework leverages the **[future]** ecosystem and therefore backends such as built-in **parallel**, **[future.callr]**, and **[future.batchtools]**.
By separating `future_lapply()` and friends from the **[future]** package, it helps clarifying the purpose of the **future** package, which is to define and provide the core Future API, which higher-level parallel APIs can build on and for which any futurized parallel backends can be plugged into.
The API and identity of the **future.apply** package will be kept close to the `*apply()` functions in base R. In other words, it will _neither_ keep growing nor be expanded with new, more powerful apply-like functions beyond those core ones in base R. Such extended functionality should be part of a separate package.
[batchtools]: https://cran.r-project.org/package=batchtools
[BiocParallel]: https://bioconductor.org/packages/BiocParallel/
[doFuture]: https://cran.r-project.org/package=doFuture
[doMC]: https://cran.r-project.org/package=doMC
[doParallel]: https://cran.r-project.org/package=doParallel
[foreach]: https://cran.r-project.org/package=foreach
[future]: https://cran.r-project.org/package=future
[future.apply]: https://cran.r-project.org/package=future.apply
[future.batchtools]: https://cran.r-project.org/package=future.batchtools
[future.callr]: https://cran.r-project.org/package=future.callr
[furrr]: https://cran.r-project.org/package=furrr
[plyr]: https://cran.r-project.org/package=plyr
## Installation
R package future.apply is available on [CRAN](https://cran.r-project.org/package=future.apply) and can be installed in R as:
```r
install.packages("future.apply")
```
### Pre-release version
To install the pre-release version that is available in Git branch `develop` on GitHub, use:
```r
remotes::install_github("futureverse/future.apply", ref="develop")
```
This will install the package from source.
<!-- pkgdown-drop-below -->
## Contributing
To contribute to this package, please see [CONTRIBUTING.md](CONTRIBUTING.md).
================================================
FILE: cran-comments.md
================================================
# CRAN submission future.apply 1.11.3
on 2024-10-27
I've verified this submission has no negative impact on any of the 168 reverse package dependencies available on CRAN (n=161) and Bioconductor (n=7).
## Notes not sent to CRAN
### R CMD check validation
The package has been verified using `R CMD check --as-cran` on:
| R version | GitHub | mac/win-builder |
| ------------- | ------ | --------------- |
| 3.6.x | L | |
| 4.1.x | L | |
| 4.2.x | L | |
| 4.3.x | L M W | W |
| 4.4.x | L M W | M1 W |
| devel | L M W | W |
*Legend: OS: L = Linux, M = macOS, M1 = macOS M1, W = Windows*
It has also be verified using various R-hub v2 checks.
================================================
FILE: incl/OVERVIEW.md
================================================
<%
## Reuse the main vignette
md <- R.rsp::rstring(file="vignettes/future.apply-1-overview.md.rsp", postprocess=FALSE)
## Drop the header, i.e. anything before the first "H2" header
md <- unlist(strsplit(md, split="\n", fixed=TRUE))
row <- grep("^## ", md)[1]
if (!is.na(row)) md <- md[-seq_len(row-1)]
## Drop the footer, i.e. anything after the first horizontal line
row <- grep("^---", md)[1]
if (!is.na(row)) md <- md[seq_len(row-1)]
## Turn otherwise local links to CRAN for README.md
md <- gsub(": (future-.*[.]html)",
": https://cran.r-project.org/web/packages/future.apply/vignettes/\\1", md)
## Output
cat(md, sep="\n")
%>
================================================
FILE: incl/future_Filter.R
================================================
## ---------------------------------------------------------
## Filter()
## ---------------------------------------------------------
is_even <- function(x) { x %% 2 == 0 }
x <- sample.int(100, size = 1000, replace = TRUE)
y <- future_Filter(is_even, x)
================================================
FILE: incl/future_apply.R
================================================
## ---------------------------------------------------------
## apply()
## ---------------------------------------------------------
X <- matrix(c(1:4, 1, 6:8), nrow = 2L)
Y0 <- apply(X, MARGIN = 1L, FUN = table)
Y1 <- future_apply(X, MARGIN = 1L, FUN = table)
print(Y1)
stopifnot(all.equal(Y1, Y0, check.attributes = FALSE)) ## FIXME
Y0 <- apply(X, MARGIN = 1L, FUN = stats::quantile)
Y1 <- future_apply(X, MARGIN = 1L, FUN = stats::quantile)
print(Y1)
stopifnot(all.equal(Y1, Y0))
## ---------------------------------------------------------
## Parallel Random Number Generation
## ---------------------------------------------------------
\donttest{
## Regardless of the future plan, the number of workers, and
## where they are, the random numbers produced are identical
X <- matrix(c(1:4, 1, 6:8), nrow = 2L)
plan(multisession)
set.seed(0xBEEF)
Y1 <- future_apply(X, MARGIN = 1L, FUN = sample, future.seed = TRUE)
print(Y1)
plan(sequential)
set.seed(0xBEEF)
Y2 <- future_apply(X, MARGIN = 1L, FUN = sample, future.seed = TRUE)
print(Y2)
stopifnot(all.equal(Y1, Y2))
}
\dontshow{
## R CMD check: make sure any open connections are closed afterward
if (!inherits(plan(), "sequential")) plan(sequential)
}
================================================
FILE: incl/future_by.R
================================================
## ---------------------------------------------------------
## by()
## ---------------------------------------------------------
library(datasets) ## warpbreaks
library(stats) ## lm()
y0 <- by(warpbreaks, warpbreaks[,"tension"],
function(x) lm(breaks ~ wool, data = x))
plan(multisession)
y1 <- future_by(warpbreaks, warpbreaks[,"tension"],
function(x) lm(breaks ~ wool, data = x))
plan(sequential)
y2 <- future_by(warpbreaks, warpbreaks[,"tension"],
function(x) lm(breaks ~ wool, data = x))
================================================
FILE: incl/future_lapply.R
================================================
## ---------------------------------------------------------
## lapply(), sapply(), tapply()
## ---------------------------------------------------------
x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE, FALSE, FALSE, TRUE))
y0 <- lapply(x, FUN = quantile, probs = 1:3/4)
y1 <- future_lapply(x, FUN = quantile, probs = 1:3/4)
print(y1)
stopifnot(all.equal(y1, y0))
y0 <- sapply(x, FUN = quantile)
y1 <- future_sapply(x, FUN = quantile)
print(y1)
stopifnot(all.equal(y1, y0))
y0 <- vapply(x, FUN = quantile, FUN.VALUE = double(5L))
y1 <- future_vapply(x, FUN = quantile, FUN.VALUE = double(5L))
print(y1)
stopifnot(all.equal(y1, y0))
## ---------------------------------------------------------
## Parallel Random Number Generation
## ---------------------------------------------------------
\donttest{
## Regardless of the future plan, the number of workers, and
## where they are, the random numbers produced are identical
plan(multisession)
set.seed(0xBEEF)
y1 <- future_lapply(1:5, FUN = rnorm, future.seed = TRUE)
str(y1)
plan(sequential)
set.seed(0xBEEF)
y2 <- future_lapply(1:5, FUN = rnorm, future.seed = TRUE)
str(y2)
stopifnot(all.equal(y1, y2))
}
## ---------------------------------------------------------
## Process chunks of data.frame rows in parallel
## ---------------------------------------------------------
iris <- datasets::iris
chunks <- split(iris, seq(1, nrow(iris), length.out = 3L))
y0 <- lapply(chunks, FUN = function(iris) sum(iris$Sepal.Length))
y0 <- do.call(sum, y0)
y1 <- future_lapply(chunks, FUN = function(iris) sum(iris$Sepal.Length))
y1 <- do.call(sum, y1)
print(y1)
stopifnot(all.equal(y1, y0))
## ---------------------------------------------------------
## Remember to pass down '...' arguments
## ---------------------------------------------------------
## It is important that we don't use '...' as a global variable,
## as attempted in the following not_okay_fcn()
bad_fcn <- function(X, ...) {
y <- future_lapply(X, FUN = function(x) {
mean(x, ...) ## here '...' is a global variable
})
y
}
## Instead, make sure to pass '...' via arguments all the way through
good_fcn <- function(X, ...) { ## outer '...'
y <- future_lapply(X, FUN = function(x, ...) {
mean(x, ...) ## here '...' is an argument of FUN()
}, ...) ## pass outer '...' to FUN()
y
}
\dontshow{
## R CMD check: make sure any open connections are closed afterward
if (!inherits(plan(), "sequential")) plan(sequential)
}
================================================
FILE: incl/future_mapply.R
================================================
## ---------------------------------------------------------
## mapply()
## ---------------------------------------------------------
y0 <- mapply(rep, 1:4, 4:1)
y1 <- future_mapply(rep, 1:4, 4:1)
stopifnot(identical(y1, y0))
y0 <- mapply(rep, times = 1:4, x = 4:1)
y1 <- future_mapply(rep, times = 1:4, x = 4:1)
stopifnot(identical(y1, y0))
y0 <- mapply(rep, times = 1:4, MoreArgs = list(x = 42))
y1 <- future_mapply(rep, times = 1:4, MoreArgs = list(x = 42))
stopifnot(identical(y1, y0))
y0 <- mapply(function(x, y) seq_len(x) + y,
c(a = 1, b = 2, c = 3), # names from first
c(A = 10, B = 0, C = -10))
y1 <- future_mapply(function(x, y) seq_len(x) + y,
c(a = 1, b = 2, c = 3), # names from first
c(A = 10, B = 0, C = -10))
stopifnot(identical(y1, y0))
word <- function(C, k) paste(rep.int(C, k), collapse = "")
y0 <- mapply(word, LETTERS[1:6], 6:1, SIMPLIFY = FALSE)
y1 <- future_mapply(word, LETTERS[1:6], 6:1, SIMPLIFY = FALSE)
stopifnot(identical(y1, y0))
## ---------------------------------------------------------
## Parallel Random Number Generation
## ---------------------------------------------------------
\donttest{
## Regardless of the future plan, the number of workers, and
## where they are, the random numbers produced are identical
plan(multisession)
set.seed(0xBEEF)
y1 <- future_mapply(stats::runif, n = 1:4, max = 2:5,
MoreArgs = list(min = 1), future.seed = TRUE)
print(y1)
plan(sequential)
set.seed(0xBEEF)
y2 <- future_mapply(stats::runif, n = 1:4, max = 2:5,
MoreArgs = list(min = 1), future.seed = TRUE)
print(y2)
stopifnot(all.equal(y1, y2))
}
\dontshow{
## R CMD check: make sure any open connections are closed afterward
if (!inherits(plan(), "sequential")) plan(sequential)
}
================================================
FILE: incl/make_rng_seeds.R
================================================
## Set up L'Ecuyer-CMRG random seeds for 100 parallel tasks
## based on .Random.seed in the current R process
seeds <- make_rng_seeds(100L, seed = TRUE)
str(seeds)
================================================
FILE: incl/random_seed_utils.R
================================================
## This example gives identical results in the two
## approaches only if .Random.seed already exists
seed_org <- next_random_seed()
set.seed(42)
## Draw two random number from 1:100 one after the other
seed_before <- get_random_seed()
x <- sample.int(100L, size = 1L)
y <- sample.int(100L, size = 1L)
seed_after <- get_random_seed()
print(c(x, y))
## Draw two random number from 1:100 at once
set_random_seed(seed_before)
z <- sample.int(100L, size = 2L)
seed_after2 <- get_random_seed()
print(z)
## The RNG state is the same after the second ...
## run as after the first, two-step, approach
stopifnot(identical(seed_after2, seed_after))
## .... and the exact same set of random numbers where
## drawn [only true in R (>= 4.0.0)]
if (getRversion() >= "4.0.0") {
stopifnot(identical(z, c(x, y)))
} else {
stopifnot(identical(z[seq_along(x)], x))
}
set_random_seed(seed_org)
stopifnot(identical(get_random_seed(), seed_org))
================================================
FILE: inst/CITATION
================================================
utils::bibentry(
header = "Please cite 'future' and the future framework using the following references:",
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# BibTeX entry:
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bibtype = "article",
key = "RJ-2021-048",
author = "Henrik Bengtsson",
title = "A Unifying Framework for Parallel and Distributed Processing in R using Futures",
year = "2021",
journal = "The R Journal",
doi = "10.32614/RJ-2021-048",
url = "https://doi.org/10.32614/RJ-2021-048",
pages = "208--227",
volume = "13",
number = "2",
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Plain-text citation:
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
textVersion = paste0(
"Henrik Bengtsson, ",
"A Unifying Framework for Parallel and Distributed Processing in R using Futures, ",
"The R Journal (2021) 13:2, pages 208-227, ",
"doi:10.32614/RJ-2021-048"
)
)
================================================
FILE: inst/WORDLIST
================================================
AppVeyor
arity
batchtools
benchmarking
BiocParallel
callr
CMD
CMRG
doFuture
doMC
doParallel
eapply
foreach
furrr
futurized
globals
HPC
L'Ecuyer
lapply
macOS
mapply
md
plyr
pre
Pre
pregenerating
reproducibility
Reproducibility
Roadmap
sapply
SGE
Slurm
stringsAsFactors
tapply
vapply
vectorize
================================================
FILE: inst/testme/_epilogue/001.undo-future.R
================================================
## Undo future debug
options(future.debug = FALSE)
## Undo future strategy
future::plan(oplan)
================================================
FILE: inst/testme/_epilogue/002.undo-state.R
================================================
testme <- as.environment("testme")
hpaste <- future:::hpaste
## Undo options
## (a) Reset
options(oopts0)
## (b) Remove added
local({
added <- setdiff(names(options()), names(oopts0))
opts <- vector("list", length = length(added))
names(opts) <- added
options(opts)
})
## (c) Assert that everything was undone
if (!identical(options(), oopts0)) {
message("Failed to undo options:")
oopts <- options()
message(sprintf(" - Expected options: [n=%d] %s",
length(oopts0), hpaste(sQuote(names(oopts0)))))
extra <- setdiff(names(oopts), names(oopts0))
message(paste(sprintf(" - Options still there: [n=%d]", length(extra)),
hpaste(sQuote(extra))))
missing <- setdiff(names(oopts0), names(oopts))
message(paste(sprintf(" - Options missing: [n=%d]", length(missing)),
hpaste(sQuote(missing))))
message("Differences option by option:")
void <- lapply(names(oopts0), FUN = function(name) {
value0 <- oopts0[[name]]
value <- oopts[[name]]
if (!identical(value, value0)) {
if (testme[["debug"]]) {
utils::str(list(name = name, expected = value0, actual = value))
}
}
})
}
## Undo system environment variables
## (a) Reset
do.call(Sys.setenv, args=as.list(oenvs0))
## (b) Removed added
added <- setdiff(names(Sys.getenv()), names(oenvs0))
Sys.unsetenv(added)
## (c) Assert that everything was undone
if (!identical(Sys.getenv(), oenvs0)) {
message("Failed to undo environment variables:")
oenvs <- Sys.getenv()
message(sprintf(" - Expected environment variables: [n=%d] %s",
length(oenvs0), hpaste(sQuote(names(oenvs0)))))
extra <- setdiff(names(oenvs), names(oenvs0))
message(paste(sprintf(" - Environment variables still there: [n=%d]", length(extra)),
hpaste(sQuote(extra))))
missing <- setdiff(names(oenvs0), names(oenvs))
message(paste(sprintf(" - Environment variables missing: [n=%d]", length(missing)),
hpaste(sQuote(missing))))
message("Differences environment variable by environment variable:")
void <- lapply(names(oenvs0), FUN = function(name) {
value0 <- unname(oenvs0[name])
value <- unname(oenvs[name])
if (!identical(value, value0)) {
if (testme[["debug"]]) {
utils::str(list(name = name, expected = value0, actual = value))
}
}
})
}
## Assert undo was successful
if (testme[["debug"]]) {
stopifnot(identical(options(), oopts0))
}
## Undo variables
rm(list = c(setdiff(ls(envir = globalenv()), ovars)), envir = globalenv())
================================================
FILE: inst/testme/_epilogue/090.gc.R
================================================
## Travis CI specific: Explicit garbage collection because it
## looks like Travis CI might run out of memory during 'covr'
## testing and we now have so many tests. /HB 2017-01-11
if ("covr" %in% loadedNamespaces()) {
res <- gc()
testme <- as.environment("testme")
if (testme[["debug"]]) print(res)
}
================================================
FILE: inst/testme/_epilogue/099.session_info.R
================================================
testme <- as.environment("testme")
if (testme[["debug"]]) {
info <- utils::sessionInfo()
message("Session information:")
print(info)
}
================================================
FILE: inst/testme/_epilogue/995.detritus-connections.R
================================================
## Look for detritus files
testme <- as.environment("testme")
local({
delta <- diff_connections(get_connections(), testme[["testme_connections"]])
if (any(lengths(delta) > 0)) {
message(sprintf("Detritus connections generated by test %s:", sQuote(testme[["name"]])))
print(delta)
}
})
================================================
FILE: inst/testme/_epilogue/999.detritus-files.R
================================================
## Look for detritus files
testme <- as.environment("testme")
local({
path <- dirname(tempdir())
if (basename(path) == "working_dir") {
files <- dir(pattern = "^Rscript", path = path, all.files = TRUE, full.names = TRUE)
if (length(files) > 0L) {
message(sprintf("Detritus 'Rscript*' files generated by test %s:", sQuote(testme[["name"]])))
print(files)
## Remove detritus files produced by this test script, so that
## other test scripts will not fail because of these files.
unlink(files)
## Signal the problem
msg <- sprintf("Detected 'Rscript*' files: [n=%d] %s", length(files), paste(sQuote(basename(files)), collapse = ", "))
## Are detritus files files expected by design on MS Windows?
## If so, produce a warning, otherwise an error
if ("detritus-files" %in% testme[["tags"]] &&
.Platform[["OS.type"]] == "windows") {
warning(msg, immediate. = TRUE)
} else {
stop(msg)
}
}
} else {
message(sprintf("Skipping, because path appears not to be an 'R CMD check' folder: %s", sQuote(path)))
}
})
================================================
FILE: inst/testme/_prologue/001.load.R
================================================
testme <- as.environment("testme")
loadNamespace(testme[["package"]])
================================================
FILE: inst/testme/_prologue/002.record-state.R
================================================
## Record original state
ovars <- ls(envir = globalenv())
oenvs <- oenvs0 <- Sys.getenv()
oopts0 <- options()
================================================
FILE: inst/testme/_prologue/030.imports.R
================================================
## Private future functions
fold <- future.apply:::fold
hpaste <- future.apply:::hpaste
mdebug <- future.apply:::mdebug
mdebugf <- future.apply:::mdebugf
import_from <- future.apply:::import_from
get_random_seed <- future.apply:::get_random_seed
set_random_seed <- future.apply:::set_random_seed
next_random_seed <- future.apply:::next_random_seed
as_lecyer_cmrg_seed <- future.apply:::as_lecyer_cmrg_seed
is_lecyer_cmrg_seed <- future.apply:::is_lecyer_cmrg_seed
make_rng_seeds <- future.apply:::make_rng_seeds
================================================
FILE: inst/testme/_prologue/050.utils.R
================================================
## Local functions for test scripts
printf <- function(...) cat(sprintf(...))
mstr <- function(...) message(paste(capture.output(str(...)), collapse = "\n"))
================================================
FILE: inst/testme/_prologue/090.context.R
================================================
fullTest <- (Sys.getenv("_R_CHECK_FULL_") != "")
covr_testing <- ("covr" %in% loadedNamespaces())
on_macos <- grepl("^darwin", R.version$os)
on_githubactions <- as.logical(Sys.getenv("GITHUB_ACTIONS", "FALSE"))
================================================
FILE: inst/testme/_prologue/090.options.R
================================================
## Default options
oopts <- options(
warn = 1L,
showNCalls = 500L,
mc.cores = 2L,
future.debug = FALSE,
## Reset the following during testing in case
## they are set on the test system
future.availableCores.system = NULL,
future.availableCores.fallback = NULL
)
================================================
FILE: inst/testme/_prologue/091.envvars.R
================================================
## Comment: The below should be set automatically whenever the future package
## is loaded and 'R CMD check' runs. The below is added in case R is changed
## in the future and we fail to detect 'R CMD check'.
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_CONNECTTIMEOUT = 2 * 60)
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_TIMEOUT = 2 * 60)
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_SESSIONINFO_PKGS = TRUE)
Sys.setenv(R_FUTURE_WAIT_INTERVAL = 0.01) ## 0.01s (instead of default 0.2s)
## Label PSOCK cluster workers (to help troubleshooting)
test_script <- grep("[.]R$", commandArgs(), value = TRUE)[1]
if (is.na(test_script)) test_script <- "UNKNOWN"
worker_label <- sprintf("future/tests/%s:%s:%s:%s", test_script, Sys.info()[["nodename"]], Sys.info()[["user"]], Sys.getpid())
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_RSCRIPT_LABEL = worker_label)
## Reset the following during testing in case
## they are set on the test system
oenvs2 <- Sys.unsetenv(c(
"R_PARALLELLY_AVAILABLECORES_SYSTEM",
"R_PARALLELLY_AVAILABLECORES_FALLBACK",
## SGE
"NSLOTS", "PE_HOSTFILE",
## Slurm
"SLURM_CPUS_PER_TASK",
## TORQUE / PBS
"NCPUS", "PBS_NUM_PPN", "PBS_NODEFILE", "PBS_NP", "PBS_NUM_NODES"
))
================================================
FILE: inst/testme/_prologue/099.future-setup.R
================================================
## Use sequential futures by default
oplan <- local({
oopts <- options(future.debug = FALSE)
on.exit(options(oopts))
future::plan(future::sequential)
})
supportedStrategies <- function(cores = NA_integer_, excl = "cluster", ...) {
strategies <- future:::supportedStrategies(...)
strategies <- setdiff(strategies, excl)
if (!is.na(cores)) {
if (cores == 1L) {
strategies <- setdiff(strategies, c("multicore", "multisession"))
} else if (cores > 1L) {
strategies <- setdiff(strategies, "sequential")
}
}
strategies
}
availCores <- min(2L, future::availableCores())
================================================
FILE: inst/testme/_prologue/995.detrius-connections.R
================================================
get_connections <- function() {
cons <- lapply(getAllConnections(), FUN = function(idx) {
tryCatch({
con <- getConnection(idx)
as.data.frame(c(index = idx, summary(con)))
}, error = function(e) {
NULL
})
})
do.call(rbind, cons)
}
diff_connections <- function(after, before) {
index <- NULL ## To please R CMD check
## Nothing to do?
if (length(before) + length(after) == 0L) {
return(c(added = NULL, removed = NULL, replaced = NULL))
}
idxs <- setdiff(after[["index"]], before[["index"]])
if (length(idxs) > 0) {
added <- subset(after, index %in% idxs)
after <- subset(after, ! index %in% idxs)
} else {
added <- NULL
}
idxs <- setdiff(before[["index"]], after[["index"]])
if (length(idxs) > 0) {
removed <- subset(before, index %in% idxs)
before <- subset(before, ! index %in% idxs)
} else {
removed <- NULL
}
idxs <- intersect(before[["index"]], after[["index"]])
if (length(idxs) > 0) {
replaced <- list()
for (idx in idxs) {
before_idx <- subset(before, index == idx)
after_idx <- subset(after, index == idx)
if (!identical(before_idx, after_idx)) {
for (name in colnames(after_idx)) {
value <- after_idx[[name]]
if (!identical(before_idx[[name]], value)) {
value <- sprintf("%s (was %s)", value, before_idx[[name]])
after_idx[[name]] <- value
}
}
replaced <- c(replaced, list(after_idx))
}
}
replaced <- do.call(rbind, replaced)
} else {
replaced <- NULL
}
list(added = added, removed = removed, replaced = replaced)
}
testme <- as.environment("testme")
testme[["testme_connections"]] <- get_connections()
================================================
FILE: inst/testme/deploy.R
================================================
#!/usr/bin/env Rscript
source <- "./inst/testme"
if (!utils::file_test("-d", source)) {
stop("Source 'testme' folder not found: ", sQuote(source))
}
target <- "./tests"
if (!utils::file_test("-d", target)) {
stop("Target 'tests' folder not found: ", sQuote(target))
}
r_path <- "./R"
if (!utils::file_test("-d", r_path)) {
stop("Target 'R' folder not found: ", sQuote(r_path))
}
desc <- "./DESCRIPTION"
if (!utils::file_test("-f", desc)) {
stop("'DESCRIPTION' file not found: ", sQuote(desc))
}
pkgname <- read.dcf(desc)[, "Package"]
if (is.na(pkgname) || !nzchar(pkgname)) {
stop("Failed to infer package name from 'DESCRIPTION' file: ", sQuote(pkgname))
} else if (!requireNamespace(pkgname)) {
stop("Package fail to load: ", sQuote(pkgname))
}
files <- dir(path = source, pattern = "^test-.*[.]R$", full.names = TRUE)
message(sprintf("Deploying %d test scripts ...", length(files)))
## Generate R unit test script
code <- c(
"## This runs 'testme' test inst/testme/test-<name>.R scripts",
"## Don't edit - it was autogenerated by inst/testme/deploy.R",
"testme <- function(name) {",
sprintf(" path <- system.file(package = '%s', 'testme', mustWork = TRUE)", pkgname),
" Sys.setenv(R_TESTME_PATH = path)",
sprintf(" Sys.setenv(R_TESTME_PACKAGE = '%s')", pkgname),
" Sys.setenv(R_TESTME_NAME = name)",
" on.exit(Sys.unsetenv('R_TESTME_NAME'))",
" source(file.path(path, 'run.R'))",
"}"
)
writeLines(code, con = file.path("./R/testme.R"))
for (kk in seq_along(files)) {
file <- files[kk]
source_file <- basename(file)
name <- sub("^test-", "", sub("[.]R$", "", source_file))
target_file <- file.path(target, source_file)
message(sprintf("%02d/%02d test script %s", kk, length(files), sQuote(target_file)))
## Assert that testme script can be parsed
res <- tryCatch(parse(file = file), error = identity)
if (inherits(res, "error")) {
stop("Syntax error: ", sQuote(file))
}
## Generate R unit test script
code <- c(
"#! /usr/bin/env Rscript",
sprintf("## This runs testme test script inst/testme/test-%s.R", name),
"## Don't edit - it was autogenerated by inst/testme/deploy.R",
sprintf('%s:::testme("%s")', pkgname, name)
)
writeLines(code, con = target_file)
Sys.chmod(target_file, mode = "0755")
}
message(sprintf("Deploying %d test scripts ... done", length(files)))
================================================
FILE: inst/testme/run.R
================================================
#!/usr/bin/env Rscript
#' Run a 'testme' Test Script
#'
#' R usage:
#' testme("<name>")
#'
#' Command-line usage:
#' tests/test-<name>.R
#'
#' Command-line usage without package re-install:
#' inst/testme/run.R --name=<test_name>
#' inst/testme/run.R <test-name.R>
#'
#' Options:
#' --package=<pkg> The name of the package being tested
#' (Environment variable: `R_TESTME_PACKAGE`)
#' (Default: The `Package` field of the DESCRIPTION file)
#' --name=<name> The name of the test to run, used to locate the test
#' script `test-<name>.R`
#' (Environment variable: `R_TESTME_NAME`)
#' --not-cran Set environment variable `NOT_CRAN=true`
#' --coverage=summary Estimate test code coverage with basic summary
#' --coverage=tally Estimate test code coverage with full tally summary
#' --coverage=report Estimate test code coverage with full HTML report
#' --debug Output debug messages
#' (Environment variable: `R_TESTME_DEBUG`)
#'
#' Examples:
#' testme/test-abc.R
#' testme/test-abc.R --not-cran
#' tests/test-cpuLoad.R --coverage=report
#'
#' inst/testme/run.R inst/testme/test-abc.R
#' inst/testme/run.R inst/testme/test-abc.R --coverage
#'
#' Environment variables:
#' * R_TESTME_PACKAGE
#' * R_TESTME_NAME
#' * R_TESTME_PATH
#' * R_TESTME_FILTER_NAME
#' * R_TESTME_FILTER_TAGS
#' * R_TESTME_COVERAGE
#' * R_TESTME_DEBUG
main <- function() {
cmd_args <- commandArgs(trailingOnly = TRUE)
pattern <- "--package=([[:alpha:][:alnum:]]+)"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
stopifnot(length(idx) == 1L)
testme_package <- gsub(pattern, "\\1", cmd_args[idx])
cmd_args <- cmd_args[-idx]
} else {
testme_package <- Sys.getenv("R_TESTME_PACKAGE", NA_character_)
if (is.na(testme_package)) {
desc <- read.dcf("DESCRIPTION")
testme_package <- desc[1, "Package"]
}
}
pattern <- "--path=([[:alpha:][:alnum:]]+)"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
stopifnot(length(idx) == 1L)
path <- gsub(pattern, "\\1", cmd_args[idx])
cmd_args <- cmd_args[-idx]
} else {
path <- Sys.getenv("R_TESTME_PATH", NA_character_)
if (is.na(path)) {
path <- file.path("inst", "testme")
}
if (!utils::file_test("-d", path)) {
stop("There exist no such 'R_TESTME_PATH' folder: ", sQuote(path))
}
}
pattern <- "--name=([[:alpha:][:alnum:]]+)"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
stopifnot(length(idx) == 1L)
testme_name <- gsub(pattern, "\\1", cmd_args[idx])
cmd_args <- cmd_args[-idx]
} else {
testme_name <- NULL
}
pattern <- "^--not-cran"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
cmd_args <- cmd_args[-idx]
Sys.setenv(NOT_CRAN = "TRUE")
}
pattern <- "^--debug"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
cmd_args <- cmd_args[-idx]
Sys.setenv(R_TESTME_DEBUG = "TRUE")
}
pattern <- "^--coverage(|=([[:alpha:][:alnum:]]+))$"
idx <- grep(pattern, cmd_args)
if (length(idx) > 0L) {
value <- gsub(pattern, "\\2", cmd_args[idx])
if (!nzchar(value)) {
coverage <- "summary"
} else {
coverage <- match.arg(value, choices = c("none", "summary", "tally", "report"))
}
cmd_args <- cmd_args[-idx]
} else {
value <- Sys.getenv("R_TESTME_COVERAGE", "none")
coverage <- match.arg(value, choices = c("none", "summary", "tally", "report"))
}
if (coverage != "none") {
if (!utils::file_test("-f", "DESCRIPTION")) {
stop("Current folder does not look like a package folder")
}
}
## Fallback for 'testme_name'?
if (is.null(testme_name)) {
if (length(cmd_args) > 0) {
stopifnot(length(cmd_args) == 1L)
file <- cmd_args[1]
if (utils::file_test("-f", file)) {
testme_name <- gsub("(^test-|[.]R$)", "", basename(file))
} else {
stop("No such file: ", file)
}
} else {
testme_name <- Sys.getenv("R_TESTME_NAME", NA_character_)
if (is.na(testme_name)) {
stop("testme: Environment variable 'R_TESTME_NAME' is not set")
}
}
}
testme_file <- file.path(path, sprintf("test-%s.R", testme_name))
if (!utils::file_test("-f", testme_file)) {
stop("There exist no such 'testme' file: ", sQuote(testme_file))
}
## -----------------------------------------------------------------
## testme environment
## -----------------------------------------------------------------
on_cran <- function() {
not_cran <- Sys.getenv("NOT_CRAN", NA_character_)
if (is.na(not_cran)) {
not_cran <- FALSE
} else {
not_cran <- isTRUE(as.logical(not_cran))
}
!interactive() && !not_cran
} ## on_cran()
## Get test script tags
tags <- local({
lines <- readLines(testme_file, warn = FALSE)
pattern <- "^#'[[:blank:]]+@tags[[:blank:]]+"
lines <- grep(pattern, lines, value = TRUE)
tags <- sub(pattern, "", lines)
tags
})
if (length(tags) > 0) {
tags <- sub("[[:blank:]]*$", "", tags)
tags <- unlist(strsplit(tags, split = "[[:blank:]]+"))
tags <- sort(unique(tags))
} else {
tags <- character(0L)
}
debug <- isTRUE(as.logical(Sys.getenv("R_TESTME_DEBUG")))
coverage <- match.arg(coverage, choices = c("none", "summary", "tally", "report"))
## Create 'testme' environment on the search() path
testme_config <- list(
testme = TRUE,
package = testme_package,
name = testme_name,
tags = tags,
status = "created",
start = proc.time(),
script = testme_file,
path = path,
on_cran = on_cran(),
coverage = coverage,
debug = debug
)
if ("testme" %in% search()) detach(name = "testme")
testme <- attach(testme_config, name = "testme", warn.conflicts = FALSE)
rm(list = c("tags", "testme_package", "testme_name", "testme_file"))
## -----------------------------------------------------------------
## Filters
## -----------------------------------------------------------------
## Skip on CRAN? To run these tests, set env var NOT_CRAN=true
if ("skip_on_cran" %in% tags && on_cran()) {
testme[["status"]] <- "skipped"
}
code <- Sys.getenv("R_TESTME_FILTER_NAME", NA_character_)
if (!is.na(code)) {
expr <- tryCatch(parse(text = code), error = identity)
if (inherits(expr, "error")) {
stop("Syntax error in R_TESTME_FILTER_NAME: ", sQuote(code))
}
keep <- tryCatch(eval(expr, envir = testme), error = identity)
if (inherits(keep, "error")) {
stop("Evaluation of R_TESTME_FILTER_NAME=%s produced an error: %s",
sQuote(code), conditionMessage(keep))
}
if (!isTRUE(keep)) testme[["status"]] <- "skipped"
}
code <- Sys.getenv("R_TESTME_FILTER_TAGS", NA_character_)
if (!is.na(code)) {
expr <- tryCatch(parse(text = code), error = identity)
if (inherits(expr, "error")) {
stop("Syntax error in R_TESTME_FILTER_TAGS: ", sQuote(code))
}
keep <- tryCatch(eval(expr, envir = testme), error = identity)
if (inherits(keep, "error")) {
stop("Evaluation of R_TESTME_FILTER_TAGS=%s produced an error: %s",
sQuote(code), conditionMessage(keep))
}
if (!isTRUE(keep)) testme[["status"]] <- "skipped"
}
testme_run_test(testme)
} ## main()
#' @param testme A names list
#'
testme_run_test <- function(testme) {
message(sprintf("Test %s ...", sQuote(testme[["name"]])))
if (testme[["debug"]]) {
message("testme:")
message(paste(utils::capture.output(utils::str(as.list(testme))), collapse = "\n"))
}
path <- testme[["path"]]
## Process prologue scripts, if they exist
if (testme[["status"]] != "skipped" &&
utils::file_test("-d", file.path(path, "_prologue"))) {
testme[["status"]] <- "prologue"
local({
## Find all prologue scripts
files <- dir(file.path(path, "_prologue"), pattern = "*[.]R$", full.names = TRUE)
files <- sort(files)
testme[["prologue_scripts"]] <- files
## Source all prologue scripts inside the 'testme' environment
expr <- bquote({
files <- prologue_scripts
if (.(testme[["debug"]])) message(sprintf("Sourcing %d prologue scripts ...", length(files)))
for (kk in seq_along(files)) {
file <- files[kk]
if (.(testme[["debug"]])) message(sprintf("%02d/%02d prologue script %s", kk, length(files), sQuote(file)))
source(file, local = TRUE)
}
if (.(testme[["debug"]])) message(sprintf("Sourcing %d prologue scripts ... done", length(files)))
rm(list = c("kk", "file", "files"))
})
eval(expr, envir = testme)
})
# ## In case prologue scripts overwrote some elements in 'testme'
# for (name in names(testme_config)) {
# testme[[name]] <- testme_config[[name]]
# }
}
## Run test script
## Note, prologue scripts may trigger test to be skipped
if (testme[["status"]] != "skipped") {
if (testme[["debug"]]) message("Running test script: ", sQuote(testme[["script"]]))
testme[["status"]] <- "failed"
str(testme[["coverage"]])
if (testme[["coverage"]] != "none") {
pkg_env <- pkgload::load_all()
cov <- covr::environment_coverage(pkg_env[["env"]], test_files = testme[["script"]])
## Keep source files with non-zero coverage
tally <- covr::tally_coverage(cov)
tally <- subset(tally, value > 0)
cov <- cov[covr::display_name(cov) %in% unique(tally$filename)]
testme[["test_coverage"]] <- cov
} else {
testme[["test_coverage"]] <- NULL
source(testme[["script"]], echo = TRUE)
}
testme[["status"]] <- "success"
}
## Process epilogue scripts, if they exist
## Note, epilogue scripts may change status or produce check errors
if (testme[["status"]] == "success" &&
utils::file_test("-d", file.path(path, "_epilogue"))) {
testme[["status"]] <- "epilogue"
local({
## Find all epilogue scripts
files <- dir(file.path(path, "_epilogue"), pattern = "*[.]R$", full.names = TRUE)
files <- sort(files)
testme[["epilogue_scripts"]] <- files
## Source all epilogue scripts inside the 'testme' environment
expr <- bquote({
files <- epilogue_scripts
if (.(testme[["debug"]])) message(sprintf("Sourcing %d epilogue scripts ...", length(files)))
for (kk in seq_along(files)) {
file <- files[kk]
if (.(testme[["debug"]])) message(sprintf("%02d/%02d epilogue script %s", kk, length(files), sQuote(file)))
source(file, local = TRUE)
}
if (.(testme[["debug"]])) message(sprintf("Sourcing %d epilogue scripts ... done", length(files)))
rm(list = c("kk", "file", "files"))
})
eval(expr, envir = testme)
})
testme[["status"]] <- "success"
}
testme[["stop"]] <- proc.time()
dt <- testme[["stop"]] - testme[["start"]]
dt_str <- sprintf("%s=%.1gs", names(dt), dt)
message("Test time: ", paste(dt_str, collapse = ", "))
if ("testme" %in% search()) detach(name = "testme")
cov <- testme[["test_coverage"]]
if (!is.null(cov)) {
message("Source files covered by the test script:")
if (length(cov) > 0) {
print(cov)
if ("tally" %in% testme[["coverage"]]) {
tally <- covr::tally_coverage(cov)
print(tally)
}
if ("report" %in% testme[["coverage"]]) {
html <- covr::report(cov, browse = FALSE)
browseURL(html)
Sys.sleep(5.0)
}
} else {
message("* No source files were covered by this test!")
}
}
message(sprintf("Test %s ... %s", sQuote(testme[["name"]]), testme[["status"]]))
} ## testme_run_test()
main()
================================================
FILE: inst/testme/test-fold.R
================================================
#' @tags fold
loadNamespace("future.apply")
message("*** fold() ...")
x1s <- list(
a = NULL,
b = 1,
c = c(a = 1, b = 2),
d = 1:10e3
)
x2s <- lapply(x1s, FUN = as.list)
names(x2s) <- toupper(names(x1s))
x3s <- list(
E = data.frame(a = 1:3),
F = data.frame(a = 1:3, b = letters[1:3], stringsAsFactors=FALSE)
)
xs <- c(x1s, x2s, x3s)
fcns <- list("c" = base::c, "cbind" = base::cbind)
for (kk in seq_along(xs)) {
x_name <- names(xs)[kk]
for (fcn_name in names(fcns)) {
fcn <- fcns[[fcn_name]]
message(sprintf(" - #%d. %s(x[['%s']]) ...", kk, fcn_name, x_name))
x <- xs[[kk]]
str(list(x = x))
y0 <- Reduce(x, f = fcn)
y1 <- fold(x, f = fcn)
y2 <- fold(x, f = fcn, unname = FALSE)
str(list(y0 = y0, y1 = y1, y2 = y2))
stopifnot(all.equal(unname(y1), unname(y0)))
stopifnot(all.equal(unname(y2), unname(y0)))
if (!fcn_name %in% "cbind") {
stopifnot(all.equal(y1, y0))
stopifnot(all.equal(y2, y0))
}
y0 <- Reduce(x, f = fcn, right = TRUE)
y1 <- fold(x, f = fcn, left = FALSE)
y2 <- fold(x, f = fcn, left = FALSE, unname = FALSE)
str(list(y0 = y0, y1 = y1, y2 = y2))
stopifnot(all.equal(unname(y1), unname(y0)))
stopifnot(all.equal(unname(y2), unname(y0)))
if (!fcn_name %in% "cbind") {
stopifnot(all.equal(y1, y0))
stopifnot(all.equal(y2, y0))
}
message(sprintf(" - #%d. %s(x[['%s']]) ... DONE", kk, fcn_name, x_name))
}
}
make_table <- function(n) {
data.frame(key = sample(n), value = sample(n), stringsAsFactors=FALSE)
}
sizes <- rep(10, 20)
set.seed(3180)
tables <- lapply(sizes, make_table)
key_merge <- function(x, y) merge(x, y, by = "key", all = FALSE)
suppressWarnings(
folded <- fold(tables, key_merge, left = TRUE, unname = FALSE,
threshold = 6L)
)
suppressWarnings(
reduced <- Reduce(key_merge, tables[-1], tables[[1]])
)
stopifnot(all.equal(unname(folded), unname(reduced)))
message("*** fold() ... DONE")
================================================
FILE: inst/testme/test-future_Filter.R
================================================
#' @tags future_Filter
#' @tags sequential multisession multicore
library(future.apply)
message("*** future_Filter() ...")
is_even <- function(x) { x %% 2 == 0 }
x <- sample.int(100, size = 1000, replace = TRUE)
y_truth <- x[vapply(x, FUN.VALUE = NA, FUN = is_even)]
str(y_truth)
for (strategy in supportedStrategies()) {
message(sprintf("*** strategy = %s ...", sQuote(strategy)))
plan(strategy)
y <- Filter(is_even, x)
str(y)
stopifnot(identical(y, y_truth))
message(sprintf("*** strategy = %s ... done", sQuote(strategy)))
}
plan(sequential)
message("*** future_Filter() ... DONE")
================================================
FILE: inst/testme/test-future_apply.R
================================================
#' @tags future_apply
#' @tags sequential multisession multicore
library(future.apply)
message("*** future_apply() ...")
z0 <- NULL
for (strategy in supportedStrategies()) {
message(sprintf("*** strategy = %s ...", sQuote(strategy)))
plan(strategy)
message("- From example(apply) ...")
X <- matrix(c(1:4, 1, 6:8), nrow = 2L)
Y0 <- apply(X, MARGIN = 1L, FUN = table)
Y1 <- future_apply(X, MARGIN = 1L, FUN = table)
print(Y1)
stopifnot(all.equal(Y1, Y0, check.attributes = FALSE)) ## FIXME
Y2 <- future_apply(X, MARGIN = 1L, FUN = "table")
print(Y2)
stopifnot(identical(Y2, Y1))
Y0 <- apply(X, MARGIN = 1L, FUN = stats::quantile)
Y1 <- future_apply(X, MARGIN = 1L, FUN = stats::quantile)
print(Y1)
stopifnot(all.equal(Y1, Y0))
x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
names(dimnames(x)) <- c("row", "col")
x3 <- array(x, dim = c(dim(x), 3),
dimnames = c(dimnames(x), list(C = paste0("cop.", 1:3))))
y0 <- apply(x, MARGIN = 2L, FUN = identity)
stopifnot(identical(y0, x))
y1 <- future_apply(x, MARGIN = 2L, FUN = identity)
print(y1)
stopifnot(identical(y1, y0))
y0 <- apply(x3, MARGIN = 2:3, FUN = identity)
stopifnot(identical(y0, x3))
y1 <- future_apply(x3, MARGIN = 2:3, FUN = identity)
print(y1)
stopifnot(identical(y1, y0))
z <- array(1:24, dim = 2:4)
y0 <- apply(z, MARGIN = 1:2, FUN = function(x) seq_len(max(x)))
y1 <- future_apply(z, MARGIN = 1:2, FUN = function(x) seq_len(max(x)))
print(y1)
stopifnot(identical(y1, y0))
message("- apply(X, MARGIN = <character>, ...) ...")
X <- matrix(1:2, nrow = 2L, ncol = 1L, dimnames = list(rows = c("a", "b")))
y0 <- apply(X, MARGIN = "rows", FUN = identity)
y1 <- future_apply(X, MARGIN = "rows", FUN = identity)
print(y1)
stopifnot(identical(y1, y0))
message("- apply(X, ...) - dim(X) > 2 ...")
X <- array(1:12, dim = c(2, 2, 3))
y0 <- apply(X, MARGIN = 1L, FUN = identity)
y1 <- future_apply(X, MARGIN = 1L, FUN = identity)
print(y1)
stopifnot(identical(y1, y0))
message("- apply(X, ...) - not all same names ...")
FUN <- function(x) {
if (x[1] == 1L) names(x) <- letters[seq_along(x)]
x
}
X <- matrix(1:4, nrow = 2L, ncol = 2L)
y0 <- apply(X, MARGIN = 1L, FUN = FUN)
y1 <- future_apply(X, MARGIN = 1L, FUN = FUN)
print(y1)
stopifnot(identical(y1, y0))
message("- example(future_apply) - reproducible RNG ...")
z1 <- future_apply(X, MARGIN = 1L, FUN = sample,
future.seed = 0xBEEF,
## Test also all other 'future.*' arguments
future.stdout = TRUE,
future.conditions = NULL,
future.globals = TRUE,
future.packages = NULL,
future.scheduling = 1.0,
future.chunk.size = NULL,
future.label = "future_apply-%d"
)
print(z1)
if (is.null(z0)) {
z0 <- z1
} else {
stopifnot(identical(z1, z0))
}
plan(sequential)
message(sprintf("*** strategy = %s ... done", sQuote(strategy)))
} ## for (strategy in ...)
message("*** apply(X, ...) - prod(dim(X)) == 0 [non-parallel] ...")
X <- matrix(nrow = 0L, ncol = 2L)
y0 <- apply(X, MARGIN = 1L, FUN = identity)
y1 <- future_apply(X, MARGIN = 1L, FUN = identity)
print(y1)
stopifnot(identical(y1, y0))
message("*** exceptions ...")
## Error: dim(X) must have a positive length
res <- tryCatch({
y <- future_apply(1L, MARGIN = 1L, FUN = identity)
}, error = identity)
stopifnot(inherits(res, "error"))
## Error: 'X' must have named dimnames
X <- matrix(1:2, nrow = 2L, ncol = 1L)
res <- tryCatch({
y <- future_apply(X, MARGIN = "rows", FUN = identity)
}, error = identity)
stopifnot(inherits(res, "error"))
## Error: not all elements of 'MARGIN' are names of dimensions
X <- matrix(1:2, nrow = 2L, ncol = 1L, dimnames = list(rows = c("a", "b")))
res <- tryCatch({
y <- future_apply(X, MARGIN = "cols", FUN = identity)
}, error = identity)
stopifnot(inherits(res, "error"))
message("*** future_apply() ... DONE")
================================================
FILE: inst/testme/test-future_by.R
================================================
#' @tags future_by
#' @tags listenv
#' @tags sequential multisession multicore
library(future.apply)
library(listenv)
all_equal_but_call <- function(target, current, ...) {
attr(target, "call") <- NULL
attr(current, "call") <- NULL
all.equal(target = target, current = current, ...)
}
message("*** future_by() ...")
## ---------------------------------------------------------
## by()
## ---------------------------------------------------------
if (require("datasets") && require("stats")) { ## warpbreaks & lm()
## Use a local variable to test that it is properly exported, because
## 'warpbreaks' is available in all R sessions
data <- warpbreaks
y0 <- by(data[, 1:2], INDICES = data[,"tension"], FUN = summary)
y1 <- by(data[, 1], INDICES = data[, -1], FUN = summary, digits = 2L)
y2 <- by(data, INDICES = data[,"tension"], FUN = function(x, ...) {
lm(breaks ~ wool, data = x, ...)
}, singular.ok = FALSE)
## now suppose we want to extract the coefficients by group
tmp <- with(data, by(data, INDICES = tension, FUN = function(x) {
lm(breaks ~ wool, data = x)
}))
y3 <- sapply(tmp, coef)
## Source: {r-source}/tests/reg-tests-1d.R
by2 <- function(data, INDICES, FUN) {
by(data, INDICES = INDICES, FUN = FUN)
}
future_by2 <- function(data, INDICES, FUN) {
future_by(data, INDICES = INDICES, FUN = FUN)
}
y4 <- by2(data, INDICES = data[,"tension"], FUN = summary)
for (cores in 1:availCores) {
message(sprintf("Testing with %d cores ...", cores))
options(mc.cores = cores)
strategies <- supportedStrategies(cores)
for (strategy in supportedStrategies()) {
message(sprintf("- plan('%s') ...", strategy))
plan(strategy)
y0f <- future_by(data[, 1:2], INDICES = data[,"tension"], FUN = summary)
stopifnot(all_equal_but_call(y0f, y0, check.attributes = FALSE))
y1f <- future_by(data[, 1], INDICES = data[, -1], FUN = summary, digits = 2L)
stopifnot(all_equal_but_call(y1f, y1))
y2f <- future_by(data, INDICES = data[,"tension"], FUN = function(x, ...) {
lm(breaks ~ wool, data = x, ...)
}, singular.ok = FALSE)
stopifnot(all_equal_but_call(y2f, y2))
## now suppose we want to extract the coefficients by group
tmp <- with(data, future_by(data, INDICES = tension, FUN = function(x) {
lm(breaks ~ wool, data = x)
}))
y3f <- sapply(tmp, coef)
stopifnot(all_equal_but_call(y3f, y3))
y4f <- future_by2(data, INDICES = data[,"tension"], FUN = summary)
stopifnot(all_equal_but_call(y4f, y4))
## Defunct /HB 2025-01-11
res <- tryCatch({
y4f2 <- future_by2(data, INDICES = data[,"tension"], FUN = "summary")
}, error = identity)
stopifnot(inherits(res, "error"))
if (getRversion() >= "3.6.0") {
stopifnot(inherits(res, "defunctError"))
}
} ## for (strategy ...)
message(sprintf("Testing with %d cores ... DONE", cores))
} ## for (cores ...)
} ## if (require("stats"))
message("*** future_by() ... DONE")
================================================
FILE: inst/testme/test-future_eapply.R
================================================
#' @tags future_eapply
#' @tags sequential multisession multicore
library(future.apply)
message("*** future_eapply() ...")
message("- From example(eapply) ...")
for (strategy in supportedStrategies()) {
message(sprintf("*** strategy = %s ...", sQuote(strategy)))
plan(strategy)
env <- new.env(hash = FALSE)
env$a <- 1:10
env$beta <- exp(-3:3)
env$logic <- c(TRUE, FALSE, FALSE, TRUE)
y0 <- unlist(eapply(env, mean, USE.NAMES = FALSE))
y1 <- unlist(future_eapply(env, mean, USE.NAMES = FALSE))
stopifnot(all.equal(y1, y0))
y0 <- eapply(env, quantile, probs = 1:3/4)
y1 <- future_eapply(env, quantile, probs = 1:3/4)
stopifnot(all.equal(y1, y0))
y0 <- eapply(env, quantile)
y1 <- future_eapply(env, quantile)
stopifnot(all.equal(y1, y0))
y2 <- future_eapply(env, "quantile")
stopifnot(all.equal(y2, y0))
plan(sequential)
message(sprintf("*** strategy = %s ... done", sQuote(strategy)))
} ## for (strategy in ...)
message("*** future_eapply() ... DONE")
================================================
FILE: inst/testme/test-future_kernapply.R
================================================
if (require("datasets") && require("stats")) {
library(future.apply)
library(datasets)
plan(multisession)
## Adopted from example("kernapply", package = "stats")
## ------------------------------------------------------
## Test {future_}kernapply() for 'default'
## ------------------------------------------------------
X <- EuStockMarkets[, 1:2]
X <- unclass(X)
stopifnot(inherits(X, "matrix"), !inherits(X, "ts"))
k1 <- kernel("daniell", m = 50L)
stopifnot(inherits(k1, "tskernel"))
X1_truth <- kernapply(X, k = k1)
str(X1_truth)
X1 <- future_kernapply(X, k = k1)
str(X1)
stopifnot(identical(X1, X1_truth))
## ------------------------------------------------------
## Test {future_}kernapply() for 'ts'
## ------------------------------------------------------
X <- EuStockMarkets[, 1:2]
stopifnot(inherits(X, "matrix"), inherits(X, "ts"))
k1 <- kernel("daniell", m = 50L)
stopifnot(inherits(k1, "tskernel"))
X1_truth <- kernapply(X, k = k1)
str(X1_truth)
X1 <- future_kernapply(X, k = k1)
str(X1)
stopifnot(identical(X1, X1_truth))
plan(sequential)
}
================================================
FILE: inst/testme/test-future_lapply,RNG.R
================================================
#' @tags future_lapply
#' @tags sequential multisession multicore
library(future.apply)
message("*** future_lapply() and RNGs ...")
options(future.debug = FALSE)
message("* future_lapply(x, ..., future.seed = <invalid>) ...")
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = as.list(1:2))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = list(1, 2, 3:4))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = as.list(1:3))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
seeds <- lapply(1:3, FUN = as_lecyer_cmrg_seed)
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = lapply(seeds, FUN = as.numeric))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
seeds[[1]][1] <- seeds[[1]][1] + 1L
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = seeds)
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
message("* future_lapply(x, ..., future.seed = <invalid>) ... DONE")
## Iterate of the same set in all tests
x <- 1:5
message("* future_lapply(x, ..., future.seed = FALSE) ...")
y0 <- y0_nested <- seed00 <- NULL
for (cores in 1:availCores) {
message(sprintf(" - Testing with %d cores ...", cores))
options(mc.cores = cores)
for (strategy in supportedStrategies(cores)) {
message(sprintf("* plan('%s') ...", strategy))
plan(strategy)
set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) i, future.seed = FALSE)
y <- unlist(y)
seed <- get_random_seed()
if (is.null(y0)) {
y0 <- y
seed00 <- seed
}
str(list(y = y))
stopifnot(identical(seed, seed0), identical(seed, seed00))
## NOTE: We cannot guarantee the same random numbers, because
## future.seed = FALSE.
message(sprintf("* plan('%s') ... DONE", strategy))
} ## for (strategy ...)
message(sprintf(" - Testing with %d cores ... DONE", cores))
} ## for (core ...)
message("* future_lapply(x, ..., future.seed = FALSE) ... DONE")
seed_sets <- list(
A = TRUE,
## B = NA,
C = 42L,
D = as_lecyer_cmrg_seed(42L),
E = list(),
F = vector("list", length = length(x)),
G = NULL
)
## Generate sequence of seeds of the current RNGkind()
## NOTE: This is NOT a good way to generate random seeds!!!
seeds <- lapply(seq_along(x), FUN = function(i) {
set.seed(i)
globalenv()$.Random.seed
})
seed_sets$E <- seeds
## Generate sequence of L'Ecyer CMRG seeds
seeds <- seed_sets$F
seeds[[1]] <- seed_sets$D
for (kk in 2:length(x)) seeds[[kk]] <- parallel::nextRNGStream(seeds[[kk - 1]])
seed_sets$F <- seeds
seed_sets$G <- seed_sets$A
rm(list = "seeds")
for (name in names(seed_sets)) {
future.seed <- seed_sets[[name]]
if (is.list(future.seed)) {
label <- sprintf("<list of %d seeds each being a %d-int seed>",
length(future.seed), length(future.seed[[1]]))
} else {
label <- hpaste(future.seed)
}
message(sprintf("* future_lapply(x, ..., future.seed = %s) ...", label))
set.seed(0xBEEF)
y0 <- seed00 <- NULL
for (cores in 1:availCores) {
message(sprintf(" - Testing with %d cores ...", cores))
options(mc.cores = cores)
for (strategy in supportedStrategies(cores)) {
message(sprintf("* plan('%s') ...", strategy))
plan(strategy)
set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) {
rnorm(1L)
}, future.seed = future.seed)
y <- unlist(y)
seed <- get_random_seed()
if (is.null(y0)) {
y0 <- y
seed00 <- seed
}
str(list(y = y))
stopifnot(!identical(seed, seed0), identical(seed, seed00),
identical(y, y0))
## RNG-based results should also be identical regardless of
## load-balance scheduling.
for (scheduling in list(FALSE, TRUE, 0, 0.5, 2.0, Inf)) {
set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) {
rnorm(1L)
}, future.seed = future.seed, future.scheduling = scheduling)
seed <- get_random_seed()
y <- unlist(y)
str(list(y = y))
stopifnot(!identical(seed, seed0), identical(seed, seed00),
identical(y, y0))
}
## Nested future_lapply():s
for (scheduling in list(FALSE, TRUE)) {
y <- future_lapply(x, FUN = function(i) {
.seed <- globalenv()$.Random.seed
z <- future_lapply(1:3, FUN = function(j) {
list(j = j, seed = globalenv()$.Random.seed)
}, future.seed = .seed)
## Assert that all future seeds are unique
seeds <- lapply(z, FUN = function(x) x$seed)
for (kk in 2:length(seeds)) stopifnot(!all(seeds[[kk]] == seeds[[1]]))
list(i = i, seed = .seed, sample = rnorm(1L), z = z)
}, future.seed = 42L, future.scheduling = scheduling)
if (is.null(y0_nested)) y0_nested <- y
str(list(y = y))
## Assert that all future seeds (also nested ones) are unique
seeds <- Reduce(c, lapply(y, FUN = function(x) {
c(list(seed = x$seed), lapply(x$z, FUN = function(x) x$seed))
}))
for (kk in 2:length(seeds)) stopifnot(!all(seeds[[kk]] == seeds[[1]]))
stopifnot(identical(y, y0_nested))
}
message(sprintf("* plan('%s') ... DONE", strategy))
} ## for (strategy ...)
message(sprintf(" - Testing with %d cores ... DONE", cores))
} ## for (cores ...)
message(sprintf("* future_lapply(x, ..., future.seed = %s) ... DONE", label))
} ## for (name ...)
message("*** future_lapply() and RNGs ... DONE")
================================================
FILE: inst/testme/test-future_lapply,globals.R
================================================
#' @tags future_lapply
#' @tags sequential multisession multicore
library(future.apply)
library(tools) ## toTitleCase()
options(future.debug = FALSE)
options(future.apply.debug = TRUE)
message("*** future_lapply() - globals ...")
plan(cluster, workers = "localhost")
a <- 1
b <- 2
globals_set <- list(
A = FALSE,
B = TRUE,
C = c("a", "b"),
D = list(a = 2, b = 3)
)
x <- list(1)
y_truth <- list(A = NULL, B = list(1), C = list(1), D = list(2))
str(y_truth)
for (name in names(globals_set)) {
globals <- globals_set[[name]]
message("Globals set ", sQuote(name))
y <- tryCatch({
future_lapply(x, FUN = function(x) {
median(c(x, a, b))
}, future.globals = globals, future.packages = "utils")
}, error = identity)
print(y)
stopifnot((name == "A" && inherits(y, "error")) ||
identical(y, y_truth[[name]]))
}
message("*** future_lapply() - globals ... DONE")
message("*** future_lapply() - manual globals ...")
d <- 42
y <- future_lapply(1:2, FUN = function(x) { x * d },
future.globals = structure(FALSE, add = "d"))
stopifnot(identical(y, list(42, 84)))
e <- 42
res <- tryCatch({
future_lapply(1:2, FUN = function(x) { 2 * e },
future.globals = structure(TRUE, ignore = "e"))
}, error = identity)
stopifnot(inherits(res, "error"))
message("*** future_lapply() - manual globals ... DONE")
## Test adopted from http://stackoverflow.com/questions/42561088/nested-do-call-within-a-foreach-dopar-environment-cant-find-function-passed-w
message("*** future_lapply() - tricky globals ...")
my_add <- function(a, b) a + b
call_my_add <- function(a, b) {
do.call(my_add, args = list(a = a, b = b))
}
call_my_add_caller <- function(a, b, FUN = call_my_add) {
do.call(FUN, args = list(a = a, b = b))
}
main <- function(x = 1:2, caller = call_my_add_caller,
args = list(FUN = call_my_add)) {
results <- future_lapply(x, FUN = function(i) {
do.call(caller, args = c(list(a = i, b = i + 1L), args))
})
results
}
x <- list(list(1:2))
z_length <- lapply(x, FUN = do.call, what = length)
fun <- function(...) sum(...)
z_fun <- lapply(x, FUN = do.call, what = fun)
y0 <- NULL
for (strategy in supportedStrategies()) {
plan(strategy)
y <- main(1:3)
if (is.null(y0)) y0 <- y
stopifnot(identical(y, y0))
message("- future_lapply(x, FUN = do.call, ...) ...")
z <- future_lapply(x, FUN = do.call, what = length)
stopifnot(identical(z, z_length))
z <- future_lapply(x, FUN = do.call, what = fun)
stopifnot(identical(z, z_fun))
message("- future_lapply(x, ...) - passing arguments via '...' ...")
## typeof() == "list"
obj <- data.frame(a = 1:2)
stopifnot(typeof(obj) == "list")
y <- future_lapply(1L, function(a, b) typeof(b), b = obj)
stopifnot(identical(y[[1]], typeof(obj)))
## typeof() == "environment"
obj <- new.env()
stopifnot(typeof(obj) == "environment")
y <- future_lapply(1L, function(a, b) typeof(b), b = obj)
stopifnot(identical(y[[1]], typeof(obj)))
## typeof() == "S4"
if (requireNamespace("methods")) {
obj <- methods::getClass("MethodDefinition")
stopifnot(typeof(obj) == "S4")
y <- future_lapply(1L, function(a, b) typeof(b), b = obj)
stopifnot(identical(y[[1]], typeof(obj)))
}
message("- future_lapply(X, ...) - 'X' containing globals ...")
## From https://github.com/futureverse/future.apply/issues/12
a <- 42
b <- 21
X <- list(
function(b) 2 * a,
function() b / 2,
function() a + b,
function() nchar(toTitleCase("hello world"))
)
z0 <- lapply(X, FUN = function(f) f())
str(z0)
z1 <- future_lapply(X, FUN = function(f) f())
str(z1)
stopifnot(identical(z1, z0))
# message("- future_lapply(x, ...) - passing '...' as a global ...")
# ## https://github.com/futureverse/future/issues/417
# fcn0 <- function(...) { lapply(1, FUN = function(x) list(...)) }
# z0 <- fcn0(a = 1)
# str(list(z0 = z0))
# stopifnot(identical(z0, list(list(a = 1))))
# fcn <- function(...) { future_lapply(1, FUN = function(x) list(...)) }
# z1 <- fcn(a = 1)
# str(list(z1 = z1))
# stopifnot(identical(z1, z0))
## https://github.com/futureverse/future.apply/issues/47
message("- future_lapply(X, ...) - '{ a <- a + 1; a }' ...")
a <- 1
z0 <- lapply(1, function(ii) {
a <- a + 1
a
})
z1 <- future_lapply(1, function(ii) {
a <- a + 1
a
})
stopifnot(identical(z1, z0))
## https://github.com/futureverse/future.apply/issues/47
message("- future_lapply(X, ...) - '{ a; a <- a + 1 }' ...")
z2 <- tryCatch(future_lapply(1, function(ii) {
a
a <- a + 1
}), error = identity)
stopifnot(identical(z2, z0))
## https://github.com/futureverse/future.apply/issues/85
message("- future_lapply(..., future.globals = <list>) ...")
a <- 0
y <- future_lapply(1, FUN = function(x) a, future.globals = list(a = 42))
str(y)
stopifnot(y[[1]] == 42)
} ## for (strategy ...)
message("*** future_lapply() - tricky globals ... DONE")
message("*** future_lapply() - missing arguments ...")
## Here 'abc' becomes missing, i.e. missing(abc) is TRUE
foo <- function(x, abc) future_lapply(x, FUN = function(y) y)
y <- foo(1:2)
stopifnot(identical(y, as.list(1:2)))
message("*** future_lapply() - missing arguments ... DONE")
message("*** future_lapply() - false positives ...")
## Here 'abc' becomes a promise, which fails to resolve
## iff 'xyz' does not exist. (Issue #161)
suppressWarnings(rm(list = "xyz"))
foo <- function(x, abc) future_lapply(x, FUN = function(y) y)
y <- foo(1:2, abc = (xyz >= 3.14))
stopifnot(identical(y, as.list(1:2)))
message("*** future_lapply() - false positives ... DONE")
message("*** future_lapply() - too large ...")
oMaxSize <- getOption("future.globals.maxSize")
X <- replicate(10L, 1:100, simplify = FALSE)
FUN <- function(x) {
getOption("future.globals.maxSize")
}
y0 <- lapply(X, FUN = FUN)
stopifnot(all(sapply(y0, FUN = identical, oMaxSize)))
sizes <- unclass(c(FUN = object.size(FUN), X = object.size(X)))
cat(sprintf("Baseline size of globals: %.2f KiB\n", sizes[["FUN"]] / 1024))
message("- true positive ...")
options(future.globals.maxSize = 1L)
res <- tryCatch({
y <- future_lapply(X, FUN = FUN)
}, error = identity)
stopifnot(inherits(res, "error"))
res <- NULL
options(future.globals.maxSize = oMaxSize)
maxSize <- getOption("future.globals.maxSize")
y <- future_lapply(X, FUN = FUN)
str(y)
stopifnot(all(sapply(y, FUN = identical, oMaxSize)))
message("- approximately invariant to chunk size ...")
maxSize <- sizes[["FUN"]] + sizes[["X"]] / length(X)
options(future.globals.maxSize = maxSize)
for (chunk.size in c(1L, 2L, 5L, 10L)) {
y <- future_lapply(X, FUN = FUN, future.chunk.size = chunk.size)
str(y)
stopifnot(all(unlist(y) == maxSize))
cat(sprintf("maxSize = %g bytes\nfuture.globals.maxSize = %g bytes\n",
maxSize, getOption("future.globals.maxSize")))
stopifnot(getOption("future.globals.maxSize") == maxSize)
}
y <- NULL
options(future.globals.maxSize = oMaxSize)
message("*** future_lapply() - too large ... DONE")
message("*** future_lapply() - globals exceptions ...")
res <- tryCatch({
y <- future_lapply(1, FUN = function(x) x, future.globals = 42)
}, error = identity)
stopifnot(inherits(res, "error"))
res <- tryCatch({
y <- future_lapply(1, FUN = function(x) x, future.globals = list(1))
}, error = identity)
stopifnot(inherits(res, "error"))
res <- tryCatch({
y <- future_lapply(1, FUN = function(x) x, future.globals = "...future.FUN")
}, error = identity)
stopifnot(inherits(res, "error"))
res <- tryCatch({
y <- future_lapply(1, FUN = function(x) x, future.globals = "...future.FUN")
}, error = identity)
stopifnot(inherits(res, "error"))
...future.elements_ii <- 42L
X <- list(function() 2 * ...future.elements_ii)
res <- tryCatch({
y <- future_lapply(X, FUN = function(f) f())
}, error = identity)
stopifnot(inherits(res, "error"))
message("*** future_lapply() - globals exceptions ... DONE")
================================================
FILE: inst/testme/test-future_lapply.R
================================================
#' @tags future_lapply
#' @tags listenv
#' @tags sequential multisession multicore
library(future.apply)
library(listenv)
message("*** future_lapply() ...")
x_a <- list(a = "integer", b = "numeric", c = "character", c = "list")
str(list(x_a = x_a))
y_a <- lapply(x_a, FUN = base::vector, length = 2L)
str(list(y_a = y_a))
x_b <- list(a = c("hello", b = 1:100))
str(list(x_b = x_b))
y_b <- lapply(x_b, FUN = future:::hpaste, collapse = "; ", maxHead = 3L)
str(list(y_b = y_b))
x_c <- list()
y_c <- listenv()
y_c$A <- 3L
x_c$a <- y_c
y_c<- listenv()
y_c$A <- 3L
y_c$B <- c("hello", b = 1:100)
x_c$b <- y_c
print(x_c)
y_c <- lapply(x_c, FUN = listenv::mapping)
str(list(y_c = y_c))
for (cores in 1:availCores) {
message(sprintf("Testing with %d cores ...", cores))
options(mc.cores = cores)
strategies <- supportedStrategies(cores)
for (strategy in sup
gitextract_3rrfdcst/
├── .Rbuildignore
├── .Rinstignore
├── .github/
│ ├── .gitignore
│ ├── ISSUE_TEMPLATE/
│ │ ├── bug_report.md
│ │ ├── config.yml
│ │ └── feature_request.md
│ └── workflows/
│ ├── R-CMD-check.yaml
│ ├── rhub.yaml
│ └── test-coverage.yaml
├── .gitignore
├── CONDUCT.md
├── CONTRIBUTING.md
├── DESCRIPTION
├── Makefile
├── NAMESPACE
├── NEWS.md
├── R/
│ ├── 000.import.R
│ ├── 001.bquote.R
│ ├── 001.import_future_functions.R
│ ├── chunking.R
│ ├── condition-handlers.R
│ ├── fold.R
│ ├── future.apply-package.R
│ ├── future_Filter.R
│ ├── future_Map.R
│ ├── future_apply.R
│ ├── future_by.R
│ ├── future_eapply.R
│ ├── future_kernapply.R
│ ├── future_lapply.R
│ ├── future_mapply.R
│ ├── future_replicate.R
│ ├── future_sapply.R
│ ├── future_tapply.R
│ ├── future_vapply.R
│ ├── future_xapply.R
│ ├── globals.R
│ ├── makeChunks.R
│ ├── options.R
│ ├── testme.R
│ ├── utils,conditions.R
│ ├── utils-debug.R
│ ├── utils.R
│ └── zzz.R
├── README.md
├── cran-comments.md
├── incl/
│ ├── OVERVIEW.md
│ ├── future_Filter.R
│ ├── future_apply.R
│ ├── future_by.R
│ ├── future_lapply.R
│ ├── future_mapply.R
│ ├── make_rng_seeds.R
│ └── random_seed_utils.R
├── inst/
│ ├── CITATION
│ ├── WORDLIST
│ └── testme/
│ ├── _epilogue/
│ │ ├── 001.undo-future.R
│ │ ├── 002.undo-state.R
│ │ ├── 090.gc.R
│ │ ├── 099.session_info.R
│ │ ├── 995.detritus-connections.R
│ │ └── 999.detritus-files.R
│ ├── _prologue/
│ │ ├── 001.load.R
│ │ ├── 002.record-state.R
│ │ ├── 030.imports.R
│ │ ├── 050.utils.R
│ │ ├── 090.context.R
│ │ ├── 090.options.R
│ │ ├── 091.envvars.R
│ │ ├── 099.future-setup.R
│ │ └── 995.detrius-connections.R
│ ├── deploy.R
│ ├── run.R
│ ├── test-fold.R
│ ├── test-future_Filter.R
│ ├── test-future_apply.R
│ ├── test-future_by.R
│ ├── test-future_eapply.R
│ ├── test-future_kernapply.R
│ ├── test-future_lapply,RNG.R
│ ├── test-future_lapply,globals.R
│ ├── test-future_lapply.R
│ ├── test-future_mapply,globals.R
│ ├── test-future_mapply.R
│ ├── test-future_replicate.R
│ ├── test-future_sapply.R
│ ├── test-future_tapply.R
│ ├── test-future_vapply.R
│ ├── test-globals,tricky2.R
│ ├── test-globals,tricky_recursive.R
│ ├── test-options,nested.R
│ ├── test-rng.R
│ ├── test-stdout.R
│ └── test-utils.R
├── man/
│ ├── fold.Rd
│ ├── future.apply.Rd
│ ├── future.apply.options.Rd
│ ├── future_apply.Rd
│ ├── future_by.Rd
│ ├── future_kernapply.Rd
│ ├── future_lapply.Rd
│ ├── future_mapply.Rd
│ └── makeChunks.Rd
├── pkgdown/
│ ├── _pkgdown.yml
│ └── _pkgdown.yml.rsp
├── revdep/
│ ├── README.md
│ ├── cran.md
│ ├── failures.md
│ ├── notes.md
│ ├── problems.md
│ ├── revdepcheck.Renviron
│ ├── revdepcheck.init.sh
│ ├── run.R
│ ├── run.pbs
│ └── run.sge
├── tests/
│ ├── incl/
│ │ ├── end.R
│ │ └── start,load-only.R
│ ├── test-fold.R
│ ├── test-future_Filter.R
│ ├── test-future_apply.R
│ ├── test-future_by.R
│ ├── test-future_eapply.R
│ ├── test-future_kernapply.R
│ ├── test-future_lapply,RNG.R
│ ├── test-future_lapply,globals.R
│ ├── test-future_lapply.R
│ ├── test-future_mapply,globals.R
│ ├── test-future_mapply.R
│ ├── test-future_replicate.R
│ ├── test-future_sapply.R
│ ├── test-future_tapply.R
│ ├── test-future_vapply.R
│ ├── test-globals,tricky2.R
│ ├── test-globals,tricky_recursive.R
│ ├── test-options,nested.R
│ ├── test-rng.R
│ ├── test-stdout.R
│ └── test-utils.R
└── vignettes/
└── future.apply-1-overview.md.rsp
Condensed preview — 139 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (373K chars).
[
{
"path": ".Rbuildignore",
"chars": 1001,
"preview": "#----------------------------\n# Git and SVN related\n#----------------------------\n^.svn\n^.git\n^.make\n^INSTALL[.]md$\n^OVE"
},
{
"path": ".Rinstignore",
"chars": 247,
"preview": "# Certain LaTeX files (e.g. bib, bst, sty) must be part of the build \n# such that they are available for R CMD check. T"
},
{
"path": ".github/.gitignore",
"chars": 7,
"preview": "*.html\n"
},
{
"path": ".github/ISSUE_TEMPLATE/bug_report.md",
"chars": 538,
"preview": "---\nname: Bug report\nabout: Create a report to help us improve (Please use future's 'Discussions' for Q&A)\ntitle: ''\nlab"
},
{
"path": ".github/ISSUE_TEMPLATE/config.yml",
"chars": 209,
"preview": "lank_issues_enabled: true\ncontact_links:\n - name: Support & Discussions\n url: https://github.com/futureverse/future/"
},
{
"path": ".github/ISSUE_TEMPLATE/feature_request.md",
"chars": 352,
"preview": "---\nname: Feature request\nabout: Suggest an idea for this project (Please use future's 'Discussions' for Q&A)\ntitle: ''\n"
},
{
"path": ".github/workflows/R-CMD-check.yaml",
"chars": 5232,
"preview": "on: [push, pull_request]\n\nname: R-CMD-check\n\njobs:\n R-CMD-check:\n if: \"! contains(github.event.head_commit.message, "
},
{
"path": ".github/workflows/rhub.yaml",
"chars": 2942,
"preview": "# R-hub's generic GitHub Actions workflow file. It's canonical location is at\n# https://github.com/r-hub/actions/blob/v1"
},
{
"path": ".github/workflows/test-coverage.yaml",
"chars": 1803,
"preview": "on:\n workflow_dispatch: # Enables manual triggering\n\nname: test-coverage.yaml\n\npermissions: read-all\n\njobs:\n test-cov"
},
{
"path": ".gitignore",
"chars": 210,
"preview": ".Rhistory\n*~\n**/*~\n.R\n.benchmark\n.check\n.devel\n.test\n*.o\n*.dll\n*.Rout\n.RData\n*.Rproj*\n*.swp\n.covr.rds\n.future\n.ghi\n.issu"
},
{
"path": "CONDUCT.md",
"chars": 3204,
"preview": "# Contributor Covenant Code of Conduct\n\n## Our Pledge\n\nIn the interest of fostering an open and welcoming environment, w"
},
{
"path": "CONTRIBUTING.md",
"chars": 1251,
"preview": "\n# Contributing to the 'future.apply' package\n\nThis Git repository uses the [Git Flow](https://nvie.com/posts/a-successf"
},
{
"path": "DESCRIPTION",
"chars": 1337,
"preview": "Package: future.apply\nVersion: 1.20.2-9000\nTitle: Apply Function to Elements in Parallel using Futures\nDepends:\n R (>"
},
{
"path": "Makefile",
"chars": 23,
"preview": "include .make/Makefile\n"
},
{
"path": "NAMESPACE",
"chars": 1109,
"preview": "# Generated by roxygen2: do not edit by hand\n\nS3method(future_by,data.frame)\nS3method(future_by,default)\nS3method(future"
},
{
"path": "NEWS.md",
"chars": 11972,
"preview": "# Version (development version)\n\n * ...\n\n\n# Version 1.20.2 [2026-02-19]\n\n## Miscellaneous\n\n * This is a maintenance upda"
},
{
"path": "R/000.import.R",
"chars": 639,
"preview": "import_from <- function(name, mode = \"function\", default = NULL, package) {\n ns <- getNamespace(package)\n if (exists(n"
},
{
"path": "R/001.bquote.R",
"chars": 165,
"preview": "#' @importFrom utils globalVariables\nglobalVariables(c(\".\", \"..\"))\n\nbquote_compile <- import_future(\"bquote_compile\")\nbq"
},
{
"path": "R/001.import_future_functions.R",
"chars": 729,
"preview": "## To be imported from 'future', if available\nsQuoteLabel <- NULL\n.debug <- NULL\n\nmake_rng_seeds <- import_future(\"make_"
},
{
"path": "R/chunking.R",
"chars": 506,
"preview": "`chunkWith[[` <- function(x, subset) {\n if (getOption(\"future.apply.chunkWith\", \"[[\") == \"[\") {\n return(x[subset])\n "
},
{
"path": "R/condition-handlers.R",
"chars": 1279,
"preview": "#' @importFrom future FutureInterruptError\nonInterrupt <- function(int, fcn_name, debug = FALSE) {\n if (debug) {\n md"
},
{
"path": "R/fold.R",
"chars": 2568,
"preview": "#' Efficient Fold, Reduce, Accumulate, Combine of a Vector\n#'\n#' @param x A vector.\n#' \n#' @param f A binary function, i"
},
{
"path": "R/future.apply-package.R",
"chars": 4014,
"preview": "#' future.apply: Apply Function to Elements in Parallel using Futures\n#'\n#' The \\pkg{future.apply} package provides para"
},
{
"path": "R/future_Filter.R",
"chars": 766,
"preview": "#' @inheritParams future_mapply\n#' \n#' @param f A function of the arity \\eqn{k} if `future_Map()` is called with\n#' \\eqn"
},
{
"path": "R/future_Map.R",
"chars": 788,
"preview": "#' @inheritParams future_mapply\n#' \n#' @param f A function of the arity \\eqn{k} if `future_Map()` is called with\n#' \\eqn"
},
{
"path": "R/future_apply.R",
"chars": 7667,
"preview": "#' Apply Functions Over Array Margins via Futures\n#'\n#' `future_apply()` implements [base::apply()] using future with pe"
},
{
"path": "R/future_by.R",
"chars": 5776,
"preview": "#' Apply a Function to a Data Frame Split by Factors via Futures\n#'\n#' @inheritParams future_lapply\n#' \n#' @param data A"
},
{
"path": "R/future_eapply.R",
"chars": 794,
"preview": "#' @inheritParams future_lapply\n#' \n#' @param env An \\R environment.\n#' \n#' @param all.names If `TRUE`, the function wil"
},
{
"path": "R/future_kernapply.R",
"chars": 1433,
"preview": "#' Apply Smoothing Kernel in Parallel\n#'\n#' `future_kernapply()` is a futurized version of\n#' [stats::kernapply()], i.e."
},
{
"path": "R/future_lapply.R",
"chars": 12575,
"preview": "#' Apply a Function over a List or Vector via Futures\n#'\n#' `future_lapply()` implements [base::lapply()] using futures "
},
{
"path": "R/future_mapply.R",
"chars": 7127,
"preview": "#' Apply a Function to Multiple List or Vector Arguments\n#'\n#' `future_mapply()` implements [base::mapply()] using futur"
},
{
"path": "R/future_replicate.R",
"chars": 1120,
"preview": "#' @inheritParams future_lapply\n#'\n#' @param n The number of replicates.\n#'\n#' @param expr An \\R expression to evaluate "
},
{
"path": "R/future_sapply.R",
"chars": 1078,
"preview": "#' @inheritParams future_lapply\n#' \n#' @param simplify See [base::sapply()] and [base::tapply()], respectively.\n#' \n#' @"
},
{
"path": "R/future_tapply.R",
"chars": 3295,
"preview": "#' @inheritParams future_lapply\n#'\n#' @param X An \\R object for which a \\code{\\link[base]{split}} method\n#' exists. Typ"
},
{
"path": "R/future_vapply.R",
"chars": 2889,
"preview": "#' @inheritParams future_lapply\n#' \n#' @param FUN.VALUE A template for the required return value from\n#' each `FUN(X[ii]"
},
{
"path": "R/future_xapply.R",
"chars": 14491,
"preview": "#' @importFrom future cancel Future nbrOfWorkers future resolve value as.FutureGlobals getGlobalsAndPackages\nfuture_xapp"
},
{
"path": "R/globals.R",
"chars": 4198,
"preview": "#' @importFrom globals globalsByName\n#' @importFrom future as.FutureGlobals getGlobalsAndPackages resolve\ngetGlobalsAndP"
},
{
"path": "R/makeChunks.R",
"chars": 4162,
"preview": "#' Create Chunks of Index Vectors\n#'\n#' _This is an internal function._\n#' \n#' @param nbrOfElements (integer) Total numb"
},
{
"path": "R/options.R",
"chars": 4096,
"preview": "#' Options used for future.apply\n#'\n#' Below are the \\R options and environment variables that are used by the\n#' \\pkg{f"
},
{
"path": "R/testme.R",
"chars": 420,
"preview": "## This runs 'testme' test inst/testme/test-<name>.R scripts\n## Don't edit - it was autogenerated by inst/testme/deploy."
},
{
"path": "R/utils,conditions.R",
"chars": 1016,
"preview": "stopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint\n msg <- sprintf(fmt, ...)\n msg <- .makeMessage(msg"
},
{
"path": "R/utils-debug.R",
"chars": 2141,
"preview": "now <- function(x = Sys.time(), format = \"[%H:%M:%OS3] \") {\n ## format(x, format = format) ## slower\n format(as.POSIXl"
},
{
"path": "R/utils.R",
"chars": 3784,
"preview": "isFALSE <- function(x) {\n is.logical(x) && length(x) == 1L && !is.na(x) && !x\n}\n\nisNA <- function(x) {\n is.logical(x) "
},
{
"path": "R/zzz.R",
"chars": 650,
"preview": ".package <- new.env()\n\n## covr: skip=all\n.onLoad <- function(libname, pkgname) {\n .package[[\"version\"]] <- utils::packa"
},
{
"path": "README.md",
"chars": 7381,
"preview": "\n\n<div id=\"badges\"><!-- pkgdown markup -->\n<a href=\"https://CRAN.R-project.org/web/checks/check_results_future.apply.htm"
},
{
"path": "cran-comments.md",
"chars": 806,
"preview": "# CRAN submission future.apply 1.11.3\n\non 2024-10-27\n\nI've verified this submission has no negative impact on any of the"
},
{
"path": "incl/OVERVIEW.md",
"chars": 647,
"preview": "<%\n## Reuse the main vignette\nmd <- R.rsp::rstring(file=\"vignettes/future.apply-1-overview.md.rsp\", postprocess=FALSE)\n\n"
},
{
"path": "incl/future_Filter.R",
"chars": 256,
"preview": "## ---------------------------------------------------------\n## Filter()\n## --------------------------------------------"
},
{
"path": "incl/future_apply.R",
"chars": 1217,
"preview": "## ---------------------------------------------------------\n## apply()\n## ---------------------------------------------"
},
{
"path": "incl/future_by.R",
"chars": 540,
"preview": "## ---------------------------------------------------------\n## by()\n## ------------------------------------------------"
},
{
"path": "incl/future_lapply.R",
"chars": 2468,
"preview": "## ---------------------------------------------------------\n## lapply(), sapply(), tapply()\n## ------------------------"
},
{
"path": "incl/future_mapply.R",
"chars": 1829,
"preview": "## ---------------------------------------------------------\n## mapply()\n## --------------------------------------------"
},
{
"path": "incl/make_rng_seeds.R",
"chars": 164,
"preview": "## Set up L'Ecuyer-CMRG random seeds for 100 parallel tasks\n## based on .Random.seed in the current R process\nseeds <- m"
},
{
"path": "incl/random_seed_utils.R",
"chars": 933,
"preview": "## This example gives identical results in the two\n## approaches only if .Random.seed already exists\nseed_org <- next_ra"
},
{
"path": "inst/CITATION",
"chars": 1003,
"preview": "utils::bibentry(\n header = \"Please cite 'future' and the future framework using the following references:\",\n\n # - - - "
},
{
"path": "inst/WORDLIST",
"chars": 292,
"preview": "AppVeyor\narity\nbatchtools\nbenchmarking\nBiocParallel\ncallr\nCMD\nCMRG\ndoFuture\ndoMC\ndoParallel\neapply\nforeach\nfurrr\nfuturiz"
},
{
"path": "inst/testme/_epilogue/001.undo-future.R",
"chars": 96,
"preview": "## Undo future debug\noptions(future.debug = FALSE)\n\n## Undo future strategy\nfuture::plan(oplan)\n"
},
{
"path": "inst/testme/_epilogue/002.undo-state.R",
"chars": 2576,
"preview": "testme <- as.environment(\"testme\")\nhpaste <- future:::hpaste\n\n## Undo options\n## (a) Reset\noptions(oopts0)\n\n## (b) Remov"
},
{
"path": "inst/testme/_epilogue/090.gc.R",
"chars": 308,
"preview": "## Travis CI specific: Explicit garbage collection because it\n## looks like Travis CI might run out of memory during 'co"
},
{
"path": "inst/testme/_epilogue/099.session_info.R",
"chars": 141,
"preview": "testme <- as.environment(\"testme\")\nif (testme[[\"debug\"]]) {\n info <- utils::sessionInfo()\n message(\"Session informatio"
},
{
"path": "inst/testme/_epilogue/995.detritus-connections.R",
"chars": 301,
"preview": "## Look for detritus files\ntestme <- as.environment(\"testme\")\nlocal({\n delta <- diff_connections(get_connections(), tes"
},
{
"path": "inst/testme/_epilogue/999.detritus-files.R",
"chars": 1135,
"preview": "## Look for detritus files\ntestme <- as.environment(\"testme\")\n\nlocal({\n path <- dirname(tempdir())\n \n if (basename(pa"
},
{
"path": "inst/testme/_prologue/001.load.R",
"chars": 71,
"preview": "testme <- as.environment(\"testme\")\nloadNamespace(testme[[\"package\"]])\n\n"
},
{
"path": "inst/testme/_prologue/002.record-state.R",
"chars": 110,
"preview": "## Record original state\novars <- ls(envir = globalenv())\noenvs <- oenvs0 <- Sys.getenv()\noopts0 <- options()\n"
},
{
"path": "inst/testme/_prologue/030.imports.R",
"chars": 512,
"preview": "## Private future functions\nfold <- future.apply:::fold\nhpaste <- future.apply:::hpaste\nmdebug <- future.apply:::mdebug\n"
},
{
"path": "inst/testme/_prologue/050.utils.R",
"chars": 158,
"preview": "## Local functions for test scripts\nprintf <- function(...) cat(sprintf(...))\nmstr <- function(...) message(paste(captur"
},
{
"path": "inst/testme/_prologue/090.context.R",
"chars": 212,
"preview": "fullTest <- (Sys.getenv(\"_R_CHECK_FULL_\") != \"\")\n\ncovr_testing <- (\"covr\" %in% loadedNamespaces())\non_macos <- grepl(\"^d"
},
{
"path": "inst/testme/_prologue/090.options.R",
"chars": 278,
"preview": "## Default options\noopts <- options(\n warn = 1L,\n showNCalls = 500L,\n mc.cores = 2L,\n future.debug = FALSE,\n ## Res"
},
{
"path": "inst/testme/_prologue/091.envvars.R",
"chars": 1183,
"preview": "## Comment: The below should be set automatically whenever the future package\n## is loaded and 'R CMD check' runs. The "
},
{
"path": "inst/testme/_prologue/099.future-setup.R",
"chars": 612,
"preview": "## Use sequential futures by default\noplan <- local({\n oopts <- options(future.debug = FALSE)\n on.exit(options(oopts))"
},
{
"path": "inst/testme/_prologue/995.detrius-connections.R",
"chars": 1742,
"preview": "get_connections <- function() {\n cons <- lapply(getAllConnections(), FUN = function(idx) {\n tryCatch({\n con <- "
},
{
"path": "inst/testme/deploy.R",
"chars": 2370,
"preview": "#!/usr/bin/env Rscript\n\nsource <- \"./inst/testme\"\nif (!utils::file_test(\"-d\", source)) {\n stop(\"Source 'testme' folder "
},
{
"path": "inst/testme/run.R",
"chars": 11819,
"preview": "#!/usr/bin/env Rscript\n\n#' Run a 'testme' Test Script\n#'\n#' R usage:\n#' testme(\"<name>\")\n#'\n#' Command-line usage:\n#' te"
},
{
"path": "inst/testme/test-fold.R",
"chars": 1987,
"preview": "#' @tags fold\n\nloadNamespace(\"future.apply\")\n\nmessage(\"*** fold() ...\")\n\nx1s <- list(\n a = NULL,\n b = 1,\n c = c(a = 1"
},
{
"path": "inst/testme/test-future_Filter.R",
"chars": 609,
"preview": "#' @tags future_Filter\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_Filter() ."
},
{
"path": "inst/testme/test-future_apply.R",
"chars": 3991,
"preview": "#' @tags future_apply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_apply() ..."
},
{
"path": "inst/testme/test-future_by.R",
"chars": 3095,
"preview": "#' @tags future_by\n#' @tags listenv\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\nlibrary(listenv)\n\n"
},
{
"path": "inst/testme/test-future_eapply.R",
"chars": 1010,
"preview": "#' @tags future_eapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_eapply() ."
},
{
"path": "inst/testme/test-future_kernapply.R",
"chars": 1128,
"preview": "if (require(\"datasets\") && require(\"stats\")) {\n library(future.apply)\n library(datasets)\n \n plan(multisession)\n \n "
},
{
"path": "inst/testme/test-future_lapply,RNG.R",
"chars": 5931,
"preview": "#' @tags future_lapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_lapply() a"
},
{
"path": "inst/testme/test-future_lapply,globals.R",
"chars": 7987,
"preview": "#' @tags future_lapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\nlibrary(tools) ## toTitleCase()"
},
{
"path": "inst/testme/test-future_lapply.R",
"chars": 4421,
"preview": "#' @tags future_lapply\n#' @tags listenv\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\nlibrary(listen"
},
{
"path": "inst/testme/test-future_mapply,globals.R",
"chars": 6534,
"preview": "#' @tags future_mapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\nlibrary(tools) ## toTitleCase()"
},
{
"path": "inst/testme/test-future_mapply.R",
"chars": 8113,
"preview": "#' @tags future_mapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_mapply() ."
},
{
"path": "inst/testme/test-future_replicate.R",
"chars": 1122,
"preview": "library(future.apply)\n\nmessage(\"*** future_replicate() ...\")\n\nfor (strategy in supportedStrategies()) {\n message(sprint"
},
{
"path": "inst/testme/test-future_sapply.R",
"chars": 1868,
"preview": "#' @tags future_sapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** future_sapply() ."
},
{
"path": "inst/testme/test-future_tapply.R",
"chars": 5528,
"preview": "#' @tags future_tapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nlibrary(\"datasets\") ## warpbre"
},
{
"path": "inst/testme/test-future_vapply.R",
"chars": 5175,
"preview": "#' @tags future_vapply\n#' @tags detritus-files\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessag"
},
{
"path": "inst/testme/test-globals,tricky2.R",
"chars": 1178,
"preview": "#' @tags future_apply\n#' @tags globals\n#' @tags detritus-files\n#' @tags sequential multisession multicore\n\nif (packageVe"
},
{
"path": "inst/testme/test-globals,tricky_recursive.R",
"chars": 2131,
"preview": "#' @tags future_apply\n#' @tags globals\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\n## Test adopte"
},
{
"path": "inst/testme/test-options,nested.R",
"chars": 1413,
"preview": "#' @tags future_lapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** Options in nested"
},
{
"path": "inst/testme/test-rng.R",
"chars": 4175,
"preview": "#' @tags rng\n\nloadNamespace(\"future.apply\")\n\nmessage(\"*** RNG ...\")\n\nset_random_seed(seed = NULL)\nseed <- get_random_see"
},
{
"path": "inst/testme/test-stdout.R",
"chars": 2021,
"preview": "#' @tags future_lapply future_mapply\n#' @tags sequential multisession multicore\n\nlibrary(future.apply)\n\nmessage(\"*** fut"
},
{
"path": "inst/testme/test-utils.R",
"chars": 2915,
"preview": "loadNamespace(\"future.apply\")\nstop_if_not <- future.apply:::stop_if_not\n\nmessage(\"*** utils ...\")\n\nmessage(\"*** hpaste()"
},
{
"path": "man/fold.Rd",
"chars": 1395,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fold.R\n\\name{fold}\n\\alias{fold}\n\\title{Eff"
},
{
"path": "man/future.apply.Rd",
"chars": 5113,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future.apply-package.R\n\\docType{package}\n\\"
},
{
"path": "man/future.apply.options.Rd",
"chars": 1598,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/options.R\n\\name{future.apply.options}\n\\ali"
},
{
"path": "man/future_apply.Rd",
"chars": 5201,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future_apply.R\n\\name{future_apply}\n\\alias{"
},
{
"path": "man/future_by.Rd",
"chars": 2797,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future_by.R\n\\name{future_by}\n\\alias{future"
},
{
"path": "man/future_kernapply.Rd",
"chars": 1281,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future_kernapply.R\n\\name{future_kernapply}"
},
{
"path": "man/future_lapply.Rd",
"chars": 15070,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future_eapply.R, R/future_lapply.R,\n% R/"
},
{
"path": "man/future_mapply.Rd",
"chars": 7622,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/future_Filter.R, R/future_Map.R,\n% R/fut"
},
{
"path": "man/makeChunks.Rd",
"chars": 1878,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/makeChunks.R\n\\name{makeChunks}\n\\alias{make"
},
{
"path": "pkgdown/_pkgdown.yml",
"chars": 2241,
"preview": "url: https://future.apply.futureverse.org\n\nhome:\n links:\n - text: Roadmap/Milestones\n href: https://github.com/futu"
},
{
"path": "pkgdown/_pkgdown.yml.rsp",
"chars": 1805,
"preview": "<%\npkgs_mapreduce <- c(\"futurize\", \"future.apply\", \"doFuture\", \"furrr\")\npkgs_backend <- c(\"future.batchtools\", \"future.c"
},
{
"path": "revdep/README.md",
"chars": 18474,
"preview": "# Platform\n\n|field |value |\n|:--------|:-----------------------"
},
{
"path": "revdep/cran.md",
"chars": 235,
"preview": "## revdepcheck results\n\nWe checked 259 reverse dependencies (252 from CRAN + 7 from Bioconductor), comparing R CMD check"
},
{
"path": "revdep/failures.md",
"chars": 29,
"preview": "*Wow, no problems at all. :)*"
},
{
"path": "revdep/notes.md",
"chars": 3236,
"preview": "# Notes\n\n## Setup\n\n```r\n> options(Ncpus = 6L)\n> install.packages(\"remotes\")\n> remotes::install_github(\"r-lib/revdepcheck"
},
{
"path": "revdep/problems.md",
"chars": 29338,
"preview": "# adestr (1.0.0)\n\n* Email: <mailto:meis@imbi.uni-heidelberg.de>\n* GitHub mirror: <https://github.com/cran/adestr>\n\nRun `"
},
{
"path": "revdep/revdepcheck.Renviron",
"chars": 694,
"preview": "## Environment variables set by revdepcheck.extras::run()\nR_REVDEPCHECK_TIMEOUT=${R_REVDEPCHECK_TIMEOUT:-180}\nTAR_SKIP_C"
},
{
"path": "revdep/revdepcheck.init.sh",
"chars": 633,
"preview": "#! /usr/bin/env bash\n\n## Missing or outdated LaTeX packages\nif (FALSE) {\n tinytex::install_tinytex(force = TRUE)\n mess"
},
{
"path": "revdep/run.R",
"chars": 280,
"preview": "#!/usr/bin/env Rscript\n\nprecheck <- function() {\n ## WORKAROUND: Remove checked pkgs that use file links, which otherwi"
},
{
"path": "revdep/run.pbs",
"chars": 168,
"preview": "#!/bin/bash\n## Example: qsub -l nodes=1:ppn=24 -l vmem=30gb revdep/run.pbs\n#PBS -j oe # Join STDERR and STDOUT\ncd \"$PBS"
},
{
"path": "revdep/run.sge",
"chars": 1723,
"preview": "#!/bin/bash\n## Example: qsub -pe smp 24 -l h_rt=08:00:00 revdep/run.sge\n#$ -S /bin/bash\n#$ -R yes # SGE host res"
},
{
"path": "tests/incl/end.R",
"chars": 2088,
"preview": "## Undo future strategy\nfuture::plan(oplan)\n\n\n## Undo options\n## (a) Added\nadded <- setdiff(names(options()), names(oopt"
},
{
"path": "tests/incl/start,load-only.R",
"chars": 2002,
"preview": "## Record original state\novars <- ls()\noenvs <- oenvs0 <- Sys.getenv()\noopts0 <- options()\n\ncovr_testing <- (\"covr\" %in%"
},
{
"path": "tests/test-fold.R",
"chars": 171,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-fold.R\n## Don't edit - it was autogenerated by "
},
{
"path": "tests/test-future_Filter.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_Filter.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_apply.R",
"chars": 187,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_apply.R\n## Don't edit - it was autogener"
},
{
"path": "tests/test-future_by.R",
"chars": 181,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_by.R\n## Don't edit - it was autogenerate"
},
{
"path": "tests/test-future_eapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_eapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_kernapply.R",
"chars": 195,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_kernapply.R\n## Don't edit - it was autog"
},
{
"path": "tests/test-future_lapply,RNG.R",
"chars": 197,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_lapply,RNG.R\n## Don't edit - it was auto"
},
{
"path": "tests/test-future_lapply,globals.R",
"chars": 205,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_lapply,globals.R\n## Don't edit - it was "
},
{
"path": "tests/test-future_lapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_lapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_mapply,globals.R",
"chars": 205,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_mapply,globals.R\n## Don't edit - it was "
},
{
"path": "tests/test-future_mapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_mapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_replicate.R",
"chars": 195,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_replicate.R\n## Don't edit - it was autog"
},
{
"path": "tests/test-future_sapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_sapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_tapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_tapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-future_vapply.R",
"chars": 189,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-future_vapply.R\n## Don't edit - it was autogene"
},
{
"path": "tests/test-globals,tricky2.R",
"chars": 193,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-globals,tricky2.R\n## Don't edit - it was autoge"
},
{
"path": "tests/test-globals,tricky_recursive.R",
"chars": 211,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-globals,tricky_recursive.R\n## Don't edit - it w"
},
{
"path": "tests/test-options,nested.R",
"chars": 191,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-options,nested.R\n## Don't edit - it was autogen"
},
{
"path": "tests/test-rng.R",
"chars": 169,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-rng.R\n## Don't edit - it was autogenerated by i"
},
{
"path": "tests/test-stdout.R",
"chars": 175,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-stdout.R\n## Don't edit - it was autogenerated b"
},
{
"path": "tests/test-utils.R",
"chars": 173,
"preview": "#! /usr/bin/env Rscript\n## This runs testme test script inst/testme/test-utils.R\n## Don't edit - it was autogenerated by"
},
{
"path": "vignettes/future.apply-1-overview.md.rsp",
"chars": 6705,
"preview": "<%@meta language=\"R-vignette\" content=\"--------------------------------\n%\\VignetteIndexEntry{A Future for R: Apply Funct"
}
]
About this extraction
This page contains the full source code of the HenrikBengtsson/future.apply GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 139 files (342.5 KB), approximately 104.6k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.