├── .Rbuildignore ├── .github ├── .gitignore ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md └── workflows │ ├── R-CMD-check.yaml │ ├── pkgdown.yaml │ ├── pr-commands.yaml │ └── test-coverage.yaml ├── .gitignore ├── .vscode ├── extensions.json └── settings.json ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── conditions.R ├── evaluate-package.R ├── evaluate.R ├── evaluation.R ├── flush-console.R ├── graphics.R ├── hooks.R ├── inject-funs.R ├── output-handler.R ├── output.R ├── parse_all.R ├── replay.R ├── reproducible-output.R ├── traceback.R ├── utils.R ├── watchout.R └── zzz.R ├── README.md ├── _pkgdown.yml ├── air.toml ├── codecov.yml ├── cran-comments.md ├── evaluate.Rproj ├── man ├── create_traceback.Rd ├── evaluate-package.Rd ├── evaluate.Rd ├── flush_console.Rd ├── inject_funs.Rd ├── is.message.Rd ├── line_prompt.Rd ├── local_reproducible_output.Rd ├── new_output_handler.Rd ├── parse_all.Rd ├── replay.Rd ├── set_hooks.Rd ├── trim_intermediate_plots.Rd └── try_capture_stack.Rd ├── revdep ├── .gitignore ├── README.md ├── cran.md ├── failures.md └── problems.md └── tests ├── test-all.R └── testthat ├── _snaps ├── conditions.md ├── conditions │ ├── abort-error.txt │ ├── rmd-abort-error.md │ ├── rmd-abort-error.txt │ ├── rmd-stop-error-auto-entrace.txt │ ├── rmd-stop-error-entrace-sewed.md │ ├── rmd-stop-error.md │ ├── stop-error-no-trace.txt │ ├── stop-error-trace-calling-handler.txt │ ├── stop-error-trace-trim.txt │ └── stop-error-trace-wch.txt ├── evaluate.md ├── evaluation.md ├── graphics.md ├── output-handler.md ├── output.md ├── replay.md └── watchout.md ├── helper.R ├── resources ├── with-abort-error.R ├── with-abort-error.Rmd ├── with-stop-error-auto-entrace.Rmd ├── with-stop-error-no-trace.R ├── with-stop-error-sewed.Rmd ├── with-stop-error-trace-trim.R ├── with-stop-error-trace.R └── with-stop-error-wch.R ├── test-conditions.R ├── test-evaluate.R ├── test-evaluation.R ├── test-flush-console.R ├── test-graphics.R ├── test-inject-funs.R ├── test-output-handler.R ├── test-output.R ├── test-parse_all.R ├── test-replay.R ├── test-reproducible-output.R └── test-watchout.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^codecov\.yml$ 5 | ^\.github$ 6 | ^revdep$ 7 | ^LICENSE\.md$ 8 | ^_pkgdown\.yml$ 9 | ^docs$ 10 | ^pkgdown$ 11 | ^cran-comments\.md$ 12 | ^CRAN-SUBMISSION$ 13 | ^[\.]?air\.toml$ 14 | ^\.vscode$ 15 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, caste, color, religion, or sexual 10 | identity and orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the overall 26 | community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or advances of 31 | any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email address, 35 | without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards of 42 | acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies when 54 | an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail address, 56 | posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at codeofconduct@posit.co. 63 | All complaints will be reviewed and investigated promptly and fairly. 64 | 65 | All community leaders are obligated to respect the privacy and security of the 66 | reporter of any incident. 67 | 68 | ## Enforcement Guidelines 69 | 70 | Community leaders will follow these Community Impact Guidelines in determining 71 | the consequences for any action they deem in violation of this Code of Conduct: 72 | 73 | ### 1. Correction 74 | 75 | **Community Impact**: Use of inappropriate language or other behavior deemed 76 | unprofessional or unwelcome in the community. 77 | 78 | **Consequence**: A private, written warning from community leaders, providing 79 | clarity around the nature of the violation and an explanation of why the 80 | behavior was inappropriate. A public apology may be requested. 81 | 82 | ### 2. Warning 83 | 84 | **Community Impact**: A violation through a single incident or series of 85 | actions. 86 | 87 | **Consequence**: A warning with consequences for continued behavior. No 88 | interaction with the people involved, including unsolicited interaction with 89 | those enforcing the Code of Conduct, for a specified period of time. This 90 | includes avoiding interactions in community spaces as well as external channels 91 | like social media. Violating these terms may lead to a temporary or permanent 92 | ban. 93 | 94 | ### 3. Temporary Ban 95 | 96 | **Community Impact**: A serious violation of community standards, including 97 | sustained inappropriate behavior. 98 | 99 | **Consequence**: A temporary ban from any sort of interaction or public 100 | communication with the community for a specified period of time. No public or 101 | private interaction with the people involved, including unsolicited interaction 102 | with those enforcing the Code of Conduct, is allowed during this period. 103 | Violating these terms may lead to a permanent ban. 104 | 105 | ### 4. Permanent Ban 106 | 107 | **Community Impact**: Demonstrating a pattern of violation of community 108 | standards, including sustained inappropriate behavior, harassment of an 109 | individual, or aggression toward or disparagement of classes of individuals. 110 | 111 | **Consequence**: A permanent ban from any sort of public interaction within the 112 | community. 113 | 114 | ## Attribution 115 | 116 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 117 | version 2.1, available at 118 | . 119 | 120 | Community Impact Guidelines were inspired by 121 | [Mozilla's code of conduct enforcement ladder][https://github.com/mozilla/inclusion]. 122 | 123 | For answers to common questions about this code of conduct, see the FAQ at 124 | . Translations are available at . 125 | 126 | [homepage]: https://www.contributor-covenant.org 127 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to evaluate 2 | 3 | This outlines how to propose a change to evaluate. 4 | For more detailed info about contributing to this, and other tidyverse packages, please see the 5 | [**development contributing guide**](https://rstd.io/tidy-contrib). 6 | 7 | ## Fixing typos 8 | 9 | You can fix typos, spelling mistakes, or grammatical errors in the documentation directly using the GitHub web interface, as long as the changes are made in the _source_ file. 10 | This generally means you'll need to edit [roxygen2 comments](https://roxygen2.r-lib.org/articles/roxygen2.html) in an `.R`, not a `.Rd` file. 11 | You can find the `.R` file that generates the `.Rd` by reading the comment in the first line. 12 | 13 | ## Bigger changes 14 | 15 | If you want to make a bigger change, it's a good idea to first file an issue and make sure someone from the team agrees that it’s needed. 16 | If you’ve found a bug, please file an issue that illustrates the bug with a minimal 17 | [reprex](https://www.tidyverse.org/help/#reprex) (this will also help you write a unit test, if needed). 18 | 19 | ### Pull request process 20 | 21 | * Fork the package and clone onto your computer. If you haven't done this before, we recommend using `usethis::create_from_github("r-lib/evaluate", fork = TRUE)`. 22 | 23 | * Install all development dependencies with `devtools::install_dev_deps()`, and then make sure the package passes R CMD check by running `devtools::check()`. 24 | If R CMD check doesn't pass cleanly, it's a good idea to ask for help before continuing. 25 | * Create a Git branch for your pull request (PR). We recommend using `usethis::pr_init("brief-description-of-change")`. 26 | 27 | * Make your changes, commit to git, and then create a PR by running `usethis::pr_push()`, and following the prompts in your browser. 28 | The title of your PR should briefly describe the change. 29 | The body of your PR should contain `Fixes #issue-number`. 30 | 31 | * For user-facing changes, add a bullet to the top of `NEWS.md` (i.e. just below the first header). Follow the style described in . 32 | 33 | ### Code style 34 | 35 | * New code should follow the tidyverse [style guide](https://style.tidyverse.org). 36 | You can use the [styler](https://CRAN.R-project.org/package=styler) package to apply these styles, but please don't restyle code that has nothing to do with your PR. 37 | 38 | * We use [roxygen2](https://cran.r-project.org/package=roxygen2), with [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/rd-formatting.html), for documentation. 39 | 40 | * We use [testthat](https://cran.r-project.org/package=testthat) for unit tests. 41 | Contributions with test cases included are easier to accept. 42 | 43 | ## Code of Conduct 44 | 45 | Please note that the evaluate project is released with a 46 | [Contributor Code of Conduct](CODE_OF_CONDUCT.md). By contributing to this 47 | project you agree to abide by its terms. 48 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | branches: [main, master] 12 | 13 | name: R-CMD-check 14 | 15 | permissions: read-all 16 | 17 | jobs: 18 | R-CMD-check: 19 | runs-on: ${{ matrix.config.os }} 20 | 21 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 22 | 23 | strategy: 24 | fail-fast: false 25 | matrix: 26 | config: 27 | - {os: macos-latest, r: 'release'} 28 | 29 | - {os: windows-latest, r: 'release'} 30 | # use 4.1 to check with rtools40's older compiler 31 | - {os: windows-latest, r: '4.1'} 32 | 33 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 34 | - {os: ubuntu-latest, r: 'release'} 35 | - {os: ubuntu-latest, r: 'oldrel-1'} 36 | - {os: ubuntu-latest, r: 'oldrel-2'} 37 | - {os: ubuntu-latest, r: 'oldrel-3'} 38 | - {os: ubuntu-latest, r: 'oldrel-4'} 39 | 40 | - {os: ubuntu-latest, r: '3.6'} 41 | 42 | 43 | env: 44 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 45 | R_KEEP_PKG_SOURCE: yes 46 | 47 | steps: 48 | - uses: actions/checkout@v4 49 | 50 | - uses: r-lib/actions/setup-pandoc@v2 51 | 52 | - uses: r-lib/actions/setup-r@v2 53 | with: 54 | r-version: ${{ matrix.config.r }} 55 | http-user-agent: ${{ matrix.config.http-user-agent }} 56 | use-public-rspm: true 57 | 58 | - uses: r-lib/actions/setup-r-dependencies@v2 59 | with: 60 | extra-packages: any::rcmdcheck 61 | needs: check 62 | 63 | - uses: r-lib/actions/check-r-package@v2 64 | with: 65 | upload-snapshots: true 66 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 67 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | pkgdown: 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 | permissions: 25 | contents: write 26 | steps: 27 | - uses: actions/checkout@v4 28 | 29 | - uses: r-lib/actions/setup-pandoc@v2 30 | 31 | - uses: r-lib/actions/setup-r@v2 32 | with: 33 | use-public-rspm: true 34 | 35 | - uses: r-lib/actions/setup-r-dependencies@v2 36 | with: 37 | extra-packages: any::pkgdown, local::. 38 | needs: website 39 | 40 | - name: Build site 41 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 42 | shell: Rscript {0} 43 | 44 | - name: Deploy to GitHub pages 🚀 45 | if: github.event_name != 'pull_request' 46 | uses: JamesIves/github-pages-deploy-action@v4.5.0 47 | with: 48 | clean: false 49 | branch: gh-pages 50 | folder: docs 51 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: Commands 8 | 9 | permissions: read-all 10 | 11 | jobs: 12 | document: 13 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 14 | name: document 15 | runs-on: ubuntu-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | steps: 19 | - uses: actions/checkout@v4 20 | 21 | - uses: r-lib/actions/pr-fetch@v2 22 | with: 23 | repo-token: ${{ secrets.GITHUB_TOKEN }} 24 | 25 | - uses: r-lib/actions/setup-r@v2 26 | with: 27 | use-public-rspm: true 28 | 29 | - uses: r-lib/actions/setup-r-dependencies@v2 30 | with: 31 | extra-packages: any::roxygen2 32 | needs: pr-document 33 | 34 | - name: Document 35 | run: roxygen2::roxygenise() 36 | shell: Rscript {0} 37 | 38 | - name: commit 39 | run: | 40 | git config --local user.name "$GITHUB_ACTOR" 41 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 42 | git add man/\* NAMESPACE 43 | git commit -m 'Document' 44 | 45 | - uses: r-lib/actions/pr-push@v2 46 | with: 47 | repo-token: ${{ secrets.GITHUB_TOKEN }} 48 | 49 | style: 50 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 51 | name: style 52 | runs-on: ubuntu-latest 53 | env: 54 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 55 | steps: 56 | - uses: actions/checkout@v4 57 | 58 | - uses: r-lib/actions/pr-fetch@v2 59 | with: 60 | repo-token: ${{ secrets.GITHUB_TOKEN }} 61 | 62 | - uses: r-lib/actions/setup-r@v2 63 | 64 | - name: Install dependencies 65 | run: install.packages("styler") 66 | shell: Rscript {0} 67 | 68 | - name: Style 69 | run: styler::style_pkg() 70 | shell: Rscript {0} 71 | 72 | - name: commit 73 | run: | 74 | git config --local user.name "$GITHUB_ACTOR" 75 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 76 | git add \*.R 77 | git commit -m 'Style' 78 | 79 | - uses: r-lib/actions/pr-push@v2 80 | with: 81 | repo-token: ${{ secrets.GITHUB_TOKEN }} 82 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | permissions: read-all 12 | 13 | jobs: 14 | test-coverage: 15 | runs-on: ubuntu-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | 19 | steps: 20 | - uses: actions/checkout@v4 21 | 22 | - uses: r-lib/actions/setup-r@v2 23 | with: 24 | use-public-rspm: true 25 | 26 | - uses: r-lib/actions/setup-r-dependencies@v2 27 | with: 28 | extra-packages: any::covr, any::xml2 29 | needs: coverage 30 | 31 | - name: Test coverage 32 | run: | 33 | cov <- covr::package_coverage( 34 | quiet = FALSE, 35 | clean = FALSE, 36 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 37 | ) 38 | covr::to_cobertura(cov) 39 | shell: Rscript {0} 40 | 41 | - uses: codecov/codecov-action@v4 42 | with: 43 | fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} 44 | file: ./cobertura.xml 45 | plugin: noop 46 | disable_search: true 47 | token: ${{ secrets.CODECOV_TOKEN }} 48 | 49 | - name: Show testthat output 50 | if: always() 51 | run: | 52 | ## -------------------------------------------------------------------- 53 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 54 | shell: bash 55 | 56 | - name: Upload test results 57 | if: failure() 58 | uses: actions/upload-artifact@v4 59 | with: 60 | name: coverage-test-failures 61 | path: ${{ runner.temp }}/package 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | docs 5 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": ["Posit.air-vscode"] 3 | } 4 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "[r]": { 3 | "editor.formatOnSave": true, 4 | "editor.defaultFormatter": "Posit.air-vscode" 5 | } 6 | } 7 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: evaluate 3 | Title: Parsing and Evaluation Tools that Provide More Details than the 4 | Default 5 | Version: 1.0.3.9000 6 | Authors@R: c( 7 | person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), 8 | person("Yihui", "Xie", role = "aut", 9 | comment = c(ORCID = "0000-0003-0645-5666")), 10 | person("Michael", "Lawrence", role = "ctb"), 11 | person("Thomas", "Kluyver", role = "ctb"), 12 | person("Jeroen", "Ooms", role = "ctb"), 13 | person("Barret", "Schloerke", role = "ctb"), 14 | person("Adam", "Ryczkowski", role = "ctb"), 15 | person("Hiroaki", "Yutani", role = "ctb"), 16 | person("Michel", "Lang", role = "ctb"), 17 | person("Karolis", "Koncevičius", role = "ctb"), 18 | person("Posit Software, PBC", role = c("cph", "fnd")) 19 | ) 20 | Description: Parsing and evaluation tools that make it easy to recreate 21 | the command line behaviour of R. 22 | License: MIT + file LICENSE 23 | URL: https://evaluate.r-lib.org/, https://github.com/r-lib/evaluate 24 | BugReports: https://github.com/r-lib/evaluate/issues 25 | Depends: 26 | R (>= 3.6.0) 27 | Suggests: 28 | callr, 29 | covr, 30 | ggplot2 (>= 3.3.6), 31 | lattice, 32 | methods, 33 | pkgload, 34 | ragg (>= 1.3.3.9000), 35 | rlang (>= 1.1.5), 36 | knitr, 37 | testthat (>= 3.0.0), 38 | withr 39 | Remotes: r-lib/ragg 40 | Config/Needs/website: tidyverse/tidytemplate 41 | Config/testthat/edition: 3 42 | Encoding: UTF-8 43 | Roxygen: list(markdown = TRUE) 44 | RoxygenNote: 7.3.2 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2023 2 | COPYRIGHT HOLDER: evaluate authors 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2023 evaluate authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",evaluate_evaluation) 4 | S3method(parse_all,"function") 5 | S3method(parse_all,call) 6 | S3method(parse_all,character) 7 | S3method(parse_all,connection) 8 | S3method(print,evaluate_evaluation) 9 | S3method(replay,character) 10 | S3method(replay,condition) 11 | S3method(replay,default) 12 | S3method(replay,list) 13 | S3method(replay,recordedplot) 14 | S3method(replay,source) 15 | export(create_traceback) 16 | export(evaluate) 17 | export(flush_console) 18 | export(inject_funs) 19 | export(is.error) 20 | export(is.message) 21 | export(is.recordedplot) 22 | export(is.source) 23 | export(is.warning) 24 | export(local_reproducible_output) 25 | export(new_output_handler) 26 | export(parse_all) 27 | export(remove_hooks) 28 | export(replay) 29 | export(set_hooks) 30 | export(trim_intermediate_plots) 31 | export(try_capture_stack) 32 | import(grDevices) 33 | import(graphics) 34 | import(utils) 35 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # evaluate (development version) 2 | 3 | * `evaluate()` uses `ragg::agg_capture()` this supports more modern graphics 4 | capabilities than `pdf()`, and should generally be faster (#238). 5 | * `evaluate()` once again doesn't open a device if `new_device = FALSE` (#234) 6 | 7 | # evaluate 1.0.3 8 | 9 | # evaluate 1.0.2 10 | 11 | * Restore correct traceback behaviour (#232). 12 | 13 | # evaluate 1.0.1 14 | 15 | * Fix buglet revealed when using `rlang::abort()` inside of `evaluate()`. 16 | 17 | # evaluate 1.0.0 18 | 19 | * Setting `ACTIONS_STEP_DEBUG=1` (as in a failing GHA workflow) will 20 | automatically set `log_echo` and `log_warning` to `TRUE` (#175). 21 | 22 | * evaluate works on R 3.6.0 once again. 23 | 24 | * `evaluate()` improvements: 25 | 26 | * Now terminates on the first error in a multi-expression input, i.e. 27 | `1;stop('2');3` will no longer evaluate the third component. This 28 | matches console behaviour more closely. 29 | 30 | * Calls from conditions emitted by top-level code are automatically stripped 31 | (#150). 32 | 33 | * Result has a class (`evaluate_evaluation`/`list`) with a basic print method. 34 | 35 | * Plots created before messages/warnings/errors are correctly captured (#28). 36 | 37 | * Handler improvements: 38 | 39 | * The default `value` handler now evaluates `print()` in a child of the 40 | evaluation environment. This largely makes evaluate easier to test, but 41 | should make defining S3 methods for print a little easier (#192). 42 | 43 | * The `source` output handler is now passed the entire complete input 44 | expression, not just the first component. 45 | 46 | * `evalute(include_timing)` has been deprecated. I can't find any use of it on 47 | GitHub, and it adds substantial code complexity for little gain. 48 | 49 | * `is.value()` has been removed since it tests for an object that evaluate 50 | never creates. 51 | 52 | * New `local_reproducible_output()` helper that sets various options and env 53 | vars to help ensure consistency of output across environments. 54 | 55 | * `parse_all()` adds a `\n` to the end of every line, even the last one if it 56 | didn't have one in the input. Additionally, it no longer has a default 57 | method, which will generate better errors if you pass in something unexpected. 58 | 59 | * New `trim_intermediate_plots()` drops intermediate plots to reveal the 60 | complete/final plot (#206). 61 | 62 | * `watchout()` is no longer exported; it's really an implementation detail that 63 | should never have been leaked to the public interface. 64 | 65 | # evaluate 0.24.0 66 | 67 | * The `source` output handler can now take two arguments (the unparsed `src` 68 | and the parsed `call`) and choose to affect the displayed source. 69 | * The package now depends on R 4.0.0 in order to decrease our maintenance burden. 70 | 71 | # Version 0.23 72 | 73 | - Prevent existing plots from leaking into `evaluate()` results (thanks, @dmurdoch, yihui/knitr#2297). 74 | 75 | - If the environment variable `R_EVALUATE_BYPASS_MESSAGES` is set to true, the arguments `keep_message` and `keep_warning` of `evaluate()` will be set to `NA`, regardless of user input, which means messages and warnings will not be captured by `evaluate()`. This provides a possibility to force logging messages and warnings (thanks, @slodge, yihui/yihui.org#1458). 76 | 77 | # Version 0.22 78 | 79 | - Fixed a problem in the internal function `plot_calls()` that made the examples of `recordGraphics` fail to run on its help page (thanks, Kurt Hornik). 80 | 81 | # Version 0.21 82 | 83 | - `evaluate()` gains `log_echo` and `log_warning` arguments. When set to `TRUE` 84 | these cause code and warnings (respectively) to be immediately emitted to 85 | `stderr()`. This is useful for logging in unattended environments (#118). 86 | 87 | - Improved the error message when users accidentally called `closeAllConnections()` (thanks, @guslipkin, quarto-dev/quarto-cli#5214). 88 | 89 | # Version 0.20 90 | 91 | - The arguments `keep_message` and `keep_warning` of `evaluate()` can take the value `NA` now, which means `evaluate()` will not capture the messages and they will be sent to the console. This is equivalent to the `FALSE` value before v0.19 (thanks, @gadenbuie, https://github.com/yihui/yihui.org/discussions/1458). 92 | 93 | # Version 0.19 94 | 95 | - In `evaluate()`, `keep_message` and `keep_warning` will completely drop messages and warnings, respectively, when their values are `FALSE`. Previously messages would still be emitted (to the console) even if they take `FALSE` values. 96 | 97 | - Fixed the bug that `parse_all()` fails with line directives (thanks, @ArcadeAntics, #114). 98 | 99 | # Version 0.18 100 | 101 | - Fixed tests that were still using the deprecated `ggplot2::qplot()`. 102 | 103 | # Version 0.17 104 | 105 | - Adapted a unit test to the next version of **ggplot2** (thanks, @thomasp85, #113). 106 | 107 | # Version 0.16 108 | 109 | - Fixed a bug that an empty **ggplot2** plot could be recorded and incorrectly saved (thanks, @sjspielman, rstudio/rmarkdown#2363). 110 | 111 | # Version 0.15 112 | 113 | - `new_output_handler()` gains a `calling_handlers` argument. These are passed to `withCallingHandlers()` before `evaluate()` captures any conditions. 114 | 115 | - Fixed #106: do not assume that `is.atomic(NULL)` returns `TRUE` (thanks, @mmaechler). 116 | 117 | # Version 0.14 118 | 119 | - The hooks `persp`, `before.plot.new`, and `before.grid.newpage` set by users will be respected throughout the R session (thanks, @KKPMW, #96). 120 | 121 | # Version 0.13 122 | 123 | - Errors generated by try() are now part of the output (for R >= 3.4). To achieve this, the try.outFile option is set for the duration of all evaluations (thanks, @krlmlr, #91) 124 | 125 | # Version 0.12 126 | 127 | - Removed the stringr dependency (thanks, @mllg, #90). 128 | 129 | # Version 0.11 130 | 131 | - Fix for regression introduced in 0.10.1 in parse_all.call() (fixes #77) 132 | 133 | - evaluate() now respects options(warn >= 2); all warnings are turned into errors (#81) 134 | 135 | # Version 0.10.1 136 | 137 | - Added parse_all.call() method to use the original source for evaluating call objects (because base::deparse() breaks non-ascii source code) (fixes #74) 138 | 139 | # Version 0.10 140 | 141 | - Added option for the evaluate function to include timing information of ran commands. This information will be subsequently rendered by the replay. Example usage: evaluate::replay(evaluate::evaluate('Sys.sleep(1)', include_timing = TRUE)) 142 | 143 | - Added a new function `flush_console()` to emulate `flush.console()` in `evaluate()` (#61). 144 | 145 | - Added a `inject_funs()` function to create functions in the environment passed to the `envir` argument of `evaluate()`. 146 | 147 | # Version 0.9 148 | 149 | - Added an argument `allow_error` to `parse_all()` to allow syntactical errors in R source code when `allow_error = TRUE`; this means `evaluate(stop_on_error = 0 or 1)` will no longer stop on syntactical errors but returns a list of source code and the error object instead. This can be useful to show syntactical errors for pedagogical purposes. 150 | 151 | # Version 0.8.3 152 | 153 | - Added an argument `filename` to evaluate() and parse_all() (thanks, @flying-sheep, #58). 154 | 155 | # Version 0.8 156 | 157 | - Changed package license to MIT. 158 | 159 | # Version 0.7.2 160 | 161 | - replay() fails to replay certain objects such as NULL (#53). 162 | 163 | # Version 0.7 164 | 165 | - R 3.0.2 is the minimal required version for this package now. 166 | 167 | # Version 0.6 168 | 169 | - Plots are no longer recorded when the current graphical device has been changed, which may introduce issues like yihui/knitr#824. 170 | 171 | - `parse_all()` can parse R code that contains multibyte characters correctly now (#49, yihui/knitr#988) 172 | 173 | # Version 0.5.5 174 | 175 | - Actually use the `text` and `graphics` in `new_output_handler` 176 | 177 | - Multiple expressions separated by `;` on the same line can be printed as expected when the result returned is visible, e.g. both `x` and `y` will be printed when the source code is `x; y`. In previous versions, only `y` is printed. (thanks, Bill Venables) 178 | 179 | # Version 0.5.3 180 | 181 | ## BUG FIXES 182 | 183 | - fixed the bug reported at https://github.com/yihui/knitr/issues/722 (repeatedly knitting the same code results in plots being omitted randomly) (thanks, Simon Urbanek) 184 | 185 | # Version 0.5.1 186 | 187 | ## BUG FIXES 188 | 189 | - under R 2.15.x, evaluate() was unable to filter out the plots triggered by clip() (thanks, Uwe Ligges) 190 | 191 | # Version 0.5 192 | 193 | ## NEW FEATURES 194 | 195 | - evaluate() is better at telling if a new plot should render a new page due to the new par('page') in R 3.0.2 196 | 197 | ## BUG FIXES 198 | 199 | - fixed yihui/knitr#600: when the last expression in the code is a comment, the previous incomplete plot was not captured 200 | 201 | - the empty plots produced by strwidth(), strheight(), and clip() are no longer recorded 202 | 203 | ## MAJOR CHANGES 204 | 205 | - evaluate() no longer records warnings in case of options(warn = -1); see yihui/knitr#610 206 | 207 | - for 'output_handler' in evaluate(), visible values from the 'value' handler will be saved to the output list; this makes it possible for users to save the original values instead of their printed side effects; this change will not affect those who use the default output handlers (#40, thanks, Gabriel Becker) 208 | 209 | - the 'value' handler in new_output_handler() may take an additional argument that means if the value is visible or not; this makes it possible to save the invisible values as well (#41, thanks, Joroen Ooms) 210 | 211 | # Version 0.4.7 212 | 213 | ## NEW FEATURES 214 | 215 | - added two arguments keep_warning and keep_message in evaluate() so that it is possible not to capture warnings or messages now 216 | 217 | ## BUG FIXES 218 | 219 | - fixed #25: plots can be correctly recorded under a complex layout now (#25, thanks, Jack Tanner and Andy Barbour) 220 | 221 | - fixed yihui/knitr#582: evaluate() misclassified some plot changes as "par changes" and removed some plots when it should not; now it is better at identifying plot changes dur to par() (thanks, Keith Twombley) 222 | 223 | # Version 0.4.4 224 | 225 | ## BUG FIXES 226 | 227 | - Perspective plots from `persp()` are captured now (thanks to Harvey Lime and Yihui Xie) 228 | 229 | - If an error occurs during printing a visible value, evaluate will halt on a cryptic error "operator is invalid for atomic vectors" (#26, fixed by Yihui Xie) 230 | 231 | - If the internal connection was accidentally closed by the user, a more informative message will show up (#23) 232 | 233 | - Now the graphical device will always try to record graphics by default (when new_device = TRUE) (#34) 234 | 235 | - Some empty and incomplete plots caused by par() or layout() will be filtered out correctly for R 3.0 (#35) 236 | 237 | ## MAINTAINENCE 238 | 239 | - Yihui Xie is the new maintainer of this package now 240 | 241 | # Version 0.4.3 242 | 243 | ## NEW FEATURES 244 | 245 | - Added `output_handler` argument to `evaluate`. Should be a `output_handler` object, which is a list of functions for handling each type of result, prior to printing of visible return values. This allows clients to override the console-like printing of values, while still processing them in the correct temporal context. The other handlers are necessary to convey the correct ordering of the output. This essentially provides stream-based processing, as an alternative to the existing deferred processing. 246 | 247 | - New option, `stop_on_error` which controls behaviour when errors occur. The default value, `0`, acts like you've copied and pasted the code into the console, and continues to execute all code. `1` will stop the code execution and return the results of evaluation up to that point, and `2` will raise an error. 248 | 249 | ## BUG FIXES 250 | 251 | - Compound expressions like `x <- 10; x` are now evaluated completely. 252 | 253 | - Chinese characters on windows now work correctly (thanks to Yihui Xie) 254 | 255 | - Graphics and output interleaved correctly when generated from a loop or other compound statements 256 | 257 | - By default, `evaluate` will now open a new graphics device and clean it up afterwards. To suppress that behaviour use `new_device = FALSE` 258 | 259 | - use `show` to display S4 objects. 260 | 261 | # Version 0.4.2 262 | 263 | - replace deprecated `.Internal(eval.with.vis)` with correct `withVisible` 264 | 265 | - `evaluate` gains `debug` argument 266 | 267 | # Version 0.4.1 268 | 269 | - use `test_package` to avoid problems with latest version of `testthat` 270 | 271 | # Version 0.4 272 | 273 | - Use plot hooks to capture multiple plots created in a loop or within a function. (Contributed by Yihui Xie) 274 | 275 | # Version 0.3 276 | 277 | - Import `stringr` instead of depending on it. 278 | 279 | - Test plot recording only in the presence of interactive devices. 280 | 281 | # Version 0.2 282 | 283 | - try_capture_stack and create_traceback do a much better job of removing infrastructure calls from the captured traceback 284 | 285 | - visible results are automatically evaluated and their outputs are captured. This is particularly important for lattice and ggplot graphics, which otherwise require special handling. It also correctly captures warnings, errors and messages raised by the print method. 286 | -------------------------------------------------------------------------------- /R/conditions.R: -------------------------------------------------------------------------------- 1 | condition_handlers <- function(watcher, on_error, on_warning, on_message) { 2 | list( 3 | message = function(cnd) { 4 | watcher$capture_plot_and_output() 5 | 6 | if (on_message$capture) { 7 | watcher$push(cnd) 8 | } 9 | if (on_message$silence) { 10 | invokeRestart("muffleMessage") 11 | } 12 | }, 13 | warning = function(cnd) { 14 | # do not handle warnings that shortly become errors or have been silenced 15 | if (getOption("warn") >= 2 || getOption("warn") < 0) { 16 | return() 17 | } 18 | 19 | watcher$capture_plot_and_output() 20 | if (on_warning$capture) { 21 | cnd <- sanitize_call(cnd) 22 | watcher$push(cnd) 23 | } 24 | if (on_warning$silence) { 25 | invokeRestart("muffleWarning") 26 | } 27 | }, 28 | error = function(cnd) { 29 | watcher$capture_plot_and_output() 30 | 31 | cnd <- sanitize_call(cnd) 32 | watcher$push(cnd) 33 | 34 | switch( 35 | on_error, 36 | continue = invokeRestart("eval_continue"), 37 | stop = invokeRestart("eval_stop"), 38 | # No need to invoke a restart as we want the error to be thrown in this case. 39 | error = NULL 40 | ) 41 | } 42 | ) 43 | } 44 | 45 | 46 | with_handlers <- function(code, handlers) { 47 | if (!is.list(handlers)) { 48 | stop("`handlers` must be a list", call. = FALSE) 49 | } 50 | 51 | call <- as.call(c(quote(withCallingHandlers), quote(code), handlers)) 52 | eval(call) 53 | } 54 | 55 | sanitize_call <- function(cnd) { 56 | if (identical(cnd$call, quote(eval(expr, envir)))) { 57 | cnd$call <- NULL 58 | } 59 | 60 | cnd 61 | } 62 | -------------------------------------------------------------------------------- /R/evaluate-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | the <- new.env(parent = emptyenv()) 5 | 6 | ## usethis namespace: start 7 | ## usethis namespace: end 8 | NULL 9 | -------------------------------------------------------------------------------- /R/evaluate.R: -------------------------------------------------------------------------------- 1 | #' Evaluate input and return all details of evaluation 2 | #' 3 | #' Compare to [eval()], `evaluate` captures all of the 4 | #' information necessary to recreate the output as if you had copied and pasted 5 | #' the code into a R terminal. It captures messages, warnings, errors and 6 | #' output, all correctly interleaved in the order in which they occured. It 7 | #' stores the final result, whether or not it should be visible, and the 8 | #' contents of the current graphics device. 9 | #' 10 | #' @export 11 | #' @param input input object to be parsed and evaluated. May be a string, file 12 | #' connection or function. Passed on to [parse_all()]. 13 | #' @param envir environment in which to evaluate expressions. 14 | #' @param enclos when `envir` is a list or data frame, this is treated as 15 | #' the parent environment to `envir`. 16 | #' @param debug if `TRUE`, displays information useful for debugging, 17 | #' including all output that evaluate captures. 18 | #' @param stop_on_error A number between 0 and 2 that controls what happens 19 | #' when the code errors: 20 | #' 21 | #' * If `0`, the default, will continue running all code, just as if you'd 22 | #' pasted the code into the command line. 23 | #' * If `1`, evaluation will stop on first error without signaling the error, 24 | #' and you will get back all results up to that point. 25 | #' * If `2`, evaluation will halt on first error and you will get back no 26 | #' results. 27 | #' @param keep_warning,keep_message A single logical value that controls what 28 | #' happens to warnings and messages. 29 | #' 30 | #' * If `TRUE`, the default, warnings and messages will be captured in the 31 | #' output. 32 | #' * If `NA`, warnings and messages will not be captured and bubble up to 33 | #' the calling environment of `evaluate()`. 34 | #' * If `FALSE`, warnings and messages will be completed supressed and 35 | #' not shown anywhere. 36 | #' 37 | #' Note that setting the envvar `R_EVALUATE_BYPASS_MESSAGES` to `true` will 38 | #' force these arguments to be set to `NA`. 39 | #' @param log_echo,log_warning If `TRUE`, will immediately log code and 40 | #' warnings (respectively) to `stderr`. 41 | #' 42 | #' This will be force to `TRUE` if env var `ACTIONS_STEP_DEBUG` is 43 | #' `true`, as when debugging a failing GitHub Actions workflow. 44 | #' @param new_device if `TRUE`, will open a new graphics device and 45 | #' automatically close it after completion. This prevents evaluation from 46 | #' interfering with your existing graphics environment. 47 | #' @param output_handler an instance of [output_handler()] that 48 | #' processes the output from the evaluation. The default simply prints the 49 | #' visible return values. 50 | #' @param filename string overrriding the [base::srcfile()] filename. 51 | #' @param include_timing Deprecated. 52 | #' @import graphics grDevices utils 53 | #' @examples 54 | #' evaluate(c( 55 | #' "1 + 1", 56 | #' "2 + 2" 57 | #' )) 58 | #' 59 | #' # Not that's there's a difference in output between putting multiple 60 | #' # expressions on one line vs spreading them across multiple lines 61 | #' evaluate("1;2;3") 62 | #' evaluate(c("1", "2", "3")) 63 | #' 64 | #' # This also affects how errors propagate, matching the behaviour 65 | #' # of the R console 66 | #' evaluate("1;stop(2);3") 67 | #' evaluate(c("1", "stop(2)", "3")) 68 | evaluate <- function( 69 | input, 70 | envir = parent.frame(), 71 | enclos = NULL, 72 | debug = FALSE, 73 | stop_on_error = 0L, 74 | keep_warning = TRUE, 75 | keep_message = TRUE, 76 | log_echo = FALSE, 77 | log_warning = FALSE, 78 | new_device = TRUE, 79 | output_handler = NULL, 80 | filename = NULL, 81 | include_timing = FALSE 82 | ) { 83 | on_error <- check_stop_on_error(stop_on_error) 84 | 85 | # if this env var is set to true, always bypass messages 86 | if (env_var_is_true("R_EVALUATE_BYPASS_MESSAGES")) { 87 | keep_message <- NA 88 | keep_warning <- NA 89 | } 90 | if (env_var_is_true("ACTIONS_STEP_DEBUG")) { 91 | log_warning <- TRUE 92 | log_echo <- TRUE 93 | } 94 | 95 | on_message <- check_keep(keep_message, "keep_message") 96 | on_warning <- check_keep(keep_warning, "keep_warning", log_warning) 97 | 98 | output_handler <- output_handler %||% evaluate_default_output_handler 99 | 100 | if (isTRUE(include_timing)) { 101 | warning("`evaluate(include_timing)` is deprecated") 102 | } 103 | 104 | # Capture output 105 | watcher <- watchout(output_handler, new_device = new_device, debug = debug) 106 | 107 | if (on_error != "error" && !can_parse(input)) { 108 | err <- tryCatch(parse(text = input), error = function(cnd) cnd) 109 | watcher$push_source(input, expression()) 110 | watcher$push(err) 111 | return(watcher$get()) 112 | } 113 | 114 | parsed <- parse_all(input, filename = filename) 115 | # "Transpose" parsed so we get a list that's easier to iterate over 116 | tles <- Map( 117 | function(src, exprs) list(src = src, exprs = exprs), 118 | parsed$src, 119 | parsed$expr 120 | ) 121 | 122 | if (is.list(envir)) { 123 | envir <- list2env(envir, parent = enclos %||% parent.frame()) 124 | } 125 | local_inject_funs(envir) 126 | 127 | if (is.null(getOption("rlang_trace_top_env"))) { 128 | # If not already set, indicate the top environment to trim traceback 129 | options(rlang_trace_top_env = envir) 130 | } 131 | 132 | # Handlers for warnings, errors and messages 133 | user_handlers <- output_handler$calling_handlers 134 | evaluate_handlers <- condition_handlers( 135 | watcher, 136 | on_error = on_error, 137 | on_warning = on_warning, 138 | on_message = on_message 139 | ) 140 | # The user's condition handlers have priority over ours 141 | handlers <- c(user_handlers, evaluate_handlers) 142 | 143 | for (tle in tles) { 144 | watcher$push_source(tle$src, tle$exprs) 145 | if (debug || log_echo) { 146 | cat_line(tle$src, file = stderr()) 147 | } 148 | 149 | continue <- withRestarts( 150 | with_handlers( 151 | { 152 | for (expr in tle$exprs) { 153 | ev <- withVisible(eval(expr, envir)) 154 | watcher$capture_plot_and_output() 155 | watcher$print_value(ev$value, ev$visible, envir) 156 | } 157 | TRUE 158 | }, 159 | handlers 160 | ), 161 | eval_continue = function() TRUE, 162 | eval_stop = function() FALSE 163 | ) 164 | watcher$check_devices() 165 | 166 | if (!continue) { 167 | break 168 | } 169 | } 170 | 171 | # Always capture last plot, even if incomplete 172 | watcher$capture_plot(TRUE) 173 | 174 | watcher$get() 175 | } 176 | 177 | check_stop_on_error <- function(x) { 178 | if (is.numeric(x) && length(x) == 1 && !is.na(x)) { 179 | if (x == 0L) { 180 | return("continue") 181 | } else if (x == 1L) { 182 | return("stop") 183 | } else if (x == 2L) { 184 | return("error") 185 | } 186 | } 187 | stop("`stop_on_error` must be 0, 1, or 2.", call. = FALSE) 188 | } 189 | 190 | check_keep <- function(x, arg, log = FALSE) { 191 | if (!is.logical(x) || length(x) != 1) { 192 | stop("`", arg, "` must be TRUE, FALSE, or NA.", call. = FALSE) 193 | } 194 | 195 | list( 196 | capture = isTRUE(x), 197 | silence = !is.na(x) && !log 198 | ) 199 | } 200 | -------------------------------------------------------------------------------- /R/evaluation.R: -------------------------------------------------------------------------------- 1 | new_evaluation <- function(x) { 2 | # Needs explicit list for backwards compatibility 3 | structure(x, class = c("evaluate_evaluation", "list")) 4 | } 5 | 6 | is_evaluation <- function(x) { 7 | inherits(x, "evaluate_evaluation") 8 | } 9 | 10 | #' @export 11 | `[.evaluate_evaluation` <- function(x, i, ...) { 12 | new_evaluation(NextMethod()) 13 | } 14 | 15 | #' @export 16 | print.evaluate_evaluation <- function(x, ...) { 17 | cat_line("") 18 | for (component in x) { 19 | type <- output_type(component) 20 | if (type == "source") { 21 | cat_line("Source code: ") 22 | cat_line(indent(component$src)) 23 | } else if (type == "text") { 24 | cat_line("Text output: ") 25 | cat_line(indent(component)) 26 | } else if (type %in% c("message", "warning", "error")) { 27 | cat_line("Condition: ") 28 | cat_line(indent(format_condition(component))) 29 | } else if (type == "plot") { 30 | dl <- component[[1]] 31 | cat_line("Plot [", length(dl), "]:") 32 | for (call in dl) { 33 | fun_call <- call[[2]][[1]] 34 | if (hasName(fun_call, "name")) { 35 | cat_line(" ", fun_call$name, "()") 36 | } else { 37 | cat_line(" ", deparse(fun_call)) 38 | } 39 | } 40 | } else { 41 | cat_line("Other: ") 42 | cat(" ") 43 | str(component, indent.str = " ") 44 | } 45 | } 46 | 47 | invisible(x) 48 | } 49 | 50 | output_type <- function(x) { 51 | if (is.character(x)) { 52 | "text" 53 | } else if (is.error(x)) { 54 | "error" 55 | } else if (is.warning(x)) { 56 | "warning" 57 | } else if (is.message(x)) { 58 | "message" 59 | } else if (is.recordedplot(x)) { 60 | "plot" 61 | } else if (is.source(x)) { 62 | "source" 63 | } else { 64 | class(x)[[1]] 65 | } 66 | } 67 | 68 | #' Object class tests 69 | #' 70 | #' @keywords internal 71 | #' @rdname is.message 72 | #' @export 73 | is.message <- function(x) inherits(x, "message") 74 | #' @rdname is.message 75 | #' @export 76 | is.warning <- function(x) inherits(x, "warning") 77 | #' @rdname is.message 78 | #' @export 79 | is.error <- function(x) inherits(x, "error") 80 | #' @rdname is.message 81 | #' @export 82 | is.source <- function(x) inherits(x, "source") 83 | #' @rdname is.message 84 | #' @export 85 | is.recordedplot <- function(x) inherits(x, "recordedplot") 86 | -------------------------------------------------------------------------------- /R/flush-console.R: -------------------------------------------------------------------------------- 1 | #' An emulation of `flush.console()` in `evaluate()` 2 | #' 3 | #' @description 4 | #' When [evaluate()] is evaluating code, the text output is diverted into 5 | #' an internal connection, and there is no way to flush that connection. This 6 | #' function provides a way to "flush" the connection so that any text output can 7 | #' be immediately written out, and more importantly, the `text` handler 8 | #' (specified in the `output_handler` argument of `evaluate()`) will 9 | #' be called, which makes it possible for users to know it when the code 10 | #' produces text output using the handler. 11 | #' 12 | #' This function is supposed to be called inside `evaluate()` (e.g. 13 | #' either a direct `evaluate()` call or in \pkg{knitr} code chunks). 14 | #' @export 15 | flush_console <- function() { 16 | if (!is.null(the$console_flusher)) { 17 | the$console_flusher() 18 | } 19 | invisible() 20 | } 21 | 22 | the$console_flusher <- NULL 23 | 24 | local_console_flusher <- function(flusher, frame = parent.frame()) { 25 | old <- set_console_flusher(flusher) 26 | defer(set_console_flusher(old), frame) 27 | invisible() 28 | } 29 | 30 | set_console_flusher <- function(flusher) { 31 | old <- the$console_flusher 32 | the$console_flusher <- flusher 33 | invisible(old) 34 | } 35 | -------------------------------------------------------------------------------- /R/graphics.R: -------------------------------------------------------------------------------- 1 | local_plot_hooks <- function(f, frame = parent.frame()) { 2 | hook_list <- list( 3 | persp = f, 4 | before.plot.new = f, 5 | before.grid.newpage = f 6 | ) 7 | set_hooks(hook_list) 8 | defer(remove_hooks(hook_list), frame) 9 | invisible() 10 | } 11 | 12 | # visual changes --------------------------------------------------------- 13 | 14 | looks_different <- function(old_dl, new_dl) { 15 | if (identical(old_dl, new_dl)) { 16 | return(FALSE) 17 | } 18 | 19 | # If the new plot has fewer calls, it must be a visual change 20 | if (length(new_dl) < length(old_dl)) { 21 | return(TRUE) 22 | } 23 | 24 | # If the initial calls are different, it must be a visual change 25 | if (!identical(old_dl[], new_dl[seq_along(old_dl)])) { 26 | return(TRUE) 27 | } 28 | 29 | # If the last calls involve visual changes then it's a visual change 30 | added_dl <- new_dl[-seq_along(old_dl)] 31 | makes_visual_change(added_dl) 32 | } 33 | 34 | makes_visual_change <- function(plot) { 35 | xs <- lapply(plot, function(x) x[[2]][[1]]) 36 | 37 | for (x in xs) { 38 | if (hasName(x, "name")) { 39 | # base graphics 40 | if (!x$name %in% non_visual_calls) { 41 | return(TRUE) 42 | } 43 | } else if (is.call(x)) { 44 | # grid graphics 45 | if (as.character(x[[1]]) != "requireNamespace") { 46 | return(TRUE) 47 | } 48 | } 49 | } 50 | FALSE 51 | } 52 | 53 | non_visual_calls <- c( 54 | "C_clip", 55 | "C_layout", 56 | "C_par", 57 | "C_plot_window", 58 | "C_strHeight", 59 | "C_strWidth", 60 | "palette", 61 | "palette2" 62 | ) 63 | 64 | # plot trimming ---------------------------------------------------------- 65 | 66 | #' Trim away intermediate plots 67 | #' 68 | #' Trim off plots that are modified by subsequent lines to only show 69 | #' the "final" plot. 70 | #' 71 | #' @param x An evaluation object produced by [evaluate()]. 72 | #' @return A modified evaluation object. 73 | #' @export 74 | #' @examples 75 | #' ev <- evaluate(c( 76 | #' "plot(1:3)", 77 | #' "text(1, 1, 'x')", 78 | #' "text(1, 1, 'y')" 79 | #' )) 80 | #' 81 | #' # All intermediate plots are captured 82 | #' ev 83 | #' # Only the final plot is shown 84 | #' trim_intermediate_plots(ev) 85 | trim_intermediate_plots <- function(x) { 86 | if (!is_evaluation(x)) { 87 | stop("`x` must be an evaluation object.") 88 | } 89 | 90 | is_plot <- vapply(x, is.recordedplot, logical(1)) 91 | plot_idx <- which(is_plot) 92 | keep <- rep(TRUE, length(plot_idx)) 93 | 94 | prev_plot <- NULL 95 | for (i in seq2(2, length(plot_idx))) { 96 | cur_plot_dl <- x[[plot_idx[i]]][[1]] 97 | prev_plot_dl <- x[[plot_idx[i - 1]]][[1]] 98 | 99 | if (prev_plot_dl %is_prefix_of% cur_plot_dl) { 100 | keep[i - 1] <- FALSE 101 | } 102 | } 103 | 104 | idx <- seq_along(x) 105 | idx <- setdiff(idx, plot_idx[!keep]) 106 | x[idx] 107 | } 108 | 109 | `%is_prefix_of%` <- function(x, y) { 110 | if (length(x) > length(y)) { 111 | return(FALSE) 112 | } 113 | 114 | identical(x[], y[seq_along(x)]) 115 | } 116 | -------------------------------------------------------------------------------- /R/hooks.R: -------------------------------------------------------------------------------- 1 | #' Set and remove hooks 2 | #' 3 | #' This interface wraps the base [setHook()] function to provide a return 4 | #' value that makes it easy to undo. 5 | #' 6 | #' @param hooks a named list of hooks - each hook can either be a function or 7 | #' a list of functions. 8 | #' @param action `"replace"`, `"append"` or `"prepend"` 9 | #' @keywords internal 10 | #' @export 11 | #' @examples 12 | #' new1 <- list(before.plot.new = function() print("Plotted!")) 13 | #' new2 <- list(before.plot.new = function() print("Plotted Again!")) 14 | #' set_hooks(new1) 15 | #' set_hooks(new2) 16 | #' plot(1) 17 | #' remove_hooks(new1) 18 | #' plot(1) 19 | #' remove_hooks(new2) 20 | #' plot(1) 21 | set_hooks <- function(hooks, action = "append") { 22 | old <- list() 23 | for (hook_name in names(hooks)) { 24 | old[[hook_name]] <- getHook(hook_name) 25 | setHook(hook_name, hooks[[hook_name]], action = action) 26 | } 27 | invisible(old) 28 | } 29 | 30 | #' @rdname set_hooks 31 | #' @export 32 | remove_hooks <- function(hooks) { 33 | for (hook_name in names(hooks)) { 34 | hook <- getHook(hook_name) 35 | for (fun in unlist(hooks[hook_name])) { 36 | hook[sapply(hook, identical, fun)] <- NULL 37 | } 38 | setHook(hook_name, hook, "replace") 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /R/inject-funs.R: -------------------------------------------------------------------------------- 1 | #' Inject functions into the environment of `evaluate()` 2 | #' 3 | #' Create functions in the environment specified in the `envir` argument of 4 | #' [evaluate()]. This can be helpful if you want to substitute certain 5 | #' functions when evaluating the code. To make sure it does not wipe out 6 | #' existing functions in the environment, only functions that do not exist in 7 | #' the environment are injected. 8 | #' @param ... Named arguments of functions. If empty, previously injected 9 | #' functions will be emptied. 10 | #' @note For expert use only. Do not use it unless you clearly understand it. 11 | #' @keywords internal 12 | #' @return Invisibly returns previous values. 13 | #' @examples library(evaluate) 14 | #' # normally you cannot capture the output of system 15 | #' evaluate("system('R --version')") 16 | #' 17 | #' # replace the system() function 18 | #' old <- inject_funs(system = function(...) { 19 | #' cat(base::system(..., intern = TRUE), sep = "\n") 20 | #' }) 21 | #' 22 | #' evaluate("system('R --version')") 23 | #' 24 | #' # restore previously injected functions 25 | #' inject_funs(old) 26 | #' @export 27 | inject_funs <- function(...) { 28 | funs <- list(...) 29 | funs <- funs[names(funs) != ""] 30 | old <- the$inject_funs 31 | the$inject_funs <- Filter(is.function, funs) 32 | 33 | invisible(old) 34 | } 35 | 36 | local_inject_funs <- function(envir, frame = parent.frame()) { 37 | funs <- the$inject_funs 38 | if (length(funs) == 0) { 39 | return() 40 | } 41 | 42 | funs_names <- names(funs) 43 | funs_new <- !vapply(funs_names, exists, logical(1), envir, inherits = FALSE) 44 | funs_names <- funs_names[funs_new] 45 | funs <- funs[funs_new] 46 | 47 | defer(rm(list = funs_names, envir = envir), frame = frame) 48 | 49 | for (i in seq_along(funs_names)) { 50 | assign(funs_names[i], funs[[i]], envir) 51 | } 52 | 53 | invisible() 54 | } 55 | -------------------------------------------------------------------------------- /R/output-handler.R: -------------------------------------------------------------------------------- 1 | #' Custom output handlers 2 | #' 3 | #' An `output_handler` handles the results of [evaluate()], 4 | #' including the values, graphics, conditions. Each type of output is handled by 5 | #' a particular function in the handler object. 6 | #' 7 | #' The handler functions should accept an output object as their first argument. 8 | #' The return value of the handlers is ignored, except in the case of the 9 | #' `value` handler, where a visible return value is saved in the output 10 | #' list. 11 | #' 12 | #' Calling the constructor with no arguments results in the default handler, 13 | #' which mimics the behavior of the console by printing visible values. 14 | #' 15 | #' Note that recursion is common: for example, if `value` does any 16 | #' printing, then the `text` or `graphics` handlers may be called. 17 | #' 18 | #' @param source Function to handle the echoed source code under evaluation. 19 | #' This function should take two arguments (`src` and `expr`), and return 20 | #' an object that will be inserted into the evaluate outputs. `src` is the 21 | #' unparsed text of the source code, and `expr` is the complete input 22 | #' expression (which may have 0, 1, 2, or more components; see [parse_all()] 23 | #' for details). 24 | #' 25 | #' Return `src` for the default evaluate behaviour. Return `NULL` to 26 | #' drop the source from the output. 27 | #' @param text Function to handle any textual console output. 28 | #' @param graphics Function to handle graphics, as returned by 29 | #' [recordPlot()]. 30 | #' @param message Function to handle [message()] output. 31 | #' @param warning Function to handle [warning()] output. 32 | #' @param error Function to handle [stop()] output. 33 | #' @param value Function to handle the values returned from evaluation. 34 | #' * If it has one argument, it called on visible values. 35 | #' * If it has two arguments, it handles all values, with the second 36 | #' argument indicating whether or not the value is visible. 37 | #' * If it has three arguments, it will be called on all values, with the 38 | #' the third argument given the evaluation environment which is needed 39 | #' to look up print methods for S3 objects. 40 | #' @param calling_handlers List of [calling handlers][withCallingHandlers]. 41 | #' These handlers have precedence over the exiting handler installed 42 | #' by [evaluate()] when `stop_on_error` is set to 0. 43 | #' @return A new `output_handler` object 44 | #' @aliases output_handler 45 | #' @export 46 | new_output_handler <- function( 47 | source = identity, 48 | text = identity, 49 | graphics = identity, 50 | message = identity, 51 | warning = identity, 52 | error = identity, 53 | value = render, 54 | calling_handlers = list() 55 | ) { 56 | source <- match.fun(source) 57 | stopifnot(length(formals(source)) >= 1) 58 | text <- match.fun(text) 59 | stopifnot(length(formals(text)) >= 1) 60 | graphics <- match.fun(graphics) 61 | stopifnot(length(formals(graphics)) >= 1) 62 | message <- match.fun(message) 63 | stopifnot(length(formals(message)) >= 1) 64 | warning <- match.fun(warning) 65 | stopifnot(length(formals(warning)) >= 1) 66 | error <- match.fun(error) 67 | stopifnot(length(formals(error)) >= 1) 68 | value <- match.fun(value) 69 | stopifnot(length(formals(value)) >= 1) 70 | 71 | check_handlers(calling_handlers) 72 | 73 | structure( 74 | list( 75 | source = source, 76 | text = text, 77 | graphics = graphics, 78 | message = message, 79 | warning = warning, 80 | error = error, 81 | value = value, 82 | calling_handlers = calling_handlers 83 | ), 84 | class = "output_handler" 85 | ) 86 | } 87 | 88 | check_handlers <- function(x) { 89 | if (!is.list(x)) { 90 | stop_bad_handlers() 91 | } 92 | 93 | if (!length(x)) { 94 | return() 95 | } 96 | 97 | names <- names(x) 98 | if (!is.character(names) || anyNA(names) || any(names == "")) { 99 | stop_bad_handlers() 100 | } 101 | 102 | for (elt in x) { 103 | if (!is.function(elt)) { 104 | stop_bad_handlers() 105 | } 106 | } 107 | } 108 | stop_bad_handlers <- function() { 109 | stop(simpleError( 110 | "`calling_handlers` must be a named list of functions.", 111 | call = call("new_output_handler") 112 | )) 113 | } 114 | -------------------------------------------------------------------------------- /R/output.R: -------------------------------------------------------------------------------- 1 | new_source <- function(src, call, handler = NULL) { 2 | src <- structure(list(src = src), class = "source") 3 | if (is.null(handler)) { 4 | return(src) 5 | } 6 | 7 | n_args <- length(formals(handler)) 8 | if (n_args == 1) { 9 | # Old format only called for side effects 10 | handler(src) 11 | src 12 | } else if (n_args == 2) { 13 | # New format can influence result 14 | handler(src, call) 15 | } else { 16 | stop("Source output handler must have one or two arguments") 17 | } 18 | } 19 | 20 | # If the output handler has two arguments, then the user has opted into 21 | # handling the value regardless of whether it's not visible. 22 | show_value <- function(handler, visible) { 23 | visible || length(formals(handler$value)) > 1 24 | } 25 | 26 | handle_value <- function(handler, value, visible, envir = parent.frame()) { 27 | n_args <- length(formals(handler$value)) 28 | if (n_args == 1) { 29 | handler$value(value) 30 | } else if (n_args == 2) { 31 | handler$value(value, visible) 32 | } else if (n_args == 3) { 33 | handler$value(value, visible, envir) 34 | } else { 35 | stop("Value output handler must have one or two arguments") 36 | } 37 | } 38 | 39 | render <- function(value, visible, envir) { 40 | if (!visible) { 41 | return(invisible()) 42 | } 43 | 44 | if (isS4(value)) { 45 | methods::show(value) 46 | } else { 47 | # We need to evaluate the print() generic in a child environment of the 48 | # evaluation frame in order to find any methods registered there 49 | print_env <- new.env(parent = envir) 50 | print_env$value <- value 51 | evalq(print(value), envir = print_env) 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /R/parse_all.R: -------------------------------------------------------------------------------- 1 | #' Parse, retaining comments 2 | #' 3 | #' Works very similarly to parse, but also keeps original formatting and 4 | #' comments. 5 | #' 6 | #' @param x object to parse. Can be a string, a file connection, or a function. 7 | #' If a connection, will be opened and closed only if it was closed initially. 8 | #' @param filename string overriding the file name 9 | #' @param allow_error whether to allow syntax errors in `x` 10 | #' @return 11 | #' A data frame two columns, `src` and `expr`, and one row for each complete 12 | #' input in `x`. A complete input is R code that would trigger execution when 13 | #' typed at the console. This might consist of multiple expressions separated 14 | #' by `;` or one expression spread over multiple lines (like a function 15 | #' definition). 16 | #' 17 | #' `src` is a character vector of source code. Each element represents a 18 | #' complete input expression (which might span multiple line) and always has a 19 | #' terminal `\n`. 20 | #' 21 | #' `expr` is a list-column of [expression]s. The expressions can be of any 22 | #' length, depending on the structure of the complete input source: 23 | #' 24 | #' * If `src` consists of only only whitespace and/or comments, `expr` will 25 | #' be length 0. 26 | #' * If `src` a single scalar (like `TRUE`, `1`, or `"x"`), name, or 27 | #' function call, `expr` will be length 1. 28 | #' * If `src` contains multiple expressions separated by `;`, `expr` will 29 | #' have length two or more. 30 | #' 31 | #' The expressions have their srcrefs removed. 32 | #' 33 | #' If there are syntax errors in `x` and `allow_error = TRUE`, the data 34 | #' frame will have an attribute `PARSE_ERROR` that stores the error object. 35 | #' @export 36 | #' @examples 37 | #' # Each of these inputs are single line, but generate different numbers of 38 | #' # expressions 39 | #' source <- c( 40 | #' "# a comment", 41 | #' "x", 42 | #' "x;y", 43 | #' "x;y;z" 44 | #' ) 45 | #' parsed <- parse_all(source) 46 | #' lengths(parsed$expr) 47 | #' str(parsed$expr) 48 | #' 49 | #' # Each of these inputs are a single expression, but span different numbers 50 | #' # of lines 51 | #' source <- c( 52 | #' "function() {}", 53 | #' "function() {", 54 | #' " # Hello!", 55 | #' "}", 56 | #' "function() {", 57 | #' " # Hello!", 58 | #' " # Goodbye!", 59 | #' "}" 60 | #' ) 61 | #' parsed <- parse_all(source) 62 | #' lengths(parsed$expr) 63 | #' parsed$src 64 | parse_all <- function(x, filename = NULL, allow_error = FALSE) { 65 | UseMethod("parse_all") 66 | } 67 | 68 | 69 | #' @export 70 | parse_all.character <- function(x, filename = NULL, allow_error = FALSE) { 71 | if (any(grepl("\n", x))) { 72 | # Ensure that empty lines are not dropped by strsplit() 73 | x[x == ""] <- "\n" 74 | # Standardise to a character vector with one line per element; 75 | # this is the input that parse() is documented to accept 76 | x <- unlist(strsplit(x, "\n"), recursive = FALSE, use.names = FALSE) 77 | } 78 | n <- length(x) 79 | 80 | filename <- filename %||% "" 81 | 82 | src <- srcfilecopy(filename, x) 83 | if (allow_error) { 84 | exprs <- tryCatch(parse(text = x, srcfile = src), error = identity) 85 | if (inherits(exprs, "error")) { 86 | return(structure( 87 | data.frame(src = paste(x, collapse = "\n"), expr = empty_expr()), 88 | PARSE_ERROR = exprs 89 | )) 90 | } 91 | } else { 92 | exprs <- parse(text = x, srcfile = src) 93 | } 94 | 95 | srcref <- attr(exprs, "srcref", exact = TRUE) 96 | pos <- data.frame( 97 | start = vapply(srcref, `[[`, 7, FUN.VALUE = integer(1)), 98 | end = vapply(srcref, `[[`, 8, FUN.VALUE = integer(1)) 99 | ) 100 | pos$exprs <- exprs 101 | 102 | # parse() splits TLEs that use ; into multiple expressions so we 103 | # join together expressions that overlaps on the same line(s) 104 | line_group <- cumsum(is_new_line(pos$start, pos$end)) 105 | tles <- lapply(split(pos, line_group), function(p) { 106 | n <- nrow(p) 107 | data.frame( 108 | src = paste(x[p$start[1]:p$end[n]], collapse = "\n"), 109 | expr = I(list(p$exprs)), 110 | line = p$start[1] 111 | ) 112 | }) 113 | tles <- do.call(rbind, tles) 114 | 115 | # parse() drops comments and whitespace so we add them back in 116 | gaps <- data.frame(start = c(1, pos$end + 1), end = c(pos$start - 1, n)) 117 | gaps <- gaps[gaps$start <= gaps$end, , ] 118 | # some indexing magic in order to vectorise the extraction 119 | lengths <- gaps$end - gaps$start + 1 120 | lines <- sequence(lengths) + rep(gaps$start, lengths) - 1 121 | 122 | comments <- data.frame( 123 | src = x[lines], 124 | expr = empty_expr(length(lines)), 125 | line = lines 126 | ) 127 | 128 | res <- rbind(tles, comments) 129 | res <- res[order(res$line), c("src", "expr")] 130 | 131 | # Restore newlines stripped while converting to vector of lines 132 | if (length(res$src)) { 133 | res$src <- paste0(res$src, "\n") 134 | } else { 135 | res$src <- character() 136 | } 137 | 138 | res$expr <- lapply(res$expr, removeSource) 139 | 140 | rownames(res) <- NULL 141 | res 142 | } 143 | 144 | #' @export 145 | parse_all.connection <- function(x, filename = NULL, ...) { 146 | if (!isOpen(x, "r")) { 147 | open(x, "r") 148 | defer(close(x)) 149 | } 150 | text <- readLines(x) 151 | filename <- filename %||% summary(x)$description 152 | 153 | parse_all(text, filename, ...) 154 | } 155 | 156 | #' @export 157 | parse_all.function <- function(x, filename = NULL, ...) { 158 | filename <- filename %||% "" 159 | parse_all(find_function_body(x), filename = filename, ...) 160 | } 161 | 162 | # Calls are already parsed and always length one 163 | #' @export 164 | parse_all.call <- function(x, filename = NULL, ...) { 165 | parse_all(deparse(x), filename = filename, ...) 166 | } 167 | 168 | # Helpers --------------------------------------------------------------------- 169 | 170 | empty_expr <- function(n = 1) { 171 | I(rep(list(expression()), n)) 172 | } 173 | 174 | is_new_line <- function(start, end) { 175 | if (length(start) == 0) { 176 | logical() 177 | } else if (length(start) == 1) { 178 | TRUE 179 | } else { 180 | c(TRUE, start[-1] != end[-length(end)]) 181 | } 182 | } 183 | 184 | find_function_body <- function(f) { 185 | if (is_call(body(f), "{")) { 186 | lines <- deparse(f, control = "useSource") 187 | expr <- parse(text = lines, keep.source = TRUE) 188 | 189 | data <- getParseData(expr) 190 | token_start <- which(data$token == "'{'")[[1]] 191 | token_end <- last(which(data$token == "'}'")) 192 | 193 | line_start <- data$line1[token_start] + 1 194 | line_end <- data$line2[token_end] - 1 195 | lines <- lines[seq2(line_start, line_end)] 196 | 197 | dedent <- min(data$col1[seq2(token_start + 1, token_end - 1)], 1e3) 198 | substr(lines, dedent, nchar(lines)) 199 | } else { 200 | deparse(body(f)) 201 | } 202 | } 203 | -------------------------------------------------------------------------------- /R/replay.R: -------------------------------------------------------------------------------- 1 | #' Replay a list of evaluated results 2 | #' 3 | #' Replay a list of evaluated results, as if you'd run them in an R 4 | #' terminal. 5 | #' 6 | #' @param x result from [evaluate()] 7 | #' @export 8 | #' @examples 9 | #' f1 <- function() { 10 | #' cat("1\n") 11 | #' print("2") 12 | #' warning("3") 13 | #' print("4") 14 | #' message("5") 15 | #' stop("6") 16 | #' } 17 | #' replay(evaluate("f1()")) 18 | #' 19 | #' f2 <- function() { 20 | #' message("Hello") 21 | #' plot(1:10) 22 | #' message("Goodbye") 23 | #' } 24 | #' replay(evaluate("f2()")) 25 | replay <- function(x) { 26 | UseMethod("replay", x) 27 | } 28 | 29 | #' @export 30 | replay.list <- function(x) { 31 | invisible(lapply(x, replay)) 32 | } 33 | 34 | #' @export 35 | replay.default <- function(x) { 36 | render(x, TRUE, parent.frame()) 37 | } 38 | 39 | #' @export 40 | replay.character <- function(x) { 41 | cat(x) 42 | } 43 | 44 | #' @export 45 | replay.source <- function(x) { 46 | cat(line_prompt(x$src)) 47 | } 48 | 49 | #' @export 50 | replay.condition <- function(x) { 51 | cat_line(format_condition(x)) 52 | } 53 | 54 | #' @export 55 | replay.recordedplot <- function(x) { 56 | print(x) 57 | } 58 | 59 | format_condition <- function(x) { 60 | if (inherits(x, "message")) { 61 | return(gsub("\n$", "", conditionMessage(x))) 62 | } 63 | 64 | if (inherits(x, "error")) { 65 | type <- "Error" 66 | } else if (inherits(x, "warning")) { 67 | type <- "Warning" 68 | } 69 | 70 | call <- conditionCall(x) 71 | if (is.null(call)) { 72 | header <- paste0(type, ":") 73 | } else { 74 | header <- paste0(type, " in ", deparse1(call), ":") 75 | } 76 | 77 | body <- conditionMessage(x) 78 | paste0(header, "\n", body) 79 | } 80 | 81 | #' Line prompt. 82 | #' 83 | #' Format a single expression as if it had been entered at the command prompt. 84 | #' 85 | #' @param x string representing a single expression 86 | #' @param prompt prompt for first line 87 | #' @param continue prompt for subsequent lines 88 | #' @keywords internal 89 | #' @return a string 90 | line_prompt <- function( 91 | x, 92 | prompt = getOption("prompt"), 93 | continue = getOption("continue") 94 | ) { 95 | lines <- strsplit(x, "\n")[[1]] 96 | n <- length(lines) 97 | 98 | lines[1] <- paste0(prompt, lines[1]) 99 | if (n > 1) { 100 | lines[2:n] <- paste0(continue, lines[2:n]) 101 | } 102 | 103 | paste0(lines, "\n", collapse = "") 104 | } 105 | -------------------------------------------------------------------------------- /R/reproducible-output.R: -------------------------------------------------------------------------------- 1 | #' Control common output options 2 | #' 3 | #' @description 4 | #' Often when using `evaluate()` you are running R code with a specific output 5 | #' context in mind. But there are many options and env vars that packages 6 | #' will take from the current environment, meaning that output depends on 7 | #' the current state in undesirable ways. 8 | #' 9 | #' This function allows you to describe the characteristics of the desired 10 | #' output and takes care of setting the options and environment variables 11 | #' for you. 12 | #' 13 | #' @export 14 | #' @param width Value of the `"width"` option. 15 | #' @param color Determines whether or not cli/crayon colour should be used. 16 | #' @param unicode Should we use unicode characaters where possible? 17 | #' @param hyperlinks Should we use ANSI hyperlinks? 18 | #' @param rstudio Should we pretend that we're running inside of RStudio? 19 | #' @param frame Scope of the changes; when this calling frame terminates the 20 | #' changes will be undone. For expert use only. 21 | local_reproducible_output <- function( 22 | width = 80, 23 | color = FALSE, 24 | unicode = FALSE, 25 | hyperlinks = FALSE, 26 | rstudio = FALSE, 27 | frame = parent.frame() 28 | ) { 29 | local_options( 30 | # crayon 31 | crayon.enabled = color, 32 | 33 | # cli 34 | cli.width = width, 35 | cli.condition_width = width, 36 | cli.num_colors = if (color) 8L else 1L, 37 | cli.hyperlink = hyperlinks, 38 | cli.hyperlink_run = hyperlinks, 39 | cli.hyperlink_help = hyperlinks, 40 | cli.hyperlink_vignette = hyperlinks, 41 | cli.unicode = unicode, 42 | cli.dynamic = FALSE, 43 | 44 | # base R 45 | width = width, 46 | useFancyQuotes = unicode, 47 | 48 | # rlang 49 | rlang_interactive = FALSE, 50 | .frame = frame 51 | ) 52 | 53 | local_envvar( 54 | NO_COLOR = if (color) NA else 1, 55 | 56 | # Simulate RStudio 57 | RSTUDIO = if (rstudio) 1 else NA, 58 | RSTUDIO_SESSION_PID = if (rstudio) Sys.getpid() else NA, 59 | RSTUDIO_CHILD_PROCESS_PANE = if (rstudio) "build" else NA, 60 | RSTUDIO_CLI_HYPERLINKS = if (rstudio) 1 else NA, 61 | RSTUDIO_CONSOLE_WIDTH = width, 62 | .frame = frame 63 | ) 64 | 65 | local_collate("C", frame = frame) 66 | 67 | invisible() 68 | } 69 | 70 | local_options <- function(..., .frame = parent.frame()) { 71 | old <- options(...) 72 | defer(options(old), .frame) 73 | 74 | invisible() 75 | } 76 | 77 | local_envvar <- function(..., .frame = parent.frame()) { 78 | old <- set_envvar(list(...)) 79 | defer(set_envvar(old), .frame) 80 | 81 | invisible() 82 | } 83 | 84 | local_collate <- function(locale, frame = parent.frame()) { 85 | old <- Sys.getlocale("LC_COLLATE") 86 | defer(Sys.setlocale("LC_COLLATE", old), frame) 87 | Sys.setlocale("LC_COLLATE", locale) 88 | 89 | # From https://github.com/r-lib/withr/blob/v3.0.0/R/locale.R#L51-L55: 90 | # R supports setting LC_COLLATE to C via envvar. When that is the 91 | # case, it takes precedence over the currently set locale. We need 92 | # to set both the envvar and the locale for collate to fully take 93 | # effect. 94 | local_envvar(LC_COLLATE = locale, .frame = frame) 95 | 96 | invisible() 97 | } 98 | 99 | # adapted from withr:::set_envvar 100 | set_envvar <- function(envs) { 101 | if (length(envs) == 0) { 102 | return() 103 | } 104 | 105 | old <- Sys.getenv(names(envs), names = TRUE, unset = NA) 106 | set <- !is.na(envs) 107 | 108 | if (any(set)) do.call("Sys.setenv", as.list(envs[set])) 109 | if (any(!set)) Sys.unsetenv(names(envs)[!set]) 110 | 111 | invisible(old) 112 | } 113 | -------------------------------------------------------------------------------- /R/traceback.R: -------------------------------------------------------------------------------- 1 | #' Generate a traceback from a list of calls 2 | #' 3 | #' @param callstack stack of calls, as generated by (e.g.) 4 | #' [base::sys.calls()] 5 | #' @keywords internal 6 | #' @export 7 | create_traceback <- function(callstack) { 8 | if (length(callstack) == 0) { 9 | return() 10 | } 11 | 12 | # Convert to text 13 | calls <- lapply(callstack, deparse, width = 500) 14 | calls <- sapply(calls, paste0, collapse = "\n") 15 | 16 | # Number and indent 17 | calls <- paste0(seq_along(calls), ": ", calls) 18 | calls <- sub("\n", "\n ", calls) 19 | calls 20 | } 21 | 22 | #' Try, capturing stack on error 23 | #' 24 | #' This is a variant of [tryCatch()] that also captures the call 25 | #' stack if an error occurs. 26 | #' 27 | #' @param quoted_code code to evaluate, in quoted form 28 | #' @param env environment in which to execute code 29 | #' @keywords internal 30 | #' @export 31 | try_capture_stack <- function(quoted_code, env) { 32 | capture_calls <- function(e) { 33 | # Make sure a "call" component exists to avoid warnings with partial 34 | # matching in conditionCall.condition() 35 | e["call"] <- e["call"] 36 | 37 | # Capture call stack, removing last two calls from end (added by 38 | # withCallingHandlers), and first frame + 7 calls from start (added by 39 | # tryCatch etc) 40 | e$calls <- head(sys.calls()[-seq_len(frame + 7)], -2) 41 | signalCondition(e) 42 | } 43 | frame <- sys.nframe() 44 | 45 | tryCatch( 46 | withCallingHandlers(eval(quoted_code, env), error = capture_calls), 47 | error = identity 48 | ) 49 | } 50 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | cat_line <- function(..., file = stdout()) { 2 | cat(paste0(..., "\n", collapse = ""), file = file) 3 | } 4 | 5 | indent <- function(x, by = " ", drop_trailing_nl = TRUE) { 6 | if (drop_trailing_nl) { 7 | x <- gsub("\n$", "", x) 8 | } 9 | paste0(by, gsub("\n", paste0("\n", by), x)) 10 | } 11 | 12 | defer <- function(expr, frame = parent.frame(), after = FALSE) { 13 | thunk <- as.call(list(function() expr)) 14 | do.call(on.exit, list(thunk, TRUE, after), envir = frame) 15 | } 16 | 17 | `%||%` <- function(a, b) if (is.null(a)) b else a 18 | 19 | env_var_is_true <- function(x) { 20 | isTRUE(as.logical(Sys.getenv(x, "false"))) 21 | } 22 | 23 | is_call <- function(x, name) { 24 | if (!is.call(x)) { 25 | return(FALSE) 26 | } 27 | is.name(x[[1]]) && as.character(x[[1]]) %in% name 28 | } 29 | 30 | last <- function(x) x[length(x)] 31 | 32 | seq2 <- function(start, end, by = 1) { 33 | if (start > end) { 34 | integer() 35 | } else { 36 | seq(start, end, by = 1) 37 | } 38 | } 39 | 40 | can_parse <- function(x) { 41 | if (!is.character(x)) { 42 | return(TRUE) 43 | } 44 | 45 | tryCatch( 46 | { 47 | parse(text = x) 48 | TRUE 49 | }, 50 | error = function(e) FALSE 51 | ) 52 | } 53 | 54 | deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { 55 | paste(deparse(expr, width.cutoff, ...), collapse = collapse) 56 | } 57 | -------------------------------------------------------------------------------- /R/watchout.R: -------------------------------------------------------------------------------- 1 | watchout <- function( 2 | handler = new_output_handler(), 3 | new_device = TRUE, 4 | debug = FALSE, 5 | frame = parent.frame() 6 | ) { 7 | if (new_device) { 8 | # Ensure we have a graphics device available for recording, but choose 9 | # one that's available on all platforms and doesn't write to disk. 10 | if (has_ragg()) { 11 | ragg::agg_record() 12 | } else { 13 | pdf(file = NULL) 14 | } 15 | dev.control(displaylist = "enable") 16 | dev <- dev.cur() 17 | defer(dev.off(dev), frame) 18 | } 19 | 20 | # Maintain a list of outputs that we'll grow over time 21 | output <- list() 22 | i <- 1 23 | push <- function(value) { 24 | output[i] <<- list(value) 25 | i <<- i + 1 26 | 27 | switch( 28 | output_type(value), 29 | plot = handler$graphics(value), 30 | text = handler$text(value), 31 | message = handler$message(value), 32 | warning = handler$warning(value), 33 | error = handler$error(value) 34 | ) 35 | 36 | invisible() 37 | } 38 | push_source <- function(src, tle) { 39 | source <- new_source(src, tle, handler$source) 40 | if (!is.null(source)) { 41 | push(source) 42 | } 43 | } 44 | 45 | # record current devices for plot handling 46 | last_plot <- NULL 47 | devn <- length(dev.list()) 48 | dev <- dev.cur() 49 | 50 | sink_con <- local_persistent_sink_connection(debug, frame) 51 | 52 | capture_plot <- function(incomplete = FALSE) { 53 | # no plots open; par("page") will open a device 54 | if (is.null(dev.list())) { 55 | return() 56 | } 57 | 58 | # only record plots for our graphics device 59 | if (!identical(dev.cur(), dev)) { 60 | return() 61 | } 62 | 63 | # current page is incomplete 64 | if (!par("page") && !incomplete) { 65 | return() 66 | } 67 | 68 | plot <- recordPlot() 69 | if (!makes_visual_change(plot[[1]])) { 70 | return() 71 | } 72 | 73 | if (!looks_different(last_plot[[1]], plot[[1]])) { 74 | return() 75 | } 76 | 77 | last_plot <<- plot 78 | push(plot) 79 | invisible() 80 | } 81 | 82 | capture_output <- function() { 83 | out <- sink_con() 84 | if (!is.null(out)) { 85 | push(out) 86 | } 87 | invisible() 88 | } 89 | 90 | capture_plot_and_output <- function() { 91 | capture_plot() 92 | capture_output() 93 | } 94 | 95 | print_value <- function(value, visible, envir) { 96 | if (!show_value(handler, visible)) { 97 | return() 98 | } 99 | 100 | pv <- withVisible(handle_value(handler, value, visible, envir)) 101 | capture_plot_and_output() 102 | # If the return value is visible, save the value to the output 103 | if (pv$visible) { 104 | push(pv$value) 105 | } 106 | } 107 | 108 | check_devices <- function() { 109 | # if dev.off() was called, make sure to restore device to the one opened 110 | # when watchout() was called 111 | if (length(dev.list()) < devn) { 112 | dev.set(dev) 113 | } 114 | devn <<- length(dev.list()) 115 | invisible() 116 | } 117 | 118 | local_console_flusher(capture_output, frame = frame) 119 | local_plot_hooks(capture_plot_and_output, frame = frame) 120 | 121 | list( 122 | capture_plot = capture_plot, 123 | capture_output = capture_output, 124 | capture_plot_and_output = capture_plot_and_output, 125 | check_devices = check_devices, 126 | push = push, 127 | push_source = push_source, 128 | print_value = print_value, 129 | get = function() new_evaluation(output) 130 | ) 131 | } 132 | 133 | # Persistent way to capture output --------------------------------------------- 134 | 135 | local_persistent_sink_connection <- function( 136 | debug = FALSE, 137 | frame = parent.frame() 138 | ) { 139 | con <- file("", "w+b") 140 | defer(if (isValid(con)) close(con), frame) 141 | 142 | # try() defaults to using stderr() so we need to explicitly override(#88) 143 | old <- options(try.outFile = con) 144 | defer(options(old), frame) 145 | 146 | sink(con, split = debug) 147 | sinkn <- sink.number() 148 | defer(if (sink.number() >= sinkn) sink(), frame) 149 | 150 | function() { 151 | if (!isValid(con)) { 152 | con <<- file("", "w+b") 153 | options(try.outFile = con) 154 | } 155 | 156 | if (sink.number() < sinkn) { 157 | sink(con) 158 | sinkn <<- sink.number() 159 | } 160 | 161 | read_con(con) 162 | } 163 | } 164 | 165 | read_con <- function(con, buffer = 32 * 1024) { 166 | bytes <- raw() 167 | repeat { 168 | new <- readBin(con, "raw", n = buffer) 169 | if (length(new) == 0) break 170 | bytes <- c(bytes, new) 171 | } 172 | if (length(bytes) == 0) { 173 | NULL 174 | } else { 175 | rawToChar(bytes) 176 | } 177 | } 178 | 179 | # isOpen doesn't work for two reasons: 180 | # 1. It errors if con has been closed, rather than returning FALSE 181 | # 2. If returns TRUE if con has been closed and a new connection opened 182 | # 183 | # So instead we retrieve the connection from its number and compare to the 184 | # original connection. This works because connections have an undocumented 185 | # external pointer. 186 | isValid <- function(con) { 187 | tryCatch( 188 | identical(getConnection(con), con), 189 | error = function(cnd) FALSE 190 | ) 191 | } 192 | 193 | has_ragg <- function() { 194 | requireNamespace("ragg", quietly = TRUE) && 195 | exists("agg_record", getNamespace("ragg")) 196 | } 197 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # used evaluate() to avoid overhead of calling new_output_handler() repeatedly 2 | evaluate_default_output_handler <- NULL 3 | # used by knitr, as above, but also for value handler 4 | default_output_handler <- NULL 5 | 6 | .onLoad <- function(...) { 7 | evaluate_default_output_handler <<- new_output_handler() 8 | default_output_handler <<- new_output_handler() 9 | # Match knitr's expectations 10 | default_output_handler$value <<- function(x) { 11 | render(x, visible = TRUE, envir = parent.frame()) 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # evaluate 2 | 3 | 4 | [![R-CMD-check](https://github.com/r-lib/evaluate/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/evaluate/actions/workflows/R-CMD-check.yaml) 5 | [![CRAN status](https://www.r-pkg.org/badges/version/evaluate)](https://CRAN.R-project.org/package=evaluate) 6 | [![Downloads from the RStudio CRAN mirror](https://cranlogs.r-pkg.org/badges/evaluate)](https://cran.r-project.org/package=evaluate) 7 | [![Codecov test coverage](https://codecov.io/gh/r-lib/evaluate/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/evaluate?branch=main) 8 | 9 | 10 | evaluate provides tools that allow you to recreate the parsing, evaluation and 11 | display of R code, with enough information that you can accurately recreate what 12 | happens at the command line. Evaluate + replay works very similarly to 13 | `source()`, but is written in such a way to make it easy to adapt for other 14 | output formats, such as html or latex. 15 | 16 | ```R 17 | library(evaluate) 18 | ``` 19 | 20 | There are three components to the `evaluate` package: 21 | 22 | * `parse_all()`, a version of parse that keeps expressions with their original 23 | source code, maintaining formatting and comments. 24 | * `evaluate()`, which evaluates each expression produced by `parse_all()`, 25 | tracking all output, messages, warnings, and errors as their occur, and 26 | interleaving them in the correct order with the original source and value 27 | of the expression. 28 | * `replay()`, which outputs these pieces in a way that makes it look like you've 29 | entered the code at the command line. This function also serves as a 30 | template for other output formats. 31 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: evaluate.r-lib.org 2 | 3 | template: 4 | package: tidytemplate 5 | bootstrap: 5 6 | 7 | includes: 8 | in_header: | 9 | 10 | 11 | development: 12 | mode: auto 13 | -------------------------------------------------------------------------------- /air.toml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/evaluate/ec9ca4e2e4fa0b7c7ccf9f9d11be19a163478ab7/air.toml -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## R CMD check results 2 | 3 | 0 errors | 0 warnings | 0 notes 4 | 5 | ## revdepcheck results 6 | 7 | We checked 21 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 8 | 9 | * We saw 0 new problems 10 | * We failed to check 0 packages 11 | -------------------------------------------------------------------------------- /evaluate.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageInstallArgs: -v && Rscript -e "Rd2roxygen::rab(install=T,build=F)" 20 | PackageBuildArgs: -v && Rscript -e "Rd2roxygen::rab()" 21 | PackageCheckArgs: --as-cran 22 | -------------------------------------------------------------------------------- /man/create_traceback.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/traceback.R 3 | \name{create_traceback} 4 | \alias{create_traceback} 5 | \title{Generate a traceback from a list of calls} 6 | \usage{ 7 | create_traceback(callstack) 8 | } 9 | \arguments{ 10 | \item{callstack}{stack of calls, as generated by (e.g.) 11 | \code{\link[base:sys.parent]{base::sys.calls()}}} 12 | } 13 | \description{ 14 | Generate a traceback from a list of calls 15 | } 16 | \keyword{internal} 17 | -------------------------------------------------------------------------------- /man/evaluate-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/evaluate-package.R 3 | \docType{package} 4 | \name{evaluate-package} 5 | \alias{evaluate-package} 6 | \title{evaluate: Parsing and Evaluation Tools that Provide More Details than the Default} 7 | \description{ 8 | Parsing and evaluation tools that make it easy to recreate the command line behaviour of R. 9 | } 10 | \seealso{ 11 | Useful links: 12 | \itemize{ 13 | \item \url{https://evaluate.r-lib.org/} 14 | \item \url{https://github.com/r-lib/evaluate} 15 | \item Report bugs at \url{https://github.com/r-lib/evaluate/issues} 16 | } 17 | 18 | } 19 | \author{ 20 | \strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} 21 | 22 | Authors: 23 | \itemize{ 24 | \item Yihui Xie (\href{https://orcid.org/0000-0003-0645-5666}{ORCID}) 25 | } 26 | 27 | Other contributors: 28 | \itemize{ 29 | \item Michael Lawrence [contributor] 30 | \item Thomas Kluyver [contributor] 31 | \item Jeroen Ooms [contributor] 32 | \item Barret Schloerke [contributor] 33 | \item Adam Ryczkowski [contributor] 34 | \item Hiroaki Yutani [contributor] 35 | \item Michel Lang [contributor] 36 | \item Karolis Koncevičius [contributor] 37 | \item Posit Software, PBC [copyright holder, funder] 38 | } 39 | 40 | } 41 | \keyword{internal} 42 | -------------------------------------------------------------------------------- /man/evaluate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/evaluate.R 3 | \name{evaluate} 4 | \alias{evaluate} 5 | \title{Evaluate input and return all details of evaluation} 6 | \usage{ 7 | evaluate( 8 | input, 9 | envir = parent.frame(), 10 | enclos = NULL, 11 | debug = FALSE, 12 | stop_on_error = 0L, 13 | keep_warning = TRUE, 14 | keep_message = TRUE, 15 | log_echo = FALSE, 16 | log_warning = FALSE, 17 | new_device = TRUE, 18 | output_handler = NULL, 19 | filename = NULL, 20 | include_timing = FALSE 21 | ) 22 | } 23 | \arguments{ 24 | \item{input}{input object to be parsed and evaluated. May be a string, file 25 | connection or function. Passed on to \code{\link[=parse_all]{parse_all()}}.} 26 | 27 | \item{envir}{environment in which to evaluate expressions.} 28 | 29 | \item{enclos}{when \code{envir} is a list or data frame, this is treated as 30 | the parent environment to \code{envir}.} 31 | 32 | \item{debug}{if \code{TRUE}, displays information useful for debugging, 33 | including all output that evaluate captures.} 34 | 35 | \item{stop_on_error}{A number between 0 and 2 that controls what happens 36 | when the code errors: 37 | \itemize{ 38 | \item If \code{0}, the default, will continue running all code, just as if you'd 39 | pasted the code into the command line. 40 | \item If \code{1}, evaluation will stop on first error without signaling the error, 41 | and you will get back all results up to that point. 42 | \item If \code{2}, evaluation will halt on first error and you will get back no 43 | results. 44 | }} 45 | 46 | \item{keep_warning, keep_message}{A single logical value that controls what 47 | happens to warnings and messages. 48 | \itemize{ 49 | \item If \code{TRUE}, the default, warnings and messages will be captured in the 50 | output. 51 | \item If \code{NA}, warnings and messages will not be captured and bubble up to 52 | the calling environment of \code{evaluate()}. 53 | \item If \code{FALSE}, warnings and messages will be completed supressed and 54 | not shown anywhere. 55 | } 56 | 57 | Note that setting the envvar \code{R_EVALUATE_BYPASS_MESSAGES} to \code{true} will 58 | force these arguments to be set to \code{NA}.} 59 | 60 | \item{log_echo, log_warning}{If \code{TRUE}, will immediately log code and 61 | warnings (respectively) to \code{stderr}. 62 | 63 | This will be force to \code{TRUE} if env var \code{ACTIONS_STEP_DEBUG} is 64 | \code{true}, as when debugging a failing GitHub Actions workflow.} 65 | 66 | \item{new_device}{if \code{TRUE}, will open a new graphics device and 67 | automatically close it after completion. This prevents evaluation from 68 | interfering with your existing graphics environment.} 69 | 70 | \item{output_handler}{an instance of \code{\link[=output_handler]{output_handler()}} that 71 | processes the output from the evaluation. The default simply prints the 72 | visible return values.} 73 | 74 | \item{filename}{string overrriding the \code{\link[base:srcfile]{base::srcfile()}} filename.} 75 | 76 | \item{include_timing}{Deprecated.} 77 | } 78 | \description{ 79 | Compare to \code{\link[=eval]{eval()}}, \code{evaluate} captures all of the 80 | information necessary to recreate the output as if you had copied and pasted 81 | the code into a R terminal. It captures messages, warnings, errors and 82 | output, all correctly interleaved in the order in which they occured. It 83 | stores the final result, whether or not it should be visible, and the 84 | contents of the current graphics device. 85 | } 86 | \examples{ 87 | evaluate(c( 88 | "1 + 1", 89 | "2 + 2" 90 | )) 91 | 92 | # Not that's there's a difference in output between putting multiple 93 | # expressions on one line vs spreading them across multiple lines 94 | evaluate("1;2;3") 95 | evaluate(c("1", "2", "3")) 96 | 97 | # This also affects how errors propagate, matching the behaviour 98 | # of the R console 99 | evaluate("1;stop(2);3") 100 | evaluate(c("1", "stop(2)", "3")) 101 | } 102 | -------------------------------------------------------------------------------- /man/flush_console.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/flush-console.R 3 | \name{flush_console} 4 | \alias{flush_console} 5 | \title{An emulation of \code{flush.console()} in \code{evaluate()}} 6 | \usage{ 7 | flush_console() 8 | } 9 | \description{ 10 | When \code{\link[=evaluate]{evaluate()}} is evaluating code, the text output is diverted into 11 | an internal connection, and there is no way to flush that connection. This 12 | function provides a way to "flush" the connection so that any text output can 13 | be immediately written out, and more importantly, the \code{text} handler 14 | (specified in the \code{output_handler} argument of \code{evaluate()}) will 15 | be called, which makes it possible for users to know it when the code 16 | produces text output using the handler. 17 | 18 | This function is supposed to be called inside \code{evaluate()} (e.g. 19 | either a direct \code{evaluate()} call or in \pkg{knitr} code chunks). 20 | } 21 | -------------------------------------------------------------------------------- /man/inject_funs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/inject-funs.R 3 | \name{inject_funs} 4 | \alias{inject_funs} 5 | \title{Inject functions into the environment of \code{evaluate()}} 6 | \usage{ 7 | inject_funs(...) 8 | } 9 | \arguments{ 10 | \item{...}{Named arguments of functions. If empty, previously injected 11 | functions will be emptied.} 12 | } 13 | \value{ 14 | Invisibly returns previous values. 15 | } 16 | \description{ 17 | Create functions in the environment specified in the \code{envir} argument of 18 | \code{\link[=evaluate]{evaluate()}}. This can be helpful if you want to substitute certain 19 | functions when evaluating the code. To make sure it does not wipe out 20 | existing functions in the environment, only functions that do not exist in 21 | the environment are injected. 22 | } 23 | \note{ 24 | For expert use only. Do not use it unless you clearly understand it. 25 | } 26 | \examples{ 27 | library(evaluate) 28 | # normally you cannot capture the output of system 29 | evaluate("system('R --version')") 30 | 31 | # replace the system() function 32 | old <- inject_funs(system = function(...) { 33 | cat(base::system(..., intern = TRUE), sep = "\n") 34 | }) 35 | 36 | evaluate("system('R --version')") 37 | 38 | # restore previously injected functions 39 | inject_funs(old) 40 | } 41 | \keyword{internal} 42 | -------------------------------------------------------------------------------- /man/is.message.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/evaluation.R 3 | \name{is.message} 4 | \alias{is.message} 5 | \alias{is.warning} 6 | \alias{is.error} 7 | \alias{is.source} 8 | \alias{is.recordedplot} 9 | \title{Object class tests} 10 | \usage{ 11 | is.message(x) 12 | 13 | is.warning(x) 14 | 15 | is.error(x) 16 | 17 | is.source(x) 18 | 19 | is.recordedplot(x) 20 | } 21 | \description{ 22 | Object class tests 23 | } 24 | \keyword{internal} 25 | -------------------------------------------------------------------------------- /man/line_prompt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/replay.R 3 | \name{line_prompt} 4 | \alias{line_prompt} 5 | \title{Line prompt.} 6 | \usage{ 7 | line_prompt(x, prompt = getOption("prompt"), continue = getOption("continue")) 8 | } 9 | \arguments{ 10 | \item{x}{string representing a single expression} 11 | 12 | \item{prompt}{prompt for first line} 13 | 14 | \item{continue}{prompt for subsequent lines} 15 | } 16 | \value{ 17 | a string 18 | } 19 | \description{ 20 | Format a single expression as if it had been entered at the command prompt. 21 | } 22 | \keyword{internal} 23 | -------------------------------------------------------------------------------- /man/local_reproducible_output.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/reproducible-output.R 3 | \name{local_reproducible_output} 4 | \alias{local_reproducible_output} 5 | \title{Control common output options} 6 | \usage{ 7 | local_reproducible_output( 8 | width = 80, 9 | color = FALSE, 10 | unicode = FALSE, 11 | hyperlinks = FALSE, 12 | rstudio = FALSE, 13 | frame = parent.frame() 14 | ) 15 | } 16 | \arguments{ 17 | \item{width}{Value of the \code{"width"} option.} 18 | 19 | \item{color}{Determines whether or not cli/crayon colour should be used.} 20 | 21 | \item{unicode}{Should we use unicode characaters where possible?} 22 | 23 | \item{hyperlinks}{Should we use ANSI hyperlinks?} 24 | 25 | \item{rstudio}{Should we pretend that we're running inside of RStudio?} 26 | 27 | \item{frame}{Scope of the changes; when this calling frame terminates the 28 | changes will be undone. For expert use only.} 29 | } 30 | \description{ 31 | Often when using \code{evaluate()} you are running R code with a specific output 32 | context in mind. But there are many options and env vars that packages 33 | will take from the current environment, meaning that output depends on 34 | the current state in undesirable ways. 35 | 36 | This function allows you to describe the characteristics of the desired 37 | output and takes care of setting the options and environment variables 38 | for you. 39 | } 40 | -------------------------------------------------------------------------------- /man/new_output_handler.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/output-handler.R 3 | \name{new_output_handler} 4 | \alias{new_output_handler} 5 | \alias{output_handler} 6 | \title{Custom output handlers} 7 | \usage{ 8 | new_output_handler( 9 | source = identity, 10 | text = identity, 11 | graphics = identity, 12 | message = identity, 13 | warning = identity, 14 | error = identity, 15 | value = render, 16 | calling_handlers = list() 17 | ) 18 | } 19 | \arguments{ 20 | \item{source}{Function to handle the echoed source code under evaluation. 21 | This function should take two arguments (\code{src} and \code{expr}), and return 22 | an object that will be inserted into the evaluate outputs. \code{src} is the 23 | unparsed text of the source code, and \code{expr} is the complete input 24 | expression (which may have 0, 1, 2, or more components; see \code{\link[=parse_all]{parse_all()}} 25 | for details). 26 | 27 | Return \code{src} for the default evaluate behaviour. Return \code{NULL} to 28 | drop the source from the output.} 29 | 30 | \item{text}{Function to handle any textual console output.} 31 | 32 | \item{graphics}{Function to handle graphics, as returned by 33 | \code{\link[=recordPlot]{recordPlot()}}.} 34 | 35 | \item{message}{Function to handle \code{\link[=message]{message()}} output.} 36 | 37 | \item{warning}{Function to handle \code{\link[=warning]{warning()}} output.} 38 | 39 | \item{error}{Function to handle \code{\link[=stop]{stop()}} output.} 40 | 41 | \item{value}{Function to handle the values returned from evaluation. 42 | \itemize{ 43 | \item If it has one argument, it called on visible values. 44 | \item If it has two arguments, it handles all values, with the second 45 | argument indicating whether or not the value is visible. 46 | \item If it has three arguments, it will be called on all values, with the 47 | the third argument given the evaluation environment which is needed 48 | to look up print methods for S3 objects. 49 | }} 50 | 51 | \item{calling_handlers}{List of \link[=withCallingHandlers]{calling handlers}. 52 | These handlers have precedence over the exiting handler installed 53 | by \code{\link[=evaluate]{evaluate()}} when \code{stop_on_error} is set to 0.} 54 | } 55 | \value{ 56 | A new \code{output_handler} object 57 | } 58 | \description{ 59 | An \code{output_handler} handles the results of \code{\link[=evaluate]{evaluate()}}, 60 | including the values, graphics, conditions. Each type of output is handled by 61 | a particular function in the handler object. 62 | } 63 | \details{ 64 | The handler functions should accept an output object as their first argument. 65 | The return value of the handlers is ignored, except in the case of the 66 | \code{value} handler, where a visible return value is saved in the output 67 | list. 68 | 69 | Calling the constructor with no arguments results in the default handler, 70 | which mimics the behavior of the console by printing visible values. 71 | 72 | Note that recursion is common: for example, if \code{value} does any 73 | printing, then the \code{text} or \code{graphics} handlers may be called. 74 | } 75 | -------------------------------------------------------------------------------- /man/parse_all.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parse_all.R 3 | \name{parse_all} 4 | \alias{parse_all} 5 | \title{Parse, retaining comments} 6 | \usage{ 7 | parse_all(x, filename = NULL, allow_error = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{object to parse. Can be a string, a file connection, or a function. 11 | If a connection, will be opened and closed only if it was closed initially.} 12 | 13 | \item{filename}{string overriding the file name} 14 | 15 | \item{allow_error}{whether to allow syntax errors in \code{x}} 16 | } 17 | \value{ 18 | A data frame two columns, \code{src} and \code{expr}, and one row for each complete 19 | input in \code{x}. A complete input is R code that would trigger execution when 20 | typed at the console. This might consist of multiple expressions separated 21 | by \verb{;} or one expression spread over multiple lines (like a function 22 | definition). 23 | 24 | \code{src} is a character vector of source code. Each element represents a 25 | complete input expression (which might span multiple line) and always has a 26 | terminal \verb{\\n}. 27 | 28 | \code{expr} is a list-column of \link{expression}s. The expressions can be of any 29 | length, depending on the structure of the complete input source: 30 | \itemize{ 31 | \item If \code{src} consists of only only whitespace and/or comments, \code{expr} will 32 | be length 0. 33 | \item If \code{src} a single scalar (like \code{TRUE}, \code{1}, or \code{"x"}), name, or 34 | function call, \code{expr} will be length 1. 35 | \item If \code{src} contains multiple expressions separated by \verb{;}, \code{expr} will 36 | have length two or more. 37 | } 38 | 39 | The expressions have their srcrefs removed. 40 | 41 | If there are syntax errors in \code{x} and \code{allow_error = TRUE}, the data 42 | frame will have an attribute \code{PARSE_ERROR} that stores the error object. 43 | } 44 | \description{ 45 | Works very similarly to parse, but also keeps original formatting and 46 | comments. 47 | } 48 | \examples{ 49 | # Each of these inputs are single line, but generate different numbers of 50 | # expressions 51 | source <- c( 52 | "# a comment", 53 | "x", 54 | "x;y", 55 | "x;y;z" 56 | ) 57 | parsed <- parse_all(source) 58 | lengths(parsed$expr) 59 | str(parsed$expr) 60 | 61 | # Each of these inputs are a single expression, but span different numbers 62 | # of lines 63 | source <- c( 64 | "function() {}", 65 | "function() {", 66 | " # Hello!", 67 | "}", 68 | "function() {", 69 | " # Hello!", 70 | " # Goodbye!", 71 | "}" 72 | ) 73 | parsed <- parse_all(source) 74 | lengths(parsed$expr) 75 | parsed$src 76 | } 77 | -------------------------------------------------------------------------------- /man/replay.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/replay.R 3 | \name{replay} 4 | \alias{replay} 5 | \title{Replay a list of evaluated results} 6 | \usage{ 7 | replay(x) 8 | } 9 | \arguments{ 10 | \item{x}{result from \code{\link[=evaluate]{evaluate()}}} 11 | } 12 | \description{ 13 | Replay a list of evaluated results, as if you'd run them in an R 14 | terminal. 15 | } 16 | \examples{ 17 | f1 <- function() { 18 | cat("1\n") 19 | print("2") 20 | warning("3") 21 | print("4") 22 | message("5") 23 | stop("6") 24 | } 25 | replay(evaluate("f1()")) 26 | 27 | f2 <- function() { 28 | message("Hello") 29 | plot(1:10) 30 | message("Goodbye") 31 | } 32 | replay(evaluate("f2()")) 33 | } 34 | -------------------------------------------------------------------------------- /man/set_hooks.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/hooks.R 3 | \name{set_hooks} 4 | \alias{set_hooks} 5 | \alias{remove_hooks} 6 | \title{Set and remove hooks} 7 | \usage{ 8 | set_hooks(hooks, action = "append") 9 | 10 | remove_hooks(hooks) 11 | } 12 | \arguments{ 13 | \item{hooks}{a named list of hooks - each hook can either be a function or 14 | a list of functions.} 15 | 16 | \item{action}{\code{"replace"}, \code{"append"} or \code{"prepend"}} 17 | } 18 | \description{ 19 | This interface wraps the base \code{\link[=setHook]{setHook()}} function to provide a return 20 | value that makes it easy to undo. 21 | } 22 | \examples{ 23 | new1 <- list(before.plot.new = function() print("Plotted!")) 24 | new2 <- list(before.plot.new = function() print("Plotted Again!")) 25 | set_hooks(new1) 26 | set_hooks(new2) 27 | plot(1) 28 | remove_hooks(new1) 29 | plot(1) 30 | remove_hooks(new2) 31 | plot(1) 32 | } 33 | \keyword{internal} 34 | -------------------------------------------------------------------------------- /man/trim_intermediate_plots.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/graphics.R 3 | \name{trim_intermediate_plots} 4 | \alias{trim_intermediate_plots} 5 | \title{Trim away intermediate plots} 6 | \usage{ 7 | trim_intermediate_plots(x) 8 | } 9 | \arguments{ 10 | \item{x}{An evaluation object produced by \code{\link[=evaluate]{evaluate()}}.} 11 | } 12 | \value{ 13 | A modified evaluation object. 14 | } 15 | \description{ 16 | Trim off plots that are modified by subsequent lines to only show 17 | the "final" plot. 18 | } 19 | \examples{ 20 | ev <- evaluate(c( 21 | "plot(1:3)", 22 | "text(1, 1, 'x')", 23 | "text(1, 1, 'y')" 24 | )) 25 | 26 | # All intermediate plots are captured 27 | ev 28 | # Only the final plot is shown 29 | trim_intermediate_plots(ev) 30 | } 31 | -------------------------------------------------------------------------------- /man/try_capture_stack.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/traceback.R 3 | \name{try_capture_stack} 4 | \alias{try_capture_stack} 5 | \title{Try, capturing stack on error} 6 | \usage{ 7 | try_capture_stack(quoted_code, env) 8 | } 9 | \arguments{ 10 | \item{quoted_code}{code to evaluate, in quoted form} 11 | 12 | \item{env}{environment in which to execute code} 13 | } 14 | \description{ 15 | This is a variant of \code{\link[=tryCatch]{tryCatch()}} that also captures the call 16 | stack if an error occurs. 17 | } 18 | \keyword{internal} 19 | -------------------------------------------------------------------------------- /revdep/.gitignore: -------------------------------------------------------------------------------- 1 | checks 2 | library 3 | checks.noindex 4 | library.noindex 5 | cloud.noindex 6 | data.sqlite 7 | *.html 8 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Revdeps 2 | 3 | -------------------------------------------------------------------------------- /revdep/cran.md: -------------------------------------------------------------------------------- 1 | ## revdepcheck results 2 | 3 | We checked 21 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/failures.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- 1 | *Wow, no problems at all. :)* -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | library(evaluate) 2 | 3 | if (require("testthat", quietly = TRUE)) test_check("evaluate") 4 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions.md: -------------------------------------------------------------------------------- 1 | # log_warning causes warnings to be emitted 2 | 3 | Code 4 | ev <- evaluate("f()", log_warning = TRUE) 5 | Condition 6 | Warning in `f()`: 7 | Hi! 8 | 9 | # all three values of stop_on_error work as expected 10 | 11 | Code 12 | ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L) 13 | Condition 14 | Error: 15 | ! 1 16 | 17 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/abort-error.txt: -------------------------------------------------------------------------------- 1 | Error in `h()`: 2 | ! ! 3 | Backtrace: 4 | x 5 | 1. \-global f() 6 | 2. \-global g() 7 | 3. \-global h() 8 | 4. \-rlang::abort("!") 9 | Execution halted 10 | Ran 8/8 deferred expressions 11 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/rmd-abort-error.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | 6 | ``` r 7 | f <- function() g() 8 | g <- function() h() 9 | h <- function() rlang::abort("!") 10 | f() 11 | ``` 12 | 13 | ``` 14 | ## Error in `h()`: 15 | ## ! ! 16 | ## Backtrace: 17 | ## x 18 | ## 1. \-evaluate (local) f() 19 | ## 2. \-evaluate (local) g() 20 | ## 3. \-evaluate (local) h() 21 | ## 4. \-rlang::abort("!") 22 | ``` 23 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/rmd-abort-error.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | processing file: resources/with-abort-error.Rmd 4 | Error in `h()`: 5 | ! ! 6 | Backtrace: 7 | x 8 | 1. \-global f() 9 | 2. \-global g() 10 | 3. \-global h() 11 | 4. \-rlang::abort("!") 12 | 13 | Quitting from resources/with-abort-error.Rmd:5-10 [unnamed-chunk-1] 14 | Execution halted 15 | Ran 8/8 deferred expressions 16 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | processing file: resources/with-stop-error-auto-entrace.Rmd 4 | Error in `h()`: 5 | ! ! 6 | Backtrace: 7 | x 8 | 1. \-global f() 9 | 2. \-global g() 10 | 3. \-global h() 11 | 12 | Quitting from resources/with-stop-error-auto-entrace.Rmd:5-10 [unnamed-chunk-1] 13 | Execution halted 14 | Ran 8/8 deferred expressions 15 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | 6 | ``` r 7 | rlang::global_entrace() 8 | options(rlang_backtrace_on_error_report = "full") 9 | ``` 10 | 11 | 12 | ``` r 13 | f <- function() g() 14 | g <- function() h() 15 | h <- function() stop("!") 16 | f() 17 | ``` 18 | 19 | ``` 20 | ## Error in `h()`: 21 | ## ! ! 22 | ## Backtrace: 23 | ## x 24 | ## 1. \-evaluate (local) f() 25 | ## 2. \-evaluate (local) g() 26 | ## 3. \-evaluate (local) h() 27 | ``` 28 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/rmd-stop-error.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | 6 | ``` r 7 | f <- function() g() 8 | g <- function() h() 9 | h <- function() stop("!") 10 | f() 11 | ``` 12 | 13 | ``` 14 | ## Error in h(): ! 15 | ``` 16 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/stop-error-no-trace.txt: -------------------------------------------------------------------------------- 1 | Error in h() : ! 2 | Calls: ... withCallingHandlers -> withVisible -> eval -> eval -> f -> g -> h 3 | Execution halted 4 | Ran 8/8 deferred expressions 5 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt: -------------------------------------------------------------------------------- 1 | Error in `h()`: 2 | ! ! 3 | Backtrace: 4 | x 5 | 1. \-global f() 6 | 2. \-global g() 7 | 3. \-global h() 8 | Execution halted 9 | Ran 8/8 deferred expressions 10 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/stop-error-trace-trim.txt: -------------------------------------------------------------------------------- 1 | Error in `h()`: 2 | ! ! 3 | Backtrace: 4 | x 5 | 1. +-evaluate::evaluate(...) 6 | 2. | +-base::withRestarts(...) 7 | 3. | | \-base (local) withRestartList(expr, restarts) 8 | 4. | | +-base (local) withOneRestart(withRestartList(expr, restarts[-nr]), restarts[[nr]]) 9 | 5. | | | \-base (local) doWithOneRestart(return(expr), restart) 10 | 6. | | \-base (local) withRestartList(expr, restarts[-nr]) 11 | 7. | | \-base (local) withOneRestart(expr, restarts[[1L]]) 12 | 8. | | \-base (local) doWithOneRestart(return(expr), restart) 13 | 9. | +-evaluate:::with_handlers(...) 14 | 10. | | +-base::eval(call) 15 | 11. | | | \-base::eval(call) 16 | 12. | | \-base::withCallingHandlers(...) 17 | 13. | +-base::withVisible(eval(expr, envir)) 18 | 14. | \-base::eval(expr, envir) 19 | 15. | \-base::eval(expr, envir) 20 | 16. \-global f() 21 | 17. \-global g() 22 | 18. \-global h() 23 | Execution halted 24 | Ran 8/8 deferred expressions 25 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/conditions/stop-error-trace-wch.txt: -------------------------------------------------------------------------------- 1 | Error in `h()`: 2 | ! ! 3 | Backtrace: 4 | x 5 | 1. \-global f() 6 | 2. \-global g() 7 | 3. \-global h() 8 | Execution halted 9 | Ran 8/8 deferred expressions 10 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/evaluate.md: -------------------------------------------------------------------------------- 1 | # check_stop_on_error converts integer to enum 2 | 3 | Code 4 | check_stop_on_error(4) 5 | Condition 6 | Error: 7 | ! `stop_on_error` must be 0, 1, or 2. 8 | 9 | # check_keep errors with bad inputs 10 | 11 | Code 12 | check_keep(1, "keep_message") 13 | Condition 14 | Error: 15 | ! `keep_message` must be TRUE, FALSE, or NA. 16 | Code 17 | check_keep(c(TRUE, FALSE), "keep_message") 18 | Condition 19 | Error: 20 | ! `keep_message` must be TRUE, FALSE, or NA. 21 | 22 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/evaluation.md: -------------------------------------------------------------------------------- 1 | # has a reasonable print method 2 | 3 | Code 4 | evaluate("f()") 5 | Output 6 | 7 | Source code: 8 | f() 9 | Text output: 10 | [1] "1" 11 | Condition: 12 | 2 13 | Condition: 14 | Warning in f(): 15 | 3 16 | Condition: 17 | Error in f(): 18 | 4 19 | Code 20 | evaluate("plot(1:3)") 21 | Output 22 | 23 | Source code: 24 | plot(1:3) 25 | Plot [8]: 26 | C_plot_new() 27 | palette2() 28 | C_plot_window() 29 | C_plotXY() 30 | C_axis() 31 | C_axis() 32 | C_box() 33 | C_title() 34 | 35 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/graphics.md: -------------------------------------------------------------------------------- 1 | # checks its input 2 | 3 | Code 4 | trim_intermediate_plots(1) 5 | Condition 6 | Error in `trim_intermediate_plots()`: 7 | ! `x` must be an evaluation object. 8 | 9 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/output-handler.md: -------------------------------------------------------------------------------- 1 | # calling handlers are checked 2 | 3 | Code 4 | check_handlers(list(condition = 1)) 5 | Condition 6 | Error in `new_output_handler()`: 7 | ! `calling_handlers` must be a named list of functions. 8 | Code 9 | check_handlers(list(function(...) NULL)) 10 | Condition 11 | Error in `new_output_handler()`: 12 | ! `calling_handlers` must be a named list of functions. 13 | Code 14 | check_handlers(stats::setNames(list(function(...) NULL), NA)) 15 | Condition 16 | Error in `new_output_handler()`: 17 | ! `calling_handlers` must be a named list of functions. 18 | Code 19 | check_handlers(stats::setNames(list(function(...) NULL), "")) 20 | Condition 21 | Error in `new_output_handler()`: 22 | ! `calling_handlers` must be a named list of functions. 23 | 24 | # can conditionally omit output with output handler 25 | 26 | Code 27 | replay(out) 28 | Output 29 | > x 30 | [1] 1 31 | 32 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/output.md: -------------------------------------------------------------------------------- 1 | # handles various numbers of arguments 2 | 3 | Code 4 | new_source("x", quote(x), f3) 5 | Condition 6 | Error in `new_source()`: 7 | ! Source output handler must have one or two arguments 8 | 9 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/replay.md: -------------------------------------------------------------------------------- 1 | # replay() should work when print() returns visible NULLs 2 | 3 | Code 4 | replay(ret) 5 | Output 6 | > structure(1, class = "FOO_BAR") 7 | NULL 8 | 9 | # replay handles various output types 10 | 11 | Code 12 | replay(ev) 13 | Output 14 | > print("1") 15 | [1] "1" 16 | > message("2") 17 | 2 18 | > warning("3") 19 | Warning: 20 | 3 21 | > stop("4") 22 | Error: 23 | 4 24 | 25 | # replay handles rlang conditions 26 | 27 | Code 28 | replay(ev) 29 | Output 30 | > rlang::inform("2") 31 | 2 32 | > rlang::warn("3") 33 | Warning: 34 | 3 35 | > rlang::abort("4", call = NULL) 36 | Error: 37 | 4 38 | 39 | # replace nicely formats multiple lines 40 | 41 | Code 42 | replay(ev) 43 | Output 44 | > 1 + 45 | + 2 46 | [1] 3 47 | 48 | # format_condition handles different types of warning 49 | 50 | Code 51 | w1 <- simpleWarning("This is a warning") 52 | cat(format_condition(w1)) 53 | Output 54 | Warning: 55 | This is a warning 56 | Code 57 | w2 <- simpleWarning("This is a warning", call = quote(f())) 58 | cat(format_condition(w2)) 59 | Output 60 | Warning in f(): 61 | This is a warning 62 | Code 63 | w3 <- rlang::warning_cnd(message = "This is a warning") 64 | cat(format_condition(w3)) 65 | Output 66 | Warning: 67 | This is a warning 68 | Code 69 | w4 <- rlang::warning_cnd(message = "This is a warning") 70 | cat(format_condition(w4)) 71 | Output 72 | Warning: 73 | This is a warning 74 | 75 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/watchout.md: -------------------------------------------------------------------------------- 1 | # evaluate recovers from closed sink 2 | 3 | Code 4 | ev <- evaluate("sink()\n1") 5 | 6 | # evaluate recovers from closed connection 7 | 8 | Code 9 | ev <- evaluate("closeAllConnections()\n1") 10 | 11 | -------------------------------------------------------------------------------- /tests/testthat/helper.R: -------------------------------------------------------------------------------- 1 | expect_output_types <- function(x, types) { 2 | output_types <- vapply(x, output_type, character(1)) 3 | expect_equal(output_types, types) 4 | } 5 | 6 | quick_install <- function(package, lib, quiet = TRUE) { 7 | opts <- c( 8 | "--data-compress=none", 9 | "--no-byte-compile", 10 | "--no-data", 11 | "--no-demo", 12 | "--no-docs", 13 | "--no-help", 14 | "--no-html", 15 | "--no-libs", 16 | "--use-vanilla", 17 | sprintf("--library=%s", lib), 18 | package 19 | ) 20 | invisible(callr::rcmd("INSTALL", opts, show = !quiet, fail_on_status = TRUE)) 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-abort-error.R: -------------------------------------------------------------------------------- 1 | testthat::local_reproducible_output() 2 | evaluate::evaluate( 3 | function() { 4 | f <- function() g() 5 | g <- function() h() 6 | h <- function() rlang::abort("!") 7 | f() 8 | }, 9 | stop_on_error = 2L 10 | ) 11 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-abort-error.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | ```{r} 6 | f <- function() g() 7 | g <- function() h() 8 | h <- function() rlang::abort("!") 9 | f() 10 | ``` 11 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-auto-entrace.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | ```{r} 6 | f <- function() g() 7 | g <- function() h() 8 | h <- function() stop("!") 9 | f() 10 | ``` 11 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-no-trace.R: -------------------------------------------------------------------------------- 1 | testthat::local_reproducible_output() 2 | evaluate::evaluate( 3 | function() { 4 | f <- function() g() 5 | g <- function() h() 6 | h <- function() stop("!") 7 | f() 8 | }, 9 | stop_on_error = 2L 10 | ) 11 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-sewed.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: document with error 3 | --- 4 | 5 | ```{r} 6 | rlang::global_entrace() 7 | options(rlang_backtrace_on_error_report = "full") 8 | ``` 9 | 10 | ```{r} 11 | f <- function() g() 12 | g <- function() h() 13 | h <- function() stop("!") 14 | f() 15 | ``` 16 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-trace-trim.R: -------------------------------------------------------------------------------- 1 | testthat::local_reproducible_output() 2 | handlers <- evaluate::new_output_handler( 3 | calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) 4 | ) 5 | library(evaluate) 6 | options(rlang_trace_top_env = rlang::pkg_env("evaluate")) 7 | evaluate( 8 | function() { 9 | f <- function() g() 10 | g <- function() h() 11 | h <- function() stop("!") 12 | f() 13 | }, 14 | stop_on_error = 2L, 15 | output_handler = handlers 16 | ) 17 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-trace.R: -------------------------------------------------------------------------------- 1 | testthat::local_reproducible_output() 2 | handlers <- evaluate::new_output_handler( 3 | calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) 4 | ) 5 | evaluate::evaluate( 6 | function() { 7 | f <- function() g() 8 | g <- function() h() 9 | h <- function() stop("!") 10 | f() 11 | }, 12 | stop_on_error = 2L, 13 | output_handler = handlers 14 | ) 15 | -------------------------------------------------------------------------------- /tests/testthat/resources/with-stop-error-wch.R: -------------------------------------------------------------------------------- 1 | testthat::local_reproducible_output() 2 | withCallingHandlers( 3 | error = function(cnd) rlang::entrace(cnd), 4 | evaluate::evaluate( 5 | function() { 6 | f <- function() g() 7 | g <- function() h() 8 | h <- function() stop("!") 9 | f() 10 | }, 11 | stop_on_error = 2L 12 | ) 13 | ) 14 | -------------------------------------------------------------------------------- /tests/testthat/test-conditions.R: -------------------------------------------------------------------------------- 1 | test_that("all condition handlers first capture output", { 2 | test <- function() { 3 | plot(1, main = "one") 4 | message("this is an message!") 5 | plot(2, main = "two") 6 | warning("this is a warning") 7 | plot(3, main = "three") 8 | stop("this is an error") 9 | } 10 | expect_output_types( 11 | evaluate("test()"), 12 | c("source", "plot", "message", "plot", "warning", "plot", "error") 13 | ) 14 | }) 15 | 16 | test_that("conditions get calls stripped", { 17 | expect_equal(evaluate("warning('x')")[[2]]$call, NULL) 18 | expect_equal(evaluate("stop('x')")[[2]]$call, NULL) 19 | 20 | # including errors emitted by C 21 | expect_equal(evaluate("mpg")[[2]]$call, NULL) 22 | expect_equal(evaluate("3()")[[2]]$call, NULL) 23 | }) 24 | 25 | test_that("envvar overrides keep_* arguments", { 26 | withr::local_envvar(R_EVALUATE_BYPASS_MESSAGES = "true") 27 | 28 | expect_message(ev <- evaluate("message('Hi!')", keep_message = FALSE), "Hi") 29 | expect_output_types(ev, "source") 30 | 31 | expect_warning(ev <- evaluate("warning('Hi!')", keep_warning = FALSE), "Hi") 32 | expect_output_types(ev, "source") 33 | }) 34 | 35 | # messages -------------------------------------------------------------------- 36 | 37 | test_that("all three states of keep_message work as expected", { 38 | test <- function() { 39 | message("Hi!") 40 | } 41 | 42 | # message captured in output 43 | expect_no_message(ev <- evaluate("test()", keep_message = TRUE)) 44 | expect_output_types(ev, c("source", "message")) 45 | 46 | # message propagated 47 | expect_message(ev <- evaluate("test()", keep_message = NA), "Hi") 48 | expect_output_types(ev, "source") 49 | 50 | # message ignored 51 | expect_no_message(ev <- evaluate("test()", keep_message = FALSE)) 52 | expect_output_types(ev, "source") 53 | }) 54 | 55 | # warnings -------------------------------------------------------------------- 56 | 57 | test_that("respects warn options", { 58 | # suppress warnings 59 | withr::local_options(warn = -1) 60 | ev <- evaluate("warning('hi')") 61 | expect_output_types(ev, "source") 62 | 63 | # delayed warnings are always immediate in knitr 64 | withr::local_options(warn = 0) 65 | ev <- evaluate("warning('hi')") 66 | expect_output_types(ev, c("source", "warning")) 67 | 68 | # immediate warnings 69 | withr::local_options(warn = 1) 70 | ev <- evaluate("warning('hi')") 71 | expect_output_types(ev, c("source", "warning")) 72 | 73 | # warnings become errors 74 | withr::local_options(warn = 2) 75 | ev <- evaluate("warning('hi')") 76 | expect_output_types(ev, c("source", "error")) 77 | }) 78 | 79 | test_that("all three states of keep_warning work as expected", { 80 | test <- function() { 81 | warning("Hi!") 82 | } 83 | 84 | # warning captured in output 85 | expect_no_warning(ev <- evaluate("test()", keep_warning = TRUE)) 86 | expect_output_types(ev, c("source", "warning")) 87 | 88 | # warning propagated 89 | expect_warning(ev <- evaluate("test()", keep_warning = NA), "Hi") 90 | expect_output_types(ev, "source") 91 | 92 | # warning ignored 93 | expect_no_warning(ev <- evaluate("test()", keep_warning = FALSE)) 94 | expect_output_types(ev, "source") 95 | }) 96 | 97 | test_that("log_warning causes warnings to be emitted", { 98 | f <- function() { 99 | warning("Hi!", immediate. = TRUE) 100 | } 101 | expect_snapshot(ev <- evaluate("f()", log_warning = TRUE)) 102 | 103 | # And still recorded in eval result 104 | expect_output_types(ev, c("source", "warning")) 105 | expect_equal(ev[[1]]$src, "f()\n") 106 | expect_equal(ev[[2]], simpleWarning("Hi!", quote(f()))) 107 | }) 108 | 109 | # errors ---------------------------------------------------------------------- 110 | 111 | test_that("an error terminates evaluation of multi-expression input", { 112 | ev <- evaluate("stop('1');2\n3") 113 | expect_output_types(ev, c("source", "error", "source", "text")) 114 | expect_equal(ev[[1]]$src, "stop('1');2\n") 115 | 116 | ev <- evaluate("stop('1');2\n3", stop_on_error = 1L) 117 | expect_equal(ev[[1]]$src, "stop('1');2\n") 118 | expect_output_types(ev, c("source", "error")) 119 | }) 120 | 121 | test_that("all three values of stop_on_error work as expected", { 122 | ev <- evaluate('stop("1")\n2', stop_on_error = 0L) 123 | expect_output_types(ev, c("source", "error", "source", "text")) 124 | 125 | ev <- evaluate('stop("1")\n2', stop_on_error = 1L) 126 | expect_output_types(ev, c("source", "error")) 127 | 128 | expect_snapshot( 129 | ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L), 130 | error = TRUE 131 | ) 132 | }) 133 | 134 | test_that("errors during printing are captured", { 135 | methods::setClass("A", contains = "function", where = environment()) 136 | methods::setMethod("show", "A", function(object) stop("B")) 137 | a <- methods::new("A", function() b) 138 | 139 | ev <- evaluate("a") 140 | expect_output_types(ev, c("source", "error")) 141 | }) 142 | 143 | test_that("Error can be entraced and correctly handled in outputs", { 144 | skip_if_not_installed("rlang") 145 | skip_if_not_installed("knitr") 146 | skip_if_not_installed("callr") 147 | skip_on_cran() 148 | 149 | # traceback is different in old R 150 | skip_if_not(getRversion() >= "4.0.0") 151 | 152 | # pretend that we're never running inside of R CMD check 153 | withr::local_envvar( 154 | `_R_CHECK_PACKAGE_NAME_` = NA, 155 | `_R_CHECK_LICENSE_` = NA, 156 | ) 157 | 158 | # if not inside of R CMD check, install dev version into temp directory 159 | if (Sys.getenv("_R_CHECK_TIMINGS_") == "") { 160 | withr::local_temp_libpaths() 161 | quick_install(pkgload::pkg_path("."), lib = .libPaths()[1]) 162 | } 163 | 164 | out <- withr::local_tempfile(fileext = ".txt") 165 | 166 | # Checking different way to entrace with evaluate 167 | ## No trace 168 | callr::rscript( 169 | test_path("resources/with-stop-error-no-trace.R"), 170 | fail_on_status = FALSE, 171 | show = FALSE, 172 | stderr = out 173 | ) 174 | expect_snapshot_file(out, name = 'stop-error-no-trace.txt') 175 | 176 | ## Using calling.handler in evaluate's output handler 177 | callr::rscript( 178 | test_path("resources/with-stop-error-trace.R"), 179 | fail_on_status = FALSE, 180 | show = FALSE, 181 | stderr = out 182 | ) 183 | expect_snapshot_file(out, name = 'stop-error-trace-calling-handler.txt') 184 | 185 | ## Using withCallingHandler() 186 | callr::rscript( 187 | test_path("resources/with-stop-error-wch.R"), 188 | fail_on_status = FALSE, 189 | show = FALSE, 190 | stderr = out 191 | ) 192 | expect_snapshot_file(out, name = 'stop-error-trace-wch.txt') 193 | 194 | ## Using abort() in evaluated code 195 | callr::rscript( 196 | test_path("resources/with-abort-error.R"), 197 | fail_on_status = FALSE, 198 | show = FALSE, 199 | stderr = out 200 | ) 201 | expect_snapshot_file(out, name = 'abort-error.txt') 202 | 203 | # setting option rlang_trace_top_env modified opt-out default evaluate trace trimming 204 | callr::rscript( 205 | test_path("resources/with-stop-error-trace-trim.R"), 206 | fail_on_status = FALSE, 207 | show = FALSE, 208 | stderr = out 209 | ) 210 | expect_snapshot_file( 211 | out, 212 | name = 'stop-error-trace-trim.txt', 213 | transform = function(lines) 214 | gsub("\\s*at evaluate/R/.*\\.R(:\\d+)*", "", lines) 215 | ) 216 | 217 | # Checking error thrown when in rmarkdown and knitr context 218 | rscript <- withr::local_tempfile(fileext = ".R") 219 | out2 <- normalizePath( 220 | withr::local_tempfile(fileext = ".md"), 221 | winslash = "/", 222 | mustWork = FALSE 223 | ) 224 | writeLines( 225 | c( 226 | "testthat::local_reproducible_output()", 227 | "options(knitr.chunk.error = FALSE)", 228 | sprintf( 229 | 'knitr::knit("%s", output = "%s")', 230 | test_path("resources/with-stop-error-auto-entrace.Rmd"), 231 | out2 232 | ) 233 | ), 234 | con = rscript 235 | ) 236 | callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) 237 | expect_snapshot_file(out, name = 'rmd-stop-error-auto-entrace.txt') 238 | 239 | writeLines( 240 | c( 241 | "testthat::local_reproducible_output()", 242 | "options(knitr.chunk.error = FALSE)", 243 | sprintf( 244 | 'res <- knitr::knit("%s", output = "%s")', 245 | test_path("resources/with-abort-error.Rmd"), 246 | out2 247 | ) 248 | ), 249 | con = rscript 250 | ) 251 | callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) 252 | expect_snapshot_file(out, name = 'rmd-abort-error.txt') 253 | 254 | # Checking error captured in cell output in rmarkdown and knitr context 255 | withr::with_options(list(options(knitr.chunk.error = TRUE)), { 256 | expect_snapshot_file( 257 | knitr::knit( 258 | test_path("resources/with-stop-error-auto-entrace.Rmd"), 259 | output = out, 260 | quiet = TRUE 261 | ), 262 | name = "rmd-stop-error.md" 263 | ) 264 | expect_snapshot_file( 265 | knitr::knit( 266 | test_path("resources/with-stop-error-sewed.Rmd"), 267 | output = out, 268 | quiet = TRUE 269 | ), 270 | name = "rmd-stop-error-entrace-sewed.md" 271 | ) 272 | expect_snapshot_file( 273 | knitr::knit( 274 | test_path("resources/with-abort-error.Rmd"), 275 | output = out, 276 | quiet = TRUE 277 | ), 278 | name = "rmd-abort-error.md" 279 | ) 280 | }) 281 | }) 282 | -------------------------------------------------------------------------------- /tests/testthat/test-evaluate.R: -------------------------------------------------------------------------------- 1 | test_that("file with only comments runs", { 2 | ev <- evaluate(function() { 3 | # This test case contains no executable code 4 | # but it shouldn't throw an error 5 | }) 6 | expect_output_types(ev, c("source", "source")) 7 | }) 8 | 9 | test_that("can evaluate expressions of all lengths", { 10 | source <- " 11 | # a comment 12 | 1 13 | x <- 2; x 14 | " 15 | expect_no_error(evaluate(source)) 16 | }) 17 | 18 | test_that("log_echo causes output to be immediately written to stderr()", { 19 | f <- function() { 20 | 1 21 | } 22 | out <- capture.output( 23 | res <- evaluate("f()", log_echo = TRUE), 24 | type = "message" 25 | ) 26 | expect_equal(out, c("f()", "")) 27 | 28 | # But still recorded in eval result 29 | expect_output_types(res, c("source", "text")) 30 | expect_equal(res[[1]]$src, "f()\n") 31 | }) 32 | 33 | test_that("ACTIONS_STEP_DEBUG forces log_warning and log_echo to TRUE", { 34 | f <- function() { 35 | 1 36 | warning("abc") 37 | } 38 | out <- local({ 39 | withr::local_envvar(ACTIONS_STEP_DEBUG = "true") 40 | capture.output(expect_warning(evaluate("f()"), "abc"), type = "message") 41 | }) 42 | expect_equal(out, c("f()", "")) 43 | }) 44 | 45 | test_that("data sets loaded", { 46 | skip_if_not_installed("lattice") 47 | 48 | ev <- evaluate(function() { 49 | data(barley, package = "lattice") 50 | barley 51 | }) 52 | expect_output_types(ev, c("source", "source", "text")) 53 | }) 54 | 55 | test_that("terminal newline not needed", { 56 | ev <- evaluate("cat('foo')") 57 | expect_output_types(ev, c("source", "text")) 58 | expect_equal(ev[[2]], "foo") 59 | }) 60 | 61 | test_that("S4 methods are displayed with show, not print", { 62 | methods::setClass("A", contains = "function", where = environment()) 63 | methods::setMethod("show", "A", function(object) cat("B")) 64 | a <- methods::new("A", function() b) 65 | 66 | ev <- evaluate("a") 67 | expect_equal(ev[[2]], "B") 68 | }) 69 | 70 | test_that("output and plots interleaved correctly", { 71 | ev <- evaluate(function() { 72 | for (i in 1:2) { 73 | cat(i) 74 | plot(i) 75 | } 76 | }) 77 | expect_output_types(ev, c("source", "text", "plot", "text", "plot")) 78 | 79 | ev <- evaluate(function() { 80 | for (i in 1:2) { 81 | plot(i) 82 | cat(i) 83 | } 84 | }) 85 | expect_output_types(ev, c("source", "plot", "text", "plot", "text")) 86 | }) 87 | 88 | test_that("multiple expressions on one line can get printed as expected", { 89 | ev <- evaluate("x <- 1; y <- 2; x; y") 90 | expect_output_types(ev, c("source", "text", "text")) 91 | }) 92 | 93 | test_that("multiple lines of comments do not lose the terminating \\n", { 94 | ev <- evaluate("# foo\n#bar") 95 | expect_output_types(ev, c("source", "source")) 96 | expect_equal(ev[[1]]$src, "# foo\n") 97 | }) 98 | 99 | test_that("check_stop_on_error converts integer to enum", { 100 | expect_equal(check_stop_on_error(0), "continue") 101 | expect_equal(check_stop_on_error(1), "stop") 102 | expect_equal(check_stop_on_error(2), "error") 103 | 104 | expect_snapshot(check_stop_on_error(4), error = TRUE) 105 | }) 106 | 107 | test_that("check_keep converts to logical as expected", { 108 | expect_true(check_keep(TRUE)$capture) 109 | expect_false(check_keep(NA)$capture) 110 | expect_false(check_keep(FALSE)$capture) 111 | 112 | expect_true(check_keep(TRUE)$silence) 113 | expect_false(check_keep(NA)$silence) 114 | expect_true(check_keep(FALSE)$silence) 115 | }) 116 | 117 | test_that("check_keep can integrate log option", { 118 | # logging means we never silence the ouptut 119 | expect_false(check_keep(TRUE, log = TRUE)$silence) 120 | expect_false(check_keep(NA, log = TRUE)$silence) 121 | expect_false(check_keep(FALSE, log = TRUE)$silence) 122 | }) 123 | 124 | test_that("new_device = FALSE doesn't open any devices", { 125 | graphics.off() 126 | skip_if_not(is.null(dev.list())) 127 | 128 | ev <- evaluate("1", new_device = FALSE) 129 | expect_equal(dev.list(), NULL) 130 | }) 131 | 132 | 133 | test_that("check_keep errors with bad inputs", { 134 | expect_snapshot(error = TRUE, { 135 | check_keep(1, "keep_message") 136 | check_keep(c(TRUE, FALSE), "keep_message") 137 | }) 138 | }) 139 | -------------------------------------------------------------------------------- /tests/testthat/test-evaluation.R: -------------------------------------------------------------------------------- 1 | test_that("has a reasonable print method", { 2 | f <- function() { 3 | print("1") 4 | message("2") 5 | warning("3") 6 | stop("4") 7 | } 8 | 9 | expect_snapshot({ 10 | evaluate("f()") 11 | evaluate("plot(1:3)") 12 | }) 13 | }) 14 | -------------------------------------------------------------------------------- /tests/testthat/test-flush-console.R: -------------------------------------------------------------------------------- 1 | test_that("flush_console() is a null op by default", { 2 | expect_no_error(flush_console()) 3 | }) 4 | 5 | test_that("can set and restore output handler", { 6 | f <- function() message("Hi") 7 | old <- set_console_flusher(function() message("Hi")) 8 | expect_equal(the$console_flusher, f) 9 | expect_equal(old, NULL) 10 | 11 | expect_message(flush_console(), "Hi") 12 | old2 <- set_console_flusher(old) 13 | expect_equal(old2, f) 14 | }) 15 | 16 | test_that("can use flush_console() inside evaluate", { 17 | test <- function() { 18 | cat("hi") 19 | flush_console() 20 | cat("bye") 21 | } 22 | ev <- evaluate("test()") 23 | expect_equal(ev[[2]], "hi") 24 | expect_equal(ev[[3]], "bye") 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/test-graphics.R: -------------------------------------------------------------------------------- 1 | test_that("single plot is captured", { 2 | ev <- evaluate("plot(1:10)") 3 | expect_output_types(ev, c("source", "plot")) 4 | }) 5 | 6 | test_that("plot additions are captured", { 7 | ev <- evaluate(function() { 8 | plot(1:10) 9 | lines(1:10) 10 | }) 11 | expect_output_types(ev, c("source", "plot", "source", "plot")) 12 | }) 13 | 14 | test_that("blank plots created by plot.new() are preserved", { 15 | ev <- evaluate(function() { 16 | plot.new() 17 | plot(1:10) 18 | plot.new() 19 | plot(1:10) 20 | plot.new() 21 | }) 22 | expect_output_types(ev, rep(c("source", "plot"), 5)) 23 | }) 24 | 25 | test_that("evaluate doesn't open plots or create files", { 26 | n <- length(dev.list()) 27 | evaluate("plot(1)") 28 | 29 | expect_false(file.exists("Rplots.pdf")) 30 | expect_equal(length(dev.list()), n) 31 | }) 32 | 33 | test_that("base plots in a single expression are captured", { 34 | ev <- evaluate(function() { 35 | { 36 | plot(rnorm(100)) 37 | plot(rnorm(100)) 38 | plot(rnorm(100)) 39 | } 40 | }) 41 | expect_output_types(ev, c("source", "plot", "plot", "plot")) 42 | }) 43 | 44 | test_that("captures ggplots", { 45 | skip_if_not_installed("ggplot2") 46 | library(ggplot2) 47 | 48 | ev <- evaluate( 49 | "ggplot(mtcars, aes(mpg, wt)) + geom_point()" 50 | ) 51 | expect_output_types(ev, c("source", "plot")) 52 | 53 | ev <- evaluate(function() { 54 | for (j in 1:2) { 55 | print(ggplot(mtcars, aes(mpg, wt)) + geom_point()) 56 | } 57 | }) 58 | expect_output_types(ev, c("source", "plot", "plot")) 59 | }) 60 | 61 | test_that("erroring ggplots should not be recorded", { 62 | skip_if_not_installed("ggplot2") 63 | library(ggplot2) 64 | 65 | # error in aesthetics 66 | ev <- evaluate(function() { 67 | ggplot(iris, aes(XXXXXXXXXX, Sepal.Length)) + geom_boxplot() 68 | }) 69 | expect_output_types(ev, c("source", "error")) 70 | 71 | # error in geom 72 | ev <- evaluate(function() { 73 | ggplot(iris, aes(Species, Sepal.Length)) + geom_bar() 74 | }) 75 | expect_output_types(ev, c("source", "error")) 76 | }) 77 | 78 | test_that("multirow graphics are captured only when complete", { 79 | ev <- evaluate(function() { 80 | par(mfrow = c(1, 2)) 81 | plot(1) 82 | plot(2) 83 | }) 84 | expect_output_types(ev, c("source", "source", "source", "plot")) 85 | }) 86 | 87 | test_that("multirow graphics are captured on close even if not complete", { 88 | ev <- evaluate(function() { 89 | par(mfrow = c(1, 2)) 90 | plot(1) 91 | }) 92 | expect_output_types(ev, c("source", "source", "plot")) 93 | 94 | # Even if there's a comment at the end 95 | ev <- evaluate(function() { 96 | par(mfrow = c(1, 2)) 97 | plot(1) 98 | # comment 99 | }) 100 | expect_output_types(ev, c("source", "source", "source", "plot")) 101 | }) 102 | 103 | test_that("plots are captured in a non-rectangular layout", { 104 | ev <- evaluate(function() { 105 | for (j in 1:3) { 106 | layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE)) 107 | plot(rnorm(10)) 108 | plot(rnorm(10)) 109 | plot(rnorm(10)) 110 | plot(rnorm(10)) 111 | } 112 | }) 113 | expect_output_types(ev, c("source", "plot", "plot", "plot")) 114 | 115 | ev <- evaluate(function() { 116 | layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE)) 117 | # another expression before drawing the plots 118 | x <- 1 + 1 119 | for (j in 1:2) { 120 | plot(rnorm(10)) 121 | plot(rnorm(10)) 122 | plot(rnorm(10)) 123 | plot(rnorm(10)) 124 | } 125 | }) 126 | expect_output_types(ev, rep(c("source", "plot"), c(4, 2))) 127 | }) 128 | 129 | test_that("changes in parameters don't generate new plots", { 130 | ev <- evaluate(function() { 131 | plot(1) 132 | par(mar = rep(0, 4)) 133 | plot(2) 134 | }) 135 | expect_output_types(ev, c("source", "plot", "source", "source", "plot")) 136 | }) 137 | 138 | test_that("multiple plots are captured even if calls in DL are the same", { 139 | # fmt: skip 140 | ev <- evaluate(function() { 141 | barplot(1) 142 | barplot(2); barplot(3) 143 | }) 144 | expect_output_types(ev, c("source", "plot", "source", "plot", "plot")) 145 | }) 146 | 147 | test_that("strwidth()/strheight() should not produce new plots", { 148 | ev <- evaluate(function() { 149 | x <- strwidth("foo", "inches") 150 | y <- strheight("foo", "inches") 151 | plot(1) 152 | }) 153 | expect_output_types(ev, c("source", "source", "source", "plot")) 154 | }) 155 | 156 | test_that("clip() does not produce new plots", { 157 | ev <- evaluate(function() { 158 | plot(1) 159 | clip(-1, 1, -1, 1) 160 | points(1, col = "red") 161 | }) 162 | expect_output_types(ev, c("source", "plot", "source", "source", "plot")) 163 | }) 164 | 165 | test_that("perspective plots are captured", { 166 | x <- seq(-10, 10, length.out = 30) 167 | y <- x 168 | ff <- function(x, y) { 169 | r <- sqrt(x^2 + y^2) 170 | 10 * sin(r) / r 171 | } 172 | z <- outer(x, y, ff) 173 | z[is.na(z)] <- 1 174 | 175 | ev <- evaluate(function() { 176 | for (i in 1:3) { 177 | persp(x, y, z, phi = 30 + i * 10, theta = 30) 178 | } 179 | }) 180 | expect_output_types(ev, c("source", "plot", "plot", "plot")) 181 | }) 182 | 183 | # a bug report yihui/knitr#722 184 | test_that("plot state doesn't persist over evaluate calls", { 185 | expect_output_types(evaluate("plot(1)"), c("source", "plot")) 186 | expect_output_types(evaluate("plot(1)"), c("source", "plot")) 187 | expect_output_types(evaluate("plot(1)"), c("source", "plot")) 188 | }) 189 | 190 | test_that("evaluate() doesn't depend on device option", { 191 | path <- withr::local_tempfile() 192 | # This would error if used because recording is not enable 193 | withr::local_options(device = function() png(path)) 194 | 195 | ev <- evaluate("plot(1)") 196 | expect_output_types(ev, c("source", "plot")) 197 | }) 198 | 199 | # https://github.com/yihui/knitr/issues/2297 200 | test_that("existing plot doesn't leak into evaluate()", { 201 | pdf(NULL) 202 | plot.new() 203 | defer(dev.off()) 204 | 205 | # errors because plot.new() called 206 | ev <- evaluate("lines(1)") 207 | expect_output_types(ev, c("source", "error")) 208 | }) 209 | 210 | test_that("evaluate restores existing plot", { 211 | pdf(NULL) 212 | d <- dev.cur() 213 | defer(dev.off()) 214 | 215 | ev <- evaluate("plot(1)") 216 | expect_output_types(ev, c("source", "plot")) 217 | expect_equal(dev.cur(), d) 218 | }) 219 | 220 | test_that("evaluate ignores plots created in new device", { 221 | ev <- evaluate(function() { 222 | pdf(NULL) 223 | plot(1) 224 | invisible(dev.off()) 225 | plot(1) 226 | }) 227 | expect_output_types(ev, c("source", "source", "source", "source", "plot")) 228 | }) 229 | 230 | 231 | # trim_intermediate_plots ------------------------------------------------ 232 | 233 | test_that("can trim off intermediate plots", { 234 | ev <- evaluate(c( 235 | "plot(1:3)", 236 | "text(1, 1, 'x')", 237 | "text(1, 1, 'y')" 238 | )) 239 | ev <- trim_intermediate_plots(ev) 240 | expect_output_types(ev, c("source", "source", "source", "plot")) 241 | 242 | ev <- evaluate(c( 243 | "plot(1:3)", 244 | "text(1, 1, 'x')", 245 | "plot(1:3)", 246 | "text(1, 1, 'y')" 247 | )) 248 | ev <- trim_intermediate_plots(ev) 249 | expect_output_types( 250 | ev, 251 | c("source", "source", "plot", "source", "source", "plot") 252 | ) 253 | }) 254 | 255 | test_that("works with empty output", { 256 | ev <- trim_intermediate_plots(evaluate("")) 257 | expect_output_types(ev, "source") 258 | 259 | ev <- trim_intermediate_plots(new_evaluation(list())) 260 | expect_output_types(ev, character()) 261 | }) 262 | 263 | test_that("checks its input", { 264 | expect_snapshot(trim_intermediate_plots(1), error = TRUE) 265 | }) 266 | 267 | test_that("can capture new graphics features (compositing operators) (#238)", { 268 | # Compositing operators were introduced in R 4.2 269 | skip_if_not(getRversion() >= "4.2.0") 270 | # `pdf(NULL)` may segfault or throw warning 271 | skip_if_not_installed("ragg", "1.3.3.9000") 272 | # some buglet in grid 273 | local_options(warnPartialMatchDollar = FALSE) 274 | 275 | ev <- evaluate(function() { 276 | grid::grid.group(grid::rectGrob(), "over", grid::rectGrob()) 277 | }) 278 | expect_output_types(ev, c("source", "plot")) 279 | }) 280 | 281 | test_that("falls back to pdf() if ragg not available", { 282 | # Compositing operators were introduced in R 4.2, but pdf() crashes with 283 | # them up to R 4.3.0 284 | skip_if_not(getRversion() >= "4.3.0") 285 | # some buglet in grid 286 | local_options(warnPartialMatchDollar = FALSE) 287 | 288 | local_mocked_bindings(has_ragg = function() FALSE) 289 | ev <- evaluate(function() { 290 | grid::grid.group(grid::rectGrob(), "over", grid::rectGrob()) 291 | }) 292 | # Warning in drawDetails.GridGroup(x, recording = FALSE): 293 | # Group definition failed 294 | expect_output_types(ev, c("source", "warning", "plot")) 295 | }) 296 | -------------------------------------------------------------------------------- /tests/testthat/test-inject-funs.R: -------------------------------------------------------------------------------- 1 | test_that("can inject functons into evaluation context", { 2 | old <- inject_funs(f = function() 1) 3 | defer(inject_funs(old)) 4 | 5 | ev <- evaluate("f()") 6 | expect_equal(ev[[2]], "[1] 1\n") 7 | }) 8 | -------------------------------------------------------------------------------- /tests/testthat/test-output-handler.R: -------------------------------------------------------------------------------- 1 | test_that("calling handlers are checked", { 2 | expect_snapshot(error = TRUE, { 3 | check_handlers(list(condition = 1)) 4 | check_handlers(list(function(...) NULL)) 5 | check_handlers(stats::setNames(list(function(...) NULL), NA)) 6 | check_handlers(stats::setNames(list(function(...) NULL), "")) 7 | }) 8 | }) 9 | 10 | test_that("text output handler is called with text", { 11 | text <- NULL 12 | oh <- new_output_handler(text = function(o) text <<- o) 13 | 14 | evaluate("print('abc')", output_handler = oh) 15 | expect_equal(text, "[1] \"abc\"\n") 16 | }) 17 | 18 | test_that("graphic output handler not called with no graphics", { 19 | graphics <- NULL 20 | oh <- new_output_handler(graphics = function(o) graphics <<- 1) 21 | 22 | evaluate("print('abc')", output_handler = oh) 23 | expect_equal(graphics, NULL) 24 | }) 25 | 26 | 27 | test_that("can conditionally omit output with output handler", { 28 | hide_source <- function(src, tle) { 29 | if (length(tle) == 0) { 30 | src 31 | } else if (is.call(tle[[1]]) && identical(tle[[1]][[1]], quote(hide))) { 32 | NULL 33 | } else { 34 | src 35 | } 36 | } 37 | handler <- new_output_handler(source = hide_source) 38 | hide <- function(x) invisible(x) 39 | 40 | out <- evaluate("hide(x <- 1)\nx", output_handler = handler) 41 | expect_output_types(out, c("source", "text")) 42 | expect_snapshot(replay(out)) 43 | }) 44 | 45 | test_that("source handled called correctly when src is unparseable", { 46 | src <- NULL 47 | call <- NULL 48 | capture_args <- function(src, call) { 49 | src <<- src 50 | call <<- call 51 | 52 | src 53 | } 54 | handler <- new_output_handler(source = capture_args) 55 | 56 | evaluate("x + ", output_handler = handler) 57 | expect_equal(src, new_source("x + ")) 58 | expect_equal(call, expression()) 59 | }) 60 | 61 | 62 | test_that("return value of value handler inserted directly in output list", { 63 | skip_if_not_installed("ggplot2") 64 | 65 | ev <- evaluate( 66 | function() { 67 | rnorm(10) 68 | x <- list("I\'m a list!") 69 | ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) 70 | }, 71 | output_handler = new_output_handler(value = identity) 72 | ) 73 | expect_output_types(ev, c("source", "numeric", "source", "source", "gg")) 74 | }) 75 | 76 | test_that("invisible values can also be saved if value handler has two arguments", { 77 | handler <- new_output_handler(value = function(x, visible) { 78 | x # always returns a visible value 79 | }) 80 | expect_true(show_value(handler, FALSE)) 81 | 82 | ev <- evaluate("x<-1:10", output_handler = handler) 83 | expect_output_types(ev, c("source", "integer")) 84 | }) 85 | 86 | test_that("user can register calling handlers", { 87 | cnd <- structure(list(), class = c("foobar", "condition")) 88 | hnd <- function(cnd) handled <<- cnd 89 | 90 | handled <- NULL 91 | hnd <- function(cnd) handled <<- cnd 92 | 93 | out_hnd <- new_output_handler(calling_handlers = list(foobar = hnd)) 94 | evaluate("signalCondition(cnd)", output_handler = out_hnd) 95 | expect_s3_class(handled, "foobar") 96 | 97 | handled <- NULL 98 | out_hnd <- new_output_handler(calling_handlers = list(error = hnd)) 99 | evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd) 100 | expect_s3_class(handled, "error") 101 | }) 102 | -------------------------------------------------------------------------------- /tests/testthat/test-output.R: -------------------------------------------------------------------------------- 1 | # new_source ------------------------------------------------------------------- 2 | 3 | test_that("handles various numbers of arguments", { 4 | signal_condition <- function(class) { 5 | signalCondition(structure(list(), class = c(class, "condition"))) 6 | } 7 | expected <- structure(list(src = "x"), class = "source") 8 | 9 | # No handler 10 | expect_equal(new_source("x", quote(x)), expected) 11 | 12 | # One argument 13 | f1 <- function(src) signal_condition("handler_called") 14 | expect_condition( 15 | out <- new_source("x", quote(x), f1), 16 | class = "handler_called" 17 | ) 18 | expect_equal(out, expected) 19 | 20 | # Two arguments 21 | f2 <- function(src, call) { 22 | signal_condition("handler_called") 23 | NULL 24 | } 25 | expect_condition( 26 | out <- new_source("x", quote(x), f2), 27 | class = "handler_called" 28 | ) 29 | expect_equal(out, NULL) 30 | 31 | # Three arguments 32 | f3 <- function(a, b, c) NULL 33 | expect_snapshot(new_source("x", quote(x), f3), error = TRUE) 34 | }) 35 | -------------------------------------------------------------------------------- /tests/testthat/test-parse_all.R: -------------------------------------------------------------------------------- 1 | test_that("can parse empty input", { 2 | expect_equal(parse_all(character())$src, character()) 3 | }) 4 | 5 | test_that("can parse even if no expressions", { 6 | expect_equal(parse_all("")$src, "\n") 7 | expect_equal(parse_all("#")$src, "#\n") 8 | expect_equal(parse_all("#\n\n")$src, c("#\n", "\n")) 9 | }) 10 | 11 | test_that("every line gets nl", { 12 | expect_equal(parse_all("x")$src, "x\n") 13 | expect_equal(parse_all("")$src, "\n") 14 | expect_equal(parse_all("\n")$src, "\n") 15 | 16 | # even empty lines 17 | expect_equal(parse_all("a\n\nb")$src, c("a\n", "\n", "b\n")) 18 | expect_equal(parse_all("a\n\nb\n")$src, c("a\n", "\n", "b\n")) 19 | 20 | expect_equal(parse_all("\n\n")$src, c("\n", "\n")) 21 | }) 22 | 23 | test_that("empty lines are never silently dropped", { 24 | # It's not possible to simulate problem directly from code, but it can occur 25 | # in knitr 26 | # ```{r, tidy = TRUE}` 27 | # for (i in 1) {} 28 | # # two blank lines below 29 | # 30 | # 31 | # 1 32 | # ``` 33 | expect_equal(parse_all(c("\n", "", "1"))$src, c("\n", "\n", "1\n")) 34 | }) 35 | 36 | test_that("a character vector is equivalent to a multi-line string", { 37 | expect_equal(parse_all(c("a", "b")), parse_all(c("a\nb"))) 38 | }) 39 | 40 | test_that("recombines multi-expression TLEs", { 41 | expect_equal(parse_all("1;2;3")$expr[[1]], expression(1, 2, 3)) 42 | expect_equal(parse_all("1+\n2;3")$expr[[1]], expression(1 + 2, 3)) 43 | expect_equal( 44 | parse_all("1+\n2;3+\n4; 5")$expr[[1]], 45 | expression(1 + 2, 3 + 4, 5) 46 | ) 47 | }) 48 | 49 | test_that("re-integrates lines without expressions", { 50 | expect_equal(parse_all("1\n\n2")$src, c("1\n", "\n", "2\n")) 51 | expect_equal(parse_all("1\n#\n2")$src, c("1\n", "#\n", "2\n")) 52 | }) 53 | 54 | test_that("expr is always an expression", { 55 | expect_equal(parse_all("#")$expr[[1]], expression()) 56 | expect_equal(parse_all("1")$expr[[1]], expression(1)) 57 | expect_equal(parse_all("1;2")$expr[[1]], expression(1, 2)) 58 | 59 | parsed <- parse_all("#\n1\n1;2") 60 | expect_equal(lengths(parsed$expr), c(0, 1, 2)) 61 | }) 62 | 63 | test_that("parse(allow_error = TRUE/FALSE)", { 64 | expect_error(parse_all("x <-", allow_error = FALSE)) 65 | res <- parse_all("x <-", allow_error = TRUE) 66 | expect_true(inherits(attr(res, "PARSE_ERROR"), "error")) 67 | 68 | # And correctly flows through to evaluate 69 | expect_no_error(evaluate("x <-", stop_on_error = 0)) 70 | }) 71 | 72 | test_that("double quotes in Chinese characters not destroyed", { 73 | skip_if_not(l10n_info()[["UTF-8"]]) 74 | 75 | out <- parse_all(c("1+1", '"你好"')) 76 | expect_equal(out$src[[2]], '"你好"\n') 77 | expect_equal(out$expr[[2]], expression("你好")) 78 | }) 79 | 80 | test_that("multibyte characters are parsed correctly", { 81 | skip_if_not(l10n_info()[["UTF-8"]]) 82 | 83 | code <- c("ϱ <- 1# g / ml", "äöüßÄÖÜπ <- 7 + 3# nonsense") 84 | out <- parse_all(code) 85 | expect_equal(out$src, paste0(code, "\n")) 86 | }) 87 | 88 | # input types ------------------------------------------------------------------ 89 | 90 | test_that("can parse a call", { 91 | out <- parse_all(quote(f(a, b, c))) 92 | expect_equal(out$src, "f(a, b, c)\n") 93 | expect_equal(out$expr, list(expression(f(a, b, c)))) 94 | }) 95 | 96 | test_that("can parse a connection", { 97 | path <- withr::local_tempfile(lines = c("# 1", "1 + 1")) 98 | cur_cons <- getAllConnections() 99 | 100 | con <- file(path) 101 | out <- parse_all(con) 102 | 103 | expect_equal(out$src, c("# 1\n", "1 + 1\n")) 104 | expect_equal(out$expr, list(expression(), expression(1 + 1))) 105 | 106 | # Doesn't leave any connections around 107 | expect_equal(getAllConnections(), cur_cons) 108 | }) 109 | 110 | test_that("can parse a function", { 111 | out <- parse_all(function() { 112 | # Hi 113 | 1 + 1 114 | }) 115 | expect_equal(out$src, c("# Hi\n", "1 + 1\n")) 116 | expect_equal(out$expr, list(expression(), expression(1 + 1))) 117 | }) 118 | 119 | # find_function_body ----------------------------------------------------------- 120 | 121 | test_that("parsing a function parses its body", { 122 | out <- parse_all(function() { 123 | # Hi 124 | 1 + 1 125 | }) 126 | expect_equal(out$src, c("# Hi\n", "1 + 1\n")) 127 | }) 128 | 129 | test_that("dedents function body", { 130 | f <- function() { 131 | 1 + 1 132 | } 133 | expect_equal(find_function_body(f), "1 + 1") 134 | }) 135 | 136 | test_that("preserves src if possible", { 137 | # fmt: skip 138 | f <- function() { 139 | 1 + 1 # hi 140 | } 141 | expect_equal(find_function_body(f), "1 + 1 # hi") 142 | 143 | f <- removeSource(f) 144 | expect_equal(find_function_body(f), "1 + 1") 145 | }) 146 | 147 | test_that("isn't flumoxed by nested parens", { 148 | f <- function() { 149 | { 150 | 1 + 1 151 | } 152 | } 153 | expect_equal(find_function_body(f), c("{", " 1 + 1", "}")) 154 | }) 155 | 156 | test_that("works if no parens", { 157 | f <- function() 1 + 1 158 | expect_equal(find_function_body(f), "1 + 1") 159 | 160 | # fmt: skip 161 | f <- function() ( 162 | 1 + 1 163 | ) 164 | expect_equal(find_function_body(f), "(1 + 1)") 165 | }) 166 | 167 | test_that("can handle empty body", { 168 | # fmt: skip 169 | f <- function() {} 170 | expect_equal(find_function_body(f), character()) 171 | }) 172 | -------------------------------------------------------------------------------- /tests/testthat/test-replay.R: -------------------------------------------------------------------------------- 1 | test_that("replay() should work when print() returns visible NULLs", { 2 | withr::local_options(prompt = "> ") 3 | 4 | print.FOO_BAR <- function(x, ...) NULL 5 | ret <- evaluate('structure(1, class = "FOO_BAR")') 6 | expect_snapshot(replay(ret)) 7 | }) 8 | 9 | test_that("replay handles various output types", { 10 | ev <- evaluate(function() { 11 | print("1") 12 | message("2") 13 | warning("3") 14 | stop("4") 15 | }) 16 | expect_snapshot(replay(ev)) 17 | }) 18 | 19 | test_that("replay handles rlang conditions", { 20 | ev <- evaluate(function() { 21 | rlang::inform("2") 22 | rlang::warn("3") 23 | rlang::abort("4", call = NULL) 24 | }) 25 | expect_snapshot(replay(ev)) 26 | }) 27 | 28 | test_that("replace nicely formats multiple lines", { 29 | ev <- evaluate("1 + \n 2") 30 | expect_snapshot(replay(ev)) 31 | }) 32 | 33 | test_that("can replay plots", { 34 | ev <- evaluate("plot(1)") 35 | 36 | path <- withr::local_tempfile() 37 | pdf(path) 38 | expect_output(replay(ev)) 39 | dev.off() 40 | 41 | expect_true(file.exists(path)) 42 | }) 43 | 44 | test_that("format_condition handles different types of warning", { 45 | expect_snapshot({ 46 | w1 <- simpleWarning("This is a warning") 47 | cat(format_condition(w1)) 48 | w2 <- simpleWarning("This is a warning", call = quote(f())) 49 | cat(format_condition(w2)) 50 | w3 <- rlang::warning_cnd(message = "This is a warning") 51 | cat(format_condition(w3)) 52 | w4 <- rlang::warning_cnd(message = "This is a warning") 53 | cat(format_condition(w4)) 54 | }) 55 | }) 56 | -------------------------------------------------------------------------------- /tests/testthat/test-reproducible-output.R: -------------------------------------------------------------------------------- 1 | test_that("local_reproducible_output() respects local context", { 2 | local_reproducible_output(width = 105) 3 | expect_equal(getOption("width"), 105) 4 | 5 | local({ 6 | local_reproducible_output(width = 110) 7 | expect_equal(getOption("width"), 110) 8 | }) 9 | 10 | expect_equal(getOption("width"), 105) 11 | }) 12 | 13 | test_that("local_envvar respects local context", { 14 | local_envvar(test = "a") 15 | expect_equal(Sys.getenv("test"), "a") 16 | 17 | local({ 18 | local_envvar(test = "b") 19 | expect_equal(Sys.getenv("test"), "b") 20 | }) 21 | 22 | expect_equal(Sys.getenv("test"), "a") 23 | local({ 24 | local_envvar(test = NA) 25 | expect_equal(Sys.getenv("test"), "") 26 | }) 27 | 28 | expect_equal(Sys.getenv("test"), "a") 29 | }) 30 | 31 | test_that("local_collate respects local context", { 32 | locale <- switch( 33 | Sys.info()[["sysname"]], 34 | Darwin = , 35 | Linux = "en_US.UTF-8", 36 | Windows = if (getRversion() >= "4.2") "en-US" 37 | ) 38 | skip_if(is.null(locale), "Don't know good locale to use for this platform") 39 | 40 | local_collate("C") 41 | expect_equal(Sys.getlocale("LC_COLLATE"), "C") 42 | 43 | local({ 44 | local_collate(locale) 45 | expect_equal(Sys.getlocale("LC_COLLATE"), locale) 46 | }) 47 | 48 | expect_equal(Sys.getlocale("LC_COLLATE"), "C") 49 | }) 50 | -------------------------------------------------------------------------------- /tests/testthat/test-watchout.R: -------------------------------------------------------------------------------- 1 | test_that("capture messages in try() (#88)", { 2 | f <- function(x) stop(paste0("Obscure ", x)) 3 | g <- function() f("error") 4 | 5 | ev <- evaluate("try(g())") 6 | expect_output_types(ev, c("source", "text")) 7 | expect_match(ev[[2]], "Obscure error") 8 | }) 9 | 10 | test_that("code can use own sink", { 11 | f <- function() { 12 | con <- file("") 13 | defer(close(con)) 14 | 15 | sink(con) 16 | cat("One") 17 | sink() 18 | } 19 | ev <- evaluate("f()\n1") 20 | expect_output_types(ev, c("source", "source", "text")) 21 | }) 22 | 23 | test_that("evaluate preserves externally created sinks", { 24 | sink(withr::local_tempfile()) 25 | defer(sink()) 26 | n <- sink.number() 27 | 28 | ev <- evaluate("1") 29 | expect_output_types(ev, c("source", "text")) 30 | 31 | expect_equal(sink.number(), n) 32 | }) 33 | 34 | test_that("evaluate recovers from closed sink", { 35 | expect_snapshot(ev <- evaluate("sink()\n1")) 36 | expect_output_types(ev, c("source", "source", "text")) 37 | }) 38 | 39 | test_that("unbalanced sink doesn't break evaluate", { 40 | path <- withr::local_tempfile() 41 | ev <- evaluate(function() { 42 | sink(path) 43 | 1 44 | 1 45 | }) 46 | expect_output_types(ev, c("source", "source", "source")) 47 | }) 48 | 49 | test_that("evaluate recovers from closed connection", { 50 | expect_snapshot(ev <- evaluate("closeAllConnections()\n1")) 51 | expect_output_types(ev, c("source", "source", "text")) 52 | }) 53 | 54 | test_that("isValid() works correctly", { 55 | con1 <- file("") 56 | expect_true(isValid(con1)) 57 | close(con1) 58 | expect_false(isValid(con1)) 59 | 60 | con2 <- file("") 61 | expect_false(isValid(con1)) # isOpen would return TRUE here 62 | expect_true(isValid(con2)) 63 | close(con2) 64 | }) 65 | --------------------------------------------------------------------------------