├── .Rbuildignore ├── .Rinstignore ├── .github ├── .gitignore ├── ISSUE_TEMPLATE │ ├── bug_report.md │ └── feature_request.md └── workflows │ ├── R-CMD-check.yaml │ ├── future-revdepcheck-top.yaml │ ├── future_tests.yaml │ ├── pkgdown.yaml │ ├── rhub.yaml │ └── test-coverage.yaml ├── .gitignore ├── .make └── Makefile ├── CONDUCT.md ├── CONTRIBUTING.md ├── DESCRIPTION ├── Makefile ├── NAMESPACE ├── NEWS.md ├── R ├── Globals-class.R ├── call_find_globals_with_dotdotdot.R ├── cleanup.R ├── environment_of.R ├── findGlobals.R ├── findGlobalsDFS.R ├── find_globals_conservative.R ├── find_globals_liberal.R ├── find_globals_ordered.R ├── globalsByName.R ├── globalsOf.R ├── options.R ├── packagesOf.R ├── testme.R ├── utils,codetools-bugfix.R ├── utils,conditions.R ├── utils-debug.R ├── utils.R ├── walkAST.R ├── where.R └── zzz.R ├── README.md ├── cran-comments.md ├── incl ├── globalsByName.R └── globalsOf.R ├── inst ├── WORDLIST └── testme │ ├── _epilogue │ ├── 002.undo-state.R │ ├── 090.gc.R │ ├── 099.session_info.R │ ├── 995.detritus-connections.R │ └── 999.detritus-files.R │ ├── _prologue │ ├── 001.load.R │ ├── 005.globals.R │ ├── 010.record-state.R │ ├── 030.imports.R │ ├── 050.utils.R │ ├── 090.context.R │ ├── 090.options.R │ ├── 091.envvars.R │ └── 995.detrius-connections.R │ ├── deploy.R │ ├── run.R │ ├── test-Globals.R │ ├── test-cleanup.R │ ├── test-codetools-bug16.R │ ├── test-conservative.R │ ├── test-dotdotdot.R │ ├── test-findGlobals,dfs.R │ ├── test-findGlobals.R │ ├── test-formulas.R │ ├── test-globalsByName.R │ ├── test-globalsOf,locals.R │ ├── test-globalsOf.R │ ├── test-liberal.R │ ├── test-utils.R │ ├── test-walkAST.R │ └── test-zzz.R ├── man ├── Globals.Rd ├── cleanup.Globals.Rd ├── globalsByName.Rd ├── globalsOf.Rd ├── packagesOf.Globals.Rd ├── private_length.Rd └── walkAST.Rd ├── pkgdown ├── _pkgdown.yml ├── _pkgdown.yml.rsp └── favicon │ ├── apple-touch-icon-120x120.png │ ├── apple-touch-icon-60x60.png │ ├── apple-touch-icon-76x76.png │ ├── apple-touch-icon.png │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ └── favicon.ico ├── revdep ├── DESCRIPTION ├── NOT_CRAN │ ├── README.md │ ├── cran.md │ ├── failures.md │ └── problems.md ├── README.md ├── cran.md ├── failures.md ├── problems.md ├── revdepcheck.Renviron ├── run.R ├── run.pbs └── run.sge └── tests ├── test-Globals.R ├── test-cleanup.R ├── test-codetools-bug16.R ├── test-conservative.R ├── test-dotdotdot.R ├── test-findGlobals,dfs.R ├── test-findGlobals.R ├── test-formulas.R ├── test-globalsByName.R ├── test-globalsOf,locals.R ├── test-globalsOf.R ├── test-liberal.R ├── test-utils.R ├── test-walkAST.R └── test-zzz.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | #---------------------------- 2 | # Git and SVN related 3 | #---------------------------- 4 | ^.svn 5 | ^.git 6 | ^.github 7 | ^.make 8 | ^.local 9 | INSTALL[.]md 10 | OVERVIEW[.]md 11 | README[.]md 12 | CONDUCT[.]md 13 | CONTRIBUTING[.]md 14 | ^docs 15 | ^pkgdown 16 | 17 | 18 | #---------------------------- 19 | # devtools 20 | #---------------------------- 21 | ^revdep 22 | 23 | #---------------------------- 24 | # Travis-CI et al. 25 | #---------------------------- 26 | ^[.]travis[.]yml$ 27 | ^travis-tool[.]sh$ 28 | ^pkg-build[.]sh$ 29 | ^appveyor[.]yml$ 30 | ^covr-utils.R$ 31 | ^[.]covr[.]R$ 32 | ^[.]covr[.]rds$ 33 | 34 | #---------------------------- 35 | # R related 36 | #---------------------------- 37 | Rplots.pdf$ 38 | ^cran-comments[.].*$ 39 | ^vignettes/.*[.](pdf|PDF)$ 40 | ^vignettes/.*[.](r|R)$ 41 | ^vignettes/[.]install_extras$ 42 | ^Makefile$ 43 | ^incl 44 | ^NAMESPACE,.*[.]txt$ 45 | ^nohup.*$ 46 | ^[.]R 47 | ^[.]benchmark 48 | ^[.]devel 49 | ^[.]test 50 | ^[.]check 51 | ^.*[.]tar[.]gz$ 52 | 53 | #---------------------------- 54 | # Package specific 55 | #---------------------------- 56 | ^[.]BatchJobs[.]R$ 57 | [.]future 58 | ^last.dump_.* 59 | 60 | -------------------------------------------------------------------------------- /.Rinstignore: -------------------------------------------------------------------------------- 1 | # Certain LaTeX files (e.g. bib, bst, sty) must be part of the build 2 | # such that they are available for R CMD check. These are excluded 3 | # from the install using .Rinstignore in the top-level directory 4 | # such as this one. 5 | doc/.*[.](bib|bst|sty)$ 6 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: 'bug' 6 | assignees: '' 7 | 8 | --- 9 | **Describe the bug** 10 | 11 | A clear and concise description of what the bug is. 12 | 13 | 14 | **Reproduce example** 15 | 16 | A reproducible example using R code. 17 | 18 | Please format your inline code and code blocks using Markdown (). 19 | 20 | 21 | **Expected behavior** 22 | 23 | A clear and concise description of what you expected to happen. 24 | 25 | 26 | **Session information** 27 | 28 | Please share your session information *after* the error has occurred so that we also see which packages and versions are involved; 29 | 30 | ```r 31 | > sessionInfo() 32 | ``` 33 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: 'feature request' 6 | assignees: '' 7 | 8 | --- 9 | **Wish or feature request** 10 | 11 | A clear and concise description of what the problem is. For example, I would like to be able to ... 12 | 13 | Please format your inline code and code blocks using Markdown (). 14 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | name: R-CMD-check 4 | 5 | jobs: 6 | R-CMD-check: 7 | if: "! contains(github.event.head_commit.message, '[ci skip]')" 8 | 9 | timeout-minutes: 30 10 | 11 | runs-on: ${{ matrix.config.os }} 12 | 13 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) ${{ matrix.config.label }} 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | config: 19 | - {os: windows-latest, r: 'devel' } 20 | - {os: windows-latest, r: 'release' } 21 | # - {os: macOS-latest, r: 'devel' } 22 | # - {os: macOS-latest, r: 'release' } 23 | # - {os: macOS-latest, r: 'oldrel' } 24 | - {os: ubuntu-latest, r: 'devel' } 25 | - {os: ubuntu-latest, r: 'release' } 26 | - {os: ubuntu-latest, r: 'oldrel' } 27 | - {os: ubuntu-latest, r: 'oldrel-1' } 28 | - {os: ubuntu-latest, r: 'oldrel-2' } 29 | - {os: ubuntu-latest, r: '3.6' } 30 | - {os: ubuntu-latest, r: 'release' , language: ko, label: ko } 31 | - {os: ubuntu-latest, r: 'release' , language: zh_CN, label: zh_CN } 32 | - {os: ubuntu-latest, r: 'release' , language: zh_TW, label: zh_TW } 33 | env: 34 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 35 | R_KEEP_PKG_SOURCE: yes 36 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 37 | ## Test in other locale (optional) 38 | LANGUAGE: ${{ matrix.config.language }} 39 | ## R CMD check 40 | _R_CHECK_CRAN_INCOMING_: false 41 | _R_CHECK_MATRIX_DATA_: true 42 | _R_CHECK_SUGGESTS_ONLY_: true 43 | _R_CHECK_THINGS_IN_TEMP_DIR_: true 44 | ## R (>= 4.4.0) Note, no trailing underscore (sic!) 45 | _R_COMPARE_LANG_OBJECTS: eqonly 46 | 47 | steps: 48 | - uses: actions/checkout@v4 49 | 50 | - uses: r-lib/actions/setup-pandoc@v2 51 | 52 | - uses: r-lib/actions/setup-tinytex@v2 53 | 54 | - name: Install system dependencies (Linux) 55 | if: runner.os == 'Linux' 56 | run: sudo apt-get install -y tidy 57 | 58 | - uses: r-lib/actions/setup-r@v2 59 | with: 60 | r-version: ${{ matrix.config.r }} 61 | http-user-agent: ${{ matrix.config.http-user-agent }} 62 | use-public-rspm: true 63 | 64 | - uses: r-lib/actions/setup-r-dependencies@v2 65 | with: 66 | extra-packages: any::rcmdcheck 67 | needs: check 68 | 69 | - name: Install itself (to build vignettes) 70 | run: | 71 | install.packages(".", repos=NULL, type="source") 72 | shell: Rscript {0} 73 | 74 | - name: Session info 75 | run: | 76 | options(width = 100) 77 | capabilities() 78 | pkgs <- installed.packages()[, "Package"] 79 | sessioninfo::session_info(pkgs, include_base = TRUE) 80 | ## Verify LANGUAGE settings by generating a translatable error 81 | cat(sprintf("LANGUAGE=%s\n", sQuote(Sys.getenv("LANGUAGE")))) 82 | cat(sprintf("locales: %s\n", sQuote(Sys.getlocale()))) 83 | tryCatch(log("a"), error = conditionMessage) 84 | shell: Rscript {0} 85 | 86 | - name: Check 87 | run: | 88 | rcmdcheck::rcmdcheck( 89 | args = c("--as-cran", if (.Platform$OS.type == "windows") "--no-manual"), 90 | error_on = "note", 91 | check_dir = "check" 92 | ) 93 | shell: Rscript {0} 94 | 95 | - name: Upload check results 96 | if: failure() 97 | uses: actions/upload-artifact@v4 98 | with: 99 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 100 | path: check 101 | -------------------------------------------------------------------------------- /.github/workflows/future-revdepcheck-top.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | name: revdepcheck-top 4 | 5 | jobs: 6 | R-CMD-check: 7 | if: "! contains(github.event.head_commit.message, '[ci skip]')" 8 | 9 | timeout-minutes: 30 10 | 11 | runs-on: ubuntu-latest 12 | 13 | name: ${{ matrix.config.pkg }} (${{ matrix.config.r }}) ${{ matrix.config.label }} 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | config: 19 | - { r: "release", pkg: "future.batchtools" } 20 | - { r: "release", pkg: "future.callr" } 21 | - { r: "release", pkg: "future.mirai" } 22 | - { r: "release", pkg: "doFuture" } 23 | - { r: "release", pkg: "future.apply" } 24 | - { r: "release", pkg: "furrr" } 25 | - { r: "release", pkg: "future.tests" } 26 | - { r: "release", pkg: "doFuture" , plan: multisession, label: multisession } 27 | - { r: "release", pkg: "future.apply" , plan: multisession, label: multisession } 28 | - { r: "release", pkg: "furrr" , plan: multisession, label: multisession } 29 | - { r: "release", pkg: "future.apply" , globals_keepWhere: true, label: 'keepWhere' } 30 | - { r: "release", pkg: "future.apply" , globals_keepWhere: false, label: '!keepWhere' } 31 | 32 | env: 33 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 34 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 35 | ## R CMD check 36 | _R_CHECK_MATRIX_DATA_: true 37 | _R_CHECK_CRAN_INCOMING_: false 38 | ## Specific to futures 39 | R_FUTURE_RNG_ONMISUSE: error 40 | R_FUTURE_PLAN: ${{ matrix.config.plan }} 41 | R_FUTURE_GLOBALS_KEEPWHERE: ${{ matrix.config.globals_keepWhere }} 42 | ## Specific to furrr (to disable expect_snapshot() tests) 43 | NOT_CRAN: false 44 | 45 | steps: 46 | - uses: actions/checkout@v4 47 | 48 | - uses: r-lib/actions/setup-pandoc@v2 49 | 50 | - uses: r-lib/actions/setup-r@v2 51 | with: 52 | r-version: ${{ matrix.config.r }} 53 | use-public-rspm: true 54 | 55 | - uses: r-lib/actions/setup-r-dependencies@v2 56 | with: 57 | extra-packages: | 58 | any::rcmdcheck 59 | any::remotes 60 | any::sessioninfo 61 | any::covr 62 | needs: check 63 | 64 | - name: Install dependencies 65 | run: | 66 | remotes::install_deps(dependencies = TRUE) 67 | install.packages(".", repos=NULL, type="source") 68 | install.packages("${{ matrix.config.pkg }}", dependencies=TRUE) 69 | shell: Rscript {0} 70 | 71 | - name: Session info 72 | run: | 73 | options(width = 100) 74 | pkgs <- installed.packages()[, "Package"] 75 | sessioninfo::session_info(pkgs, include_base = TRUE) 76 | shell: Rscript {0} 77 | 78 | - name: Check reverse dependency package 79 | run: | 80 | url=$(Rscript -e "cat(remotes:::download_version_url('${{ matrix.config.pkg }}', version=NULL, repos='https://cloud.r-project.org', type='source'))") 81 | wget "$url" 82 | R CMD check --no-manual --as-cran "$(basename "$url")" 83 | 84 | - name: Upload check results 85 | if: failure() 86 | uses: actions/upload-artifact@v4 87 | with: 88 | name: ${{ runner.os }}-r${{ matrix.config.r }}-revdep${{ matrix.config.pkg }}-results 89 | path: ${{ matrix.config.pkg }}.Rcheck 90 | -------------------------------------------------------------------------------- /.github/workflows/future_tests.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | name: future_tests 4 | 5 | jobs: 6 | future_tests: 7 | if: "! contains(github.event.head_commit.message, '[ci skip]')" 8 | 9 | timeout-minutes: 30 10 | 11 | runs-on: ubuntu-latest 12 | 13 | name: future.plan=${{ matrix.future.plan }} 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | future: 19 | - { plan: 'cluster' } 20 | - { plan: 'multicore' } 21 | - { plan: 'multisession' } 22 | - { plan: 'sequential' } 23 | - { plan: 'future.batchtools::batchtools_local' } 24 | - { plan: 'future.batchtools::batchtools_bash' } 25 | - { plan: 'future.callr::callr' } 26 | - { plan: 'future.mirai::mirai_multisession' } 27 | 28 | env: 29 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 30 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 31 | ## R CMD check 32 | _R_CHECK_LENGTH_1_LOGIC2_: true 33 | _R_CHECK_MATRIX_DATA_: true 34 | _R_CHECK_CRAN_INCOMING_: false 35 | ## Specific to futures 36 | R_FUTURE_RNG_ONMISUSE: error 37 | 38 | steps: 39 | - uses: actions/checkout@v4 40 | 41 | - uses: r-lib/actions/setup-pandoc@v2 42 | 43 | - uses: r-lib/actions/setup-r@v2 44 | with: 45 | use-public-rspm: true 46 | 47 | - uses: r-lib/actions/setup-r-dependencies@v2 48 | with: 49 | extra-packages: | 50 | any::rcmdcheck 51 | any::remotes 52 | any::sessioninfo 53 | any::covr 54 | needs: check 55 | 56 | - name: Install dependencies 57 | run: | 58 | remotes::install_deps(dependencies = TRUE) 59 | install.packages(".", repos=NULL, type="source") 60 | shell: Rscript {0} 61 | 62 | - name: Session info 63 | run: | 64 | options(width = 100) 65 | pkgs <- installed.packages()[, "Package"] 66 | sessioninfo::session_info(pkgs, include_base = TRUE) 67 | shell: Rscript {0} 68 | 69 | - name: Install 'future.tests' and any backend R packages 70 | run: | 71 | remotes::install_cran("future.tests") 72 | if (grepl("::", plan <- "${{ matrix.future.plan }}") && nzchar(pkg <- sub("::.*", "", plan))) install.packages(pkg) 73 | shell: Rscript {0} 74 | 75 | - name: Session info 76 | run: | 77 | options(width = 100) 78 | pkgs <- installed.packages()[, "Package"] 79 | sessioninfo::session_info(pkgs, include_base = TRUE) 80 | shell: Rscript {0} 81 | 82 | - name: Check future backend '${{ matrix.future.plan }}' 83 | run: | 84 | R CMD build --no-build-vignettes --no-manual . 85 | R CMD INSTALL *.tar.gz 86 | Rscript -e future.tests::check --args --test-plan=${{ matrix.future.plan }} 87 | 88 | - name: Upload check results 89 | if: failure() 90 | uses: actions/upload-artifact@v4 91 | with: 92 | name: ${{ runner.os }}-r${{ matrix.future.plan }}-results 93 | path: check 94 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master, develop] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | timeout-minutes: 15 17 | 18 | runs-on: ubuntu-latest 19 | # Only restrict concurrency for non-PR jobs 20 | concurrency: 21 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 22 | env: 23 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 24 | steps: 25 | - uses: actions/checkout@v4 26 | 27 | - uses: r-lib/actions/setup-pandoc@v2 28 | 29 | - uses: r-lib/actions/setup-r@v2 30 | with: 31 | use-public-rspm: true 32 | 33 | - uses: r-lib/actions/setup-r-dependencies@v2 34 | with: 35 | extra-packages: any::pkgdown, local::. 36 | needs: website 37 | 38 | - name: Build site 39 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 40 | shell: Rscript {0} 41 | 42 | - name: Deploy to GitHub pages 🚀 43 | if: github.event_name != 'pull_request' 44 | uses: JamesIves/github-pages-deploy-action@v4.4.1 45 | with: 46 | clean: false 47 | branch: gh-pages 48 | folder: docs 49 | -------------------------------------------------------------------------------- /.github/workflows/rhub.yaml: -------------------------------------------------------------------------------- 1 | # R-hub's generic GitHub Actions workflow file. It's canonical location is at 2 | # https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml 3 | # You can update this file to a newer version using the rhub2 package: 4 | # 5 | # rhub::rhub_setup() 6 | # 7 | # It is unlikely that you need to modify this file manually. 8 | 9 | name: R-hub 10 | run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}" 11 | 12 | on: 13 | workflow_dispatch: 14 | inputs: 15 | config: 16 | description: 'A comma separated list of R-hub platforms to use.' 17 | type: string 18 | default: 'linux,windows,macos' 19 | name: 20 | description: 'Run name. You can leave this empty now.' 21 | type: string 22 | id: 23 | description: 'Unique ID. You can leave this empty now.' 24 | type: string 25 | 26 | jobs: 27 | 28 | setup: 29 | runs-on: ubuntu-latest 30 | outputs: 31 | containers: ${{ steps.rhub-setup.outputs.containers }} 32 | platforms: ${{ steps.rhub-setup.outputs.platforms }} 33 | 34 | steps: 35 | # NO NEED TO CHECKOUT HERE 36 | - uses: r-hub/actions/setup@v1 37 | with: 38 | config: ${{ github.event.inputs.config }} 39 | id: rhub-setup 40 | 41 | linux-containers: 42 | needs: setup 43 | if: ${{ needs.setup.outputs.containers != '[]' }} 44 | runs-on: ubuntu-latest 45 | name: ${{ matrix.config.label }} 46 | strategy: 47 | fail-fast: false 48 | matrix: 49 | config: ${{ fromJson(needs.setup.outputs.containers) }} 50 | container: 51 | image: ${{ matrix.config.container }} 52 | 53 | steps: 54 | - uses: r-hub/actions/checkout@v1 55 | - uses: r-hub/actions/platform-info@v1 56 | with: 57 | token: ${{ secrets.RHUB_TOKEN }} 58 | job-config: ${{ matrix.config.job-config }} 59 | - uses: r-hub/actions/setup-deps@v1 60 | with: 61 | token: ${{ secrets.RHUB_TOKEN }} 62 | job-config: ${{ matrix.config.job-config }} 63 | - uses: r-hub/actions/run-check@v1 64 | with: 65 | token: ${{ secrets.RHUB_TOKEN }} 66 | job-config: ${{ matrix.config.job-config }} 67 | 68 | other-platforms: 69 | needs: setup 70 | if: ${{ needs.setup.outputs.platforms != '[]' }} 71 | runs-on: ${{ matrix.config.os }} 72 | name: ${{ matrix.config.label }} 73 | strategy: 74 | fail-fast: false 75 | matrix: 76 | config: ${{ fromJson(needs.setup.outputs.platforms) }} 77 | 78 | steps: 79 | - uses: r-hub/actions/checkout@v1 80 | - uses: r-hub/actions/setup-r@v1 81 | with: 82 | job-config: ${{ matrix.config.job-config }} 83 | token: ${{ secrets.RHUB_TOKEN }} 84 | - uses: r-hub/actions/platform-info@v1 85 | with: 86 | token: ${{ secrets.RHUB_TOKEN }} 87 | job-config: ${{ matrix.config.job-config }} 88 | - uses: r-hub/actions/setup-deps@v1 89 | with: 90 | job-config: ${{ matrix.config.job-config }} 91 | token: ${{ secrets.RHUB_TOKEN }} 92 | - uses: r-hub/actions/run-check@v1 93 | with: 94 | job-config: ${{ matrix.config.job-config }} 95 | token: ${{ secrets.RHUB_TOKEN }} 96 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | 3 | name: test-coverage.yaml 4 | 5 | permissions: read-all 6 | 7 | jobs: 8 | test-coverage: 9 | runs-on: ubuntu-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | 13 | steps: 14 | - uses: actions/checkout@v4 15 | 16 | - name: Assert CODECOV_TOKEN is set 17 | run: | 18 | if [[ -z "${{secrets.CODECOV_TOKEN}}" ]]; then 19 | >&2 echo "::error::ERROR: 'secrets.CODECOV_TOKEN' not set" 20 | exit 1 21 | fi 22 | 23 | - uses: r-lib/actions/setup-r@v2 24 | with: 25 | use-public-rspm: true 26 | 27 | - uses: r-lib/actions/setup-r-dependencies@v2 28 | with: 29 | extra-packages: any::covr, any::xml2 30 | needs: coverage 31 | 32 | - name: Test coverage 33 | run: | 34 | cov <- covr::package_coverage( 35 | quiet = FALSE, 36 | clean = FALSE, 37 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 38 | ) 39 | print(cov) 40 | covr::to_cobertura(cov) 41 | shell: Rscript {0} 42 | 43 | - uses: codecov/codecov-action@v4 44 | with: 45 | fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} 46 | file: ./cobertura.xml 47 | plugin: noop 48 | disable_search: true 49 | token: ${{ secrets.CODECOV_TOKEN }} 50 | 51 | - name: Upload test results 52 | if: failure() 53 | uses: actions/upload-artifact@v4 54 | with: 55 | name: coverage-test-failures 56 | path: ${{ runner.temp }}/package 57 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rhistory 2 | *~ 3 | .check 4 | .make/ 5 | .local/ 6 | .test 7 | .o 8 | .dll 9 | .async 10 | revdep/data.sqlite 11 | revdep/checks/* 12 | revdep/library/* 13 | docs/ 14 | -------------------------------------------------------------------------------- /CONDUCT.md: -------------------------------------------------------------------------------- 1 | 2 | # Contributor Covenant Code of Conduct 3 | 4 | ## Our Pledge 5 | 6 | We as members, contributors, and leaders pledge to make participation in our 7 | community a harassment-free experience for everyone, regardless of age, body 8 | size, visible or invisible disability, ethnicity, sex characteristics, gender 9 | identity and expression, level of experience, education, socio-economic status, 10 | nationality, personal appearance, race, religion, or sexual identity 11 | and orientation. 12 | 13 | We pledge to act and interact in ways that contribute to an open, welcoming, 14 | diverse, inclusive, and healthy community. 15 | 16 | ## Our Standards 17 | 18 | Examples of behavior that contributes to a positive environment for our 19 | community include: 20 | 21 | * Demonstrating empathy and kindness toward other people 22 | * Being respectful of differing opinions, viewpoints, and experiences 23 | * Giving and gracefully accepting constructive feedback 24 | * Accepting responsibility and apologizing to those affected by our mistakes, 25 | and learning from the experience 26 | * Focusing on what is best not just for us as individuals, but for the 27 | overall community 28 | 29 | Examples of unacceptable behavior include: 30 | 31 | * The use of sexualized language or imagery, and sexual attention or 32 | advances of any kind 33 | * Trolling, insulting or derogatory comments, and personal or political attacks 34 | * Public or private harassment 35 | * Publishing others' private information, such as a physical or email 36 | address, without their explicit permission 37 | * Other conduct which could reasonably be considered inappropriate in a 38 | professional setting 39 | 40 | ## Enforcement Responsibilities 41 | 42 | Community leaders are responsible for clarifying and enforcing our standards of 43 | acceptable behavior and will take appropriate and fair corrective action in 44 | response to any behavior that they deem inappropriate, threatening, offensive, 45 | or harmful. 46 | 47 | Community leaders have the right and responsibility to remove, edit, or reject 48 | comments, commits, code, wiki edits, issues, and other contributions that are 49 | not aligned to this Code of Conduct, and will communicate reasons for moderation 50 | decisions when appropriate. 51 | 52 | ## Scope 53 | 54 | This Code of Conduct applies within all community spaces, and also applies when 55 | an individual is officially representing the community in public spaces. 56 | Examples of representing our community include using an official e-mail address, 57 | posting via an official social media account, or acting as an appointed 58 | representative at an online or offline event. 59 | 60 | ## Enforcement 61 | 62 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 63 | reported to the project lead. 64 | All complaints will be reviewed and investigated promptly and fairly. 65 | 66 | All community leaders are obligated to respect the privacy and security of the 67 | reporter of any incident. 68 | 69 | ## Enforcement Guidelines 70 | 71 | Community leaders will follow these Community Impact Guidelines in determining 72 | the consequences for any action they deem in violation of this Code of Conduct: 73 | 74 | ### 1. Correction 75 | 76 | **Community Impact**: Use of inappropriate language or other behavior deemed 77 | unprofessional or unwelcome in the community. 78 | 79 | **Consequence**: A private, written warning from community leaders, providing 80 | clarity around the nature of the violation and an explanation of why the 81 | behavior was inappropriate. A public apology may be requested. 82 | 83 | ### 2. Warning 84 | 85 | **Community Impact**: A violation through a single incident or series 86 | of actions. 87 | 88 | **Consequence**: A warning with consequences for continued behavior. No 89 | interaction with the people involved, including unsolicited interaction with 90 | those enforcing the Code of Conduct, for a specified period of time. This 91 | includes avoiding interactions in community spaces as well as external channels 92 | like social media. Violating these terms may lead to a temporary or 93 | permanent ban. 94 | 95 | ### 3. Temporary Ban 96 | 97 | **Community Impact**: A serious violation of community standards, including 98 | sustained inappropriate behavior. 99 | 100 | **Consequence**: A temporary ban from any sort of interaction or public 101 | communication with the community for a specified period of time. No public or 102 | private interaction with the people involved, including unsolicited interaction 103 | with those enforcing the Code of Conduct, is allowed during this period. 104 | Violating these terms may lead to a permanent ban. 105 | 106 | ### 4. Permanent Ban 107 | 108 | **Community Impact**: Demonstrating a pattern of violation of community 109 | standards, including sustained inappropriate behavior, harassment of an 110 | individual, or aggression toward or disparagement of classes of individuals. 111 | 112 | **Consequence**: A permanent ban from any sort of public interaction within 113 | the community. 114 | 115 | ## Attribution 116 | 117 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 118 | version 2.0, available at 119 | https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. 120 | 121 | Community Impact Guidelines were inspired by [Mozilla's code of conduct 122 | enforcement ladder](https://github.com/mozilla/diversity). 123 | 124 | [homepage]: https://www.contributor-covenant.org 125 | 126 | For answers to common questions about this code of conduct, see the FAQ at 127 | https://www.contributor-covenant.org/faq. Translations are available at 128 | https://www.contributor-covenant.org/translations. 129 | 130 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | 2 | # Contributing to the 'globals' package 3 | 4 | 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/globals/tree/develop) branch contains the latest contributions and other code that will appear in the next release, and the [`master`](https://github.com/futureverse/globals) branch contains the code of the latest release, which is exactly what is currently on [CRAN](https://cran.r-project.org/package=globals). 5 | 6 | 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 [globals repository](https://github.com/futureverse/globals). Your PR should pass `R CMD check --as-cran`, which will also be checked by GitHub Actions and when the PR is submitted. 7 | 8 | We abide to the [Code of Conduct](https://www.contributor-covenant.org/version/2/0/code_of_conduct/) of Contributor Covenant. 9 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: globals 2 | Version: 0.18.0-9002 3 | Depends: 4 | R (>= 3.1.2) 5 | Imports: 6 | codetools 7 | Title: Identify Global Objects in R Expressions 8 | Authors@R: c( 9 | person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), 10 | email="henrikb@braju.com"), 11 | person("Davis","Vaughan", role="ctb", 12 | email="davis@posit.co")) 13 | Description: Identifies global ("unknown" or "free") objects in R expressions 14 | by code inspection using various strategies (ordered, liberal, 15 | conservative, or deep-first search). The objective of this package is to 16 | make it as simple as possible to identify global objects for the purpose 17 | of exporting them in parallel, distributed compute environments. 18 | License: LGPL (>= 2.1) 19 | LazyLoad: TRUE 20 | ByteCompile: TRUE 21 | Language: en-US 22 | Encoding: UTF-8 23 | URL: https://globals.futureverse.org, https://github.com/futureverse/globals 24 | BugReports: https://github.com/futureverse/globals/issues 25 | RoxygenNote: 7.3.2 26 | Roxygen: list(markdown = TRUE) 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include .make/Makefile 2 | 3 | spelling: 4 | $(R_SCRIPT) -e "spelling::spell_check_package()" 5 | $(R_SCRIPT) -e "spelling::spell_check_files(c('NEWS.md'), ignore=readLines('inst/WORDLIST', warn=FALSE))" 6 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("$<-",Globals) 4 | S3method("[",Globals) 5 | S3method("[<-",Globals) 6 | S3method("[[<-",Globals) 7 | S3method("names<-",Globals) 8 | S3method(as.Globals,Globals) 9 | S3method(as.Globals,default) 10 | S3method(as.Globals,list) 11 | S3method(c,Globals) 12 | S3method(cleanup,Globals) 13 | S3method(packagesOf,Globals) 14 | S3method(unique,Globals) 15 | export(Globals) 16 | export(as.Globals) 17 | export(cleanup) 18 | export(findGlobals) 19 | export(globalsByName) 20 | export(globalsOf) 21 | export(packagesOf) 22 | export(walkAST) 23 | importFrom(codetools,findLocalsList) 24 | importFrom(codetools,makeUsageCollector) 25 | importFrom(codetools,walkCode) 26 | importFrom(utils,capture.output) 27 | importFrom(utils,getS3method) 28 | importFrom(utils,packageDescription) 29 | importFrom(utils,str) 30 | -------------------------------------------------------------------------------- /R/Globals-class.R: -------------------------------------------------------------------------------- 1 | #' A representation of a set of globals 2 | #' 3 | #' @usage Globals(object, ...) 4 | #' 5 | #' @param object A named list. 6 | #' 7 | #' @param \ldots Not used. 8 | #' 9 | #' @return An object of class \code{Globals}, which is a \emph{named} list 10 | #' of the value of the globals, where the element names are the names of 11 | #' the globals. Attribute \code{where} is a named list of the same length 12 | #' and with the same names. 13 | #' 14 | #' @seealso 15 | #' The \code{\link{globalsOf}()} function identifies globals 16 | #' from an R expression and returns a Globals object. 17 | #' 18 | #' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals names 19 | #' @export 20 | Globals <- function(object = list(), ...) { 21 | if (!is.list(object)) { 22 | stopf("Argument 'object' is not a list: %s", class(object)[1]) 23 | } 24 | 25 | if (length(object) > 0) { 26 | names <- names(object) 27 | if (is.null(names)) { 28 | stop("Argument 'object' must be a named list.") 29 | } else if (!all(nzchar(names))) { 30 | stop("Argument 'object' specifies globals with empty names.") 31 | } 32 | } 33 | 34 | where <- attr(object, "where", exact = TRUE) 35 | if (length(object) == 0 && is.null(where)) { 36 | attr(object, "where") <- where <- list() 37 | } 38 | stop_if_not(is.list(where)) 39 | 40 | stop_if_not( 41 | is.list(where), 42 | length(where) == length(object), 43 | length(names(where)) == length(names(object)) 44 | ) 45 | 46 | structure(object, class = c("Globals", class(object))) 47 | } 48 | 49 | #' @export 50 | as.Globals <- function(x, ...) UseMethod("as.Globals") 51 | 52 | #' @export 53 | as.Globals.default <- function(x, ...) { 54 | stopf("Don't know how to coerce a %s to Globals", class(x)[1]) 55 | } 56 | 57 | #' @export 58 | as.Globals.Globals <- function(x, ...) x 59 | 60 | #' @export 61 | as.Globals.list <- function(x, ...) { 62 | if (length(x) > 0L) { 63 | stop_if_not(!is.null(names(x))) 64 | 65 | ## Use the globals environments as the locals? 66 | ## (with emptyenv() as the fallback) 67 | where <- attr(x, "where", exact = TRUE) 68 | if (is.null(where)) { 69 | where <- lapply(x, FUN = environment_of) 70 | names(where) <- names(x) 71 | attr(x, "where") <- where 72 | } 73 | } 74 | Globals(x, ...) 75 | } 76 | 77 | #' @export 78 | `names<-.Globals` <- function(x, value) { 79 | x <- NextMethod() 80 | where <- attr(x, "where", exact = TRUE) 81 | names(where) <- names(x) 82 | attr(x, "where") <- where 83 | invisible(x) 84 | } 85 | 86 | #' @export 87 | `[.Globals` <- function(x, i) { 88 | where <- attr(x, "where", exact = TRUE) 89 | res <- NextMethod() 90 | attr(res, "where") <- where[i] 91 | class(res) <- class(x) 92 | 93 | where <- attr(res, "where", exact = TRUE) 94 | stop_if_not( 95 | is.list(where), 96 | length(where) == length(res), 97 | length(names(where)) == length(names(res)) 98 | ) 99 | 100 | res 101 | } 102 | 103 | 104 | assign_Globals <- function(x, name, value) { 105 | stop_if_not(is.character(name), !is.na(name), nchar(name) > 0L) 106 | where <- attr(x, "where", exact = TRUE) 107 | stop_if_not(!is.null(where)) 108 | 109 | ## Remove an element? 110 | if (is.null(value)) { 111 | where[[name]] <- NULL 112 | } else { 113 | ## Value must be Globals object of length one 114 | if (inherits(value, "Globals")) { 115 | if (length(value) != 1) { 116 | stopf("Cannot assign Globals object of length different than one: %s", 117 | length(value)) 118 | } 119 | where[[name]] <- attr(value, "where", exact = TRUE)[[1]] 120 | value <- value[[1]] 121 | } else { 122 | where[[name]] <- environment_of(value) 123 | } 124 | } 125 | 126 | attr(x, "where") <- where 127 | 128 | ## Avoid call this function recursively 129 | class <- class(x) 130 | class(x) <- NULL 131 | x[[name]] <- value 132 | class(x) <- class 133 | 134 | invisible(x) 135 | } 136 | 137 | 138 | #' @export 139 | `[<-.Globals` <- function(x, names, value) { 140 | stop_if_not( 141 | length(names) == length(value), 142 | is.character(names), !anyNA(names), all(nchar(names) > 0) 143 | ) 144 | 145 | if (inherits(value, "Globals")) { 146 | where <- attr(value, "where") 147 | } else if (is.list(value)) { 148 | where <- lapply(value, FUN = environment_of) 149 | } else { 150 | stopf("Unsupported class of 'value': %s", class(value)[1]) 151 | } 152 | stop_if_not(length(where) == length(value)) 153 | 154 | x_where <- attr(x, "where", exact = TRUE) 155 | stop_if_not(!is.null(x_where)) 156 | 157 | class <- class(x) 158 | class(x) <- NULL 159 | attr(x, "where") <- NULL 160 | 161 | for (kk in seq_along(value)) { 162 | name <- names[kk] 163 | value_kk <- value[[kk]] 164 | if (is.null(value_kk)) { 165 | x[name] <- list(NULL) 166 | } else { 167 | x[[name]] <- value_kk 168 | } 169 | x_where[[name]] <- where[[kk]] 170 | } 171 | 172 | stop_if_not(length(x_where) == length(x)) 173 | 174 | attr(x, "where") <- x_where 175 | class(x) <- class 176 | 177 | invisible(x) 178 | } 179 | 180 | 181 | #' @export 182 | `$<-.Globals` <- function(x, name, value) { 183 | x <- assign_Globals(x, name = name, value = value) 184 | invisible(x) 185 | } 186 | 187 | #' @export 188 | `[[<-.Globals` <- function(x, name, value) { 189 | x <- assign_Globals(x, name = name, value = value) 190 | invisible(x) 191 | } 192 | 193 | 194 | #' @export 195 | c.Globals <- function(x, ...) { 196 | args <- list(...) 197 | 198 | where <- attr(x, "where", exact = TRUE) 199 | clazz <- class(x) 200 | class(x) <- NULL 201 | 202 | for (kk in seq_along(args)) { 203 | g <- args[[kk]] 204 | name <- names(args)[kk] 205 | 206 | if (inherits(g, "Globals")) { 207 | w <- attr(g, "where", exact = TRUE) 208 | } else if (is.list(g)) { 209 | ## Nothing to do? 210 | if (length(g) == 0) next 211 | 212 | names <- names(g) 213 | stop_if_not(!is.null(names)) 214 | w <- lapply(g, FUN = environment_of) 215 | names(w) <- names 216 | } else { 217 | if (is.null(name)) { 218 | stopf("Can only append named objects to Globals list: %s", sQuote(mode(g))) 219 | } 220 | e <- environment_of(g) 221 | g <- structure(list(g), names = name) 222 | w <- structure(list(e), names = name) 223 | } 224 | where <- c(where, w) 225 | x <- c(x, g) 226 | } 227 | 228 | attr(x, "where") <- where 229 | class(x) <- clazz 230 | 231 | stop_if_not( 232 | length(where) == length(x), 233 | all(names(where) == names(x)) 234 | ) 235 | 236 | x 237 | } 238 | 239 | #' @export 240 | unique.Globals <- function(x, ...) { 241 | names <- names(x) 242 | dups <- duplicated(names) 243 | if (any(dups)) { 244 | where <- attr(x, "where", exact = TRUE) 245 | where <- where[!dups] 246 | x <- x[!dups] 247 | attr(x, "where") <- where 248 | 249 | stop_if_not( 250 | length(where) == length(x), 251 | all(names(where) == names(x)) 252 | ) 253 | } 254 | 255 | x 256 | } 257 | -------------------------------------------------------------------------------- /R/call_find_globals_with_dotdotdot.R: -------------------------------------------------------------------------------- 1 | call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { 2 | if (trace) { 3 | trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) 4 | on.exit(trace_exit(trace_msg)) 5 | } 6 | 7 | ## Is there a need for global '...', '..1', '..2', etc.? 8 | dotdotdots <- character(0L) 9 | 10 | globals <- withCallingHandlers({ 11 | oopts <- options(warn = 0L) 12 | on.exit(options(oopts), add = TRUE) 13 | FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) 14 | }, warning = function(w) { 15 | ## Warned about '...', '..1', '..2', etc.? 16 | ## NOTE: The warning we're looking for is the one generated by 17 | ## codetools::findGlobals(). That warning is _not_ translated, 18 | ## meaning this approach should work as is as long as the message 19 | ## is not modified by codetools itself. If codetools ever changes 20 | ## this such that the below string matching fails, then the package 21 | ## tests (tests/dotdotdot.R) will detect that. In other words, 22 | ## such a change will not go unnoticed. /HB 2017-03-08 23 | msg <- w$message 24 | pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" 25 | if (grepl(pattern, msg, fixed = FALSE)) { 26 | if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) 27 | if (dotdotdot %in% c("ignore", "return", "warning")) { 28 | if (dotdotdot != "ignore") { 29 | dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) 30 | } 31 | if (dotdotdot != "warning") { 32 | ## Consume / muffle warning 33 | invokeRestart("muffleWarning") 34 | } 35 | } else if (dotdotdot == "error") { 36 | e <- simpleError(msg, w$call) 37 | stop(e) 38 | } 39 | } 40 | }) 41 | 42 | if (trace) { 43 | trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) 44 | } 45 | 46 | if (length(dotdotdots) > 0L) { 47 | dotdotdots <- unique(dotdotdots) 48 | if (trace) { 49 | trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) 50 | } 51 | globals <- c(globals, dotdotdots) 52 | } 53 | 54 | globals 55 | } 56 | 57 | 58 | call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { 59 | if (trace) { 60 | trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) 61 | on.exit(trace_exit(trace_msg)) 62 | } 63 | 64 | ## Is there a need for global '...', '..1', '..2', etc.? 65 | dotdotdots <- character(0L) 66 | 67 | globals <- withCallingHandlers({ 68 | oopts <- options(warn = 0L) 69 | on.exit(options(oopts), add = TRUE) 70 | FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) 71 | }, warning = function(w) { 72 | ## Warned about '...', '..1', '..2', etc.? 73 | ## NOTE: The warning we're looking for is the one generated by 74 | ## codetools::findGlobals(). That warning is _not_ translated, 75 | ## meaning this approach should work as is as long as the message 76 | ## is not modified by codetools itself. If codetools ever changes 77 | ## this such that the below string matching fails, then the package 78 | ## tests (tests/dotdotdot.R) will detect that. In other words, 79 | ## such a change will not go unnoticed. /HB 2017-03-08 80 | msg <- w$message 81 | pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" 82 | if (grepl(pattern, msg, fixed = FALSE)) { 83 | if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) 84 | if (dotdotdot %in% c("ignore", "return", "warning")) { 85 | if (dotdotdot != "ignore") { 86 | dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) 87 | } 88 | if (dotdotdot != "warning") { 89 | ## Consume / muffle warning 90 | invokeRestart("muffleWarning") 91 | } 92 | } else if (dotdotdot == "error") { 93 | e <- simpleError(msg, w$call) 94 | stop(e) 95 | } 96 | } 97 | }) 98 | 99 | if (trace) { 100 | trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) 101 | } 102 | 103 | if (length(dotdotdots) > 0L) { 104 | dotdotdots <- unique(dotdotdots) 105 | if (trace) { 106 | trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) 107 | } 108 | globals <- c(globals, dotdotdots) 109 | } 110 | 111 | globals 112 | } 113 | -------------------------------------------------------------------------------- /R/cleanup.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | cleanup <- function(...) UseMethod("cleanup") 3 | 4 | #' Drop certain types of globals 5 | #' 6 | #' @param globals A Globals object. 7 | #' @param drop A character vector specifying what type of globals to drop. 8 | #' @param \ldots Not used 9 | #' 10 | #' @aliases cleanup 11 | #' @export 12 | cleanup.Globals <- function(globals, drop = c("missing", "base-packages", "nativesymbolinfo"), ...) { 13 | where <- attr(globals, "where", exact = TRUE) 14 | 15 | names <- names(globals) 16 | keep <- rep(TRUE, times = length(globals)) 17 | names(keep) <- names 18 | 19 | ## Drop non-found objects 20 | drop_missing <- "missing" %in% drop 21 | 22 | ## Drop objects that are part of one of the "base" packages 23 | drop_base <- "base-packages" %in% drop 24 | 25 | ## Drop objects that are primitive functions 26 | drop_primitives <- "primitives" %in% drop 27 | 28 | ## Drop objects that calls .Internal() 29 | drop_internals <- "internals" %in% drop 30 | 31 | ## Drop objects that are of class NativeSymbolInfo used in calls 32 | ## to .Call(), .Call.graphics(), .External(), .External2(), and 33 | ## .External.graphics() 34 | drop_native_symbol_info <- "nativesymbolinfo" %in% drop 35 | 36 | for (name in names) { 37 | env <- where[[name]] 38 | 39 | if (drop_missing && is.null(env)) { 40 | keep[[name]] <- FALSE 41 | next 42 | } 43 | 44 | ## Never drop globals that are not in package environments. 45 | ## This will drop local copies of package objects, e.g. 46 | ## myView <- utils::View and format.aspell <- utils:::format.aspell 47 | if (is.environment(env) && !isPackageNamespace(env)) { 48 | next 49 | } 50 | 51 | env_name <- environmentName(env) 52 | env_name <- gsub("^package:", "", env_name) 53 | 54 | ## Never drop a global that is copy of an exported package object but 55 | ## has different name than the exported object. This avoids dropping 56 | ## local, renamed copies of package objects in a list, e.g. 57 | ## globals <- globals::as.Globals(list( 58 | ## identity = base::identity, 59 | ## my_identity = base::identity, ## should be kept 60 | ## print.aspell = utils:::print.aspell, ## should be kept 61 | ## my_print.aspell = utils:::print.aspell ## should be kept 62 | ## )) 63 | ## https://github.com/HenrikBengtsson/globals/issues/57 64 | 65 | ## Is the global an exported package object? 66 | is_exported <- exists(name, envir = asPkgEnvironment(env_name)) 67 | 68 | if (is_exported && drop_base && is_base_pkg(env_name)) { 69 | keep[[name]] <- FALSE 70 | next 71 | } 72 | 73 | global <- globals[[name]] 74 | 75 | ## Example: base::rm() 76 | if (is_exported && drop_primitives && is.primitive(global)) { 77 | keep[[name]] <- FALSE 78 | next 79 | } 80 | 81 | ## Example: base::quit() 82 | if (is_exported && drop_internals && is_internal(global)) { 83 | keep[[name]] <- FALSE 84 | next 85 | } 86 | 87 | ## Is the the global a non-exported package object? 88 | is_private <- !is_exported && !is.null(env) && exists(name, envir = env) 89 | 90 | ## Example: base::.C_R_addTaskCallback 91 | if ((is_exported || is_private) && 92 | drop_native_symbol_info && is_native_symbol_info(global)) { 93 | keep[[name]] <- FALSE 94 | next 95 | } 96 | } 97 | 98 | if (!all(keep)) { 99 | globals <- globals[keep] 100 | } 101 | 102 | globals 103 | } 104 | -------------------------------------------------------------------------------- /R/environment_of.R: -------------------------------------------------------------------------------- 1 | # A safe version of base::environment() that returns emptyenv() 2 | # if NULL is passed, instead of the calling environment. 3 | # Related to https://github.com/HenrikBengtsson/globals/issues/79 4 | environment_of <- function(obj) { 5 | if (is.null(obj)) return(emptyenv()) 6 | e <- environment(obj) 7 | if (is.null(e)) return(emptyenv()) 8 | e 9 | } 10 | -------------------------------------------------------------------------------- /R/find_globals_conservative.R: -------------------------------------------------------------------------------- 1 | ## This function is equivalent to: 2 | ## fun <- as_function(expr, envir = envir, ...) 3 | ## codetools::findGlobals(fun, merge = TRUE) 4 | ## but we expand it here to make it more explicit 5 | ## what is going on. 6 | #' @importFrom codetools findLocalsList walkCode 7 | find_globals_conservative <- function(expr, envir, dotdotdot, ..., trace = FALSE) { 8 | objs <- character() 9 | 10 | enter <- function(type, v, e, w) { 11 | objs <<- c(objs, v) 12 | } 13 | 14 | if (is.function(expr)) { 15 | if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-` 16 | fun <- expr 17 | w <- make_usage_collector(fun, name = "", enterGlobal = enter) 18 | if (trace) w <- inject_tracer_to_walker(w) 19 | collect_usage_function(fun, name = "", w, trace = trace) 20 | } else if (is.call(expr) && is.function(expr[[1]])) { 21 | ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 22 | for (e in list(expr[[1]], expr[-1])) { 23 | globals <- find_globals_conservative(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 24 | if (length(globals) > 0) objs <- c(objs, globals) 25 | } 26 | } else { 27 | ## From codetools::findGlobals(): 28 | fun <- as_function(expr, envir = envir, ...) 29 | # codetools::collectUsage(fun, enterGlobal = enter) 30 | 31 | ## The latter becomes equivalent to (after cleanup): 32 | w <- make_usage_collector(fun, name = "", enterGlobal = enter) 33 | if (trace) w <- inject_tracer_to_walker(w) 34 | 35 | locals <- findLocalsList(list(expr)) 36 | for (name in locals) assign(name, value = TRUE, envir = w$env) 37 | walkCode(expr, w) 38 | } 39 | 40 | unique(objs) 41 | } 42 | -------------------------------------------------------------------------------- /R/find_globals_liberal.R: -------------------------------------------------------------------------------- 1 | #' @importFrom codetools walkCode 2 | find_globals_liberal <- function(expr, envir, dotdotdot, ..., trace = FALSE) { 3 | objs <- character() 4 | 5 | enter <- function(type, v, e, w) { 6 | objs <<- c(objs, v) 7 | } 8 | 9 | if (is.function(expr)) { 10 | if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-` 11 | fun <- expr 12 | w <- make_usage_collector(fun, name = "", enterGlobal = enter) 13 | if (trace) w <- inject_tracer_to_walker(w) 14 | collect_usage_function(fun, name = "", w, trace = trace) 15 | } else if (is.call(expr) && is.function(expr[[1]])) { 16 | ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 17 | for (e in list(expr[[1]], expr[-1])) { 18 | globals <- find_globals_liberal(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 19 | if (length(globals) > 0) objs <- c(objs, globals) 20 | } 21 | } else { 22 | fun <- as_function(expr, envir = envir, ...) 23 | w <- make_usage_collector(fun, name = "", enterGlobal = enter) 24 | if (trace) w <- inject_tracer_to_walker(w) 25 | walkCode(expr, w) 26 | } 27 | 28 | unique(objs) 29 | } 30 | -------------------------------------------------------------------------------- /R/find_globals_ordered.R: -------------------------------------------------------------------------------- 1 | #' @importFrom codetools walkCode 2 | find_globals_ordered <- function(expr, envir, dotdotdot, ..., name = character(), class = character(), trace = FALSE) { 3 | selfassign <- getOption("globals.selfassign", TRUE) 4 | 5 | ## Identified objects are recorded in (name, class), which 6 | ## are located in this executation environment 7 | 8 | enter_local <- function(type, v, e, w) { 9 | hardcoded_locals <- names(w$env) 10 | if (trace) { 11 | trace_msg <- trace_enter("enter_local(type=%s, v=%s)", sQuote(type), sQuote(v)) 12 | trace_printf("before:\n") 13 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 14 | trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) 15 | on.exit(local({ 16 | trace_printf("after:\n") 17 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 18 | trace_exit(trace_msg) 19 | })) 20 | } 21 | 22 | is_already_local <- (v %in% hardcoded_locals) 23 | if (is_already_local) { 24 | if (trace) trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) 25 | } 26 | 27 | ## LHS <- RHS: Handle cases where a global variable exists in RHS and LHS 28 | ## assigns a local variable with the same name, e.g. x <- x + 1. 29 | ## In such case we want to detect 'x' as a global variable. 30 | if (selfassign && (type == "<-" || type == "=")) { 31 | if (trace) trace_printf("LHS <- RHS:\n") 32 | rhs <- e[[3]] 33 | globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = rhs, envir = w$env, dotdotdot = "ignore", trace = trace) 34 | if (trace) { 35 | trace_printf("RHS globals: [n=%d] %s\n", length(globals), commaq(globals)) 36 | trace_printf("hardcoded locals: [n=%d] %s\n", length(w$env), commaq(names(w$env))) 37 | } 38 | 39 | if (length(rhs) == 3 && globals[1] %in% c("::", ":::")) { 40 | ## Case: a <- pkg::a 41 | } else if (v %in% globals) { 42 | v_class <- if (v %in% hardcoded_locals) "local" else "global" 43 | if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) 44 | class <<- c(class, v_class) 45 | name <<- c(name, v) 46 | } 47 | } 48 | 49 | if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), sQuote(v)) 50 | class <<- c(class, "local") 51 | name <<- c(name, v) 52 | } ## enter_local() 53 | 54 | enter_global <- function(type, v, e, w) { 55 | hardcoded_locals <- names(w$env) 56 | if (trace) { 57 | trace_msg <- trace_enter("enter_global(type=%s, v=%s)", sQuote(type), sQuote(v)) 58 | trace_printf("before:\n") 59 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 60 | trace_printf("hardcoded locals: [n=%d] %s\n", length(hardcoded_locals), commaq(hardcoded_locals)) 61 | on.exit(local({ 62 | trace_printf("after:\n") 63 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 64 | trace_exit(trace_msg) 65 | })) 66 | } 67 | 68 | is_already_local <- (v %in% hardcoded_locals) 69 | if (is_already_local) { 70 | if (trace) { 71 | trace_printf("variable is a hardcoded local: %s\n", sQuote(v)) 72 | } 73 | } 74 | 75 | v_class <- if (is_already_local) "local" else "global" 76 | if (trace) trace_printf("Add %s variable %s\n", sQuote(v_class), sQuote(v)) 77 | class <<- c(class, v_class) 78 | name <<- c(name, v) 79 | 80 | ## Also walk formulas to identify globals 81 | if (type == "function") { 82 | if (v == "~") { 83 | if (trace) trace_printf("type = ~ (formula)\n") 84 | stop_if_not(length(e) >= 2L, identical(e[[1]], as.symbol("~"))) 85 | ## Ignoring dots overrides the default of silently returning 86 | ## them from formulas 87 | ## Fixes https://github.com/HenrikBengtsson/globals/issues/63 88 | if (dotdotdot == "ignore") { 89 | formula_dotdotdot <- "ignore" 90 | } else { 91 | formula_dotdotdot <- "return" 92 | } 93 | for (kk in 2:length(e)) { 94 | globals <- call_find_globals_with_dotdotdot(find_globals_ordered, expr = e[[kk]], envir = w$env, dotdotdot = formula_dotdotdot, trace = trace) 95 | if (length(globals) > 0) { 96 | if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) 97 | class <<- c(class, rep("global", times = length(globals))) 98 | name <<- c(name, globals) 99 | } 100 | } 101 | } else if (selfassign && (v == "<-" || v == "=")) { 102 | ## LHS <- RHS: Handle cases where a global variable exists in LHS in 103 | ## the form of x[1] <- 0, which will cause 'x' to be called 104 | ## a local variable later unless called global here. 105 | if (trace) trace_printf("LHS <- RHS:\n") 106 | lhs <- e[[2]] 107 | if (length(lhs) >= 2) { 108 | ## Cases: a[1] <- 0, names(a) <- "x", names(a)[1] <- "x" 109 | ## Skip first symbol, because it'll be handled up later as 110 | ## an assignment function, e.g. `[<-` and `names<-` 111 | globals <- find_globals_ordered(expr = lhs, envir = w$env, dotdotdot = dotdotdot, name = hardcoded_locals, class = rep("local", times = length(hardcoded_locals)), trace = trace) 112 | if (length(globals) > 0) { 113 | if (trace) trace_printf("Add %s variables %s\n", sQuote("global"), commaq(globals)) 114 | class <<- c(class, rep("global", times = length(globals))) 115 | name <<- c(name, globals) 116 | } 117 | } 118 | } else { 119 | if (trace) trace_printf("=> A function, but not of interest\n") 120 | } 121 | } else { 122 | if (trace) trace_printf("=> Nothing to else to explore\n") 123 | } 124 | } ## enter_global() 125 | 126 | 127 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 128 | # Main 129 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 130 | if (trace) { 131 | trace_msg <- trace_enter("find_globals_ordered()") 132 | on.exit(trace_exit(trace_msg)) 133 | } 134 | 135 | ## A function or an expression? 136 | if (is.function(expr)) { 137 | if (typeof(expr) != "closure") { 138 | if (trace) trace_printf("typeof != closure\n") 139 | return(character(0L)) ## e.g. `<-` 140 | } 141 | if (trace) trace_printf("type = function\n") 142 | fun <- expr 143 | w <- make_usage_collector(fun, name = "", 144 | enterLocal = enter_local, 145 | enterGlobal = enter_global) 146 | if (trace) w <- inject_tracer_to_walker(w) 147 | collect_usage_function(fun, name = "", w, trace = trace) 148 | } else if (is.expression(expr)) { 149 | if (trace) trace_printf("type = expression\n") 150 | 151 | } else if (is.call(expr) && is.function(expr[[1]])) { 152 | if (trace) trace_printf("type = a call to a function\n") 153 | ## AD HOC: Fixes https://github.com/HenrikBengtsson/globals/issues/60 154 | for (e in list(expr[[1]], expr[-1])) { 155 | globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 156 | if (length(globals) > 0) { 157 | class <- c(class, rep("global", times = length(globals))) 158 | name <- c(name, globals) 159 | } 160 | } 161 | } else if (is.call(expr) && is.symbol(expr[[1]]) && expr[[1]] == "{") { 162 | if (trace) trace_printf("type = {\n") 163 | class <- c(class, "global") 164 | name <- c(name, "{") 165 | nexpr <- length(expr) 166 | if (trace) trace_printf("length(expr) = %d\n", nexpr) 167 | if (nexpr >= 2) { 168 | for (kk in 2:nexpr) { 169 | e <- expr[[kk]] 170 | globals <- find_globals_ordered(expr = e, envir = envir, dotdotdot = dotdotdot, ..., trace = trace) 171 | if (length(globals) > 0) { 172 | if (trace) trace_printf("Add %s variable %s\n", sQuote("global"), commaq(globals)) 173 | class <- c(class, rep("global", times = length(globals))) 174 | name <- c(name, globals) 175 | } 176 | locals <- codetools::findLocals(e) 177 | if (length(locals) > 0) { 178 | if (trace) trace_printf("Add %s variable %s\n", sQuote("local"), commaq(locals)) 179 | class <- c(class, rep("locals", times = length(locals))) 180 | name <- c(name, locals) 181 | } 182 | } 183 | } 184 | } else { 185 | if (trace) trace_printf("type = call\n") 186 | if (trace) trace_printf("Convert to an anonymous function:\n") 187 | fun <- as_function(expr, envir = envir, ...) 188 | if (trace) trace_print(fun) 189 | w <- make_usage_collector(fun, name = "", 190 | enterLocal = enter_local, 191 | enterGlobal = enter_global) 192 | if (trace) w <- inject_tracer_to_walker(w) 193 | walkCode(expr, w) 194 | } 195 | 196 | if (trace) local({ 197 | trace_printf("variables (with duplicates):\n") 198 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 199 | }) 200 | 201 | ## Drop duplicated names 202 | dups <- duplicated(name) 203 | class <- class[!dups] 204 | name <- name[!dups] 205 | 206 | if (trace) local({ 207 | trace_printf("variables (no duplicates):\n") 208 | trace_print(data.frame(name=name, class=class, stringsAsFactors = FALSE)) 209 | }) 210 | 211 | unique(name[class == "global"]) 212 | } 213 | 214 | 215 | call_find_globals_with_dotdotdot <- function(FUN, expr, envir, dotdotdot = "error", trace = FALSE, debug = FALSE) { 216 | if (trace) { 217 | trace_msg <- trace_enter("call_find_globals_with_dotdotdot(dotdotdot = %s)", sQuote(dotdotdot)) 218 | on.exit(trace_exit(trace_msg)) 219 | } 220 | 221 | ## Is there a need for global '...', '..1', '..2', etc.? 222 | dotdotdots <- character(0L) 223 | 224 | globals <- withCallingHandlers({ 225 | oopts <- options(warn = 0L) 226 | on.exit(options(oopts), add = TRUE) 227 | FUN(expr, envir = envir, dotdotdot = dotdotdot, trace = trace) 228 | }, warning = function(w) { 229 | ## Warned about '...', '..1', '..2', etc.? 230 | ## NOTE: The warning we're looking for is the one generated by 231 | ## codetools::findGlobals(). That warning is _not_ translated, 232 | ## meaning this approach should work as is as long as the message 233 | ## is not modified by codetools itself. If codetools ever changes 234 | ## this such that the below string matching fails, then the package 235 | ## tests (tests/dotdotdot.R) will detect that. In other words, 236 | ## such a change will not go unnoticed. /HB 2017-03-08 237 | msg <- w$message 238 | pattern <- ".* ([.][.]([.]|[0-9]+)) may be used in an incorrect context.*" 239 | if (grepl(pattern, msg, fixed = FALSE)) { 240 | if (debug) mdebug("Warning message detected: %s", dQuote(trim(msg))) 241 | if (dotdotdot %in% c("ignore", "return", "warning")) { 242 | if (dotdotdot != "ignore") { 243 | dotdotdots <<- c(dotdotdots, gsub(pattern, "\\1", msg)) 244 | } 245 | if (dotdotdot != "warning") { 246 | ## Consume / muffle warning 247 | invokeRestart("muffleWarning") 248 | } 249 | } else if (dotdotdot == "error") { 250 | e <- simpleError(msg, w$call) 251 | stop(e) 252 | } 253 | } 254 | }) 255 | 256 | if (trace) { 257 | trace_printf("globals: [n=%d] %s\n", length(globals), commaq(globals)) 258 | } 259 | 260 | if (length(dotdotdots) > 0L) { 261 | dotdotdots <- unique(dotdotdots) 262 | if (trace) { 263 | trace_printf("dotdotdots: [n=%d] %s\n", length(dotdotdot), commaq(dotdotdots)) 264 | } 265 | globals <- c(globals, dotdotdots) 266 | } 267 | 268 | globals 269 | } 270 | -------------------------------------------------------------------------------- /R/globalsByName.R: -------------------------------------------------------------------------------- 1 | #' Locates and retrieves a set of global variables by their names 2 | #' 3 | #' @param names A character vector of global variable names. 4 | #' 5 | #' @param envir The environment from where to search for globals. 6 | #" 7 | #' @param mustExist If TRUE, an error is thrown if the object of the 8 | #' identified global cannot be located. Otherwise, the global 9 | #' is not returned. 10 | #' 11 | #' @param \ldots Not used. 12 | #' 13 | #' @section Special "argument" globals: 14 | #' If `names` specifies `"..."`, `"..1"`, `"..2"`, ..., then they 15 | #' are interpreted as arguments `...`, `..1`, `..2`, ..., respectively. 16 | #' If specified, then the corresponding elements in the results are 17 | #' lists of class `DotDotDotList` comprising the value of the latter. 18 | #' If the special argument does not exist, then the value is `NA`, and 19 | #' the corresponding `where` attributes is `NULL`. 20 | #' 21 | #' @return A \link{Globals} object of named elements and an attribute 22 | #' `where` with named elements. Both of sets have names according to 23 | #' `names`. 24 | #' 25 | #' @example incl/globalsByName.R 26 | #' 27 | #' @export 28 | globalsByName <- function(names, envir = parent.frame(), mustExist = TRUE, 29 | ...) { 30 | names <- as.character(names) 31 | nnames <- length(names) 32 | 33 | namesOrg <- names 34 | 35 | debug <- isTRUE(getOption("globals.debug")) 36 | if (debug) { 37 | info <- hpaste(sprintf('"%s"', names)) 38 | if (nnames > 1L) info <- sprintf("<%s> [n=%d]", info, nnames) 39 | info <- sprintf("%s, mustExist = %s", info, mustExist) 40 | mdebugf_push("globalsByName(%s) ...", info) 41 | mdebug("search from environment: %s", sQuote(envname(envir))) 42 | on.exit(mdebugf_pop("globalsByName(%s) ... done", info)) 43 | } 44 | 45 | ## Locate and retrieve the specified globals 46 | idxs <- grep("^[.][.]([.]|[0-9]+)$", names) 47 | if (length(idxs) > 0L) { 48 | dotdotdots <- unique(names[idxs]) 49 | names <- names[-idxs] 50 | idxs <- NULL 51 | if (debug) mdebugf("dotdotdots: %s", commaq(dotdotdots)) 52 | } else { 53 | dotdotdots <- NULL 54 | if (debug) mdebug("dotdotdots: ") 55 | } 56 | 57 | globals <- structure(vector("list", length = nnames), names = namesOrg) 58 | where <- structure(vector("list", length = nnames), names = namesOrg) 59 | for (kk in seq_along(names)) { 60 | name <- names[kk] 61 | if (debug) mdebugf("locating #%d (%s)", kk, sQuote(name)) 62 | env <- where(name, envir = envir, inherits = TRUE) 63 | if (debug) mdebugf("+ found in environment: %s", sQuote(envname(env))) 64 | if (!is.null(env)) { 65 | where[[name]] <- env 66 | value <- get(name, envir = env, inherits = FALSE) 67 | if (is.null(value)) { 68 | globals[name] <- list(NULL) 69 | } else { 70 | globals[[name]] <- value 71 | } 72 | } else { 73 | globals[name] <- list(NULL) 74 | where[name] <- list(NULL) 75 | if (mustExist) { 76 | stop(sprintf("Failed to locate global object in the relevant environments: %s", sQuote(name))) #nolint 77 | } 78 | } 79 | } 80 | 81 | if (length(dotdotdots) > 0L) { 82 | where... <- NULL 83 | has... <- exists("...", envir = envir, inherits = TRUE) 84 | if (has...) { 85 | where... <- where("...", envir = envir, inherits = TRUE) 86 | } 87 | 88 | for (name in dotdotdots) { 89 | where[name] <- list(where...) 90 | 91 | ## FIXME: If '...' in environment 'envir' specifies non-existing 92 | ## symbols, then we must not call list(...), list(..1), etc., 93 | ## because that will produce an "object not found" error. 94 | ## /HB 2023-05-19 95 | if (has...) { 96 | expr <- substitute(list(arg), list(arg = as.name(name))) 97 | ddd <- eval(expr, envir = envir, enclos = envir) 98 | } else { 99 | ddd <- NA 100 | } 101 | 102 | class(ddd) <- c("DotDotDotList", class(ddd)) 103 | globals[[name]] <- ddd 104 | } 105 | } 106 | stop_if_not( 107 | length(names(globals)) == nnames, 108 | all(names(globals) %in% namesOrg), 109 | identical(names(globals), namesOrg) 110 | ) 111 | 112 | stop_if_not( 113 | is.list(where), 114 | length(where) == length(globals), 115 | all(names(where) == names(globals)) 116 | ) 117 | 118 | attr(globals, "where") <- where 119 | class(globals) <- c("Globals", class(globals)) 120 | 121 | if (debug) { 122 | mdebug("Globals collected:") 123 | mstr(globals) 124 | } 125 | 126 | globals 127 | } ## globalsByName() 128 | -------------------------------------------------------------------------------- /R/globalsOf.R: -------------------------------------------------------------------------------- 1 | #' Get all global objects of an expression 2 | #' 3 | #' @param expr An R expression. 4 | #' 5 | #' @param envir The environment from where to search for globals. 6 | #' 7 | #' @param \ldots Not used. 8 | #' 9 | #' @param method A character string specifying what type of search algorithm 10 | #' to use. 11 | #' 12 | #' @param tweak An optional function that takes an expression 13 | #' and returns a tweaked expression. 14 | #' 15 | #' @param locals Should globals part of any "local" environment of 16 | #' a function be included or not? 17 | #' 18 | #' @param substitute If TRUE, the expression is \code{substitute()}:ed, 19 | #' otherwise not. 20 | #' 21 | #' @param mustExist If TRUE, an error is thrown if the object of the 22 | #' identified global cannot be located. Otherwise, the global 23 | #' is not returned. 24 | #' 25 | #' @param unlist If TRUE, a list of unique objects is returned. 26 | #' If FALSE, a list of \code{length(expr)} sublists. 27 | #' 28 | #' @param recursive If TRUE, found globals are searched for additional globals. 29 | #' For example, a closure (function) that exist outside a package 30 | #' namespace, may contain additional globals. Similarly, a formula 31 | #' may depend on globals. 32 | #' 33 | #' @param skip (internal) A list of globals not to be searched for 34 | #' additional globals. Ignored unless \code{recursive} is TRUE. 35 | #' 36 | #' @return \code{globalsOf()} returns a \link{Globals} object. 37 | #' 38 | #' @details 39 | #' There currently three strategies for identifying global objects. 40 | #' 41 | #' The \code{method = "ordered"} search method identifies globals such that 42 | #' a global variable preceding a local variable with the same name 43 | #' is not dropped (which the \code{"conservative"} method would). 44 | #' 45 | #' The \code{method = "conservative"} search method tries to keep the number 46 | #' of false positive to a minimum, i.e. the identified objects are 47 | #' most likely true global objects. At the same time, there is 48 | #' a risk that some true globals are not identified (see example). 49 | #' This search method returns the exact same result as the 50 | #' \code{\link[codetools]{findGlobals}()} function of the 51 | #' \pkg{codetools} package. 52 | #' 53 | #' The \code{method = "liberal"} search method tries to keep the 54 | #' true-positive ratio as high as possible, i.e. the true globals 55 | #' are most likely among the identified ones. At the same time, 56 | #' there is a risk that some false positives are also identified. 57 | #' 58 | #' The \code{method = "dfs"} search method identifies globals in 59 | #' the abstract syntax tree (AST) using a depth-first search, which 60 | #' better emulates how the R engine identifies global variables. 61 | #' 62 | #' With \code{recursive = TRUE}, globals part of locally defined 63 | #' functions will also be found, otherwise not. 64 | #' 65 | #' @example incl/globalsOf.R 66 | #' 67 | #' @seealso 68 | #' Internally, the \pkg{codetools} package is utilized for 69 | #' code inspections. 70 | #' 71 | #' @aliases findGlobals 72 | #' @export 73 | globalsOf <- function(expr, envir = parent.frame(), ..., 74 | method = c("ordered", "conservative", "liberal", "dfs"), 75 | tweak = NULL, 76 | locals = NA, 77 | substitute = FALSE, mustExist = TRUE, 78 | unlist = TRUE, recursive = TRUE, skip = NULL) { 79 | if (missing(method)) method <- method[1] 80 | method <- match.arg(method, choices = c("ordered", "conservative", "liberal", "dfs"), several.ok = TRUE) 81 | 82 | if (is.na(locals)) locals <- getOption("globals.globalsOf.locals", TRUE) 83 | stop_if_not(is.logical(locals), length(locals) == 1L, !is.na(locals)) 84 | 85 | if (substitute) expr <- substitute(expr) 86 | stop_if_not(is.null(skip) || is.list(skip)) 87 | 88 | debug <- isTRUE(getOption("globals.debug")) 89 | if (debug) { 90 | methods <- sprintf("'%s'", method) 91 | if (length(method) > 1) methods <- sprintf("c(%s)", paste(methods, collapse = ", ")) 92 | mdebugf_push("globalsOf(..., method = %s, mustExist = %s, unlist = %s, recursive = %s) ...", methods, mustExist, unlist, recursive) 93 | on.exit(mdebugf_pop("globalsOf(..., method = %s, mustExist = %s, unlist = %s, recursive = %s) ... done", methods, mustExist, unlist, recursive)) 94 | } 95 | 96 | ## 1. Identify global variables (static code inspection) 97 | names <- findGlobals(expr, envir = envir, ..., method = method, 98 | tweak = tweak, substitute = FALSE, unlist = unlist) 99 | if (debug) mdebugf("preliminary globals (by name): [%d] %s", 100 | length(names), hpaste(sQuote(names))) 101 | 102 | ## 2. Locate them (run time) 103 | globals <- tryCatch({ 104 | globalsByName(names, envir = envir, mustExist = mustExist) 105 | }, error = function(ex) { 106 | ## HACK: Tweak error message to also include the expression inspected. 107 | ## If fail to retrieve one or more variables, narrow in on the 108 | ## problematic ones. 109 | failed <- vapply(names, FUN.VALUE = NA, FUN = function(name) { 110 | res <- tryCatch({ 111 | globalsByName(name, envir = envir, mustExist = mustExist) 112 | }, error = identity) 113 | inherits(res, "error") 114 | }) 115 | failed <- names[failed] 116 | msg <- conditionMessage(ex) 117 | msg <- sprintf("Failed to get one or more globals that were identified via static code inspection (%s). Specifically, the %d globals %s give an error. The reason was: %s", hexpr(expr), length(failed), commaq(failed), msg) #nolint 118 | ex$message <- msg 119 | stop(ex) 120 | }) 121 | 122 | if (debug) mdebugf("preliminary globals (by value): [%d] %s", 123 | length(globals), hpaste(sQuote(names(globals)))) 124 | 125 | ## If a function, drop any globals that are part of any of the functions 126 | ## local environments, e.g. 'a' in f <- local({ a <- 1; function() a }) 127 | if (!locals && is.function(expr) && length(globals) > 0) { 128 | env <- environment(expr) ## the environment of the function 129 | eenv <- emptyenv() 130 | genv <- globalenv() 131 | where <- attr(globals, "where", exact = TRUE) 132 | while (length(where) > 0 && !identical(env, eenv) && !identical(env, genv)) { 133 | ## Any 'where' for the current environment? 134 | keep <- !vapply(where, FUN.VALUE = FALSE, FUN = identical, env) 135 | where <- where[keep] 136 | env <- parent.env(env) 137 | } 138 | ## Anything to drop? 139 | if (length(where) != length(globals)) globals <- globals[names(where)] 140 | } 141 | 142 | ## 3. Among globals that are closures (functions) and that exist outside 143 | ## of namespaces ("packages"), check for additional globals? 144 | if (recursive) { 145 | if (debug) mdebug_push("recursive scan of preliminary globals ...") 146 | 147 | ## Don't enter functions in namespaces / packages 148 | where <- attr(globals, "where", exact = TRUE) 149 | stop_if_not(length(where) == length(globals)) 150 | where <- vapply(where, FUN = envname, FUN.VALUE = NA_character_, 151 | USE.NAMES = FALSE) 152 | globals_t <- globals[!(where %in% loadedNamespaces())] 153 | 154 | if (debug) mdebugf("subset of globals to be scanned (not in loaded namespaces): [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) #nolint 155 | 156 | ## Enter only functions 157 | ## NOTE: This excludes functions "not found", but also primitives 158 | ## not dropped above. 159 | keep <- vapply(globals_t, USE.NAMES = FALSE, FUN.VALUE = NA, 160 | FUN = function(global) { 161 | typeof(global) == "closure" 162 | } 163 | ) 164 | globals_t <- globals_t[keep] 165 | 166 | if (length(globals_t) > 0) { 167 | if (debug) mdebugf("subset of globals to be scanned: [%d] %s", 168 | length(globals_t), hpaste(sQuote(names(globals_t)))) 169 | names_t <- names(globals_t) 170 | 171 | ## Avoid recursive scanning of already scanned ("known") globals 172 | skip_t <- c(skip, globals_t) 173 | 174 | for (gg in seq_along(globals_t)) { 175 | if (debug) mdebugf("+ scanning global #%d (%s) ...", 176 | gg, sQuote(names_t[[gg]])) 177 | fcn <- globals_t[[gg]] 178 | 179 | ## Is function 'fcn' among the already identified globals? 180 | already_scanned <- any(vapply(skip, FUN = identical, fcn, FUN.VALUE = NA, USE.NAMES = FALSE)) 181 | if (already_scanned) next; 182 | 183 | env <- environment(fcn) ## was 'env <- envir' in globals 0.8.0. 184 | 185 | globals_gg <- globalsOf(fcn, envir = env, ..., method = method, 186 | tweak = tweak, 187 | locals = locals, 188 | substitute = FALSE, 189 | mustExist = mustExist, unlist = unlist, 190 | recursive = recursive, 191 | skip = skip_t) 192 | if (length(globals_gg) > 0) { 193 | globals <- c(globals, globals_gg) 194 | 195 | skip_gg <- globals_gg[vapply(globals_gg, FUN = typeof, FUN.VALUE = NA_character_, USE.NAMES = FALSE) == "closure"] 196 | skip_t <- c(skip_t, skip_gg) 197 | } 198 | } 199 | globals <- unique(globals) 200 | if (debug) mdebugf("updated set of globals found: [%d] %s", 201 | length(globals), hpaste(sQuote(names(globals)))) 202 | } else { 203 | if (debug) mdebug("subset of globals to be scanned: [0]") 204 | } 205 | 206 | if (debug) mdebug_pop("recursive scan of preliminary globals ... done") 207 | } 208 | 209 | if (debug) mdebugf("globals found: [%d] %s", 210 | length(globals), hpaste(sQuote(names(globals)))) 211 | 212 | globals 213 | } ## globalsOf() 214 | -------------------------------------------------------------------------------- /R/options.R: -------------------------------------------------------------------------------- 1 | setOption <- function(name, value) { 2 | oldValue <- getOption(name) 3 | args <- list(value) 4 | names(args) <- name 5 | do.call(options, args = args) 6 | invisible(oldValue) 7 | } 8 | 9 | 10 | # Set an R option from an environment variable 11 | update_package_option <- function(name, mode = "character", default = NULL, split = NULL, trim = TRUE, disallow = c("NA"), force = FALSE, debug = FALSE) { 12 | if (debug) { 13 | mdebug_push("update_package_option() ...") 14 | on.exit(mdebug_pop("update_package_option() ... done")) 15 | } 16 | 17 | ## Nothing to do? 18 | value <- getOption(name, NULL) 19 | if (!force && !is.null(value)) return(getOption(name, default = default)) 20 | 21 | ## name="pkg.foo.bar" => env="R_PKG_FOO_BAR" 22 | env <- gsub(".", "_", toupper(name), fixed = TRUE) 23 | env <- paste("R_", env, sep = "") 24 | 25 | env_value <- value <- Sys.getenv(env, unset = NA_character_) 26 | ## Nothing to do? 27 | if (is.na(value)) { 28 | if (debug) mdebugf("Environment variable %s not set", sQuote(env)) 29 | if (!is.null(default)) setOption(name, default) 30 | return(getOption(name, default = default)) 31 | } 32 | 33 | if (debug) mdebugf("%s=%s", env, sQuote(value)) 34 | 35 | ## Trim? 36 | if (trim) value <- trim(value) 37 | 38 | ## Nothing to do? 39 | if (!nzchar(value)) { 40 | if (!is.null(default)) setOption(name, default) 41 | return(getOption(name, default = default)) 42 | } 43 | 44 | ## Split? 45 | if (!is.null(split)) { 46 | value <- strsplit(value, split = split, fixed = TRUE) 47 | value <- unlist(value, use.names = FALSE) 48 | if (trim) value <- trim(value) 49 | } 50 | 51 | ## Coerce? 52 | mode0 <- storage.mode(value) 53 | if (mode0 != mode) { 54 | suppressWarnings({ 55 | storage.mode(value) <- mode 56 | }) 57 | if (debug) { 58 | mdebugf("Coercing from %s to %s: %s", mode0, mode, commaq(value)) 59 | } 60 | } 61 | 62 | if (length(disallow) > 0) { 63 | if ("NA" %in% disallow) { 64 | if (any(is.na(value))) { 65 | 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)) 66 | } 67 | } 68 | if (is.numeric(value)) { 69 | if ("non-positive" %in% disallow) { 70 | if (any(value <= 0, na.rm = TRUE)) { 71 | stopf("Environment variable %s=%s specifies a non-positive value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) 72 | } 73 | } 74 | if ("negative" %in% disallow) { 75 | if (any(value < 0, na.rm = TRUE)) { 76 | stopf("Environment variable %s=%s specifies a negative value for option %s: %s", sQuote(env), sQuote(env_value), sQuote(name), commaq(value)) 77 | } 78 | } 79 | } 80 | } 81 | 82 | if (debug) { 83 | mdebugf("=> options(%s = %s) [n=%d, mode=%s]", 84 | dQuote(name), commaq(value), 85 | length(value), storage.mode(value)) 86 | } 87 | 88 | setOption(name, value) 89 | 90 | getOption(name, default = default) 91 | } 92 | 93 | 94 | ## Set package options based on environment variables 95 | update_package_options <- function(debug = FALSE) { 96 | ## WARNING: All but R option 'globals.debug' are internal options 97 | ## that may be changed or removed at anytime. 98 | 99 | update_package_option("globals.globalsOf.locals", mode = "logical", debug = debug) 100 | update_package_option("globals.selfassign", mode = "logical", debug = debug) 101 | update_package_option("globals.walkAST.onUnknownType", debug = debug) 102 | 103 | update_package_option("globals.debug.indent", mode = "character", default = " ", debug = debug) 104 | } 105 | -------------------------------------------------------------------------------- /R/packagesOf.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | packagesOf <- function(...) UseMethod("packagesOf") 3 | 4 | #' Identify the packages of the globals 5 | #' 6 | #' @param globals A Globals object. 7 | #' @param \ldots Not used. 8 | #' 9 | #' @return Returns a character vector of package names. 10 | #' 11 | #' @aliases packagesOf 12 | #' @export 13 | packagesOf.Globals <- function(globals, ...) { 14 | ## Scan 'globals' for which packages they are from. This information is 15 | ## in the name of the environment as given by the 'where' attribute with 16 | ## a fallback to the global object. 17 | 18 | where <- attr(globals, "where") 19 | pkgs <- rep(NA_character_, times = length(globals)) 20 | for (kk in seq_along(globals)) { 21 | obj <- globals[[kk]] 22 | env <- environment_of(obj) 23 | 24 | ## If not found, it could be an object in package without a closure 25 | if (identical(env, emptyenv())) { 26 | w <- where[[kk]] 27 | if (is.environment(w)) { 28 | pkg <- environmentName(w) 29 | if (grepl("^package:", pkg)) pkg <- sub("^package:", "", pkg) 30 | } else { 31 | pkg <- environmentName(env) 32 | } 33 | } else { 34 | pkg <- environmentName(env) 35 | } 36 | 37 | pkgs[kk] <- pkg 38 | } 39 | 40 | ## Drop "missing" packages, e.g. globals in globalenv(). 41 | pkgs <- pkgs[nzchar(pkgs)] 42 | 43 | ## Drop global environment 44 | pkgs <- pkgs[pkgs != "R_GlobalEnv"] 45 | 46 | ## Keep only names matching loaded namespaces 47 | pkgs <- intersect(pkgs, loadedNamespaces()) 48 | 49 | ## Packages to be loaded 50 | pkgs <- unique(pkgs) 51 | 52 | ## Sanity check 53 | stop_if_not(all(nzchar(pkgs))) 54 | 55 | pkgs 56 | } # packagesOf() 57 | 58 | -------------------------------------------------------------------------------- /R/testme.R: -------------------------------------------------------------------------------- 1 | ## This runs 'testme' test inst/testme/test-.R scripts 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | testme <- function(name) { 4 | path <- system.file(package = 'globals', 'testme', mustWork = TRUE) 5 | Sys.setenv(R_TESTME_PATH = path) 6 | Sys.setenv(R_TESTME_PACKAGE = 'globals') 7 | Sys.setenv(R_TESTME_NAME = name) 8 | on.exit(Sys.unsetenv('R_TESTME_NAME')) 9 | source(file.path(path, 'run.R')) 10 | } 11 | -------------------------------------------------------------------------------- /R/utils,codetools-bugfix.R: -------------------------------------------------------------------------------- 1 | # Dynamically check if the 'codetools' bug has been fixed 2 | hasCodetoolsBug16 <- local({ 3 | hasBug <- NA 4 | 5 | function() { 6 | if (is.na(hasBug)) { 7 | ## Construct function with the bug, without triggering the 8 | ## bug when 'R CMD check' runs 9 | f <- eval(quote(function() NULL %% `$<-`(NULL, NULL))) 10 | hasBug <<- tryCatch({ 11 | codetools::findGlobals(f) 12 | FALSE 13 | }, error = function(ex) TRUE) 14 | } 15 | hasBug 16 | } 17 | }) 18 | 19 | 20 | # This tweaks the future expression to work around a bug [1,2] in the 21 | # 'codetools' package affecting expression for format: 22 | # 23 | # LHS INFIX_OPERATOR `$<-`(name, value) 24 | # 25 | # [1] https://github.com/futureverse/globals/issues/94 26 | # [2] https://gitlab.com/luke-tierney/codetools/-/issues/16 27 | tweakCodetoolsBug16 <- function(expr) { 28 | if (!is.call(expr)) return(expr) 29 | expr <- unclass(expr) 30 | op <- expr[[1]] 31 | if (!is.symbol(op)) return(expr) 32 | 33 | ## An infix operator? 34 | op <- as.character(op) 35 | if (!grepl("^%[^%]*%$", op)) return(expr) 36 | 37 | n <- length(expr) 38 | if (n != 3) return(expr) ## Can this every happen? 39 | rhs <- expr[[3]] 40 | 41 | ## Is RHS a call? 42 | if (!is.call(rhs)) return(expr) 43 | 44 | ## Is RHS a call to `$<-`? 45 | rhs_op <- rhs[[1]] 46 | if (!is.symbol(rhs_op)) return(expr) 47 | if (rhs_op != as.name("$<-")) return(expr) 48 | 49 | ## Replace `$<-` with something unique, e.g. `codetools.bugfix16:::$<-` 50 | rhs <- as.list(rhs) 51 | rhs[[1]] <- as.name("codetools.bugfix16:::$<-") 52 | rhs <- as.call(rhs) 53 | expr[[3]] <- rhs 54 | expr 55 | } ## tweakCodetoolsBug16() 56 | -------------------------------------------------------------------------------- /R/utils,conditions.R: -------------------------------------------------------------------------------- 1 | stopf <- function(fmt, ..., call. = TRUE, domain = NULL) { #nolint 2 | msg <- sprintf(fmt, ...) 3 | msg <- .makeMessage(msg, domain = domain) 4 | if (is.call(call.)) { 5 | call <- call. 6 | } else if (isTRUE(call)) { 7 | call <- sys.call(which = -1L) 8 | } else { 9 | call <- NULL 10 | } 11 | cond <- simpleError(msg, call = call) 12 | stop(cond) 13 | } 14 | -------------------------------------------------------------------------------- /R/utils-debug.R: -------------------------------------------------------------------------------- 1 | now <- function(x = Sys.time(), format = "[%H:%M:%OS3] ") { 2 | ## format(x, format = format) ## slower 3 | format(as.POSIXlt(x, tz = ""), format = format) 4 | } 5 | 6 | debug_indent <- local({ 7 | symbols <- rep(c("|", ":", ".", "'", ",", ";", "`"), times = 10L) 8 | function() { 9 | depth <- length(.debug[["stack"]]) 10 | if (depth == 0) return("") 11 | indent <- getOption("globals.debug.indent", " ") 12 | paste(paste(symbols[seq_len(depth)], indent, sep = ""), collapse = "") 13 | } 14 | }) 15 | 16 | if (!exists(".debug", inherits = FALSE)) .debug <- new.env(parent = emptyenv()) 17 | if (!"stack" %in% names(".debug")) .debug$stack <- list() 18 | 19 | mdebug_push <- function(..., debug = isTRUE(getOption("globals.debug"))) { 20 | if (!debug) return() 21 | msg <- mdebug(..., debug = debug) 22 | .debug$stack <- c(.debug$stack, msg) 23 | invisible(msg) 24 | } 25 | 26 | mdebugf_push <- function(..., debug = isTRUE(getOption("globals.debug"))) { 27 | if (!debug) return() 28 | msg <- mdebugf(..., debug = debug) 29 | .debug$stack <- c(.debug$stack, msg) 30 | invisible(msg) 31 | } 32 | 33 | mdebug_pop <- function(..., debug = isTRUE(getOption("globals.debug"))) { 34 | if (!debug) return() 35 | n <- length(.debug$stack) 36 | msg <- .debug$stack[n] 37 | .debug$stack <- .debug$stack[-n] 38 | mdebug(sprintf("%s done", msg), debug = debug) 39 | } 40 | 41 | mdebugf_pop <- function(..., debug = isTRUE(getOption("globals.debug"))) { 42 | if (!debug) return() 43 | n <- length(.debug$stack) 44 | msg <- .debug$stack[n] 45 | .debug$stack <- .debug$stack[-n] 46 | mdebug(sprintf("%s done", msg), debug = debug) 47 | } 48 | 49 | mdebug <- function(..., prefix = now(), debug = isTRUE(getOption("globals.debug"))) { 50 | if (!debug) return() 51 | prefix <- paste(prefix, debug_indent(), sep = "") 52 | msg <- paste(..., sep = "") 53 | message(sprintf("%s%s", prefix, msg)) 54 | invisible(msg) 55 | } 56 | 57 | mdebugf <- function(..., appendLF = TRUE, 58 | prefix = now(), debug = isTRUE(getOption("globals.debug"))) { 59 | if (!debug) return() 60 | prefix <- paste(prefix, debug_indent(), sep = "") 61 | msg <- sprintf(...) 62 | message(sprintf("%s%s", prefix, msg), appendLF = appendLF) 63 | invisible(msg) 64 | } 65 | 66 | #' @importFrom utils capture.output 67 | mprint <- function(..., appendLF = TRUE, prefix = now(), debug = isTRUE(getOption("globals.debug"))) { 68 | if (!debug) return() 69 | prefix <- paste(prefix, debug_indent(), sep = "") 70 | message(paste(prefix, capture.output(print(...)), sep = "", collapse = "\n"), appendLF = appendLF) 71 | } 72 | 73 | #' @importFrom utils capture.output str 74 | mstr <- function(..., appendLF = TRUE, prefix = now(), debug = isTRUE(getOption("globals.debug"))) { 75 | if (!debug) return() 76 | prefix <- paste(prefix, debug_indent(), sep = "") 77 | message(paste(prefix, capture.output(str(...)), sep = "", collapse = "\n"), appendLF = appendLF) 78 | } 79 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | as_function <- function(expr, envir = parent.frame(), enclos = baseenv(), ...) { 2 | fun_expr <- substitute(function() x, list(x = expr)) 3 | eval(fun_expr, envir = envir, enclos = enclos, ...) 4 | } 5 | 6 | # Although the set of "base" packages rarely changes, it has happened 7 | # in R's history. Beause of this, we avoid hardcoding the set of known 8 | # "base" packages and instead always look them up by the 'Priority' 9 | # field in their DESCRIPTION data and cache the results. 10 | #' @importFrom utils packageDescription 11 | is_base_pkg <- local({ 12 | cache <- list( 13 | R_EmptyEnv = FALSE, 14 | R_GlobalEnv = FALSE 15 | ) 16 | function(pkgs) { 17 | pkgs <- gsub("^package:", "", pkgs) 18 | npkgs <- length(pkgs) 19 | res <- rep(FALSE, times = npkgs) 20 | for (kk in seq_len(npkgs)) { 21 | pkg <- pkgs[kk] 22 | if (nzchar(pkg)) { 23 | value <- cache[[pkg]] 24 | if (is.null(value)) { 25 | prio <- suppressWarnings(packageDescription(pkg, fields = "Priority")) 26 | value <- (!is.na(prio) && prio == "base") 27 | cache[[pkg]] <<- value 28 | } 29 | } else { 30 | value <- FALSE 31 | } 32 | res[kk] <- value 33 | } 34 | res 35 | } 36 | }) 37 | 38 | # cf. is.primitive() 39 | is.base <- function(x) { 40 | if (typeof(x) != "closure") return(FALSE) 41 | is_base_pkg(environmentName(environment(x))) 42 | } 43 | 44 | # cf. is.primitive() 45 | is_internal <- function(x) { 46 | if (typeof(x) != "closure") return(FALSE) 47 | body <- deparse(body(x)) 48 | any(grepl(".Internal", body, fixed = TRUE)) 49 | } 50 | 51 | # Example: base::.C_R_removeTaskCallback 52 | is_native_symbol_info <- function(x) { 53 | if (!inherits(x, "NativeSymbolInfo")) return(FALSE) 54 | if (typeof(x) != "list") return(FALSE) 55 | address <- x$address 56 | if (!inherits(address, "RegisteredNativeSymbol")) return(FALSE) 57 | TRUE 58 | } 59 | 60 | isPackageNamespace <- function(env) { 61 | if (!is.environment(env)) return(FALSE) 62 | name <- environmentName(env) 63 | if (name == "base") return(TRUE) 64 | if (exists(".packageName", mode = "character", envir = env, inherits = FALSE)) { 65 | packageName <- get(".packageName", mode = "character", envir = env, inherits = FALSE) 66 | if (identical(name, packageName)) return(TRUE) 67 | } 68 | if (!grepl("^package:", name)) return(FALSE) 69 | (name %in% search()) 70 | } 71 | 72 | # From future 1.18.0 73 | asPkgEnvironment <- function(pkg) { 74 | name <- sprintf("package:%s", pkg) 75 | if (!name %in% search()) return(emptyenv()) 76 | as.environment(name) 77 | } 78 | 79 | ## From R.utils 2.0.2 (2015-05-23) 80 | hpaste <- function(..., sep="", collapse=", ", last_collapse=NULL, 81 | max_head=if (missing(last_collapse)) 3 else Inf, 82 | max_tail=if (is.finite(max_head)) 1 else Inf, 83 | abbreviate="...") { 84 | max_head <- as.double(max_head) 85 | max_tail <- as.double(max_tail) 86 | if (is.null(last_collapse)) last_collapse <- collapse 87 | 88 | # Build vector 'x' 89 | x <- paste(..., sep = sep) 90 | n <- length(x) 91 | 92 | # Nothing todo? 93 | if (n == 0) return(x) 94 | if (is.null(collapse)) return(x) 95 | 96 | # Abbreviate? 97 | if (n > max_head + max_tail + 1) { 98 | head <- x[seq_len(max_head)] 99 | tail <- rev(rev(x)[seq_len(max_tail)]) 100 | x <- c(head, abbreviate, tail) 101 | n <- length(x) 102 | } 103 | 104 | if (!is.null(collapse) && n > 1) { 105 | if (last_collapse == collapse) { 106 | x <- paste(x, collapse = collapse) 107 | } else { 108 | x_head <- paste(x[1:(n - 1)], collapse = collapse) 109 | x <- paste(x_head, x[n], sep = last_collapse) 110 | } 111 | } 112 | 113 | x 114 | } 115 | 116 | 117 | ## From future 0.11.0 118 | trim <- function(s) { 119 | sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s)) 120 | } # trim() 121 | 122 | 123 | ## From future 0.11.0 124 | hexpr <- function(expr, trim = TRUE, collapse = "; ", max_head = 6L, 125 | max_tail = 3L, ...) { 126 | code <- deparse(expr) 127 | if (trim) code <- trim(code) 128 | hpaste(code, collapse = collapse, 129 | max_head = max_head, max_tail = max_tail, ...) 130 | } # hexpr() 131 | 132 | 133 | #' @importFrom utils capture.output 134 | envname <- function(env) { 135 | if (!is.environment(env)) return(NA_character_) 136 | name <- environmentName(env) 137 | if (name == "") { 138 | ## NOTE: I might be that: 139 | ## 1. 'env' is of a class that extends 'environment', e.g. 140 | ## R.oo::Object() or R6::R6Class(), or 141 | ## 2. another package defines print() for 'environment' 142 | ## Because of this, we call print.default() instead of generic print(). 143 | name <- capture.output(print.default(env)) 144 | if (length(name) > 1L) name <- name[1] 145 | name <- gsub("(.*: |>)", "", name) 146 | } else { 147 | ## e.g. globals:::where("plan") 148 | name <- gsub("package:", "", name, fixed = TRUE) 149 | } 150 | name 151 | } 152 | 153 | commaq <- function(x, sep = ", ") paste(sQuote(x), collapse = sep) 154 | 155 | if (getRversion() < "4.0.0") { 156 | ## When 'default' is specified, this is 30x faster than 157 | ## base::getOption(). The difference is that here we use 158 | ## use names(.Options) whereas in 'base' names(options()) 159 | ## is used. 160 | getOption <- local({ 161 | go <- base::getOption 162 | function(x, default = NULL) { 163 | if (missing(default) || match(x, table = names(.Options), nomatch = 0L) > 0L) go(x) else default 164 | } 165 | }) 166 | } 167 | 168 | stop_if_not <- function(...) { 169 | res <- list(...) 170 | n <- length(res) 171 | if (n == 0L) return() 172 | 173 | for (ii in 1L:n) { 174 | res_ii <- .subset2(res, ii) 175 | if (length(res_ii) != 1L || is.na(res_ii) || !res_ii) { 176 | mc <- match.call() 177 | call <- deparse(mc[[ii + 1]], width.cutoff = 60L) 178 | if (length(call) > 1L) call <- paste(call[1L], "...") 179 | stop(sQuote(call), " is not TRUE", call. = FALSE, domain = NA) 180 | } 181 | } 182 | } 183 | 184 | 185 | 186 | #' Gets the length of an object without dispatching 187 | #' 188 | #' @param x Any \R object. 189 | #' 190 | #' @return A non-negative integer. 191 | #' 192 | #' @details 193 | #' This function returns \code{length(unclass(x))}, but tries to avoid 194 | #' calling \code{unclass(x)} unless necessary. 195 | #' 196 | #' @seealso \code{\link{.subset}()} and \code{\link{.subset2}()}. 197 | #' 198 | #' @keywords internal 199 | #' @rdname private_length 200 | #' @importFrom utils getS3method 201 | .length <- function(x) { 202 | nx <- length(x) 203 | 204 | ## Can we trust base::length(x), i.e. is there a risk that there is 205 | ## a method that overrides with another definition? 206 | classes <- class(x) 207 | if (length(classes) == 1L && classes == "list") return(nx) 208 | 209 | ## Identify all length() methods for this object 210 | for (class in classes) { 211 | fun <- getS3method("length", class, optional = TRUE) 212 | if (!is.null(fun)) { 213 | nx <- length(unclass(x)) 214 | break 215 | } 216 | } 217 | 218 | nx 219 | } ## .length() 220 | 221 | 222 | ## An lapply(X) without internal X <- as.list(X), without setting names, 223 | ## and without dispatching using `[[`. 224 | list_apply <- function(X, subset = NULL, FUN, ...) { 225 | if (is.null(subset)) { 226 | n <- .length(X) 227 | } else { 228 | n <- length(subset) 229 | } 230 | res <- vector("list", length = n) 231 | if (is.environment(X)) { 232 | if (is.null(subset)) subset <- names(X) 233 | for (name in subset) { 234 | res[[name]] <- FUN(.subset2(X, name), ...) 235 | } 236 | } else { 237 | if (is.null(subset)) subset <- seq_len(n) 238 | for (kk in subset) { 239 | res[[kk]] <- FUN(.subset2(X, kk), ...) 240 | } 241 | } 242 | res 243 | } 244 | 245 | 246 | .trace <- new.env() 247 | .trace$indent <- 0L 248 | 249 | trace_indent <- function(x = "", indent = .trace$indent) { 250 | # utils::str(list(indent = indent)) 251 | # indent <- max(0L, indent) 252 | prefix <- paste(rep(" ", times = 3*indent), collapse = "") 253 | paste(prefix, x, sep = "") 254 | } 255 | 256 | trace_printf <- function(..., indent = .trace$indent, collapse = "\n", appendLF = FALSE) { 257 | msg <- sprintf(...) 258 | out <- trace_indent(msg, indent = indent) 259 | out <- paste(out, collapse = collapse) 260 | message(out, appendLF = appendLF) 261 | invisible(msg) 262 | } 263 | 264 | #' @importFrom utils capture.output 265 | trace_print <- function(..., envir = parent.frame(), indent = .trace$indent, collapse = "\n", appendLF = TRUE) { 266 | bfr <- eval(capture.output(print(...)), envir = envir) 267 | trace_printf(bfr, indent = indent, collapse = collapse, appendLF = appendLF) 268 | } 269 | 270 | #' @importFrom utils capture.output str 271 | trace_str <- function(..., envir = parent.frame(), indent = .trace$indent, collapse = "\n", appendLF = TRUE) { 272 | bfr <- eval(capture.output(str(...)), envir = envir) 273 | trace_printf(bfr, indent = indent, collapse = collapse, appendLF = appendLF) 274 | } 275 | 276 | trace_enter <- function(..., appendLF = TRUE) { 277 | msg <- trace_printf(..., appendLF = FALSE) 278 | message(" ...", appendLF = appendLF) 279 | .trace$indent <- .trace$indent + 1L 280 | attr(msg, "indent") <- .trace$indent 281 | invisible(msg) 282 | } 283 | 284 | trace_exit <- function(fmtstr, ..., appendLF = TRUE) { 285 | indent <- attr(fmtstr, "indent") 286 | if (!is.null(indent)) .trace$indent <- indent 287 | .trace$indent <- .trace$indent - 1L 288 | msg <- trace_printf(fmtstr, ..., appendLF = FALSE) 289 | message(" ... done", appendLF = appendLF) 290 | # stop_if_not(.trace$indent >= 0L) 291 | invisible(msg) 292 | } 293 | -------------------------------------------------------------------------------- /R/walkAST.R: -------------------------------------------------------------------------------- 1 | #' Walk the Abstract Syntax Tree (AST) of an R Expression 2 | #' 3 | #' @param expr R \link[base]{expression}. 4 | #' @param atomic,name,call,pairlist single-argument function that takes an 5 | #' atomic, name, call and pairlist expression, respectively. Have to 6 | #' return a valid R expression. 7 | #' @param substitute If TRUE, \code{expr} is 8 | #' \code{\link[base]{substitute}()}:ed. 9 | #' 10 | #' @return R \link[base]{expression}. 11 | #' 12 | #' @export 13 | #' @keywords programming internal 14 | walkAST <- function(expr, atomic = NULL, name = NULL, call = NULL, 15 | pairlist = NULL, substitute = FALSE) { 16 | if (substitute) expr <- substitute(expr) 17 | 18 | if (is.atomic(expr)) { 19 | if (is.function(atomic)) expr <- atomic(expr) 20 | } else if (is.name(expr)) { 21 | if (is.function(name)) expr <- name(expr) 22 | } else if (is.call(expr)) { 23 | ## message("call") 24 | for (cc in seq_along(expr)) { 25 | ## AD HOC: The following is needed to handle x[, 1]. /HB 2016-09-06 26 | if (is.name(expr[[cc]]) && expr[[cc]] == "") next 27 | e <- walkAST(expr[[cc]], atomic = atomic, name = name, call = call, 28 | pairlist = pairlist, substitute = FALSE) 29 | if (is.null(e)) { 30 | expr[cc] <- list(NULL) 31 | } else { 32 | expr[[cc]] <- e 33 | } 34 | } 35 | if (is.function(call)) expr <- call(expr) 36 | } else if (is.pairlist(expr)) { 37 | ## message("pairlist") 38 | for (pp in seq_along(expr)) { 39 | ## AD HOC: The following is needed to handle '...'. /HB 2016-09-06 40 | if (is.name(expr[[pp]]) && expr[[pp]] == "") next 41 | e <- walkAST(expr[[pp]], atomic = atomic, name = name, call = call, 42 | pairlist = pairlist, substitute = FALSE) 43 | if (is.null(e)) { 44 | expr[pp] <- list(NULL) 45 | } else { 46 | expr[[pp]] <- e 47 | } 48 | } 49 | ## WORKAROUND: Since expr[i] <- list(NULL) turns pairlist 'expr' into 50 | ## a list we have to make sure to it is a pairlist also afterward, cf. 51 | ## https://stat.ethz.ch/pipermail/r-devel/2016-October/073263.html 52 | ## /HB 2016-10-12 53 | expr <- as.pairlist(expr) 54 | } else if (is.list(expr)) { 55 | ## FIXME: Should we have a specific function for this, or is atomic() ok? 56 | ## https://github.com/HenrikBengtsson/globals/issues/27 57 | if (is.function(atomic)) expr <- atomic(expr) 58 | } else if (typeof(expr) == "closure") { 59 | body <- body(expr) 60 | body <- walkAST(body, atomic = atomic, name = name, call = call, 61 | pairlist = pairlist, substitute = FALSE) 62 | body(expr) <- body 63 | } else if (typeof(expr) %in% c("builtin", "environment", "expression", 64 | "externalptr", "S4", "special", "object")) { 65 | ## Nothing to do 66 | ## FIXME: ... or can specials be "walked"? /HB 2017-03-21 67 | ## FIXME: Should "promise", "char", "...", "any", "externalptr", 68 | ## "bytecode", and "weakref" (cf. ?typeof) also be added? /2017-07-01 69 | return(expr) 70 | } else { 71 | msg <- paste("Cannot walk expression. Unknown object type", 72 | sQuote(typeof(expr))) 73 | onUnknownType <- getOption("globals.walkAST.onUnknownType", "error") 74 | if (onUnknownType == "error") { 75 | stop(msg, call. = FALSE) 76 | } else if (onUnknownType == "warning") { 77 | warning(msg, call. = FALSE) 78 | } 79 | ## Skip below assertion 80 | return(expr) 81 | } 82 | 83 | ## Assert that the tweak functions return a valid object 84 | if (!missing(expr)) { 85 | stop_if_not(is.atomic(expr) || 86 | is.list(expr) || 87 | is.name(expr) || 88 | is.call(expr) || 89 | is.pairlist(expr) || 90 | typeof(expr) %in% c("builtin", "closure", "special")) 91 | } 92 | 93 | expr 94 | } ## walkAST() 95 | -------------------------------------------------------------------------------- /R/where.R: -------------------------------------------------------------------------------- 1 | ## Emulates R internal findVar1mode() function 2 | ## https://svn.r-project.org/R/trunk/src/main/envir.c 3 | where <- function(x, where = -1, 4 | envir = if (missing(frame)) { 5 | if (where < 0) 6 | parent.frame(-where) 7 | else as.environment(where) 8 | } else sys.frame(frame), 9 | frame, mode = "any", inherits = TRUE) { 10 | ## Validate arguments 11 | stop_if_not(is.environment(envir)) 12 | stop_if_not(is.character(mode), length(mode) == 1L) 13 | inherits <- as.logical(inherits) 14 | stop_if_not(inherits %in% c(FALSE, TRUE)) 15 | 16 | debug <- isTRUE(getOption("globals.future")) 17 | if (debug) { 18 | mdebugf_push("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) 19 | on.exit(mdebugf_pop("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits)) 20 | } 21 | 22 | ## Search 23 | env <- envir 24 | while (!identical(env, emptyenv())) { 25 | if (debug) mdebugf("searching %s: %s", sQuote(envname(env)), 26 | hpaste(sQuote(ls(envir = env, all.names = TRUE)))) 27 | if (exists(x, envir = env, mode = mode, inherits = FALSE)) { 28 | if (debug) mdebugf("+ found in location: %s", sQuote(envname(env))) 29 | return(env) 30 | } 31 | 32 | if (!inherits) { 33 | if (debug) mdebug("+ failed to locate: NULL") 34 | return(NULL) 35 | } 36 | 37 | env <- parent.env(env) 38 | } 39 | 40 | if (debug) mdebug("failed to locate: NULL") 41 | 42 | NULL 43 | } 44 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | ## covr: skip=all 2 | .onLoad <- function(libname, pkgname) { 3 | update_package_option("globals.debug", mode = "logical") 4 | debug <- getOption("globals.debug", FALSE) 5 | 6 | ## Set future options based on environment variables 7 | update_package_options(debug = debug) 8 | 9 | ## Memoize: Already here, when the package is loaded, record whether 10 | ## some packages are 'base' packages or not. 11 | ## Packages that most likely are 'base' packages: 12 | pkgs <- c("base", "compiler", "datasets", "graphics", "grDevices", "grid", 13 | "methods", "parallel", "splines", "stats", "stats4", "tcltk", 14 | "tools", "utils") 15 | ## This package and other packags already loaded (incl. it's dependencies) 16 | pkgs <- c(pkgs, pkgname, loadedNamespaces()) 17 | is_base_pkg(pkgs) 18 | } 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | CRAN check status R CMD check status future.tests checks status Coverage Status 5 |
6 | 7 | # globals: Identify Global Objects in R Expressions 8 | 9 | 10 | ## Installation 11 | R package globals is available on [CRAN](https://cran.r-project.org/package=globals) and can be installed in R as: 12 | ```r 13 | install.packages("globals") 14 | ``` 15 | 16 | 17 | ### Pre-release version 18 | 19 | To install the pre-release version that is available in Git branch `develop` on GitHub, use: 20 | ```r 21 | remotes::install_github("futureverse/globals", ref="develop") 22 | ``` 23 | This will install the package from source. 24 | 25 | 26 | 27 | 28 | ## Contributing 29 | 30 | To contribute to this package, please see [CONTRIBUTING.md](CONTRIBUTING.md). 31 | 32 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | # CRAN submission globals 0.18.0 2 | 3 | on 2025-05-08 4 | 5 | I've verified this submission has no negative impact on any of the 669 first- and second-order reverse package dependencies available on CRAN (n = 636) and Bioconductor (n = 33). 6 | 7 | Thanks in advance 8 | -------------------------------------------------------------------------------- /incl/globalsByName.R: -------------------------------------------------------------------------------- 1 | f <- function(x = 42, ...) { 2 | globalsByName("x") 3 | } 4 | 5 | globals <- f() 6 | str(globals) 7 | 8 | globals <- f(3.14) 9 | str(globals) 10 | 11 | 12 | g <- function(x = 42, ...) { 13 | globalsByName("...") 14 | } 15 | 16 | globals <- g() 17 | str(globals) 18 | 19 | globals <- g(3.14) 20 | str(globals) 21 | 22 | globals <- g(3.14, 1L, b = 2L, c = 3L) 23 | str(globals) 24 | 25 | 26 | h <- function(x = 42, ...) { 27 | globalsByName("..2") 28 | } 29 | 30 | globals <- h(x = 3.14, a = 1, b = 2) 31 | str(globals) 32 | 33 | globals <- g(3.14) 34 | str(globals) 35 | 36 | globals <- g(3.14, 1L, b = 2L, c = 3L) 37 | str(globals) 38 | -------------------------------------------------------------------------------- /incl/globalsOf.R: -------------------------------------------------------------------------------- 1 | b <- 2 2 | expr <- substitute({ a <- b; b <- 1 }) 3 | 4 | ## Will _not_ identify 'b' (because it's also a local) 5 | globalsC <- globalsOf(expr, method = "conservative") 6 | print(globalsC) 7 | 8 | ## Will identify 'b' 9 | globalsL <- globalsOf(expr, method = "liberal") 10 | print(globalsL) 11 | -------------------------------------------------------------------------------- /inst/WORDLIST: -------------------------------------------------------------------------------- 1 | AST 2 | AppVeyor 3 | CMD 4 | Globals 5 | NULLs 6 | NativeSymbolInfo 7 | Pre 8 | TBD 9 | codetools 10 | dotdotdot 11 | enterLocal 12 | env 13 | envir 14 | envname 15 | expr 16 | findGlobals 17 | fst 18 | getGlobals 19 | globals 20 | globalsByName 21 | globalsOf 22 | macOS 23 | mustExist 24 | na 25 | nnn 26 | packagesOf 27 | pre 28 | purrr 29 | vapply 30 | walkAST 31 | -------------------------------------------------------------------------------- /inst/testme/_epilogue/002.undo-state.R: -------------------------------------------------------------------------------- 1 | testme <- as.environment("testme") 2 | hpaste <- globals:::hpaste 3 | 4 | ## Undo options 5 | ## (a) Reset 6 | options(oopts0) 7 | 8 | ## (b) Remove added 9 | local({ 10 | added <- setdiff(names(options()), names(oopts0)) 11 | opts <- vector("list", length = length(added)) 12 | names(opts) <- added 13 | options(opts) 14 | }) 15 | 16 | ## (c) Assert that everything was undone 17 | if (!identical(options(), oopts0)) { 18 | message("Failed to undo options:") 19 | oopts <- options() 20 | message(sprintf(" - Expected options: [n=%d] %s", 21 | length(oopts0), hpaste(sQuote(names(oopts0))))) 22 | extra <- setdiff(names(oopts), names(oopts0)) 23 | message(paste(sprintf(" - Options still there: [n=%d]", length(extra)), 24 | hpaste(sQuote(extra)))) 25 | missing <- setdiff(names(oopts0), names(oopts)) 26 | message(paste(sprintf(" - Options missing: [n=%d]", length(missing)), 27 | hpaste(sQuote(missing)))) 28 | 29 | message("Differences option by option:") 30 | void <- lapply(names(oopts0), FUN = function(name) { 31 | value0 <- oopts0[[name]] 32 | value <- oopts[[name]] 33 | if (!identical(value, value0)) { 34 | if (testme[["debug"]]) { 35 | utils::str(list(name = name, expected = value0, actual = value)) 36 | } 37 | } 38 | }) 39 | } 40 | 41 | 42 | ## Undo system environment variables 43 | ## (a) Reset 44 | do.call(Sys.setenv, args=as.list(oenvs0)) 45 | ## (b) Removed added 46 | added <- setdiff(names(Sys.getenv()), names(oenvs0)) 47 | Sys.unsetenv(added) 48 | ## (c) Assert that everything was undone 49 | if (!identical(Sys.getenv(), oenvs0)) { 50 | message("Failed to undo environment variables:") 51 | oenvs <- Sys.getenv() 52 | message(sprintf(" - Expected environment variables: [n=%d] %s", 53 | length(oenvs0), hpaste(sQuote(names(oenvs0))))) 54 | extra <- setdiff(names(oenvs), names(oenvs0)) 55 | message(paste(sprintf(" - Environment variables still there: [n=%d]", length(extra)), 56 | hpaste(sQuote(extra)))) 57 | missing <- setdiff(names(oenvs0), names(oenvs)) 58 | message(paste(sprintf(" - Environment variables missing: [n=%d]", length(missing)), 59 | hpaste(sQuote(missing)))) 60 | message("Differences environment variable by environment variable:") 61 | void <- lapply(names(oenvs0), FUN = function(name) { 62 | value0 <- unname(oenvs0[name]) 63 | value <- unname(oenvs[name]) 64 | if (!identical(value, value0)) { 65 | if (testme[["debug"]]) { 66 | utils::str(list(name = name, expected = value0, actual = value)) 67 | } 68 | } 69 | }) 70 | } 71 | 72 | 73 | ## Assert undo was successful 74 | if (testme[["debug"]]) { 75 | stopifnot(identical(options(), oopts0)) 76 | } 77 | 78 | ## Undo variables 79 | if (!covr) { 80 | rm(list = c(setdiff(ls(envir = globalenv()), ovars)), envir = globalenv()) 81 | } 82 | 83 | -------------------------------------------------------------------------------- /inst/testme/_epilogue/090.gc.R: -------------------------------------------------------------------------------- 1 | ## Travis CI specific: Explicit garbage collection because it 2 | ## looks like Travis CI might run out of memory during 'covr' 3 | ## testing and we now have so many tests. /HB 2017-01-11 4 | if ("covr" %in% loadedNamespaces()) { 5 | res <- gc() 6 | testme <- as.environment("testme") 7 | if (testme[["debug"]]) print(res) 8 | } 9 | -------------------------------------------------------------------------------- /inst/testme/_epilogue/099.session_info.R: -------------------------------------------------------------------------------- 1 | testme <- as.environment("testme") 2 | if (testme[["debug"]]) { 3 | info <- utils::sessionInfo() 4 | message("Session information:") 5 | print(info) 6 | } 7 | -------------------------------------------------------------------------------- /inst/testme/_epilogue/995.detritus-connections.R: -------------------------------------------------------------------------------- 1 | ## Look for detritus files 2 | testme <- as.environment("testme") 3 | local({ 4 | delta <- diff_connections(get_connections(), testme[["testme_connections"]]) 5 | if (any(lengths(delta) > 0)) { 6 | message(sprintf("Detritus connections generated by test %s:", sQuote(testme[["name"]]))) 7 | print(delta) 8 | } 9 | }) 10 | 11 | 12 | -------------------------------------------------------------------------------- /inst/testme/_epilogue/999.detritus-files.R: -------------------------------------------------------------------------------- 1 | ## Look for detritus files 2 | testme <- as.environment("testme") 3 | 4 | local({ 5 | path <- dirname(tempdir()) 6 | 7 | if (basename(path) == "working_dir") { 8 | files <- dir(pattern = "^Rscript", path = path, all.files = TRUE, full.names = TRUE) 9 | if (length(files) > 0L) { 10 | message(sprintf("Detritus 'Rscript*' files generated by test %s:", sQuote(testme[["name"]]))) 11 | print(files) 12 | 13 | ## Remove detritus files produced by this test script, so that 14 | ## other test scripts will not fail because of these files. 15 | unlink(files) 16 | 17 | ## Signal the problem 18 | msg <- sprintf("Detected 'Rscript*' files: [n=%d] %s", length(files), paste(sQuote(basename(files)), collapse = ", ")) 19 | ## Are detritus files files expected by design on MS Windows? 20 | ## If so, produce a warning, otherwise an error 21 | if ("detritus-files" %in% testme[["tags"]] && 22 | .Platform[["OS.type"]] == "windows") { 23 | warning(msg, immediate. = TRUE) 24 | } else { 25 | stop(msg) 26 | } 27 | } 28 | } else { 29 | message(sprintf("Skipping, because path appears not to be an 'R CMD check' folder: %s", sQuote(path))) 30 | } 31 | }) 32 | -------------------------------------------------------------------------------- /inst/testme/_prologue/001.load.R: -------------------------------------------------------------------------------- 1 | testme <- as.environment("testme") 2 | loadNamespace(testme[["package"]]) 3 | -------------------------------------------------------------------------------- /inst/testme/_prologue/005.globals.R: -------------------------------------------------------------------------------- 1 | eval(envir = globalenv(), quote({ 2 | 3 | ## Define some globals 4 | a <- 0 5 | b <- 2 6 | c <- 3 7 | d <- NULL 8 | e <- function() TRUE 9 | 10 | 11 | ## Expression with globals 12 | exprs <- list( 13 | A = quote({ 14 | x <- b 15 | b <- 1 16 | y <- c 17 | z <- d 18 | a <- a + 1 19 | e <- e() 20 | }), 21 | B = substitute(a <- pkg::a, env=environment()), 22 | C = quote({ 23 | foo(list(a = 1)) 24 | }), 25 | D = quote({ 26 | x <- sample(10) 27 | y <- sum(x) 28 | x2 <- sample2(10) 29 | y2 <- sum2(x) 30 | s <- sessionInfo() 31 | ns <- isNamespaceLoaded("foobar") 32 | }) 33 | ) 34 | 35 | })) ## eval(...) 36 | -------------------------------------------------------------------------------- /inst/testme/_prologue/010.record-state.R: -------------------------------------------------------------------------------- 1 | ## Record original state 2 | ovars <- ls(envir = globalenv()) 3 | oenvs <- oenvs0 <- Sys.getenv() 4 | oopts0 <- options() 5 | -------------------------------------------------------------------------------- /inst/testme/_prologue/030.imports.R: -------------------------------------------------------------------------------- 1 | ## Private future functions 2 | as_function <- globals:::as_function 3 | is_base_pkg <- globals:::is_base_pkg 4 | is.base <- globals:::is.base 5 | is_internal <- globals:::is_internal 6 | where <- globals:::where 7 | mdebug <- globals:::mdebug 8 | envname <- globals:::envname 9 | -------------------------------------------------------------------------------- /inst/testme/_prologue/050.utils.R: -------------------------------------------------------------------------------- 1 | assert_identical_sets <- function(a, b) { 2 | a <- sort(a) 3 | b <- sort(b) 4 | if (!identical(a, b)) { 5 | stop(sprintf("Non-identical sets: c(%s) != c(%s)", 6 | paste(sQuote(a), collapse = ", "), 7 | paste(sQuote(b), collapse = ", "))) 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /inst/testme/_prologue/090.context.R: -------------------------------------------------------------------------------- 1 | fullTest <- (Sys.getenv("_R_CHECK_FULL_") != "") 2 | 3 | covr <- ("covr" %in% loadedNamespaces()) 4 | on_macos <- grepl("^darwin", R.version$os) 5 | on_githubactions <- as.logical(Sys.getenv("GITHUB_ACTIONS", "FALSE")) 6 | 7 | if (covr) { 8 | globalenv <- function() parent.frame() 9 | baseenv <- function() environment(base::sample) 10 | } 11 | -------------------------------------------------------------------------------- /inst/testme/_prologue/090.options.R: -------------------------------------------------------------------------------- 1 | ## Default options 2 | oopts <- options( 3 | warn = 1L, 4 | showNCalls = 500L, 5 | mc.cores = 2L, 6 | future.debug = TRUE, 7 | ## Reset the following during testing in case 8 | ## they are set on the test system 9 | future.availableCores.system = NULL, 10 | future.availableCores.fallback = NULL 11 | ) 12 | -------------------------------------------------------------------------------- /inst/testme/_prologue/091.envvars.R: -------------------------------------------------------------------------------- 1 | ## Comment: The below should be set automatically whenever the future package 2 | ## is loaded and 'R CMD check' runs. The below is added in case R is changed 3 | ## in the future and we fail to detect 'R CMD check'. 4 | Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_CONNECTTIMEOUT = 2 * 60) 5 | Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_TIMEOUT = 2 * 60) 6 | Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_SESSIONINFO_PKGS = TRUE) 7 | Sys.setenv(R_FUTURE_WAIT_INTERVAL = 0.01) ## 0.01s (instead of default 0.2s) 8 | 9 | ## Label PSOCK cluster workers (to help troubleshooting) 10 | test_script <- grep("[.]R$", commandArgs(), value = TRUE)[1] 11 | if (is.na(test_script)) test_script <- "UNKNOWN" 12 | worker_label <- sprintf("future/tests/%s:%s:%s:%s", test_script, Sys.info()[["nodename"]], Sys.info()[["user"]], Sys.getpid()) 13 | Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_RSCRIPT_LABEL = worker_label) 14 | 15 | ## Reset the following during testing in case 16 | ## they are set on the test system 17 | oenvs2 <- Sys.unsetenv(c( 18 | "R_PARALLELLY_AVAILABLECORES_SYSTEM", 19 | "R_PARALLELLY_AVAILABLECORES_FALLBACK", 20 | ## SGE 21 | "NSLOTS", "PE_HOSTFILE", 22 | ## Slurm 23 | "SLURM_CPUS_PER_TASK", 24 | ## TORQUE / PBS 25 | "NCPUS", "PBS_NUM_PPN", "PBS_NODEFILE", "PBS_NP", "PBS_NUM_NODES" 26 | )) 27 | -------------------------------------------------------------------------------- /inst/testme/_prologue/995.detrius-connections.R: -------------------------------------------------------------------------------- 1 | get_connections <- function() { 2 | cons <- lapply(getAllConnections(), FUN = function(idx) { 3 | tryCatch({ 4 | con <- getConnection(idx) 5 | as.data.frame(c(index = idx, summary(con))) 6 | }, error = function(e) { 7 | NULL 8 | }) 9 | }) 10 | do.call(rbind, cons) 11 | } 12 | 13 | diff_connections <- function(after, before) { 14 | index <- NULL ## To please R CMD check 15 | 16 | ## Nothing to do? 17 | if (length(before) + length(after) == 0L) { 18 | return(c(added = NULL, removed = NULL, replaced = NULL)) 19 | } 20 | 21 | idxs <- setdiff(after[["index"]], before[["index"]]) 22 | if (length(idxs) > 0) { 23 | added <- subset(after, index %in% idxs) 24 | after <- subset(after, ! index %in% idxs) 25 | } else { 26 | added <- NULL 27 | } 28 | 29 | idxs <- setdiff(before[["index"]], after[["index"]]) 30 | if (length(idxs) > 0) { 31 | removed <- subset(before, index %in% idxs) 32 | before <- subset(before, ! index %in% idxs) 33 | } else { 34 | removed <- NULL 35 | } 36 | 37 | idxs <- intersect(before[["index"]], after[["index"]]) 38 | if (length(idxs) > 0) { 39 | replaced <- list() 40 | for (idx in idxs) { 41 | before_idx <- subset(before, index == idx) 42 | after_idx <- subset(after, index == idx) 43 | if (!identical(before_idx, after_idx)) { 44 | for (name in colnames(after_idx)) { 45 | value <- after_idx[[name]] 46 | if (!identical(before_idx[[name]], value)) { 47 | value <- sprintf("%s (was %s)", value, before_idx[[name]]) 48 | after_idx[[name]] <- value 49 | } 50 | } 51 | replaced <- c(replaced, list(after_idx)) 52 | } 53 | } 54 | replaced <- do.call(rbind, replaced) 55 | } else { 56 | replaced <- NULL 57 | } 58 | 59 | list(added = added, removed = removed, replaced = replaced) 60 | } 61 | 62 | testme <- as.environment("testme") 63 | testme[["testme_connections"]] <- get_connections() 64 | -------------------------------------------------------------------------------- /inst/testme/deploy.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | source <- "./inst/testme" 4 | if (!utils::file_test("-d", source)) { 5 | stop("Source 'testme' folder not found: ", sQuote(source)) 6 | } 7 | 8 | target <- "./tests" 9 | if (!utils::file_test("-d", target)) { 10 | stop("Target 'tests' folder not found: ", sQuote(target)) 11 | } 12 | 13 | r_path <- "./R" 14 | if (!utils::file_test("-d", r_path)) { 15 | stop("Target 'R' folder not found: ", sQuote(r_path)) 16 | } 17 | 18 | desc <- "./DESCRIPTION" 19 | if (!utils::file_test("-f", desc)) { 20 | stop("'DESCRIPTION' file not found: ", sQuote(desc)) 21 | } 22 | pkgname <- read.dcf(desc)[, "Package"] 23 | if (is.na(pkgname) || !nzchar(pkgname)) { 24 | stop("Failed to infer package name from 'DESCRIPTION' file: ", sQuote(pkgname)) 25 | } else if (!requireNamespace(pkgname)) { 26 | stop("Package fail to load: ", sQuote(pkgname)) 27 | } 28 | 29 | 30 | files <- dir(path = source, pattern = "^test-.*[.]R$", full.names = TRUE) 31 | message(sprintf("Deploying %d test scripts ...", length(files))) 32 | 33 | ## Generate R unit test script 34 | code <- c( 35 | "## This runs 'testme' test inst/testme/test-.R scripts", 36 | "## Don't edit - it was autogenerated by inst/testme/deploy.R", 37 | "testme <- function(name) {", 38 | sprintf(" path <- system.file(package = '%s', 'testme', mustWork = TRUE)", pkgname), 39 | " Sys.setenv(R_TESTME_PATH = path)", 40 | sprintf(" Sys.setenv(R_TESTME_PACKAGE = '%s')", pkgname), 41 | " Sys.setenv(R_TESTME_NAME = name)", 42 | " on.exit(Sys.unsetenv('R_TESTME_NAME'))", 43 | " source(file.path(path, 'run.R'))", 44 | "}" 45 | ) 46 | writeLines(code, con = file.path("./R/testme.R")) 47 | 48 | for (kk in seq_along(files)) { 49 | file <- files[kk] 50 | 51 | source_file <- basename(file) 52 | name <- sub("^test-", "", sub("[.]R$", "", source_file)) 53 | target_file <- file.path(target, source_file) 54 | 55 | message(sprintf("%02d/%02d test script %s", kk, length(files), sQuote(target_file))) 56 | 57 | ## Assert that testme script can be parsed 58 | res <- tryCatch(parse(file = file), error = identity) 59 | if (inherits(res, "error")) { 60 | stop("Syntax error: ", sQuote(file)) 61 | } 62 | 63 | ## Generate R unit test script 64 | code <- c( 65 | sprintf("## This runs testme test script inst/testme/test-%s.R", name), 66 | "## Don't edit - it was autogenerated by inst/testme/deploy.R", 67 | sprintf('%s:::testme("%s")', pkgname, name) 68 | ) 69 | writeLines(code, con = target_file) 70 | } 71 | 72 | message(sprintf("Deploying %d test scripts ... done", length(files))) 73 | -------------------------------------------------------------------------------- /inst/testme/run.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | #' Run a 'testme' Test Script 4 | #' 5 | #' R usage: 6 | #' future::testme("") 7 | #' 8 | #' Command-line usage: 9 | #' Rscript tests/test-.R 10 | #' 11 | #' Command-line usage without package re-install: 12 | #' Rscript inst/testme/run.R --name= 13 | 14 | cmd_args <- commandArgs(trailingOnly = TRUE) 15 | 16 | pattern <- "--package=([[:alpha:][:alnum:]]+)" 17 | idx <- grep(pattern, cmd_args) 18 | if (length(idx) > 0L) { 19 | stopifnot(length(idx) == 1L) 20 | testme_package <- gsub(pattern, "\\1", cmd_args[idx]) 21 | cmd_args <- cmd_args[-idx] 22 | } else { 23 | testme_package <- Sys.getenv("R_TESTME_PACKAGE", NA_character_) 24 | if (is.na(testme_package)) { 25 | desc <- read.dcf("DESCRIPTION") 26 | testme_package <- desc[1, "Package"] 27 | } 28 | } 29 | 30 | pattern <- "--path=([[:alpha:][:alnum:]]+)" 31 | idx <- grep(pattern, cmd_args) 32 | if (length(idx) > 0L) { 33 | stopifnot(length(idx) == 1L) 34 | path <- gsub(pattern, "\\1", cmd_args[idx]) 35 | cmd_args <- cmd_args[-idx] 36 | } else { 37 | path <- Sys.getenv("R_TESTME_PATH", NA_character_) 38 | if (is.na(path)) { 39 | path <- file.path("inst", "testme") 40 | } 41 | if (!utils::file_test("-d", path)) { 42 | stop("There exist no such 'R_TESTME_PATH' folder: ", sQuote(path)) 43 | } 44 | } 45 | Sys.setenv(R_TESTME_PATH = path) 46 | 47 | 48 | pattern <- "--name=([[:alpha:][:alnum:]]+)" 49 | idx <- grep(pattern, cmd_args) 50 | if (length(idx) > 0L) { 51 | stopifnot(length(idx) == 1L) 52 | testme_name <- gsub(pattern, "\\1", cmd_args[idx]) 53 | cmd_args <- cmd_args[-idx] 54 | } else { 55 | testme_name <- NULL 56 | } 57 | 58 | ## Fallback for 'testme_name'? 59 | if (is.null(testme_name)) { 60 | if (length(cmd_args) > 0) { 61 | stopifnot(length(cmd_args) == 1L) 62 | file <- cmd_args[1] 63 | if (utils::file_test("-f", file)) { 64 | testme_name <- gsub("(^test-|[.]R$)", "", basename(file)) 65 | } else { 66 | stop("No such file: ", file) 67 | } 68 | } else { 69 | testme_name <- Sys.getenv("R_TESTME_NAME", NA_character_) 70 | if (is.na(testme_name)) { 71 | stop("testme: Environment variable 'R_TESTME_NAME' is not set") 72 | } 73 | } 74 | } 75 | 76 | 77 | testme_file <- file.path(path, sprintf("test-%s.R", testme_name)) 78 | if (!utils::file_test("-f", testme_file)) { 79 | stop("There exist no such 'testme' file: ", sQuote(testme_file)) 80 | } 81 | 82 | 83 | ## ----------------------------------------------------------------- 84 | ## testme environment 85 | ## ----------------------------------------------------------------- 86 | on_cran <- function() { 87 | not_cran <- Sys.getenv("NOT_CRAN", NA_character_) 88 | if (is.na(not_cran)) { 89 | not_cran <- FALSE 90 | } else { 91 | not_cran <- isTRUE(as.logical(not_cran)) 92 | } 93 | !interactive() && !not_cran 94 | } ## on_cran() 95 | 96 | 97 | ## Get test script tags 98 | tags <- local({ 99 | lines <- readLines(testme_file, warn = FALSE) 100 | pattern <- "^#'[[:blank:]]+@tags[[:blank:]]+" 101 | lines <- grep(pattern, lines, value = TRUE) 102 | tags <- sub(pattern, "", lines) 103 | tags 104 | }) 105 | if (length(tags) > 0) { 106 | tags <- sub("[[:blank:]]*$", "", tags) 107 | tags <- unlist(strsplit(tags, split = "[[:blank:]]+")) 108 | tags <- sort(unique(tags)) 109 | } else { 110 | tags <- character(0L) 111 | } 112 | 113 | ## Create 'testme' environment on the search() path 114 | testme_config <- list( 115 | package = testme_package, 116 | name = testme_name, 117 | tags = tags, 118 | status = "created", 119 | start = proc.time(), 120 | script = testme_file, 121 | on_cran = on_cran(), 122 | debug = isTRUE(as.logical(Sys.getenv("R_TESTME_DEBUG"))) 123 | ) 124 | if ("testme" %in% search()) detach(name = "testme") 125 | testme <- attach(testme_config, name = "testme", warn.conflicts = FALSE) 126 | rm(list = c("tags", "testme_package", "testme_name", "testme_file")) 127 | 128 | 129 | ## ----------------------------------------------------------------- 130 | ## Filters 131 | ## ----------------------------------------------------------------- 132 | ## Skip on CRAN? To run these tests, set env var NOT_CRAN=true 133 | if ("skip_on_cran" %in% tags && on_cran()) { 134 | testme[["status"]] <- "skipped" 135 | } 136 | 137 | code <- Sys.getenv("R_TESTME_FILTER_NAME", NA_character_) 138 | if (!is.na(code)) { 139 | expr <- tryCatch(parse(text = code), error = identity) 140 | if (inherits(expr, "error")) { 141 | stop("Syntax error in R_TESTME_FILTER_NAME: ", sQuote(code)) 142 | } 143 | 144 | keep <- tryCatch(eval(expr, envir = testme), error = identity) 145 | if (inherits(keep, "error")) { 146 | stop("Evaluation of R_TESTME_FILTER_NAME=%s produced an error: %s", 147 | sQuote(code), conditionMessage(keep)) 148 | } 149 | if (!isTRUE(keep)) testme[["status"]] <- "skipped" 150 | } 151 | 152 | code <- Sys.getenv("R_TESTME_FILTER_TAGS", NA_character_) 153 | if (!is.na(code)) { 154 | expr <- tryCatch(parse(text = code), error = identity) 155 | if (inherits(expr, "error")) { 156 | stop("Syntax error in R_TESTME_FILTER_TAGS: ", sQuote(code)) 157 | } 158 | keep <- tryCatch(eval(expr, envir = testme), error = identity) 159 | if (inherits(keep, "error")) { 160 | stop("Evaluation of R_TESTME_FILTER_TAGS=%s produced an error: %s", 161 | sQuote(code), conditionMessage(keep)) 162 | } 163 | if (!isTRUE(keep)) testme[["status"]] <- "skipped" 164 | } 165 | 166 | 167 | message(sprintf("Test %s ...", sQuote(testme[["name"]]))) 168 | 169 | if (testme[["debug"]]) { 170 | message("testme:") 171 | message(paste(utils::capture.output(utils::str(as.list(testme))), collapse = "\n")) 172 | } 173 | 174 | ## Process prologue scripts, if they exist 175 | if (testme[["status"]] != "skipped" && 176 | utils::file_test("-d", file.path(path, "_prologue"))) { 177 | testme[["status"]] <- "prologue" 178 | local({ 179 | ## Find all prologue scripts 180 | files <- dir(file.path(path, "_prologue"), pattern = "*[.]R$", full.names = TRUE) 181 | files <- sort(files) 182 | testme[["prologue_scripts"]] <- files 183 | 184 | ## Source all prologue scripts inside the 'testme' environment 185 | expr <- quote({ 186 | files <- prologue_scripts 187 | message(sprintf("Sourcing %d prologue scripts ...", length(files))) 188 | for (kk in seq_along(files)) { 189 | file <- files[kk] 190 | message(sprintf("%02d/%02d prologue script %s", kk, length(files), sQuote(file))) 191 | source(file, local = TRUE) 192 | } 193 | message(sprintf("Sourcing %d prologue scripts ... done", length(files))) 194 | rm(list = c("kk", "file", "files")) 195 | }) 196 | eval(expr, envir = testme) 197 | }) 198 | 199 | # ## In case prologue scripts overwrote some elements in 'testme' 200 | # for (name in names(testme_config)) { 201 | # testme[[name]] <- testme_config[[name]] 202 | # } 203 | } 204 | 205 | 206 | ## Run test script 207 | ## Note, prologue scripts may trigger test to be skipped 208 | if (testme[["status"]] != "skipped") { 209 | message("Running test script: ", sQuote(testme[["script"]])) 210 | testme[["status"]] <- "failed" 211 | source(testme[["script"]], echo = TRUE) 212 | testme[["status"]] <- "success" 213 | 214 | # ## In case test script overwrote some elements in 'testme' 215 | # for (name in names(testme_config)) { 216 | # testme[[name]] <- testme_config[[name]] 217 | # } 218 | } 219 | 220 | 221 | ## Process epilogue scripts, if they exist 222 | ## Note, epilogue scripts may change status or produce check errors 223 | if (testme[["status"]] == "success" && 224 | utils::file_test("-d", file.path(path, "_epilogue"))) { 225 | testme[["status"]] <- "epilogue" 226 | local({ 227 | ## Find all epilogue scripts 228 | files <- dir(file.path(path, "_epilogue"), pattern = "*[.]R$", full.names = TRUE) 229 | files <- sort(files) 230 | testme[["epilogue_scripts"]] <- files 231 | 232 | ## Source all epilogue scripts inside the 'testme' environment 233 | expr <- quote({ 234 | files <- epilogue_scripts 235 | message(sprintf("Sourcing %d epilogue scripts ...", length(files))) 236 | for (kk in seq_along(files)) { 237 | file <- files[kk] 238 | message(sprintf("%02d/%02d epilogue script %s", kk, length(files), sQuote(file))) 239 | source(file, local = TRUE) 240 | } 241 | message(sprintf("Sourcing %d epilogue scripts ... done", length(files))) 242 | rm(list = c("kk", "file", "files")) 243 | }) 244 | eval(expr, envir = testme) 245 | }) 246 | testme[["status"]] <- "success" 247 | } 248 | 249 | testme[["stop"]] <- proc.time() 250 | dt <- testme[["stop"]] - testme[["start"]] 251 | dt_str <- sprintf("%s=%.1gs", names(dt), dt) 252 | message("Test time: ", paste(dt_str, collapse = ", ")) 253 | 254 | message(sprintf("Test %s ... %s", sQuote(testme[["name"]]), testme[["status"]])) 255 | 256 | if ("testme" %in% search()) detach(name = "testme") 257 | -------------------------------------------------------------------------------- /inst/testme/test-cleanup.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** cleanup() ...") 4 | 5 | message("- cleanup() with remapped base functions") 6 | 7 | ## Don't clean out renamed base functions 8 | ## https://github.com/HenrikBengtsson/globals/issues/57 9 | globals <- list( 10 | my_fcn = function(x) x, ## should not be deleted 11 | identity = base::identity, 12 | my_identity = base::identity ## should not be deleted 13 | ) 14 | expected <- c("my_fcn", "my_identity") 15 | 16 | ## Add an example of an internal/non-exported package object from 'utils'. 17 | ## Such objects need to be kept because they will not be on the search path 18 | ## even if the package is attached 19 | ns <- asNamespace("utils") 20 | pkg <- as.environment("package:utils") 21 | internals <- setdiff(ls(ns, all.names = TRUE), ls(pkg, all.names = TRUE)) 22 | internals <- grep("^print", internals, value = TRUE) 23 | if (length(internals) > 0L) { 24 | name <- internals[1] 25 | obj <- get(name, envir = ns, inherits = FALSE) 26 | stopifnot(!exists(name, envir = pkg, inherits = FALSE)) 27 | globals[[name]] <- obj 28 | expected <- c(expected, name) 29 | name <- sprintf("my-%s", name) 30 | globals[[name]] <- obj 31 | expected <- c(expected, name) 32 | } 33 | 34 | globals <- as.Globals(globals) 35 | str(globals) 36 | 37 | globals <- cleanup(globals) 38 | str(globals) 39 | assert_identical_sets(names(globals), expected) 40 | 41 | 42 | message("- cleanup() with missing globals") 43 | rm(list = "b") 44 | expr <- quote(a <- b) 45 | print(expr) 46 | globals <- globalsOf(expr, mustExist = FALSE) 47 | str(globals) 48 | stopifnot(identical(names(globals), c("<-", "b"))) 49 | 50 | 51 | message("- cleanup(globals) with missing globals") 52 | pruned <- cleanup(globals) 53 | str(pruned) 54 | stopifnot(length(pruned) == 0L) 55 | 56 | message("- cleanup(globals, drop = 'missing') with missing globals") 57 | pruned <- cleanup(globals, drop = "missing") 58 | str(pruned) 59 | stopifnot(identical(names(pruned), c("<-"))) 60 | 61 | message("- cleanup(globals, drop = 'base-packages') with missing globals") 62 | pruned <- cleanup(globals, drop = "base-packages") 63 | str(pruned) 64 | stopifnot(identical(names(pruned), c("b"))) 65 | 66 | message("*** cleanup() ... DONE") 67 | 68 | -------------------------------------------------------------------------------- /inst/testme/test-codetools-bug16.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** codetools::findGlobals() bug #16 ...") 4 | 5 | exprs <- list( 6 | A = quote(x %% `$<-`("abc", 42)), 7 | B = quote(function() x %% `$<-`("abc", 42)) 8 | ) 9 | 10 | for (name in names(exprs)) { 11 | expr <- exprs[[name]] 12 | print(expr) 13 | globals <- globals::findGlobals(expr) 14 | print(globals) 15 | 16 | diffA <- setdiff(c("%%", "x", "$<-"), globals) 17 | print(diffA) 18 | stopifnot(length(diffA) == 0) 19 | 20 | diffB <- setdiff(globals, c("%%", "x", "$<-")) 21 | print(diffB) 22 | stopifnot(length(diffB) == 0) 23 | } 24 | 25 | message("*** codetools::findGlobals() bug #16 ... done") 26 | -------------------------------------------------------------------------------- /inst/testme/test-conservative.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | ## WORKAROUND: Avoid problem reported in testthat Issue #229, which 4 | ## causes covr::package_coverage() to given an error. /HB 2015-02-16 5 | suppressWarnings({ 6 | rm(list = c("a", "b", "c", "x", "y", "z", "square", 7 | "pathname", "url", "filename")) 8 | }) 9 | 10 | 11 | message("Setting up expressions") 12 | exprs <- list( 13 | A = quote({ 14 | Sys.sleep(1) 15 | x <- 0.1 16 | }), 17 | B = quote({ y <- 0.2 }), 18 | C = quote({ z <- a + 0.3 }), 19 | D = quote({ pathname <- file.path(dirname(url), filename) }), 20 | E = quote({ b <- c }), 21 | F = quote({ 22 | a <- { runif(1) } 23 | b <- { rnorm(1) } 24 | x <- a * b 25 | abs(x) 26 | }), 27 | G = quote({ 28 | y <- square(a) 29 | }), 30 | H = quote({ 31 | b <- a 32 | a <- 1 33 | }) 34 | ) 35 | 36 | atleast <- list( 37 | A = c(), 38 | B = c(), 39 | C = c("a"), 40 | D = c("filename"), 41 | E = c("c"), 42 | F = c(), 43 | G = c("a", "square"), 44 | H = c() ## FIXME: Should be c("a"), cf. Issue #5. 45 | ) 46 | 47 | not <- list( 48 | A = c("x"), 49 | B = c("y"), 50 | C = c("z"), 51 | D = c("pathname"), 52 | E = c("b"), 53 | F = c("a", "b", "x"), 54 | G = c(), 55 | H = c() 56 | ) 57 | 58 | 59 | ## Define globals 60 | a <- 3.14 61 | c <- 2.71 62 | square <- function(x) x ^ 2 63 | filename <- "index.html" 64 | # Yes, pretend we forget 'url' 65 | 66 | message("Find globals") 67 | for (kk in seq_along(exprs)) { 68 | key <- names(exprs)[kk] 69 | expr <- exprs[[key]] 70 | cat(sprintf("Expression #%d ('%s'):\n", kk, key)) 71 | print(expr) 72 | 73 | names <- findGlobals(expr, method = "conservative") 74 | cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) 75 | stopifnot(all(atleast[[key]] %in% names)) 76 | stopifnot(!any(names %in% not[[key]])) 77 | 78 | globals <- globalsOf(expr, method = "conservative") 79 | cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) 80 | stopifnot(all(atleast[[key]] %in% names(globals))) 81 | stopifnot(!any(names(globals) %in% not[[key]])) 82 | str(globals) 83 | 84 | cat("\n") 85 | } 86 | 87 | names <- findGlobals(exprs, method = "conservative", unlist = TRUE) 88 | cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) 89 | 90 | ## Cleanup 91 | -------------------------------------------------------------------------------- /inst/testme/test-dotdotdot.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | options(warn = 2L) 4 | 5 | exprs <- list( 6 | ok1 = quote(function(...) sum(x, ...)), 7 | ok2 = quote(function(...) sum(x, ..1, ..2, ..3)), 8 | warn1 = quote(sum(x, ...)), 9 | warn2 = quote(sum(x, ..1, ..2, ..3)) 10 | ) 11 | 12 | truth <- list( 13 | ok1 = c("sum", "x"), 14 | ok2 = c("sum", "x"), 15 | warn1 = c("sum", "x", "..."), 16 | warn2 = c("sum", "x", "..1", "..2", "..3") 17 | ) 18 | 19 | message("*** findGlobals() ...") 20 | 21 | for (name in names(exprs)) { 22 | expr <- exprs[[name]] 23 | 24 | message(sprintf("\n*** codetools::findGlobals() - step %s:", sQuote(name))) 25 | print(expr) 26 | fun <- globals:::as_function(expr) 27 | print(fun) 28 | ## Suppress '... may be used in an incorrect context' warnings 29 | suppressWarnings({ 30 | globals <- codetools::findGlobals(fun) 31 | }) 32 | print(globals) 33 | assert_identical_sets(globals, c("sum", "x")) 34 | next 35 | 36 | message("\n*** findGlobals(dotdotdot = 'ignore'):") 37 | cat(sprintf("Expression '%s':\n", name)) 38 | print(expr) 39 | globals <- findGlobals(expr, dotdotdot = "ignore") 40 | print(globals) 41 | assert_identical_sets(globals, c("sum", "x")) 42 | 43 | message("\n*** findGlobals(dotdotdot = 'return'):") 44 | cat(sprintf("Expression '%s':\n", name)) 45 | print(expr) 46 | globals <- findGlobals(expr, dotdotdot = "return") 47 | print(globals) 48 | assert_identical_sets(globals, truth[[name]]) 49 | 50 | message("\n*** findGlobals(dotdotdot = 'warning'):") 51 | cat(sprintf("Expression '%s':\n", name)) 52 | print(expr) 53 | globals <- findGlobals(expr, dotdotdot = "warning") 54 | print(globals) 55 | assert_identical_sets(globals, truth[[name]]) 56 | 57 | message("\n*** findGlobals(dotdotdot = 'error'):") 58 | cat(sprintf("Expression '%s':\n", name)) 59 | print(expr) 60 | globals <- tryCatch(findGlobals(expr, dotdotdot = "error"), error = identity) 61 | if (name %in% c("ok1", "ok2")) { 62 | assert_identical_sets(globals, truth[[name]]) 63 | } else { 64 | stopifnot(inherits(globals, "error")) 65 | } 66 | } # for (name ...) 67 | 68 | 69 | message("\n*** findGlobals(, dotdotdot = 'return'):") 70 | print(exprs) 71 | globals <- findGlobals(exprs, dotdotdot = "return") 72 | print(globals) 73 | assert_identical_sets(globals, unique(unlist(truth, use.names = FALSE))) 74 | 75 | message("\n*** findGlobals(, dotdotdot = 'return'):") 76 | formula_attr <- bquote(~ .(call("fn", quote(...)))) 77 | x <- structure(integer(), formula_attr = formula_attr) 78 | print(x) 79 | # Attributes always use `dotdotdot = "ignore"` 80 | globals <- findGlobals(x, dotdotdot = "return", attributes = TRUE) 81 | print(globals) 82 | assert_identical_sets(globals, c("~", "fn")) 83 | 84 | message("*** findGlobals() ... DONE") 85 | 86 | 87 | 88 | message("*** globalsOf() ...") 89 | 90 | x <- 1:2 91 | 92 | for (name in names(exprs)) { 93 | expr <- exprs[[name]] 94 | 95 | message("\n*** globalsOf(dotdotdot = 'ignore'):") 96 | cat(sprintf("Expression '%s':\n", name)) 97 | print(expr) 98 | globals <- globalsOf(expr, dotdotdot = "ignore") 99 | print(globals) 100 | assert_identical_sets(names(globals), c("sum", "x")) 101 | stopifnot(all.equal(globals$sum, base::sum)) 102 | stopifnot(all.equal(globals$x, x)) 103 | 104 | message("\n*** globalsOf(dotdotdot = 'return'):") 105 | cat(sprintf("Expression '%s':\n", name)) 106 | print(expr) 107 | globals <- globalsOf(expr, dotdotdot = "return") 108 | print(globals) 109 | assert_identical_sets(names(globals), truth[[name]]) 110 | if (name == "warn1") { 111 | stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) 112 | } 113 | stopifnot(all.equal(globals$sum, base::sum)) 114 | stopifnot(all.equal(globals$x, x)) 115 | 116 | message("\n*** globalsOf(dotdotdot = 'warning'):") 117 | cat(sprintf("Expression '%s':\n", name)) 118 | print(expr) 119 | globals <- globalsOf(expr, dotdotdot = "warning") 120 | print(globals) 121 | assert_identical_sets(names(globals), truth[[name]]) 122 | if (name == "warn1") { 123 | stopifnot(!is.list(globals$`...`) && is.na(globals$`...`)) 124 | } 125 | stopifnot(all.equal(globals$sum, base::sum)) 126 | stopifnot(all.equal(globals$x, x)) 127 | 128 | message("\n*** globalsOf(dotdotdot = 'error'):") 129 | cat(sprintf("Expression '%s':\n", name)) 130 | print(expr) 131 | globals <- tryCatch(globalsOf(expr, dotdotdot = "error"), error = identity) 132 | if (name %in% c("ok1", "ok2")) { 133 | assert_identical_sets(names(globals), truth[[name]]) 134 | stopifnot(all.equal(globals$sum, base::sum)) 135 | stopifnot(all.equal(globals$x, x)) 136 | } else { 137 | stopifnot(inherits(globals, "error")) 138 | } 139 | } # for (name ...) 140 | 141 | message("\n*** globalsOf(, dotdotdot = 'return'):") 142 | print(exprs) 143 | globals <- globalsOf(exprs, dotdotdot = "return") 144 | print(globals) 145 | 146 | 147 | message("*** globalsOf() ... DONE") 148 | 149 | 150 | message("*** function(x, ...) globalsOf() ...") 151 | 152 | aux <- function(x, ..., exprs) { 153 | args <- list(...) 154 | 155 | for (name in names(exprs)) { 156 | expr <- exprs[[name]] 157 | 158 | message("\n*** globalsOf(dotdotdot = 'ignore'):") 159 | cat(sprintf("Expression '%s':\n", name)) 160 | print(expr) 161 | globals <- globalsOf(expr, dotdotdot = "ignore") 162 | print(globals) 163 | assert_identical_sets(names(globals), c("sum", "x")) 164 | stopifnot(all.equal(globals$sum, base::sum)) 165 | stopifnot(all.equal(globals$x, x)) 166 | 167 | message("\n*** globalsOf(dotdotdot = 'return'):") 168 | cat(sprintf("Expression '%s':\n", name)) 169 | print(expr) 170 | globals <- globalsOf(expr, dotdotdot = "return") 171 | print(globals) 172 | assert_identical_sets(names(globals), truth[[name]]) 173 | if (name == "warn1") { 174 | stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) 175 | } 176 | stopifnot(all.equal(globals$sum, base::sum)) 177 | stopifnot(all.equal(globals$x, x)) 178 | 179 | message("\n*** globalsOf(dotdotdot = 'warning'):") 180 | cat(sprintf("Expression '%s':\n", name)) 181 | print(expr) 182 | globals <- globalsOf(expr, dotdotdot = "warning") 183 | print(globals) 184 | assert_identical_sets(names(globals), truth[[name]]) 185 | if (name == "warn1") { 186 | stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE)) 187 | } 188 | stopifnot(all.equal(globals$sum, base::sum)) 189 | stopifnot(all.equal(globals$x, x)) 190 | 191 | message("\n*** globalsOf(dotdotdot = 'error'):") 192 | cat(sprintf("Expression '%s':\n", name)) 193 | print(expr) 194 | globals <- tryCatch(globalsOf(expr, dotdotdot = "error"), error = identity) 195 | if (name %in% c("ok1", "ok2")) { 196 | assert_identical_sets(names(globals), truth[[name]]) 197 | stopifnot(all.equal(globals$sum, base::sum)) 198 | stopifnot(all.equal(globals$x, x)) 199 | } else { 200 | stopifnot(inherits(globals, "error")) 201 | } 202 | } # for (name ...) 203 | 204 | message("\n*** globalsOf(, dotdotdot = 'return'):") 205 | print(exprs) 206 | globals <- globalsOf(exprs, dotdotdot = "return") 207 | print(globals) 208 | 209 | } # aux() 210 | 211 | aux(x = 3:4, y = 1, z = 42L, 3.14, exprs = exprs) 212 | message("*** function(x, ...) globalsOf() ... DONE") 213 | 214 | 215 | ## Cleanup 216 | -------------------------------------------------------------------------------- /inst/testme/test-findGlobals,dfs.R: -------------------------------------------------------------------------------- 1 | options(globals.debug = (.Platform[["OS.type"]] == "windows")) 2 | 3 | commaq <- globals:::commaq 4 | 5 | exprs <- list() 6 | truths <- list() 7 | append_expr <- function(expr, substitute = TRUE, truth = character(0L)) { 8 | if (substitute) expr <- substitute(expr) 9 | truth <- sort(truth) 10 | exprs <<- c(exprs, list(expr)) 11 | truths <<- c(truths, list(truth)) 12 | invisible(length(exprs)) 13 | } 14 | 15 | append_expr(42, truth = character(0L)) 16 | 17 | append_expr(a, truth = c("a")) 18 | 19 | append_expr(a <- 42, truth = c("<-", if (getRversion() < "4.0.0") c("a"))) 20 | 21 | 22 | append_expr({ 23 | a + b 24 | }, truth = c("{", "+", "a", "b")) 25 | 26 | append_expr({ 27 | a <- 42 28 | a + b 29 | }, truth = c("{", "<-", "+", "b", if (getRversion() < "4.0.0") "a")) 30 | 31 | append_expr({ 32 | c() 33 | }, truth = c("{", "c")) 34 | 35 | append_expr({ 36 | c(1:3) 37 | }, truth = c("{", "c", ":")) 38 | 39 | append_expr({ 40 | pi 41 | }, truth = c("{", "pi")) 42 | 43 | append_expr({ 44 | base::pi 45 | }, truth = c("{", "::")) 46 | 47 | append_expr({ 48 | base:::pi 49 | }, truth = c("{", ":::")) 50 | 51 | append_expr(a$b, truth = c("a", "$")) 52 | 53 | append_expr(a$b(), truth = c("a", "$")) 54 | 55 | append_expr(a$b(2), truth = c("a", "$")) 56 | 57 | append_expr(a()$b, truth = c("a", "$")) 58 | 59 | append_expr(a(2)$b, truth = c("a", "$")) 60 | 61 | append_expr(a@b, truth = c("a", "@")) 62 | 63 | append_expr(a@b(), truth = c("a", "@")) 64 | 65 | append_expr(a@b(2), truth = c("a", "@")) 66 | 67 | append_expr(a()@b, truth = c("a", "@")) 68 | 69 | append_expr(a(2)@b, truth = c("a", "@")) 70 | 71 | append_expr(a[1], truth = c("a", "[")) 72 | 73 | append_expr(a[NA], truth = c("a", "[")) 74 | 75 | append_expr(a[NA_character_], truth = c("a", "[")) 76 | 77 | append_expr(a[Inf], truth = c("a", "[")) 78 | 79 | append_expr(a[], truth = c("a", "[")) 80 | 81 | append_expr(a[1,], truth = c("a", "[")) 82 | 83 | append_expr(a[,1], truth = c("a", "[")) 84 | 85 | append_expr(a[1] <- 0, truth = c("a", "[<-")) 86 | 87 | append_expr(a[b <- 1] <- 0, truth = c("a", "[<-", "<-", if (getRversion() < "4.0.0") c("b"))) 88 | 89 | append_expr({ a[b <- 1] <- 0 }, truth = c("{", "a", "[<-", "<-", if (getRversion() < "4.0.0") c("b"))) 90 | 91 | append_expr({ a$b <- 0 }, truth = c("{", "a", "$<-")) 92 | 93 | append_expr({ a@b <- 0 }, truth = c("{", "a", "@<-")) 94 | 95 | append_expr(names(a) <- "A", truth = c("a", "names<-")) 96 | 97 | append_expr({ a[1] = 0 }, truth = c("{", "a", "[<-")) 98 | 99 | append_expr({ a[b = 1] = 0 }, truth = c("{", "a", "[<-")) 100 | 101 | append_expr({ a$b = 0 }, truth = c("{", "a", "$<-")) 102 | 103 | append_expr({ names(a) = "A" }, truth = c("{", "a", "names<-")) 104 | 105 | append_expr({ names(a)[1] = "A" }, truth = c("{", "names<-", "a", "[<-", "names")) 106 | 107 | append_expr(x[is.na(x)] <- 0, truth = c("[<-", "is.na", "x")) 108 | 109 | append_expr({ x[is.na(x)] = 0 }, truth = c("{", "[<-", "is.na", "x")) 110 | 111 | append_expr(function(a) a, truth = character(0L)) 112 | 113 | append_expr(function(a) a + b, truth = c("+", "b")) 114 | 115 | append_expr(function(a, b) a + b, truth = c("+")) 116 | 117 | append_expr(function(a, b = 1) a + b, truth = c("+")) 118 | 119 | append_expr({ 120 | g <- function(a) a 121 | g(a) 122 | }, truth = c("{", "<-", "a", if (getRversion() < "4.0.0") "g")) 123 | 124 | 125 | append_expr({ 126 | x <- 1 127 | y <- function(a) { 128 | b <- 3 129 | a + b + x 130 | } 131 | z <- y(2 * x) 132 | }, truth = c("{", "<-", "+", "*", if (getRversion() < "4.0.0") c("b", "x", "y", "z"))) 133 | 134 | append_expr({ 135 | y <- function(a) a + x 136 | x <- 1 137 | z <- y(2 * x) 138 | }, truth = c("{", "<-", "x", "+", "*", if (getRversion() < "4.0.0") c("y", "z"))) 139 | 140 | 141 | append_expr({ 142 | lapply(1:3, function (i) { 143 | G <- function(a,b,c) c(a, b, c) 144 | G(a, b, c) 145 | }) 146 | }, truth = c(":", "{", "<-", "a", "b", "c", "lapply", if (getRversion() < "4.0.0") "G")) 147 | 148 | 149 | append_expr({ 150 | base::lapply(1:3, function (i) { 151 | G <- function(a,b,c) c(a, b, c) 152 | G(a, b, c) 153 | }) 154 | }, truth = c("::", ":", "{", "<-", "a", "b", "c", if (getRversion() < "4.0.0") "G")) 155 | 156 | 157 | append_expr(~ x, substitute = FALSE, truth = c("~", "x")) 158 | 159 | append_expr(. ~ x, substitute = FALSE, truth = c("~", ".", "x")) 160 | 161 | append_expr(y ~ x + 1, truth = c("~", "y", "+", "x")) 162 | 163 | env <- new.env(parent = emptyenv()) 164 | append_expr(env, substitute = FALSE, truth = character(0L)) 165 | 166 | fcn <- function() a * x 167 | append_expr(fcn, substitute = FALSE, truth = c("*", "a", "x")) 168 | 169 | fcn <- function(a) a * x 170 | append_expr(fcn, substitute = FALSE, truth = c("*", "x")) 171 | 172 | fcn <- function(a, b = 1) a * x + b 173 | append_expr(fcn, substitute = FALSE, truth = c("*", "x", "+")) 174 | 175 | fcn <- function(...) NULL 176 | append_expr(fcn, substitute = FALSE, truth = character(0L)) 177 | 178 | fcn <- function(...) list(...) 179 | append_expr(fcn, substitute = FALSE, truth = c("list")) 180 | 181 | fcn <- function() list(...) 182 | append_expr(fcn, substitute = FALSE, truth = c("list", "...")) 183 | 184 | fcn <- function(a, ...) base::list(a = a, ...) 185 | append_expr(fcn, substitute = FALSE, truth = c("::")) 186 | 187 | fcn <- function(a, ...) c(a = a, ...) 188 | append_expr(fcn, substitute = FALSE, truth = c("c")) 189 | 190 | expr <- expression(x) 191 | append_expr(expr, substitute = FALSE, truth = c("x")) 192 | 193 | expr <- expression(x + y) 194 | append_expr(expr, substitute = FALSE, truth = c("+", "x", "y")) 195 | 196 | # BUG: https://github.com/HenrikBengtsson/globals/issues/93 197 | expr <- asS3(methods::getClass("S4")@prototype, complete = FALSE) 198 | append_expr(expr, substitute = FALSE, truth = character(0L)) 199 | 200 | con <- rawConnection(raw()) 201 | append_expr(con, substitute = FALSE, truth = character(0L)) 202 | close(con) 203 | 204 | expr <- quote(for (x in NULL) NULL) 205 | append_expr(expr, substitute = FALSE, truth = c("for")) 206 | 207 | expr <- quote(for (x in NULL) x) 208 | append_expr(expr, substitute = FALSE, truth = c("for")) 209 | 210 | 211 | expr <- quote(base::names(x)[1] <- 0) 212 | append_expr(expr, substitute = FALSE, truth = c("::", "x", "[<-")) 213 | 214 | for (kk in seq_along(exprs)) { 215 | message(sprintf("\n*** Expression #%d ***", kk)) 216 | expr <- exprs[[kk]] 217 | truth <- truths[[kk]] 218 | print(expr) 219 | 220 | globals <- sort(globals::findGlobals(expr, method = "ordered")) 221 | message(sprintf(" findGlobals(..., type = 'ordered'): [n=%d] %s", length(globals), commaq(globals))) 222 | globals <- sort(globals::findGlobals(expr, method = "dfs")) 223 | msg <- sprintf("findGlobals(..., type = 'dfs' ): [n=%d] %s", length(globals), commaq(globals)) 224 | if (is.null(truth)) { 225 | message(sprintf("[SKIP] %s", msg)) 226 | } else { 227 | missed <- setdiff(truth, globals) 228 | extra <- setdiff(globals, truth) 229 | if (length(extra) + length(missed) > 0) { 230 | info <- character(0L) 231 | if (length(extra) > 0) { 232 | info <- c(info, sprintf("extra: [n=%d] %s", length(extra), commaq(extra))) 233 | } 234 | if (length(missed) > 0) { 235 | info <- c(info, sprintf("missing: [n=%d] %s", length(missed), commaq(missed))) 236 | } 237 | info <- paste(info, collapse = "; ") 238 | message(sprintf("[FAIL] %s; which is unexpected (%s)", msg, info)) 239 | stop("Unexpected results") 240 | } else { 241 | message(sprintf("[ OK ] %s", msg)) 242 | } 243 | } 244 | } ## for (kk ...) 245 | -------------------------------------------------------------------------------- /inst/testme/test-formulas.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("findGlobals() with formula ...") 4 | 5 | g <- findGlobals(. ~ x + y : z, substitute = TRUE) 6 | print(g) 7 | assert_identical_sets(g, c("~", ".", "+", "x", ":", "y", "z")) 8 | 9 | g <- findGlobals(map(1L, ~ typeof(.x)), substitute = TRUE) 10 | print(g) 11 | assert_identical_sets(g, c("map", "~", "typeof", ".x")) 12 | 13 | 14 | message("- findGlobals() with NULL in the formula ...") 15 | ## BUG: https://github.com/HenrikBengtsson/globals/issues/59 16 | for (substitute in c(TRUE, FALSE)) { 17 | message("- substitute = ", substitute) 18 | 19 | g <- findGlobals(. ~ NULL, substitute = substitute) 20 | print(g) 21 | assert_identical_sets(g, c(".", "~")) 22 | 23 | g <- findGlobals(NULL ~ NULL, substitute = substitute) 24 | print(g) 25 | assert_identical_sets(g, c("~")) 26 | 27 | g <- findGlobals(~ NULL, substitute = substitute) 28 | print(g) 29 | assert_identical_sets(g, c("~")) 30 | 31 | g <- findGlobals(NULL ~ ., substitute = substitute) 32 | print(g) 33 | assert_identical_sets(g, c("~", ".")) 34 | } 35 | 36 | # ## substitute=FALSE 37 | # Browse[2]> str(expr) 38 | # language ~NULL 39 | # 40 | # ## substitute=TRUE 41 | # Browse[2]> str(expr) 42 | # Class 'formula' language ~NULL 43 | # ..- attr(*, ".Environment")= 44 | 45 | 46 | message("- findGlobals() with ellipsis in formulas ...") 47 | ## BUG: https://github.com/HenrikBengtsson/globals/issues/62 48 | 49 | g <- findGlobals(list(..., ..3) ~ list(., .x, ..., ..1, ..2)) 50 | print(g) 51 | assert_identical_sets(g, c("~", "list", "...", "..3", ".", ".x", "..1", "..2")) 52 | 53 | message("- findGlobals() with NULL in formulas ...") 54 | ## BUG: https://github.com/HenrikBengtsson/globals/issues/64 55 | 56 | env <- new.env(parent = globalenv()) 57 | env$`~` <- function(...) "OVERRIDE!" 58 | 59 | x <- ~ NULL 60 | g <- eval(quote(findGlobals(x)), env) 61 | assert_identical_sets(g, "~") 62 | 63 | x <- list(~ NULL) 64 | g <- eval(quote(findGlobals(x)), env) 65 | assert_identical_sets(g, "~") 66 | 67 | x <- list(NULL ~ NULL) 68 | g <- eval(quote(findGlobals(x)), env) 69 | assert_identical_sets(g, "~") 70 | 71 | x <- list(NULL ~ b) 72 | g <- eval(quote(findGlobals(x)), env) 73 | assert_identical_sets(g, c("~", "b")) 74 | 75 | 76 | message("findGlobals() with formula ... DONE") 77 | 78 | 79 | message("globalsOf() with formula ...") 80 | 81 | foo <- function(x) { 82 | map(1L, ~ typeof(x + .x)) 83 | } 84 | 85 | g <- globalsOf(foo(1L), substitute = TRUE, mustExist = FALSE) 86 | str(g) 87 | assert_identical_sets(names(g), c("foo", "map", "{", "~", "typeof", "+", "x", ".x")) 88 | 89 | message("globalsOf() with formula ... DONE") 90 | 91 | -------------------------------------------------------------------------------- /inst/testme/test-globalsByName.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** globalsByName() ...") 4 | 5 | globals_c <- globalsByName(c("{", "<-", "c", "d")) 6 | str(globals_c) 7 | assert_identical_sets(names(globals_c), c("{", "<-", "c", "d")) 8 | globals_c <- cleanup(globals_c) 9 | str(globals_c) 10 | assert_identical_sets(names(globals_c), c("c", "d")) 11 | where <- attr(globals_c, "where") 12 | stopifnot( 13 | length(where) == length(globals_c), 14 | identical(where$c, globalenv()), 15 | identical(where$d, globalenv()) 16 | ) 17 | 18 | foo <- globals::Globals 19 | globals <- globalsByName(c("{", "foo", "list"), recursive = FALSE) 20 | str(globals) 21 | assert_identical_sets(names(globals), c("{", "foo", "list")) 22 | where <- attr(globals, "where") 23 | stopifnot(length(where) == length(globals)) 24 | if (!covr) stopifnot( 25 | identical(where$`{`, baseenv()), 26 | identical(where$foo, globalenv()), 27 | identical(where$list, baseenv()) 28 | ) 29 | 30 | globals <- cleanup(globals) 31 | str(globals) 32 | assert_identical_sets(names(globals), c("foo")) 33 | globals <- cleanup(globals, drop = "internals") 34 | str(globals) 35 | assert_identical_sets(names(globals), c("foo")) 36 | pkgs <- packagesOf(globals) 37 | stopifnot(pkgs == "globals") 38 | 39 | 40 | ## Also '...' 41 | myGlobals <- function(x, ...) { 42 | globalsByName(c("a", "x", "...")) 43 | } 44 | globals <- myGlobals(x = 2, y = 3, z = 4) 45 | str(globals) 46 | assert_identical_sets(names(globals), c("a", "x", "...")) 47 | assert_identical_sets(names(globals[["..."]]), c("y", "z")) 48 | 49 | ## And '..1', '..2', etc. 50 | myGlobals <- function(x, ...) { 51 | globalsByName(c("a", "x", "..1", "..2")) 52 | } 53 | globals <- myGlobals(x = 2, y = 3, 4) 54 | str(globals) 55 | assert_identical_sets(names(globals), c("a", "x", "..1", "..2")) 56 | stopifnot( 57 | globals[["..1"]] == 3, 58 | globals[["..2"]] == 4 59 | ) 60 | 61 | ## BUG FIX: Assert that '...' does not have to be specified at the end 62 | myGlobals <- function(x, ...) { 63 | globalsByName(c("a", "...", "x")) 64 | } 65 | globals <- myGlobals(x = 2, y = 3, z = 4) 66 | str(globals) 67 | assert_identical_sets(names(globals), c("a", "x", "...")) 68 | assert_identical_sets(names(globals[["..."]]), c("y", "z")) 69 | 70 | 71 | ## Test with arguments defaulting to other arguments 72 | myGlobals <- function(x, y, z = y) { 73 | globalsByName(c("a", "x", "y", "z")) 74 | } 75 | globals <- myGlobals(x = 2, y = 3) 76 | assert_identical_sets(names(globals), c("a", "x", "y", "z")) 77 | stopifnot(globals$y == 3, identical(globals$z, globals$y)) 78 | 79 | globals <- myGlobals(x = 2, y = 3, z = 4) 80 | assert_identical_sets(names(globals), c("a", "x", "y", "z")) 81 | stopifnot(globals$y == 3, globals$z == 4) 82 | 83 | myGlobals <- function(x, ...) { 84 | globalsByName(c("a", "x", "...")) 85 | } 86 | globals <- myGlobals(x = 2, y = 3) 87 | assert_identical_sets(names(globals), c("a", "x", "...")) 88 | assert_identical_sets(names(globals[["..."]]), c("y")) 89 | stopifnot(globals[["..."]]$y == 3) 90 | 91 | globals <- myGlobals(x = 2, y = 3, z = 4) 92 | assert_identical_sets(names(globals), c("a", "x", "...")) 93 | assert_identical_sets(names(globals[["..."]]), c("y", "z")) 94 | stopifnot(globals[["..."]]$y == 3, globals[["..."]]$z == 4) 95 | 96 | message("*** globalsByName() ... DONE") 97 | 98 | -------------------------------------------------------------------------------- /inst/testme/test-globalsOf,locals.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** globalsOf() w/ local() ...") 4 | 5 | for (locals in c(TRUE, FALSE)) { 6 | message(sprintf("- locals=%s", locals)) 7 | 8 | f <- local({ 9 | a <- 42 10 | function() a 11 | }) 12 | 13 | globals <- globalsOf(quote(f), locals = locals) 14 | str(globals) 15 | where <- attr(globals, "where") 16 | if (locals) { 17 | stopifnot( 18 | length(globals) == 2L, 19 | identical(sort(names(globals)), c("a", "f")), 20 | identical(where[["a"]], environment(globals[["f"]])) 21 | ) 22 | } else { 23 | stopifnot( 24 | length(globals) == 1L, 25 | identical(names(globals), "f") 26 | ) 27 | } 28 | 29 | message(sprintf("- locals=%s with nested local():s", locals)) 30 | 31 | f <- local({ 32 | b <- 3.14 33 | local({ 34 | a <- 42 35 | function() a + b 36 | }) 37 | }) 38 | 39 | globals <- globalsOf(quote(f), locals = locals) 40 | globals <- cleanup(globals) 41 | str(globals) 42 | where <- attr(globals, "where") 43 | if (locals) { 44 | stopifnot( 45 | length(globals) == 3L, 46 | identical(sort(names(globals)), c("a", "b", "f")), 47 | identical(where[["a"]], environment(globals[["f"]])), 48 | identical(where[["b"]], parent.env(environment(globals[["f"]]))) 49 | ) 50 | } else { 51 | stopifnot( 52 | length(globals) == 1L, 53 | identical(names(globals), "f") 54 | ) 55 | } 56 | } # for (locals ...) 57 | 58 | message("*** globalsOf() w/ local() ... DONE") 59 | 60 | -------------------------------------------------------------------------------- /inst/testme/test-globalsOf.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** globalsOf() ...") 4 | 5 | message(" ** globalsOf(..., method = 'conservative'):") 6 | expr <- exprs$A 7 | globals_c <- globalsOf(expr, method = "conservative") 8 | str(globals_c) 9 | assert_identical_sets(names(globals_c), c("{", "<-", "c", "d", "+")) 10 | globals_c <- cleanup(globals_c) 11 | str(globals_c) 12 | assert_identical_sets(names(globals_c), c("c", "d")) 13 | where <- attr(globals_c, "where") 14 | stopifnot( 15 | length(where) == length(globals_c), 16 | identical(where$c, globalenv()), 17 | identical(where$d, globalenv()) 18 | ) 19 | 20 | message(" ** globalsOf(..., method = 'liberal'):") 21 | expr <- exprs$A 22 | globals_l <- globalsOf(expr, method = "liberal") 23 | str(globals_l) 24 | assert_identical_sets(names(globals_l), c("{", "<-", "b", "c", "d", "+", "a", "e")) 25 | globals_l <- cleanup(globals_l) 26 | str(globals_l) 27 | assert_identical_sets(names(globals_l), c("b", "c", "d", "a", "e")) 28 | where <- attr(globals_l, "where") 29 | stopifnot( 30 | length(where) == length(globals_l), 31 | identical(where$b, globalenv()), 32 | identical(where$c, globalenv()), 33 | identical(where$d, globalenv()) 34 | ) 35 | 36 | message(" ** globalsOf(..., method = 'ordered'):") 37 | expr <- exprs$A 38 | globals_i <- globalsOf(expr, method = "ordered") 39 | str(globals_i) 40 | assert_identical_sets(names(globals_i), c("{", "<-", "b", "c", "d", "+", "a", "e")) 41 | globals_i <- cleanup(globals_i) 42 | str(globals_i) 43 | assert_identical_sets(names(globals_i), c("b", "c", "d", "a", "e")) 44 | where <- attr(globals_i, "where") 45 | stopifnot( 46 | length(where) == length(globals_i), 47 | identical(where$b, globalenv()), 48 | identical(where$c, globalenv()), 49 | identical(where$d, globalenv()) 50 | ) 51 | 52 | globals_i <- globalsOf(function(x) x <- x) 53 | print(globals_i) 54 | globals_i <- cleanup(globals_i) 55 | str(globals_i) 56 | assert_identical_sets(names(globals_i), character(0L)) 57 | where <- attr(globals_i, "where") 58 | stopifnot( 59 | length(where) == length(globals_i), 60 | identical(where, setNames(list(), character(0L))) 61 | ) 62 | 63 | 64 | globals_i <- globalsOf(function(x) x[1] <- 0) 65 | print(globals_i) 66 | globals_i <- cleanup(globals_i) 67 | str(globals_i) 68 | assert_identical_sets(names(globals_i), character(0L)) 69 | where <- attr(globals_i, "where") 70 | stopifnot( 71 | length(where) == length(globals_i), 72 | identical(where, setNames(list(), character(0L))) 73 | ) 74 | 75 | globals_i <- globalsOf(function(x) a <- x$a) 76 | print(globals_i) 77 | globals_i <- cleanup(globals_i) 78 | str(globals_i) 79 | assert_identical_sets(names(globals_i), character(0L)) 80 | where <- attr(globals_i, "where") 81 | stopifnot( 82 | length(where) == length(globals_i), 83 | identical(where, setNames(list(), character(0L))) 84 | ) 85 | 86 | globals_i <- globalsOf(function(...) args <- list(...)) 87 | print(globals_i) 88 | globals_i <- cleanup(globals_i) 89 | str(globals_i) 90 | assert_identical_sets(names(globals_i), character(0L)) 91 | where <- attr(globals_i, "where") 92 | stopifnot( 93 | length(where) == length(globals_i), 94 | identical(where, setNames(list(), character(0L))) 95 | ) 96 | 97 | 98 | x <- 1 99 | globals_i <- globalsOf({ function(x) x; x }, substitute = TRUE) 100 | print(globals_i) 101 | globals_i <- cleanup(globals_i) 102 | str(globals_i) 103 | assert_identical_sets(names(globals_i), "x") 104 | where <- attr(globals_i, "where") 105 | stopifnot( 106 | length(where) == length(globals_i) 107 | ) 108 | 109 | 110 | 111 | message(" ** globalsOf() w/ globals in functions:") 112 | 113 | a <- 1 114 | bar <- function(x) x - a 115 | foo <- function(x) bar(x) 116 | 117 | for (method in c("ordered", "conservative", "liberal")) { 118 | globals <- globalsOf({ foo(3) }, substitute = TRUE, method = method, 119 | recursive = FALSE, mustExist = FALSE) 120 | assert_identical_sets(names(globals), c("{", "foo")) 121 | stopifnot(!any("a" %in% names(globals))) 122 | globals <- cleanup(globals) 123 | str(globals) 124 | assert_identical_sets(names(globals), c("foo")) 125 | stopifnot(!any("a" %in% names(globals))) 126 | 127 | globals <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", 128 | recursive = TRUE, mustExist = FALSE) 129 | assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) 130 | globals <- cleanup(globals) 131 | str(globals) 132 | assert_identical_sets(names(globals), c("foo", "bar", "a")) 133 | 134 | globals <- globalsOf({ foo(3) }, substitute = TRUE, 135 | recursive = TRUE, mustExist = FALSE) 136 | assert_identical_sets(names(globals), c("{", "foo", "bar", "-", "a")) 137 | globals <- cleanup(globals) 138 | str(globals) 139 | assert_identical_sets(names(globals), c("foo", "bar", "a")) 140 | } 141 | 142 | 143 | message(" ** globalsOf() w/ recursive functions:") 144 | 145 | ## "Easy" 146 | f <- function() Recall() 147 | globals <- globalsOf(f) 148 | str(globals) 149 | 150 | ## Direct recursive call 151 | f <- function() f() 152 | globals <- globalsOf(f) 153 | str(globals) 154 | 155 | ## Indirect recursive call 156 | f <- function() g() 157 | g <- function() f() 158 | globals_f <- globalsOf(f) 159 | str(globals_f) 160 | globals_g <- globalsOf(g) 161 | str(globals_g) 162 | globals_f <- globals_f[order(names(globals_f))] 163 | globals_g <- globals_g[order(names(globals_g))] 164 | stopifnot(identical(globals_g, globals_f)) 165 | 166 | 167 | message("*** globalsOf() ... DONE") 168 | 169 | 170 | message("*** Subsetting of Globals:") 171 | expr <- exprs$A 172 | globals_l <- globalsOf(expr, method = "liberal") 173 | globals_s <- globals_l[-1] 174 | stopifnot(length(globals_s) == length(globals_l) - 1L) 175 | stopifnot(identical(class(globals_s), class(globals_l))) 176 | where_l <- attr(globals_l, "where") 177 | where_s <- attr(globals_s, "where") 178 | stopifnot(length(where_s) == length(where_l) - 1L) 179 | stopifnot(identical(where_s, where_l[-1])) 180 | 181 | 182 | message("*** cleanup() & packagesOf():") 183 | expr <- exprs$A 184 | globals <- globalsOf(expr, method = "conservative") 185 | str(globals) 186 | assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) 187 | 188 | globals <- as.Globals(globals) 189 | str(globals) 190 | assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) 191 | 192 | globals <- as.Globals(unclass(globals)) 193 | str(globals) 194 | assert_identical_sets(names(globals), c("{", "<-", "c", "d", "+")) 195 | 196 | pkgs <- packagesOf(globals) 197 | print(pkgs) 198 | stopifnot( 199 | length(pkgs) == 1L, 200 | identical(pkgs, c("base")) 201 | ) 202 | 203 | globals <- cleanup(globals) 204 | str(globals) 205 | assert_identical_sets(names(globals), c("c", "d")) 206 | 207 | pkgs <- packagesOf(globals) 208 | print(pkgs) 209 | stopifnot(length(pkgs) == 0L) 210 | 211 | globals <- globalsOf(quote(pi)) 212 | stopifnot( 213 | length(globals) == 1L, 214 | identical(names(globals), "pi") 215 | ) 216 | pkgs <- packagesOf(globals) 217 | print(pkgs) 218 | stopifnot( 219 | length(pkgs) == 1L, 220 | identical(pkgs, c("base")) 221 | ) 222 | 223 | message("*** globalsOf() and package functions:") 224 | foo <- globals::Globals 225 | expr <- exprs$C 226 | globals <- globalsOf(expr, recursive = FALSE) 227 | str(globals) 228 | assert_identical_sets(names(globals), c("{", "foo", "list")) 229 | where <- attr(globals, "where") 230 | stopifnot(length(where) == length(globals)) 231 | if (!covr) stopifnot( 232 | identical(where$`{`, baseenv()), 233 | identical(where$foo, globalenv()), 234 | identical(where$list, baseenv()) 235 | ) 236 | 237 | globals <- cleanup(globals) 238 | str(globals) 239 | assert_identical_sets(names(globals), c("foo")) 240 | pkgs <- packagesOf(globals) 241 | stopifnot(pkgs == "globals") 242 | 243 | 244 | message("*** globalsOf() and core-package functions:") 245 | sample2 <- base::sample 246 | sum2 <- base::sum 247 | expr <- exprs$D 248 | globals <- globalsOf(expr, recursive = FALSE) 249 | str(globals) 250 | assert_identical_sets(names(globals), c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2", "isNamespaceLoaded")) 251 | where <- attr(globals, "where") 252 | stopifnot(length(where) == length(globals)) 253 | if (!covr) stopifnot( 254 | identical(where$`<-`, baseenv()), 255 | identical(where$sample, baseenv()), 256 | identical(where$sample2, globalenv()) 257 | ) 258 | 259 | globals <- cleanup(globals, drop = "primitives") 260 | str(globals) 261 | assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo", "isNamespaceLoaded")) 262 | 263 | globals <- cleanup(globals, drop = "internals") 264 | str(globals) 265 | assert_identical_sets(names(globals), c("sample", "sample2", "sum2", "sessionInfo")) 266 | 267 | globals <- cleanup(globals) 268 | str(globals) 269 | assert_identical_sets(names(globals), c("sample2", "sum2")) 270 | where <- attr(globals, "where") 271 | stopifnot(length(where) == length(globals)) 272 | if (!covr) stopifnot(identical(where$sample2, globalenv())) 273 | 274 | 275 | message("*** globalsOf() - exceptions ...") 276 | 277 | rm(list = "a") 278 | res <- try({ 279 | globals <- globalsOf({ x <- a }, substitute = TRUE, mustExist = TRUE) 280 | }, silent = TRUE) 281 | stopifnot(inherits(res, "try-error")) 282 | 283 | message("*** globalsOf() - exceptions ... DONE") 284 | 285 | -------------------------------------------------------------------------------- /inst/testme/test-liberal.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | ## WORKAROUND: Avoid problem reported in testthat Issue #229, which 4 | ## causes covr::package_coverage() to given an error. /HB 2015-02-16 5 | suppressWarnings({ 6 | rm(list = c("a", "b", "c", "x", "y", "z", "square", 7 | "pathname", "url", "filename")) 8 | }) 9 | 10 | 11 | message("Setting up expressions") 12 | exprs <- list( 13 | A = quote({ 14 | Sys.sleep(1) 15 | x <- 0.1 16 | }), 17 | B = quote({ y <- 0.2 }), 18 | C = quote({ z <- a + 0.3 }), 19 | D = quote({ pathname <- file.path(dirname(url), filename) }), 20 | E = quote({ b <- c }), 21 | F = quote({ 22 | a <- { runif(1) } 23 | b <- { rnorm(1) } 24 | x <- a * b 25 | abs(x) 26 | }), 27 | G = quote({ 28 | y <- square(a) 29 | }), 30 | H = quote({ 31 | b <- a 32 | a <- 1 33 | }) 34 | ) 35 | 36 | atleast <- list( 37 | A = c(), 38 | B = c(), 39 | C = c("a"), 40 | D = c("filename"), 41 | E = c("c"), 42 | F = c(), 43 | G = c("a", "square"), 44 | H = c() ## FIXME: Should be c("a"), cf. Issue #5. 45 | ) 46 | 47 | not <- list( 48 | A = c("x"), 49 | B = c("y"), 50 | C = c("z"), 51 | D = c("pathname"), 52 | E = c("b"), 53 | F = c(), 54 | G = c(), 55 | H = c() 56 | ) 57 | 58 | 59 | ## Define globals 60 | a <- 3.14 61 | c <- 2.71 62 | square <- function(x) x ^ 2 63 | filename <- "index.html" 64 | # Yes, pretend we forget 'url' 65 | 66 | message("Find globals") 67 | for (kk in seq_along(exprs)) { 68 | key <- names(exprs)[kk] 69 | expr <- exprs[[key]] 70 | cat(sprintf("Expression #%d ('%s'):\n", kk, key)) 71 | print(expr) 72 | 73 | names <- findGlobals(expr, method = "liberal") 74 | cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) 75 | stopifnot(all(atleast[[key]] %in% names)) 76 | stopifnot(!any(names %in% not[[key]])) 77 | 78 | globals <- globalsOf(expr, method = "liberal", mustExist = FALSE) 79 | cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", "))) 80 | stopifnot(all(atleast[[key]] %in% names(globals))) 81 | stopifnot(!any(names(globals) %in% not[[key]])) 82 | str(globals) 83 | 84 | cat("\n") 85 | } 86 | 87 | names <- findGlobals(exprs, method = "liberal", unlist = TRUE) 88 | cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", "))) 89 | 90 | 91 | ## Cleanup 92 | -------------------------------------------------------------------------------- /inst/testme/test-utils.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** utils ...") 4 | 5 | message("- envname() ...") 6 | 7 | name <- envname(NULL) 8 | print(name) 9 | stopifnot(is.character(name), length(name) == 1L, is.na(name)) 10 | 11 | env <- new.env() 12 | print(env) 13 | name <- utils::capture.output(print(env)) 14 | stopifnot(is.character(name), length(name) == 1L) 15 | name <- envname(env) 16 | print(name) 17 | stopifnot(is.character(name), length(name) == 1L, !is.na(name), 18 | class(env) == "environment") 19 | 20 | env <- structure(new.env(), class = "foo") 21 | print.foo <- function(x, ...) { str(as.list(letters[1:3])); invisible(x) } 22 | print(env) 23 | name <- utils::capture.output(print(env)) 24 | stopifnot(is.character(name), length(name) > 1L) 25 | name <- envname(env) 26 | print(name) 27 | stopifnot(is.character(name), length(name) == 1L, !is.na(name), 28 | class(env) == "foo") 29 | 30 | env <- structure(new.env(), handlers = "foo") 31 | print(env) 32 | name <- utils::capture.output(print(env)) 33 | stopifnot(is.character(name), length(name) > 1L) 34 | name <- envname(env) 35 | print(name) 36 | stopifnot(is.character(name), length(name) == 1L, !is.na(name)) 37 | 38 | message("- envname() ... DONE") 39 | 40 | 41 | message("* hpaste() ...") 42 | 43 | printf <- function(...) cat(sprintf(...)) 44 | hpaste <- globals:::hpaste 45 | 46 | # Some vectors 47 | x <- 1:6 48 | y <- 10:1 49 | z <- LETTERS[x] 50 | 51 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 52 | # Abbreviation of output vector 53 | # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 54 | printf("x = %s.\n", hpaste(x)) 55 | ## x = 1, 2, 3, ..., 6. 56 | 57 | printf("x = %s.\n", hpaste(x, max_head = 2)) 58 | ## x = 1, 2, ..., 6. 59 | 60 | printf("x = %s.\n", hpaste(x, max_head = 3)) # Default 61 | ## x = 1, 2, 3, ..., 6. 62 | 63 | # It will never output 1, 2, 3, 4, ..., 6 64 | printf("x = %s.\n", hpaste(x, max_head = 4)) 65 | ## x = 1, 2, 3, 4, 5 and 6. 66 | 67 | # Showing the tail 68 | printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2)) 69 | ## x = 1, ..., 5, 6. 70 | 71 | # Turning off abbreviation 72 | printf("y = %s.\n", hpaste(y, max_head = Inf)) 73 | ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 74 | 75 | ## ...or simply 76 | printf("y = %s.\n", paste(y, collapse = ", ")) 77 | ## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 78 | 79 | # Change last separator 80 | printf("x = %s.\n", hpaste(x, last_collapse = " and ")) 81 | ## x = 1, 2, 3, 4, 5 and 6. 82 | 83 | # No collapse 84 | stopifnot(all(hpaste(x, collapse = NULL) == x)) 85 | 86 | # Empty input 87 | stopifnot(identical(hpaste(character(0)), character(0))) 88 | 89 | message("* hpaste() ... DONE") 90 | 91 | 92 | message("* as_function() ...") 93 | fcn <- as_function({ 1 }) 94 | print(fcn()) 95 | stopifnot(fcn() == 1) 96 | 97 | 98 | message("* is_base_pkg() ...") 99 | base_pkgs <- c("base") 100 | for (pkg in base_pkgs) { 101 | stopifnot(is_base_pkg(pkg)) 102 | } 103 | stopifnot(!is_base_pkg("globals")) 104 | 105 | message("* isPackageNamespace() ... Bug #80") 106 | 107 | `$.strict_env` <- function(x, name) get(name, envir = x, inherits = FALSE) 108 | env <- structure(new.env(), class = "strict_env") 109 | res <- globals:::isPackageNamespace(env) 110 | stopifnot(!res) 111 | 112 | 113 | message("* is.base() & is_internal() ...") 114 | stopifnot(is.base(base::library)) 115 | stopifnot(!is.base(globals::globalsOf)) 116 | stopifnot(!is.base(NULL)) 117 | stopifnot(is_internal(print.default)) 118 | stopifnot(!is_internal(globals::globalsOf)) 119 | stopifnot(!is_internal(NULL)) 120 | 121 | 122 | 123 | 124 | message("* where() ...") 125 | 126 | env <- where("sample", where = 1L) 127 | str(env) 128 | 129 | env <- where("sample", frame = 1L) 130 | str(env) 131 | 132 | message("- where('sample') ...") 133 | env <- where("sample", mode = "function") 134 | print(env) 135 | if (!"covr" %in% loadedNamespaces()) { 136 | stopifnot(identical(env, baseenv())) 137 | } 138 | obj <- get("sample", mode = "function", envir = env, inherits = FALSE) 139 | stopifnot(identical(obj, base::sample)) 140 | 141 | 142 | message("- where('sample', mode = 'integer') ...") 143 | env <- where("sample", mode = "integer") 144 | print(env) 145 | stopifnot(is.null(env)) 146 | 147 | 148 | message("- where('sample2') ...") 149 | sample2 <- base::sample 150 | env <- where("sample2", mode = "function") 151 | print(env) 152 | stopifnot(identical(env, environment())) 153 | obj <- get("sample2", mode = "function", envir = env, inherits = FALSE) 154 | stopifnot(identical(obj, sample2)) 155 | 156 | 157 | message("- where() - objects inside functions ...") 158 | aa <- 1 159 | 160 | foo <- function() { 161 | bb <- 2 #nolint 162 | list(aa = where("aa"), bb = where("bb"), cc = where("cc"), 163 | envir = environment()) 164 | } 165 | 166 | envs <- foo() 167 | str(envs) 168 | stopifnot(identical(envs$aa, globalenv())) 169 | stopifnot(identical(envs$bb, envs$envir)) 170 | stopifnot(is.null(envs$cc)) 171 | 172 | message("- where() - missing ...") 173 | env <- where("non-existing-object", inherits = FALSE) 174 | stopifnot(is.null(env)) 175 | 176 | rm(list = c("aa", "envs", "foo", "env", "obj", "where")) 177 | 178 | message("* where() ... DONE") 179 | 180 | message("- mdebug() ...") 181 | 182 | mdebug("Message A") 183 | oopts <- options(globals.debug = TRUE) 184 | mdebug("Message B") 185 | options(oopts) 186 | 187 | message("* mdebug() ... DONE") 188 | 189 | message("*** utils ... DONE") 190 | 191 | -------------------------------------------------------------------------------- /inst/testme/test-walkAST.R: -------------------------------------------------------------------------------- 1 | library(globals) 2 | 3 | message("*** walkAST() ...") 4 | 5 | exprs <- list( 6 | null = quote(NULL), 7 | atomic = quote(1), 8 | atomic = quote("a"), 9 | atomic = quote(TRUE), 10 | assign = quote(a <- 1), 11 | assign = quote(1 -> a), 12 | assign = quote(a <- b + 1), 13 | assign = quote(x <- rnorm(20, mu = 0)), 14 | index = quote(x[1, 1]), 15 | index = quote(x[1:2, 1:2]), 16 | index = quote(x[, 1:2]), 17 | index = quote(x[, 1]), 18 | fcn = quote(function(a = 1, b = 2) sum(c(a, b))), 19 | fcn = quote(function(a = 1, b) sum(c(a, b))), 20 | fcn = quote(function(a = 1, b = 2, ...) sum(c(a, b, ...))), 21 | fcn = quote(function(a = NULL) a), 22 | ok = quote(function(...) sum(x, ...)), 23 | warn = quote(sum(x, ...)), 24 | null = quote(NULL), 25 | builtin = base::length, 26 | closure = function() NULL, 27 | closure = function() a, 28 | closure = function(x = 0) a * x, 29 | special = base::log, 30 | list = substitute(FUN(a = A), list(A = list())), 31 | pairlist = substitute(FUN(a = A), list(A = pairlist(a = 1))), 32 | expression = substitute(FUN(a = A), list(A = expression())) 33 | # environment = new.env() 34 | ) 35 | if (requireNamespace("methods")) { 36 | exprs$s4 <- methods::getClass("MethodDefinition") 37 | exprs$s7 <- asS3(methods::getClass("S4")@prototype, complete = FALSE) 38 | } 39 | 40 | nullify <- function(e) NULL 41 | 42 | disp <- function(expr) { 43 | cat("Expression:\n") 44 | print(expr) 45 | cat("str():\n") 46 | try(str(expr)) 47 | cat(sprintf("typeof: %s\n", typeof(expr))) 48 | if (is.recursive(expr)) { 49 | cat("as.list():\n") 50 | str(as.list(expr)) 51 | } 52 | expr 53 | } ## disp() 54 | 55 | for (kk in seq_along(exprs)) { 56 | name <- names(exprs)[kk] 57 | message(sprintf("- walkAST() ...", kk, sQuote(name))) 58 | expr <- exprs[[kk]] 59 | disp(expr) 60 | 61 | ## Assert identity (default behavior) 62 | expr_i <- walkAST(expr) 63 | disp(expr_i) 64 | stopifnot(length(expr_i) == length(expr), identical(expr_i, expr)) 65 | 66 | ## Display the AST tree 67 | walkAST(expr, atomic = disp, name = disp, call = disp, pairlist = disp) 68 | 69 | ## Nullify 70 | expr_n <- walkAST(expr, atomic = nullify, name = nullify, 71 | call = nullify, pairlist = nullify) 72 | disp(expr_n) 73 | 74 | message("*** walkAST() - nullify ... DONE") 75 | 76 | message(sprintf("- walkAST() ... DONE", 77 | kk, sQuote(name))) 78 | } ## for (name ...) 79 | 80 | 81 | 82 | message("*** walkAST() - substitute = TRUE ...") 83 | 84 | expr <- walkAST(a <- 1, substitute = TRUE) 85 | print(expr) 86 | 87 | message("*** walkAST() - substitute = TRUE ... DONE") 88 | 89 | 90 | message("*** walkAST() - exceptions ...") 91 | 92 | f <- function(...) get("...") 93 | expr <- f(NULL) 94 | 95 | options(globals.walkAST.onUnknownType = "error") 96 | res <- tryCatch({ 97 | walkAST(expr) 98 | }, error = identity) 99 | print(res) 100 | stopifnot(inherits(res, "simpleError")) 101 | 102 | options(globals.walkAST.onUnknownType = "warning") 103 | foo <- walkAST(expr) 104 | 105 | res <- tryCatch({ 106 | walkAST(expr) 107 | }, warning = identity) 108 | print(res) 109 | stopifnot(inherits(res, "simpleWarning")) 110 | 111 | options(globals.walkAST.onUnknownType = "error") 112 | 113 | message("*** walkAST() - exceptions ... DONE") 114 | 115 | message("*** walkAST() ... DONE") 116 | 117 | -------------------------------------------------------------------------------- /inst/testme/test-zzz.R: -------------------------------------------------------------------------------- 1 | globals:::.onLoad("globals", "globals") 2 | -------------------------------------------------------------------------------- /man/Globals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Globals-class.R 3 | \name{Globals} 4 | \alias{Globals} 5 | \alias{as.Globals} 6 | \alias{as.Globals.Globals} 7 | \alias{as.Globals.list} 8 | \alias{[.Globals} 9 | \alias{names} 10 | \title{A representation of a set of globals} 11 | \usage{ 12 | Globals(object, ...) 13 | } 14 | \arguments{ 15 | \item{object}{A named list.} 16 | 17 | \item{\ldots}{Not used.} 18 | } 19 | \value{ 20 | An object of class \code{Globals}, which is a \emph{named} list 21 | of the value of the globals, where the element names are the names of 22 | the globals. Attribute \code{where} is a named list of the same length 23 | and with the same names. 24 | } 25 | \description{ 26 | A representation of a set of globals 27 | } 28 | \seealso{ 29 | The \code{\link{globalsOf}()} function identifies globals 30 | from an R expression and returns a Globals object. 31 | } 32 | -------------------------------------------------------------------------------- /man/cleanup.Globals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/cleanup.R 3 | \name{cleanup.Globals} 4 | \alias{cleanup.Globals} 5 | \alias{cleanup} 6 | \title{Drop certain types of globals} 7 | \usage{ 8 | \method{cleanup}{Globals}(globals, drop = c("missing", "base-packages", "nativesymbolinfo"), ...) 9 | } 10 | \arguments{ 11 | \item{globals}{A Globals object.} 12 | 13 | \item{drop}{A character vector specifying what type of globals to drop.} 14 | 15 | \item{\ldots}{Not used} 16 | } 17 | \description{ 18 | Drop certain types of globals 19 | } 20 | -------------------------------------------------------------------------------- /man/globalsByName.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/globalsByName.R 3 | \name{globalsByName} 4 | \alias{globalsByName} 5 | \title{Locates and retrieves a set of global variables by their names} 6 | \usage{ 7 | globalsByName(names, envir = parent.frame(), mustExist = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{names}{A character vector of global variable names.} 11 | 12 | \item{envir}{The environment from where to search for globals.} 13 | 14 | \item{mustExist}{If TRUE, an error is thrown if the object of the 15 | identified global cannot be located. Otherwise, the global 16 | is not returned.} 17 | 18 | \item{\ldots}{Not used.} 19 | } 20 | \value{ 21 | A \link{Globals} object of named elements and an attribute 22 | \code{where} with named elements. Both of sets have names according to 23 | \code{names}. 24 | } 25 | \description{ 26 | Locates and retrieves a set of global variables by their names 27 | } 28 | \section{Special "argument" globals}{ 29 | 30 | If \code{names} specifies \code{"..."}, \code{"..1"}, \code{"..2"}, ..., then they 31 | are interpreted as arguments \code{...}, \code{..1}, \code{..2}, ..., respectively. 32 | If specified, then the corresponding elements in the results are 33 | lists of class \code{DotDotDotList} comprising the value of the latter. 34 | If the special argument does not exist, then the value is \code{NA}, and 35 | the corresponding \code{where} attributes is \code{NULL}. 36 | } 37 | 38 | \examples{ 39 | f <- function(x = 42, ...) { 40 | globalsByName("x") 41 | } 42 | 43 | globals <- f() 44 | str(globals) 45 | 46 | globals <- f(3.14) 47 | str(globals) 48 | 49 | 50 | g <- function(x = 42, ...) { 51 | globalsByName("...") 52 | } 53 | 54 | globals <- g() 55 | str(globals) 56 | 57 | globals <- g(3.14) 58 | str(globals) 59 | 60 | globals <- g(3.14, 1L, b = 2L, c = 3L) 61 | str(globals) 62 | 63 | 64 | h <- function(x = 42, ...) { 65 | globalsByName("..2") 66 | } 67 | 68 | globals <- h(x = 3.14, a = 1, b = 2) 69 | str(globals) 70 | 71 | globals <- g(3.14) 72 | str(globals) 73 | 74 | globals <- g(3.14, 1L, b = 2L, c = 3L) 75 | str(globals) 76 | } 77 | -------------------------------------------------------------------------------- /man/globalsOf.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/findGlobals.R, R/globalsOf.R 3 | \name{findGlobals} 4 | \alias{findGlobals} 5 | \alias{globalsOf} 6 | \title{Get all global objects of an expression} 7 | \usage{ 8 | findGlobals( 9 | expr, 10 | envir = parent.frame(), 11 | ..., 12 | attributes = TRUE, 13 | tweak = NULL, 14 | dotdotdot = c("warning", "error", "return", "ignore"), 15 | method = c("ordered", "conservative", "liberal", "dfs"), 16 | substitute = FALSE, 17 | unlist = TRUE, 18 | trace = FALSE 19 | ) 20 | 21 | globalsOf( 22 | expr, 23 | envir = parent.frame(), 24 | ..., 25 | method = c("ordered", "conservative", "liberal", "dfs"), 26 | tweak = NULL, 27 | locals = NA, 28 | substitute = FALSE, 29 | mustExist = TRUE, 30 | unlist = TRUE, 31 | recursive = TRUE, 32 | skip = NULL 33 | ) 34 | } 35 | \arguments{ 36 | \item{expr}{An R expression.} 37 | 38 | \item{envir}{The environment from where to search for globals.} 39 | 40 | \item{attributes}{If TRUE (default), attributes of \code{expr} are also searched. 41 | If FALSE, they are not. 42 | If a character vector, then attributes with matching names are searched. 43 | Note, the attributes of the attributes elements are not searched, that is, 44 | attributes are not searched recursively. Also, attributes are searched 45 | with `dotdotdot = "ignore".} 46 | 47 | \item{tweak}{An optional function that takes an expression 48 | and returns a tweaked expression.} 49 | 50 | \item{dotdotdot}{TBD.} 51 | 52 | \item{method}{A character string specifying what type of search algorithm 53 | to use.} 54 | 55 | \item{substitute}{If TRUE, the expression is \code{substitute()}:ed, 56 | otherwise not.} 57 | 58 | \item{unlist}{If TRUE, a list of unique objects is returned. 59 | If FALSE, a list of \code{length(expr)} sublists.} 60 | 61 | \item{trace}{TBD.} 62 | 63 | \item{locals}{Should globals part of any "local" environment of 64 | a function be included or not?} 65 | 66 | \item{mustExist}{If TRUE, an error is thrown if the object of the 67 | identified global cannot be located. Otherwise, the global 68 | is not returned.} 69 | 70 | \item{recursive}{If TRUE, globals that are closures (functions) and that 71 | exist outside of namespaces ("packages"), will be recursively 72 | scanned for globals.} 73 | 74 | \item{skip}{(internal) A list of globals not to be searched for 75 | additional globals. Ignored unless \code{recursive} is TRUE.} 76 | 77 | \item{\ldots}{Not used.} 78 | } 79 | \value{ 80 | \code{findGlobals()} returns a character vector. 81 | 82 | \code{globalsOf()} returns a \link{Globals} object. 83 | } 84 | \description{ 85 | Get all global objects of an expression 86 | } 87 | \details{ 88 | There currently three strategies for identifying global objects. 89 | 90 | The \code{method = "ordered"} search method identifies globals such that 91 | a global variable preceding a local variable with the same name 92 | is not dropped (which the \code{"conservative"} method would). 93 | 94 | The \code{method = "conservative"} search method tries to keep the number 95 | of false positive to a minimum, i.e. the identified objects are 96 | most likely true global objects. At the same time, there is 97 | a risk that some true globals are not identified (see example). 98 | This search method returns the exact same result as the 99 | \code{\link[codetools]{findGlobals}()} function of the 100 | \pkg{codetools} package. 101 | 102 | The \code{method = "liberal"} search method tries to keep the 103 | true-positive ratio as high as possible, i.e. the true globals 104 | are most likely among the identified ones. At the same time, 105 | there is a risk that some false positives are also identified. 106 | 107 | The \code{method = "dfs"} search method identifies globals in 108 | the abstract syntax tree (AST) using a depth-first search, which 109 | better emulates how the R engine identifies global variables. 110 | 111 | With \code{recursive = TRUE}, globals part of locally defined 112 | functions will also be found, otherwise not. 113 | } 114 | \examples{ 115 | b <- 2 116 | expr <- substitute({ a <- b; b <- 1 }) 117 | 118 | ## Will _not_ identify 'b' (because it's also a local) 119 | globalsC <- globalsOf(expr, method = "conservative") 120 | print(globalsC) 121 | 122 | ## Will identify 'b' 123 | globalsL <- globalsOf(expr, method = "liberal") 124 | print(globalsL) 125 | } 126 | \seealso{ 127 | Internally, the \pkg{codetools} package is utilized for 128 | code inspections. 129 | } 130 | -------------------------------------------------------------------------------- /man/packagesOf.Globals.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/packagesOf.R 3 | \name{packagesOf.Globals} 4 | \alias{packagesOf.Globals} 5 | \alias{packagesOf} 6 | \title{Identify the packages of the globals} 7 | \usage{ 8 | \method{packagesOf}{Globals}(globals, ...) 9 | } 10 | \arguments{ 11 | \item{globals}{A Globals object.} 12 | 13 | \item{\ldots}{Not used.} 14 | } 15 | \value{ 16 | Returns a character vector of package names. 17 | } 18 | \description{ 19 | Identify the packages of the globals 20 | } 21 | -------------------------------------------------------------------------------- /man/private_length.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{.length} 4 | \alias{.length} 5 | \title{Gets the length of an object without dispatching} 6 | \usage{ 7 | .length(x) 8 | } 9 | \arguments{ 10 | \item{x}{Any \R object.} 11 | } 12 | \value{ 13 | A non-negative integer. 14 | } 15 | \description{ 16 | Gets the length of an object without dispatching 17 | } 18 | \details{ 19 | This function returns \code{length(unclass(x))}, but tries to avoid 20 | calling \code{unclass(x)} unless necessary. 21 | } 22 | \seealso{ 23 | \code{\link{.subset}()} and \code{\link{.subset2}()}. 24 | } 25 | \keyword{internal} 26 | -------------------------------------------------------------------------------- /man/walkAST.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/walkAST.R 3 | \name{walkAST} 4 | \alias{walkAST} 5 | \title{Walk the Abstract Syntax Tree (AST) of an R Expression} 6 | \usage{ 7 | walkAST( 8 | expr, 9 | atomic = NULL, 10 | name = NULL, 11 | call = NULL, 12 | pairlist = NULL, 13 | substitute = FALSE 14 | ) 15 | } 16 | \arguments{ 17 | \item{expr}{R \link[base]{expression}.} 18 | 19 | \item{atomic, name, call, pairlist}{single-argument function that takes an 20 | atomic, name, call and pairlist expression, respectively. Have to 21 | return a valid R expression.} 22 | 23 | \item{substitute}{If TRUE, \code{expr} is 24 | \code{\link[base]{substitute}()}:ed.} 25 | } 26 | \value{ 27 | R \link[base]{expression}. 28 | } 29 | \description{ 30 | Walk the Abstract Syntax Tree (AST) of an R Expression 31 | } 32 | \keyword{internal} 33 | \keyword{programming} 34 | -------------------------------------------------------------------------------- /pkgdown/_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://globals.futureverse.org 2 | 3 | home: 4 | links: 5 | - text: Roadmap/Milestones 6 | href: https://github.com/futureverse/globals/milestones 7 | - text: The Futureverse Project 8 | href: https://www.futureverse.org/ 9 | - text: Futureverse User Forum 10 | href: https://github.com/futureverse/future/discussions 11 | 12 | navbar: 13 | structure: 14 | right: [search, futureverse, pkgs, cran, github, lightswitch] 15 | components: 16 | futureverse: 17 | icon: fas fa-home 18 | href: https://www.futureverse.org/ 19 | pkgs: 20 | text: Packages 21 | menu: 22 | - text: doFuture (map-reduce) 23 | href: https://doFuture.futureverse.org 24 | - text: furrr (map-reduce) 25 | href: https://furrr.futureverse.org 26 | - text: future 27 | href: https://future.futureverse.org 28 | - text: future.apply (map-reduce) 29 | href: https://future.apply.futureverse.org 30 | - text: future.batchtools (backend) 31 | href: https://future.batchtools.futureverse.org 32 | - text: future.callr (backend) 33 | href: https://future.callr.futureverse.org 34 | - text: future.mirai (backend) 35 | href: https://future.mirai.futureverse.org 36 | - text: future.tests 37 | href: https://future.tests.futureverse.org 38 | - text: globals 39 | href: https://globals.futureverse.org 40 | - text: listenv 41 | href: https://listenv.futureverse.org 42 | - text: parallelly 43 | href: https://parallelly.futureverse.org 44 | - text: progressr 45 | href: https://progressr.futureverse.org 46 | - text: BiocParallel.FutureParam (experimental) 47 | href: https://BiocParallel.FutureParam.futureverse.org 48 | - text: future.tools (experimental) 49 | href: https://future.tools.futureverse.org 50 | - text: future.mapreduce (experimental) 51 | href: https://future.mapreduce.futureverse.org 52 | - text: marshal (experimental) 53 | href: https://marshal.futureverse.org 54 | cran: 55 | icon: fab fa-r-project 56 | href: https://cloud.r-project.org/package=globals 57 | 58 | search: 59 | exclude: ['README_ja.md'] 60 | 61 | template: 62 | params: 63 | docsearch: 64 | api_key: aa6e02fc501886fb0f7c91ac4e300456 65 | index_name: futureverse 66 | algoliaOptions: { 'facetFilters': ['project:globals'] } 67 | ganalytics: G-SB3EQSD9FR 68 | bootstrap: 5 69 | light-switch: true 70 | -------------------------------------------------------------------------------- /pkgdown/_pkgdown.yml.rsp: -------------------------------------------------------------------------------- 1 | <% 2 | pkgs_mapreduce <- c("future.apply", "doFuture", "furrr") 3 | pkgs_backend <- c("future.batchtools", "future.callr", "future.mirai") 4 | pkgs <- c("globals", "listenv", "parallelly", "future", "future.tests", "progressr", pkgs_mapreduce, pkgs_backend) 5 | pkgs_extra <- c("BiocParallel.FutureParam", "future.tools", "future.mapreduce", "marshal") 6 | pkgs <- c(sort(pkgs), pkgs_extra) 7 | urls <- sprintf("https://%s.futureverse.org", pkgs) 8 | names(urls) <- pkgs 9 | 10 | file <- file.path(c(".", ".."), "DESCRIPTION") 11 | file <- file[utils::file_test("-f", file)] 12 | pkg <- read.dcf(file)[,"Package"] 13 | 14 | #common_support <- c("future", "future.apply", "future.callr", "future.batchtools", "doFuture", "BiocParallel.FutureParam") 15 | %> 16 | url: https://<%= pkg %>.futureverse.org 17 | 18 | home: 19 | links: 20 | - text: Roadmap/Milestones 21 | href: https://github.com/<%= gsub("(^.*:|[.]git$)", "", subset(gert::git_remote_list(), name == "origin")$url) %>/milestones 22 | - text: The Futureverse Project 23 | href: https://www.futureverse.org/ 24 | - text: Futureverse User Forum 25 | href: https://github.com/futureverse/future/discussions 26 | 27 | navbar: 28 | structure: 29 | right: [search, futureverse, pkgs, cran, github, lightswitch] 30 | components: 31 | futureverse: 32 | icon: fas fa-home 33 | href: https://www.futureverse.org/ 34 | pkgs: 35 | text: Packages 36 | menu: 37 | <% for (name in names(urls)) { %> 38 | - text: <%= name %> <% if (name %in% pkgs_extra) { %>(experimental)<% } else if (name %in% pkgs_backend) { %>(backend)<% } else if (name %in% pkgs_mapreduce) { %>(map-reduce)<% } %> 39 | href: <%= urls[name] %> 40 | <% } %> 41 | cran: 42 | icon: fab fa-r-project 43 | href: https://cloud.r-project.org/package=<%= pkg %> 44 | 45 | search: 46 | exclude: ['README_ja.md'] 47 | 48 | template: 49 | params: 50 | docsearch: 51 | api_key: aa6e02fc501886fb0f7c91ac4e300456 52 | index_name: futureverse 53 | algoliaOptions: { 'facetFilters': ['project:<%= pkg %>'] } 54 | ganalytics: G-SB3EQSD9FR 55 | bootstrap: 5 56 | light-switch: true 57 | -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-120x120.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/apple-touch-icon-120x120.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-60x60.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/apple-touch-icon-60x60.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-76x76.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/apple-touch-icon-76x76.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/futureverse/globals/29db8a23605e52ea415c0d0ca615db72513b8dac/pkgdown/favicon/favicon.ico -------------------------------------------------------------------------------- /revdep/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: dummy 2 | Version: 0.1 3 | Title: A Dummy Package 4 | Description: A package placeholder to trick 'usethis' to stop at the folder where this DESCRIPTION file lives rather than traversing higher up in the directory structure. This protects against bugs such as the one described in https://github.com/r-lib/lifecycle/issues/52. 5 | Authors@R: person("Dummy", "Dummyson", role="aut", email = "dummy@dummy.org") 6 | License: GPL (>= 3) 7 | Imports: 8 | lifecycle 9 | RdMacros: lifecycle 10 | -------------------------------------------------------------------------------- /revdep/NOT_CRAN/README.md: -------------------------------------------------------------------------------- 1 | # Platform 2 | 3 | |field |value | 4 | |:--------|:---------------------------------------------------------| 5 | |version |R version 4.4.3 (2025-02-28) | 6 | |os |Rocky Linux 8.10 (Green Obsidian) | 7 | |system |x86_64, linux-gnu | 8 | |ui |X11 | 9 | |language |en | 10 | |collate |en_US.UTF-8 | 11 | |ctype |en_US.UTF-8 | 12 | |tz |America/Los_Angeles | 13 | |date |2025-05-07 | 14 | |pandoc |3.6.3 @ /software/c4/cbi/software/pandoc-3.6.3/bin/pandoc | 15 | |quarto |NA | 16 | 17 | # Dependencies 18 | 19 | |package |old |new |Δ | 20 | |:---------|:------|:-----------|:--| 21 | |globals |0.17.0 |0.17.0-9026 |* | 22 | |codetools |0.2-20 |0.2-20 | | 23 | 24 | # Revdeps 25 | 26 | ## All (17) 27 | 28 | |package |version |error |warning |note | 29 | |:-----------------|:-------|:-----|:-------|:----| 30 | |[activAnalyzer](problems.md#activanalyzer)|2.1.2 | | |1 | 31 | |[clustermq](problems.md#clustermq)|0.9.9 |1 | |2 | 32 | |[disk.frame](problems.md#diskframe)|0.8.3 | | |1 | 33 | |doFuture |1.0.2 | | | | 34 | |[furrr](problems.md#furrr)|0.3.1 |1 | | | 35 | |future |1.40.0 | | | | 36 | |future.apply |1.11.3 | | | | 37 | |future.batchtools |0.12.1 | | | | 38 | |future.callr |0.8.2 | | | | 39 | |howler |0.3.0 | | | | 40 | |oceanexplorer |0.1.0 | | | | 41 | |optimall |1.1.1 | | | | 42 | |parsnip |1.3.1 | | | | 43 | |ravepipeline |0.0.1 | | | | 44 | |[shinytest](problems.md#shinytest)|1.6.1 |1 | | | 45 | |shinytest2 |0.4.1 | | | | 46 | |[sparklyr](problems.md#sparklyr)|1.9.0 | | |1 | 47 | 48 | -------------------------------------------------------------------------------- /revdep/NOT_CRAN/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 17 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 4 | 5 | * We saw 0 new problems 6 | * We failed to check 0 packages 7 | 8 | -------------------------------------------------------------------------------- /revdep/NOT_CRAN/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/NOT_CRAN/problems.md: -------------------------------------------------------------------------------- 1 | # activAnalyzer 2 | 3 |
4 | 5 | * Version: 2.1.2 6 | * GitHub: https://github.com/pydemull/activAnalyzer 7 | * Source code: https://github.com/cran/activAnalyzer 8 | * Date/Publication: 2024-09-23 23:40:02 UTC 9 | * Number of recursive dependencies: 145 10 | 11 | Run `revdepcheck::revdep_details(, "activAnalyzer")` for more info 12 | 13 |
14 | 15 | ## In both 16 | 17 | * checking installed package size ... NOTE 18 | ``` 19 | installed size is 5.7Mb 20 | sub-directories of 1Mb or more: 21 | R 1.5Mb 22 | doc 1.0Mb 23 | extdata 2.0Mb 24 | ``` 25 | 26 | # clustermq 27 | 28 |
29 | 30 | * Version: 0.9.9 31 | * GitHub: https://github.com/mschubert/clustermq 32 | * Source code: https://github.com/cran/clustermq 33 | * Date/Publication: 2025-04-20 13:30:02 UTC 34 | * Number of recursive dependencies: 107 35 | 36 | Run `revdepcheck::revdep_details(, "clustermq")` for more info 37 | 38 |
39 | 40 | ## In both 41 | 42 | * checking tests ... 43 | ``` 44 | Running ‘testthat.R’ 45 | ERROR 46 | Running the tests in ‘tests/testthat.R’ failed. 47 | Last 50 lines of output: 48 | additional_attributes] [-h] [script] 49 | 50 | [ FAIL 2 | WARN 1 | SKIP 8 | PASS 126 ] 51 | 52 | ══ Skipped tests (8) ═══════════════════════════════════════════════════════════ 53 | • has_ssh_cmq("127.0.0.1") is not TRUE (1): 'test-7-ssh_proxy.r:110:5' 54 | ... 55 | ▆ 56 | 1. └─clustermq::Q(fx, x = 1:3, workers = w, timeout = 10L) at test-6-queue_impl.r:76:5 57 | 2. └─clustermq::Q_rows(...) 58 | 3. └─clustermq:::master(...) 59 | 4. └─pool$recv(timeout) 60 | 5. └─private$master$recv(timeout) 61 | 62 | [ FAIL 2 | WARN 1 | SKIP 8 | PASS 126 ] 63 | Error: Test failures 64 | Execution halted 65 | ``` 66 | 67 | * checking installed package size ... NOTE 68 | ``` 69 | installed size is 23.4Mb 70 | sub-directories of 1Mb or more: 71 | libs 22.8Mb 72 | ``` 73 | 74 | * checking dependencies in R code ... NOTE 75 | ``` 76 | Namespace in Imports field not imported from: ‘R6’ 77 | All declared Imports should be used. 78 | ``` 79 | 80 | # disk.frame 81 | 82 |
83 | 84 | * Version: 0.8.3 85 | * GitHub: https://github.com/DiskFrame/disk.frame 86 | * Source code: https://github.com/cran/disk.frame 87 | * Date/Publication: 2023-08-24 16:20:10 UTC 88 | * Number of recursive dependencies: 96 89 | 90 | Run `revdepcheck::revdep_details(, "disk.frame")` for more info 91 | 92 |
93 | 94 | ## In both 95 | 96 | * checking Rd files ... NOTE 97 | ``` 98 | checkRd: (-1) csv_to_disk.frame.Rd:56: Lost braces; missing escapes or markup? 99 | 56 | strings, and you are encouraged to use {fasttime} to convert the strings to 100 | | ^ 101 | checkRd: (-1) purrr_as_mapper.Rd:10: Lost braces; missing escapes or markup? 102 | 10 | \item{.f}{a normal function or purrr syntax function i.e. `~{ ...code...}`} 103 | | ^ 104 | ``` 105 | 106 | # furrr 107 | 108 |
109 | 110 | * Version: 0.3.1 111 | * GitHub: https://github.com/DavisVaughan/furrr 112 | * Source code: https://github.com/cran/furrr 113 | * Date/Publication: 2022-08-15 19:40:02 UTC 114 | * Number of recursive dependencies: 68 115 | 116 | Run `revdepcheck::revdep_details(, "furrr")` for more info 117 | 118 |
119 | 120 | ## In both 121 | 122 | * checking tests ... 123 | ``` 124 | Running ‘testthat.R’ 125 | ERROR 126 | Running the tests in ‘tests/testthat.R’ failed. 127 | Last 50 lines of output: 128 | 34. │ │ └─base (local) tryCatchOne(expr, names, parentenv, handlers[[1L]]) 129 | 35. │ │ └─base (local) doTryCatch(return(expr), name, parentenv, handler) 130 | 36. │ ├─base::tryCatch(...) 131 | 37. │ │ └─base (local) tryCatchList(expr, classes, parentenv, handlers) 132 | 38. │ ├─base::withCallingHandlers(...) 133 | 39. │ ├─base::withVisible(eval(expr, envir = globalenv())) 134 | ... 135 | In addition: Warning messages: 136 | 1: In for (i in seq_len(n)) { : 137 | closing unused connection 4 (<-localhost:24061) 138 | 2: In for (i in seq_len(n)) { : 139 | closing unused connection 5 (<-localhost:22083) 140 | 3: In for (i in seq_len(n)) { : 141 | closing unused connection 8 (<-localhost:22083) 142 | 4: In node_cdr(x) : closing unused connection 4 (<-localhost:38792) 143 | 5: In node_cdr(x) : closing unused connection 6 (<-localhost:38792) 144 | Execution halted 145 | ``` 146 | 147 | # shinytest 148 | 149 |
150 | 151 | * Version: 1.6.1 152 | * GitHub: https://github.com/rstudio/shinytest 153 | * Source code: https://github.com/cran/shinytest 154 | * Date/Publication: 2024-05-30 19:10:02 UTC 155 | * Number of recursive dependencies: 72 156 | 157 | Run `revdepcheck::revdep_details(, "shinytest")` for more info 158 | 159 |
160 | 161 | ## In both 162 | 163 | * checking tests ... 164 | ``` 165 | Running ‘testthat.R’ 166 | ERROR 167 | Running the tests in ‘tests/testthat.R’ failed. 168 | Last 50 lines of output: 169 | 20800K .......... .......... .......... .......... .......... 91% 103M 0s 170 | 20850K .......... .......... .......... .......... .......... 91% 108M 0s 171 | 20900K .......... .......... .......... .......... .......... 91% 80.4M 0s 172 | 20950K .......... .......... .......... .......... .......... 91% 88.7M 0s 173 | 21000K .......... .......... .......... .......... .......... 92% 95.6M 0s 174 | 21050K .......... .......... .......... .......... .......... 92% 123M 0s 175 | ... 176 | 177 | 2025-05-07 22:06:55 (88.6 MB/s) - ‘phantomjs-2.1.1-linux-x86_64.tar.bz2’ saved [23415665/23415665] 178 | 179 | Error in dir.create(destdir, showWarnings = FALSE) : 180 | zero-length 'path' argument 181 | Calls: installDependencies -> -> dir.create 182 | In addition: Warning message: 183 | In file.copy(exec, destdir, overwrite = TRUE) : 184 | problem copying phantomjs-2.1.1-linux-x86_64/bin/phantomjs to /c4/home/henrik/bin/phantomjs: Text file busy 185 | Execution halted 186 | ``` 187 | 188 | # sparklyr 189 | 190 |
191 | 192 | * Version: 1.9.0 193 | * GitHub: https://github.com/sparklyr/sparklyr 194 | * Source code: https://github.com/cran/sparklyr 195 | * Date/Publication: 2025-03-18 13:40:02 UTC 196 | * Number of recursive dependencies: 113 197 | 198 | Run `revdepcheck::revdep_details(, "sparklyr")` for more info 199 | 200 |
201 | 202 | ## In both 203 | 204 | * checking installed package size ... NOTE 205 | ``` 206 | installed size is 7.2Mb 207 | sub-directories of 1Mb or more: 208 | R 3.5Mb 209 | help 1.5Mb 210 | java 1.7Mb 211 | ``` 212 | 213 | -------------------------------------------------------------------------------- /revdep/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 668 reverse dependencies (636 from CRAN + 32 from Bioconductor), comparing R CMD check results across CRAN and dev versions of this package. 4 | 5 | * We saw 1 new problems 6 | * We failed to check 1 packages 7 | 8 | Issues with CRAN packages are summarised below. 9 | 10 | ### New problems 11 | (This reports the first line of each new failure) 12 | 13 | * bonsai 14 | checking re-building of vignette outputs ...sh: line 1: 1333462 Terminated '/software/c4/cbi/software/_rocky8/R-4.4.3-gcc13/lib64/R/bin/R' --vanilla --no-echo > '/scratch/henrik/revdep/globals/checks/bonsai/new/bonsai.Rcheck/build_vignettes.log' 2>&1 < '/scratch/henrik/RtmpDvduM2/file1284a36dd2fed9' 15 | 16 | ### Failed to check 17 | 18 | * TriDimRegression (NA) 19 | -------------------------------------------------------------------------------- /revdep/failures.md: -------------------------------------------------------------------------------- 1 | # TriDimRegression 2 | 3 |
4 | 5 | * Version: 1.0.2 6 | * GitHub: https://github.com/alexander-pastukhov/tridim-regression 7 | * Source code: https://github.com/cran/TriDimRegression 8 | * Date/Publication: 2023-09-13 14:10:03 UTC 9 | * Number of recursive dependencies: 96 10 | 11 | Run `revdepcheck::revdep_details(, "TriDimRegression")` for more info 12 | 13 |
14 | 15 | ## In both 16 | 17 | * checking whether package ‘TriDimRegression’ can be installed ... ERROR 18 | ``` 19 | Installation failed. 20 | See ‘/scratch/henrik/revdep/globals/checks/TriDimRegression/new/TriDimRegression.Rcheck/00install.out’ for details. 21 | ``` 22 | 23 | ## Installation 24 | 25 | ### Devel 26 | 27 | ``` 28 | * installing *source* package ‘TriDimRegression’ ... 29 | ** package ‘TriDimRegression’ successfully unpacked and MD5 sums checked 30 | ** using staged installation 31 | Error in loadNamespace(x) : there is no package called ‘rstantools’ 32 | Calls: loadNamespace -> withRestarts -> withOneRestart -> doWithOneRestart 33 | Execution halted 34 | ERROR: configuration failed for package ‘TriDimRegression’ 35 | * removing ‘/scratch/henrik/revdep/globals/checks/TriDimRegression/new/TriDimRegression.Rcheck/TriDimRegression’ 36 | 37 | 38 | ``` 39 | ### CRAN 40 | 41 | ``` 42 | * installing *source* package ‘TriDimRegression’ ... 43 | ** package ‘TriDimRegression’ successfully unpacked and MD5 sums checked 44 | ** using staged installation 45 | Error in loadNamespace(x) : there is no package called ‘rstantools’ 46 | Calls: loadNamespace -> withRestarts -> withOneRestart -> doWithOneRestart 47 | Execution halted 48 | ERROR: configuration failed for package ‘TriDimRegression’ 49 | * removing ‘/scratch/henrik/revdep/globals/checks/TriDimRegression/old/TriDimRegression.Rcheck/TriDimRegression’ 50 | 51 | 52 | ``` 53 | -------------------------------------------------------------------------------- /revdep/revdepcheck.Renviron: -------------------------------------------------------------------------------- 1 | ## Environment variables set by revdepcheck.extras::run() 2 | R_REVDEPCHECK_TIMEOUT=${R_REVDEPCHECK_TIMEOUT:-180} 3 | TAR_SKIP_CLUSTERMQ=${TAR_SKIP_CLUSTERMQ-true} 4 | 5 | -------------------------------------------------------------------------------- /revdep/run.R: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | precheck <- function() { 4 | ## WORKAROUND: Remove checked pkgs that use file links, which otherwise 5 | ## produce warnings which are promoted to errors by revdepcheck. 6 | unlink("revdep/checks/aroma.affymetrix", recursive = TRUE) 7 | } 8 | 9 | revdepcheck.extras::run() 10 | -------------------------------------------------------------------------------- /revdep/run.pbs: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ## Example: qsub -l nodes=1:ppn=24 -l vmem=30gb revdep/run.pbs 3 | #PBS -j oe # Join STDERR and STDOUT 4 | cd "$PBS_O_WORKDIR" 5 | 6 | module load r 7 | Rscript revdep/run.R 8 | -------------------------------------------------------------------------------- /revdep/run.sge: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ## Example: qsub -pe smp 24 -l h_rt=08:00:00 revdep/run.sge 3 | #$ -S /bin/bash 4 | #$ -R yes # SGE host reservation, highly recommended 5 | #$ -cwd # Current working directory 6 | #$ -j y # Join STDERR and STDOUT 7 | #$ -l mem_free=2G # 2 GiB RAM per core 8 | #$ -m bea # email when job (b)egins, (e)nds, or (a)borts 9 | 10 | module load CBI 11 | module load r 12 | Rscript revdep/run.R 13 | -------------------------------------------------------------------------------- /tests/test-Globals.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-Globals.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("Globals") 4 | -------------------------------------------------------------------------------- /tests/test-cleanup.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-cleanup.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("cleanup") 4 | -------------------------------------------------------------------------------- /tests/test-codetools-bug16.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-codetools-bug16.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("codetools-bug16") 4 | -------------------------------------------------------------------------------- /tests/test-conservative.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-conservative.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("conservative") 4 | -------------------------------------------------------------------------------- /tests/test-dotdotdot.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-dotdotdot.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("dotdotdot") 4 | -------------------------------------------------------------------------------- /tests/test-findGlobals,dfs.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-findGlobals,dfs.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("findGlobals,dfs") 4 | -------------------------------------------------------------------------------- /tests/test-findGlobals.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-findGlobals.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("findGlobals") 4 | -------------------------------------------------------------------------------- /tests/test-formulas.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-formulas.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("formulas") 4 | -------------------------------------------------------------------------------- /tests/test-globalsByName.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-globalsByName.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("globalsByName") 4 | -------------------------------------------------------------------------------- /tests/test-globalsOf,locals.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-globalsOf,locals.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("globalsOf,locals") 4 | -------------------------------------------------------------------------------- /tests/test-globalsOf.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-globalsOf.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("globalsOf") 4 | -------------------------------------------------------------------------------- /tests/test-liberal.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-liberal.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("liberal") 4 | -------------------------------------------------------------------------------- /tests/test-utils.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-utils.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("utils") 4 | -------------------------------------------------------------------------------- /tests/test-walkAST.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-walkAST.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("walkAST") 4 | -------------------------------------------------------------------------------- /tests/test-zzz.R: -------------------------------------------------------------------------------- 1 | ## This runs testme test script inst/testme/test-zzz.R 2 | ## Don't edit - it was autogenerated by inst/testme/deploy.R 3 | globals:::testme("zzz") 4 | --------------------------------------------------------------------------------