withr/0000755000175000017500000000000014210234012011526 5ustar nileshnileshwithr/MD50000644000175000017500000001170714210234012012044 0ustar nileshnilesh843fd47cab31bc335be2ccd3e5fdc6c1 *DESCRIPTION 6d8b003cc83b1dfced7bd996b18429dc *LICENSE 3d1b502d24fbf44cdade15005f4b62c5 *NAMESPACE 02eb2c1332237874fbd9fe4ad7126926 *NEWS.md 50085fd5d2362839c649e45ab4a12ed0 *R/aaa.R 6a039b9fdb04e0108dbe7dcd1fe7cc90 *R/collate.R 7f2c442395cfa1ac429cf91aa47c1895 *R/compat-defer.R 59e090f71fd584df1f32b0ca3591aeae *R/connection.R f5f81ad41ae7c6173c8feec2416cc092 *R/db.R b0f812b397d51381c2d54b784ae7ae10 *R/defer.R 1bc0c0680ad23bea41e86e545020aeb3 *R/devices.R ae55b528da3d76997dea1096185a6109 *R/dir.R d5289f0538a2e8934e7f6be51c9b3276 *R/env.R edeafa0fcfe39f3431c21db135a8f4af *R/file.R fc7896ab0777d36fde013f0b83650d24 *R/language.R e2a66843c9829f82ab5a4e8cf47e820b *R/libpaths.R 0f8f416866a72b41b81b1b9fc93592e8 *R/local_.R 0aac668e9fa2f97b502dd56c5658c0d2 *R/locale.R 58f6c94412d4b32ac3c026273c350915 *R/makevars.R 019fd40431718fb168bc714a00f1d680 *R/namespace.R 9168ee2a6f08f0e9392b6e2e372242d9 *R/options.R 5b11639dfd9099f963ddc94143f40d57 *R/par.R 871cf54d1ff63b72875decf918fa2a28 *R/path.R 91f27e4e753172c490af89ef389bcd9f *R/rng.R f1884947b055f5d20881226320e415e9 *R/seed.R 1939e43a0b29a1a8b446de3e0b33c233 *R/sink.R e80c9c2739401f0f61c630c257763759 *R/tempfile.R c18bfd841a74c391d6069333e349995c *R/timezone.R bd03783290e342d399ae55e4b96a5b2b *R/torture.R e323a663eb2ddcb74591be5745fd1db6 *R/utils.R e0d5b47fe55eb6190103480bfe65a731 *R/with.R 299ccc9fe63a616026f431af4660c0ca *R/with_.R 88e44ec61deb387dd1c2d8a607c420ee *R/wrap.R 218c3d1e857b827dfb161ca11ad4b1e0 *README.md 122fde171e3b5ab974a978249edddc0c *build/vignette.rds 083f07f7273b941c0bc91470ee2c3946 *inst/doc/changing-and-restoring-state.R 513119645a9dd924fef3cd504ef3b3e2 *inst/doc/changing-and-restoring-state.Rmd be0efca303e819de026097b004ce5799 *inst/doc/changing-and-restoring-state.html d945ab8c18c789b39b916f555d4e614a *man/defer.Rd 89b1f675b3b78d99ca629f4d4e2cf361 *man/devices.Rd 40af1efbfdf130062a304c44632ac021 *man/figures/README-unnamed-chunk-3-1.png ab471e54cdcde1b00fbfb165e9c3639b *man/figures/logo.png 6bf1267f5d283d5a1c77be880f86c9a2 *man/makevars_user.Rd 225704906384792f09de29161b880b66 *man/set_makevars.Rd 6027c34b4c5c712b4fc854b5dabf85ad *man/with_.Rd c598ec4a8def68c0a4a85ffcce21078e *man/with_collate.Rd 93833f77ca0916783a97bdbaaf0a27d2 *man/with_connection.Rd 43c66658e048a17686692e3bed15f277 *man/with_db_connection.Rd e2af2eae4dc1fd7c57e26bfba6c0d3a6 *man/with_dir.Rd 69d8071363d3318eafbd20a8e21ded8b *man/with_envvar.Rd 39f5c0e86b78fee515755d7037816d58 *man/with_file.Rd 577f7ae1abe32a8bab2603c1bc5f5c13 *man/with_gctorture2.Rd dfbb7ed3d0853caad149005a6771c547 *man/with_language.Rd a5fcfb94f0fbbe5cd235014752b4c199 *man/with_libpaths.Rd e59036d21725aad919378ec9d56ecb1b *man/with_locale.Rd 4cc7db3f214f7f406a584eca357b2adb *man/with_makevars.Rd c44361f6e5194cd5059bfc033fa1c251 *man/with_options.Rd 257a70fee1e2b809faa0aae98c191038 *man/with_package.Rd 2ac50a9214c2d3a35531845707cade34 *man/with_par.Rd 85cc76e58927f709274c5d5446c7f414 *man/with_path.Rd 224e5389a0136c48b75538b97ff4c28a *man/with_rng_version.Rd 86bde6be80cab07d750da77c306c4aaf *man/with_seed.Rd 07226ad884aff2aede9beadf1d8d0744 *man/with_sink.Rd 88d539e13a56830894b4573782b55761 *man/with_temp_libpaths.Rd 7e4710a4d74b7bdeed871b6edbf0f0ac *man/with_tempfile.Rd 374c13c45a2e57b027a3b144cf914151 *man/with_timezone.Rd 092e137de18cd334dbaa9a99170b1885 *man/withr.Rd 70c4d334a0974e15d0309c48ca52ca08 *tests/testthat.R d6f0f2ffb1192974245c12edc9a7a39f *tests/testthat/_snaps/defer.md eda7c5ba53d6983a366d065366b0eb48 *tests/testthat/_snaps/language.md 30736b2445676cb91054074293cb5e59 *tests/testthat/_snaps/path.md 3208718443c5e7ff5e5b2b3781646733 *tests/testthat/helper.R 2536c7975555a49c76d1e1c9f01a4493 *tests/testthat/test-collate.R 07ac5f226ff3125685ee361078937b1f *tests/testthat/test-connection.R 841d4018de83c07bb144375f5c7cc88d *tests/testthat/test-db.R 95f3a68e24ddd8e6aad587da62f474d1 *tests/testthat/test-defer.R afd3e0a72b8dc0caaa95c887df32a3fb *tests/testthat/test-devices.R da2a9b39b3f118c8c51a8b27bed2b3c0 *tests/testthat/test-env.R 96564806f8ba0f1f639543d699657b83 *tests/testthat/test-file.R 1a969fb8a467b8fd8fe3d655041c6c24 *tests/testthat/test-language.R b9eeb91221cf9fcb5c45dbe512d1eda7 *tests/testthat/test-local.R 8631b5d79eaf98fb9c3971e8d9df285a *tests/testthat/test-locale.R 39ba10d7134027cde5af2cc665639192 *tests/testthat/test-namespace.R 4eafa958f3387464ee02799d67cbacd6 *tests/testthat/test-options.R db7d8086a84fe28521fd3fe97d1161b8 *tests/testthat/test-path.R 0a87a8c81cb0bf781c55448c0e91094b *tests/testthat/test-rng.R 2a9f0ab95dfb05422c0ad09dc9bf618c *tests/testthat/test-seed.R e6834df68ee5937018b7f3e8c4d8e71f *tests/testthat/test-sink.R 7824f0a26f8144cbcc16507ec27c144f *tests/testthat/test-tempdir.R 1e8a3002142b2fbb38db4eb633d052a2 *tests/testthat/test-tempfile.R b844251a3653eb29805f766cb332be3a *tests/testthat/test-timezone.R edfe7cdf3adf8b86f904e4cc39e5595b *tests/testthat/test-with.R 022efee96cbc60f103af7e51bb306b4e *tests/testthat/test-wrap.R 513119645a9dd924fef3cd504ef3b3e2 *vignettes/changing-and-restoring-state.Rmd withr/NEWS.md0000644000175000017500000001521414210227307012640 0ustar nileshnilesh# withr 2.5.0 * `defer()` and all `local_*()` functions now work when run inside of a `.Rmd`. The deferred expressions are executed when knitr exits. * `defer()` and `local_` functions now work within `source()`. The deferred expressions are executed when `source()` exits. * `with_()` and `local_()` gain a `get` argument. Supply a getter function to create `with` and `local` functions that are robust to early exits. When supplied, this restoration pattern is used: ``` old <- get() on.exit(set(old)) set(new) action() ``` Instead of: ``` old <- set(new) on.exit(set(old)) action() ``` This ensures proper restoration of the old state when an early exit occurs during `set()` (for instance when a deprecation warning is caught, see #191). * These `with_` and `local_` functions are now robust to early exits (see next bullet): - `_locale()` - `_envvar()` - `_libpaths()` - `_options()` - `_par()` - `_path()` - `_seed()` * `with_namespace()` and `local_namespace()` now pass `warn.conflicts` to `attach()` (@kyleam, #185). * `local_rng_version()` and `local_seed()` no longer warn when restoring `sample.kind` to `"Rounding"` (#167). * `with_seed()` now preserves the current values of `RNGkind()` (#167). * `with_collate()` is no longer affected by the `LC_COLLATE` environment variable set to "C" (#179). * Local evaluations in the `globalenv()` (as opposed to top-level ones) are now unwound in the same way as regular environments. * `local_tempfile()` gains a lines argument so, if desired, you can pre-fill the temporary file with some data. # withr 2.4.3 * Lionel Henry is the new maintainer. * Handlers registered with the global environment (as happens when `local_()` is run at the top-level, outside a function) are now automatically run when the R session ends (#173). * New `with_language()` and `local_language()` to temporarily control the language used for translations (#180). * `with_seed()` now caches the check for R version, so is now faster (#170) * `with_makevars()` and `local_makevars()` now eagerly evaluate the `path` argument (#169) # withr 2.4.2 - `local_options()` now lets you set an option to `NULL` as intended (#156) - `local_tempfile()` argument `envir` is deprecated, in favor of `.local_envir`. All withr functions except `local_tempfile()` used `.local_envir` to specify environments, so this makes this function consistent with the rest. (#157) - `with_environment()` now passing `pos` and `warn.conflicts` to `attach()`, as intended (#161). - `with_seed()` now also sets the RNG via new arguments `.rng_kind`, `.rng_normal_kind` and `.rng_sample_kind` (#162, @AshesITR). - `with_timezone()` now works after recent changes to `Sys.timezone()` in R-devel (#165) # withr 2.4.1 - Tests which require `capabilities("cairo")` are now skipped. # withr 2.4.0 - withr is now licensed as MIT (#154). - Tests for `with_cairo_pdf()` and `with_cairo_ps()` have been removed, as they fail if Cairo is not available, such as with M1 macOS systems (#158) - `local_seed()` is now exported (#153) # withr 2.3.0 ## Deprecations - `local_tempfile()` argument `new` is deprecated, in favor of returning the path to the new tempfile. calls like `local_tempfile("xyz")` should be replaced with `xyx <- local_tempfile()` in your code (#141). ## New features - New `local_seed()` function and `local_preserve_seed()` functions to correspond to `with_seed()` and `with_preserve_seed()` (#139). - New `local_tempdir()` function added to create a temp directory (#140) - `local_*()` functions now take dots (`...`), which can simplify calls in some cases, e.g. you can now use `local_options(foo = "bar")` rather than `local_options(c(foo = "bar"))`. ## Minor improvements and fixes - `defer()` now throws an error if an error occurs in the deferred expression (#148) - `with_file()` and `local_file()` can now work if the file is actually a directory (#144). # withr 2.2.0 - `defer()` can set deferred events on `.GlobalEnv` to facilitate the interactive development of code inside a function or test. Helpers `deferred_run()` (and `deferred_clear()`) provide a way to explicity run and clear (or just clear) deferred events (#76, @jennybc). - `with_connection()` now works when existing objects or connections exist with the same names (#120) - `with_makevars()` now uses `tools::makevars_user()` to determine the default user makevars file (#77, @siddharthab). - `with_options()` no longer uses `do.call()`, so optiosn are not evaluated on exit (#73, @mtmorgan). - `with_package()` no longer has the `help` argument (#94, @wendtke). - `with_package()` now does not try to detach the package if it is already attached before calling `with_package()` (#107) - `with_preserve_seed()` now restores `.Random.seed` if it is not set originally (#124). - Add `with_rng_version()` and `local_rng_version()` functions to change the version of the RNG (#90, @gaborcsardi). - `with_svg()` documentation now is consistent across R versions (#129) - Add `with_timezone()` and `local_timezone()` functions to change the time zone (#92, @gaborcsardi). - `with_tempfile()` and `local_tempfile()` now delete recursively directories on exit (#84, @meta00). # withr 2.1.2 - `set_makevars()` is now exported (#68, @gaborcsardi). - `with_temp_libpaths()` gains an `action` argument, to specify how the temporary library path will be added (#66, @krlmlr). # withr 2.1.1 - Fixes test failures with testthat 2.0.0 - `with_file()` function to automatically remove files. # withr 2.1.0 - `with_connection()` function to automatically close R file connections. - `with_db_connection()` function to automatically disconnect from DBI database connections. - `with_gctorture2` command to run code with gctorture2, useful for testing (#47). - `with_package()`, `with_namespace()` and `with_environment()` (and equivalent locals) functions added, to run code with a modified object search path (#38, #48). - Add `with_tempfile()` and `local_tempfile()` functions to create temporary files which are cleanup up afterwards. (#32) - Remove the `code` argument from `local_` functions (#50). # withr 2.0.0 - Each `with_` function now has a `local_` variant, which reset at the end of their local scope, generally at the end of the function body. - New functions `with_seed()` and `with_preserve_seed()` for running code with a given random seed (#45, @krlmlr). # withr 1.0.2 - `with_makevars()` gains an `assignment` argument to allow specifying additional assignment types. # withr 1.0.1 - Relaxed R version requirement to 3.0.2 (#35, #39). - New `with_output_sink()` and `with_message_sink()` (#24). # withr 1.0.0 - First Public Release withr/DESCRIPTION0000644000175000017500000000477614210234012013252 0ustar nileshnileshPackage: withr Title: Run Code 'With' Temporarily Modified Global State Version: 2.5.0 Authors@R: c(person(given = "Jim", family = "Hester", role = "aut"), person(given = "Lionel", family = "Henry", role = c("aut", "cre"), email = "lionel@rstudio.com"), person(given = "Kirill", family = "Müller", role = "aut", email = "krlmlr+r@mailbox.org"), person(given = "Kevin", family = "Ushey", role = "aut", email = "kevinushey@gmail.com"), person(given = "Hadley", family = "Wickham", role = "aut", email = "hadley@rstudio.com"), person(given = "Winston", family = "Chang", role = "aut"), person(given = "Jennifer", family = "Bryan", role = "ctb"), person(given = "Richard", family = "Cotton", role = "ctb"), person(given = "RStudio", role = c("cph", "fnd"))) Description: A set of functions to run code 'with' safely and temporarily modified global state. Many of these functions were originally a part of the 'devtools' package, this provides a simple package with limited dependencies to provide access to these functions. License: MIT + file LICENSE URL: https://withr.r-lib.org, https://github.com/r-lib/withr#readme BugReports: https://github.com/r-lib/withr/issues Depends: R (>= 3.2.0) Imports: graphics, grDevices, stats Suggests: callr, covr, DBI, knitr, lattice, methods, rlang, rmarkdown (>= 2.12), RSQLite, testthat (>= 3.0.0) VignetteBuilder: knitr Encoding: UTF-8 RoxygenNote: 7.1.2 Collate: 'aaa.R' 'collate.R' 'compat-defer.R' 'connection.R' 'db.R' 'defer.R' 'wrap.R' 'local_.R' 'with_.R' 'devices.R' 'dir.R' 'env.R' 'file.R' 'language.R' 'libpaths.R' 'locale.R' 'makevars.R' 'namespace.R' 'options.R' 'par.R' 'path.R' 'rng.R' 'seed.R' 'sink.R' 'tempfile.R' 'timezone.R' 'torture.R' 'utils.R' 'with.R' Config/testthat/edition: 3 Config/Needs/website: tidyverse/tidytemplate NeedsCompilation: no Packaged: 2022-03-03 21:13:01 UTC; lionel Author: Jim Hester [aut], Lionel Henry [aut, cre], Kirill Müller [aut], Kevin Ushey [aut], Hadley Wickham [aut], Winston Chang [aut], Jennifer Bryan [ctb], Richard Cotton [ctb], RStudio [cph, fnd] Maintainer: Lionel Henry Repository: CRAN Date/Publication: 2022-03-03 21:50:02 UTC withr/README.md0000644000175000017500000001176714205721144013034 0ustar nileshnilesh # withr - run code ‘with’ modified state [![Codecov test coverage](https://codecov.io/gh/r-lib/withr/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/withr?branch=main) [![CRAN Version](https://www.r-pkg.org/badges/version/withr)](https://www.r-pkg.org/pkg/withr) [![R-CMD-check](https://github.com/r-lib/withr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/withr/actions/workflows/R-CMD-check.yaml) ## Overview A set of functions to run code with safely and temporarily modified global state, withr makes working with the global state, i.e. side effects, less error-prone. Pure functions, such as the `sum()` function, are easy to understand and reason about: they always map the same input to the same output and have no other impact on the workspace. In other words, pure functions have no *side effects*: they are not affected by, nor do they affect, the global state in any way apart from the value they return. The behavior of some functions *is* affected by the global state. Consider the `read.csv()` function: it takes a filename as an input and returns the contents as an output. In this case, the output depends on the contents of the file; i.e. the output is affected by the global state. Functions like this deal with side effects. The purpose of the withr package is to help you manage side effects in your code. You may want to run code with secret information, such as an API key, that you store as an environment variable. You may also want to run code with certain options, with a given random-seed, or with a particular working-directory. The withr package helps you manage these situations, and more, by providing functions to modify the global state temporarily, and safely. These functions modify one of the global settings for duration of a block of code, then automatically reset it after the block is completed. ## Installation ``` r #Install the latest version with: install.packages("withr") ``` Many of these functions were originally a part of the [devtools](https://github.com/r-lib/devtools) package, this provides a simple package with limited dependencies to provide access to these functions. - `with_collate()` / `local_collate()` - collation order - `with_dir()` / `local_dir()` - working directory - `with_envvar()` / `local_envvar()` - environment variables - `with_libpaths()` / `local_libpaths()` - library paths - `with_locale()` / `local_locale()` - any locale setting - `with_makevars()` / `local_makevars()` / `set_makevars()` - makevars variables - `with_options()` / `local_options()` - options - `with_par()` / `local_par()` - graphics parameters - `with_path()` / `local_path()` - PATH environment variable - `with_*()` and `local_*()` functions for the built in R devices, `bmp`, `cairo_pdf`, `cairo_ps`, `pdf`, `postscript`, `svg`, `tiff`, `xfig`, `png`, `jpeg`. - `with_connection()` / `local_connection()` - R file connections - `with_db_connection()` / `local_db_connection()` - DB conections - `with_package()` / `local_package()`, `with_namespace()` / `local_namespace()` and `with_environment()` / `local_environment()` - to run code with modified object search paths. - `with_tempfile()` / `local_tempfile()` - create and clean up a temp file. - `with_file()` / `local_file()` - create and clean up a normal file. - `with_message_sink()` / `local_message_sink()` - divert message - `with_output_sink()` / `local_output_sink()` - divert output - `with_preserve_seed()` / `with_seed()`- specify seeds - `with_temp_libpaths()` / `local_temp_libpaths()` - library paths - `defer()` / `defer_parent()` - defer - `with_timezone()` / `local_timezone()` - timezones - `with_rng_version()` / `local_rng_version()` - random number generation version ## Usage There are two sets of functions, those prefixed with `with_` and those with `local_`. The former reset their state as soon as the `code` argument has been evaluated. The latter reset when they reach the end of their scope, usually at the end of a function body. ``` r par("col" = "black") my_plot <- function(new) { with_par(list(col = "red", pch = 19), plot(mtcars$hp, mtcars$wt) ) par("col") } my_plot() ``` #> [1] "black" par("col") #> [1] "black" f <- function(x) { local_envvar(c("WITHR" = 2)) Sys.getenv("WITHR") } f() #> [1] "2" Sys.getenv("WITHR") #> [1] "" There are also `with_()` and `local_()` functions to construct new `with_*` and `local_*` functions if needed. ``` r Sys.getenv("WITHR") #> [1] "" with_envvar(c("WITHR" = 2), Sys.getenv("WITHR")) #> [1] "2" Sys.getenv("WITHR") #> [1] "" with_envvar(c("A" = 1), with_envvar(c("A" = 2), action = "suffix", Sys.getenv("A")) ) #> [1] "1 2" ``` # See Also - [Devtools](https://github.com/r-lib/devtools) withr/man/0000755000175000017500000000000014205720724012317 5ustar nileshnileshwithr/man/makevars_user.Rd0000644000175000017500000000040613670443075015463 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{makevars_user} \alias{makevars_user} \title{Shim for tools::makevars_user()} \usage{ makevars_user() } \description{ Shim for tools::makevars_user() } \keyword{internal} withr/man/defer.Rd0000644000175000017500000000513613672125251013701 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/defer.R \name{defer} \alias{defer} \alias{defer_parent} \alias{deferred_run} \alias{deferred_clear} \title{Defer Evaluation of an Expression} \usage{ defer(expr, envir = parent.frame(), priority = c("first", "last")) defer_parent(expr, priority = c("first", "last")) deferred_run(envir = parent.frame()) deferred_clear(envir = parent.frame()) } \arguments{ \item{expr}{\verb{[expression]}\cr An expression to be evaluated.} \item{envir}{\verb{[environment]}\cr Attach exit handlers to this environment. Typically, this should be either the current environment or a parent frame (accessed through \code{\link[=parent.frame]{parent.frame()}}).} \item{priority}{\verb{[character(1)]}\cr Specify whether this handler should be executed \code{"first"} or \code{"last"}, relative to any other registered handlers on this environment.} } \description{ Similar to \code{\link[=on.exit]{on.exit()}}, but allows one to attach an expression to be evaluated when exiting any frame currently on the stack. This provides a nice mechanism for scoping side effects for the duration of a function's execution. } \details{ \code{defer()} works by attaching handlers to the requested environment (as an attribute called \code{"handlers"}), and registering an exit handler that executes the registered handler when the function associated with the requested environment finishes execution. Deferred events can be set on the global environment, primarily to facilitate the interactive development of code that is intended to be executed inside a function or test. A message alerts the user to the fact that an explicit \code{deferred_run()} is the only way to trigger these deferred events. Use \code{deferred_clear()} to clear them without evaluation. The global environment scenario is the main motivation for these functions. } \examples{ # define a 'local' function that creates a file, and # removes it when the parent function has finished executing local_file <- function(path) { file.create(path) defer_parent(unlink(path)) } # create tempfile path path <- tempfile() # use 'local_file' in a function local({ local_file(path) stopifnot(file.exists(path)) }) # file is deleted as we leave 'local' local stopifnot(!file.exists(path)) # investigate how 'defer' modifies the # executing function's environment local({ local_file(path) print(attributes(environment())) }) # defer and trigger events on the global environment defer(print("one")) defer(print("two")) deferred_run() defer(print("three")) deferred_clear() deferred_run() } \concept{local-related functions} withr/man/with_.Rd0000644000175000017500000000543114205720724013723 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/local_.R, R/with_.R \name{local_} \alias{local_} \alias{with_} \title{Create a new "with" or "local" function} \usage{ local_( set, reset = set, get = NULL, ..., envir = parent.frame(), new = TRUE, dots = FALSE ) with_(set, reset = set, get = NULL, ..., envir = parent.frame(), new = TRUE) } \arguments{ \item{set}{\verb{[function(...)]}\cr Function used to set the state. The function can have arbitrarily many arguments, they will be replicated in the formals of the returned function.} \item{reset}{\verb{[function(x)]}\cr Function used to reset the state. The first argument can be named arbitrarily, further arguments with default values, or a "dots" argument, are supported but not used: The function will be called as \code{reset(old)}.} \item{get}{\verb{[function(...)]}\cr Optionally, a getter function. If supplied, the \code{on.exit()} restoration is set up \emph{before} calling \code{set}. This is more robust in edge cases. For technical reasons, this getter function must have the same interface as \code{set}, which means it is passed the new values as well. These can be safely ignored.} \item{...}{These dots are for future extensions and must be empty.} \item{envir}{\verb{[environment]}\cr Environment of the returned function.} \item{new}{\verb{[logical(1)]}\cr Replace the first argument of the \code{set} function by \code{new}? Set to \code{FALSE} if the \code{set} function only has optional arguments.} } \value{ \verb{[function(new, code, ...)]} A function with at least two arguments, \itemize{ \item \code{new}: New state to use \item \code{code}: Code to run in that state. } If there are more arguments to the function passed in \code{set} they are added to the returned function. If \code{set} does not have arguments, or \code{new} is \code{FALSE}, the returned function does not have a \code{code} argument. } \description{ These are constructors for \code{with_...} or \code{local_...} functions. They are only needed if you want to alter some global state which is not covered by the existing \code{with_...} functions, see \link{withr} for an overview. } \details{ The \code{with_...} functions reset the state immediately after the \code{code} argument has been evaluated. The \code{local_...} functions reset their arguments after they go out of scope, usually at the end of the function body. } \examples{ with_(setwd) global_stack <- list() set_global_state <- function(state, msg = "Changing global state.") { global_stack <- c(list(state), global_stack) message(msg) state } reset_global_state <- function(state) { old_state <- global_stack[[1]] global_stack <- global_stack[-1] stopifnot(identical(state, old_state)) } with_(set_global_state, reset_global_state) } \keyword{internal} withr/man/with_timezone.Rd0000644000175000017500000000235513615130050015467 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/timezone.R \name{with_timezone} \alias{with_timezone} \alias{local_timezone} \title{Time zone} \usage{ with_timezone(tz, code) local_timezone(tz, .local_envir = parent.frame()) } \arguments{ \item{tz}{\verb{[character(1)]} a valid time zone specification, note that time zone names might be platform dependent.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{The environment to apply the change to.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Change the time zone, and restore it afterwards. } \details{ \code{with_time_zone()} runs the code with the specified time zone and resets it afterwards. \code{local_time_zone()} changes the time zone for the caller execution environment. } \examples{ Sys.time() with_timezone("Europe/Paris", print(Sys.time())) with_timezone("US/Pacific", print(Sys.time())) fun1 <- function() { local_timezone("CET") print(Sys.time()) } fun2 <- function() { local_timezone("US/Pacific") print(Sys.time()) } Sys.time() fun1() fun2() Sys.time() } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.timezone]{Sys.timezone()}}. } withr/man/with_path.Rd0000644000175000017500000000225114205720724014575 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/path.R \name{with_path} \alias{with_path} \alias{local_path} \title{PATH environment variable} \usage{ with_path(new, code, action = c("prefix", "suffix", "replace")) local_path( new = list(), action = c("prefix", "suffix", "replace"), .local_envir = parent.frame() ) } \arguments{ \item{new}{\verb{[character]}\cr New \code{PATH} entries} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{\verb{[character(1)]}\cr Should new values \code{"replace"}, \code{"prefix"} (the default) or \code{"suffix"} existing paths} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change the system search path. } \examples{ # temporarily modify the system PATH, *prefixing* the current path with_path(getwd(), Sys.getenv("PATH")) # temporarily modify the system PATH, *appending* to the current path with_path(getwd(), Sys.getenv("PATH"), "suffix") } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setenv]{Sys.setenv()}} } withr/man/with_db_connection.Rd0000644000175000017500000000247513615130050016444 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/db.R \name{with_db_connection} \alias{with_db_connection} \alias{local_db_connection} \title{DBMS Connections which disconnect themselves.} \usage{ with_db_connection(con, code) local_db_connection(con, .local_envir = parent.frame()) } \arguments{ \item{con}{For \code{with_db_connection()} a named list with the connection(s) to create. For \code{local_db_connection()} the code to create a single connection, which is then returned.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Connections to Database Management Systems which automatically disconnect. In particular connections which are created with \code{DBI::dbConnect()} and closed with \code{DBI::dbDisconnect()}. } \examples{ db <- tempfile() with_db_connection( list(con = DBI::dbConnect(RSQLite::SQLite(), db)), { DBI::dbWriteTable(con, "mtcars", mtcars) }) head_db_table <- function(...) { con <- local_db_connection(DBI::dbConnect(RSQLite::SQLite(), db)) head(DBI::dbReadTable(con, "mtcars"), ...) } head_db_table() unlink(db) } \seealso{ \code{\link{withr}} for examples } withr/man/with_language.Rd0000644000175000017500000000172614165531434015435 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/language.R \name{with_language} \alias{with_language} \alias{local_language} \title{Language} \usage{ with_language(lang, code) local_language(lang, .local_envir = parent.frame()) } \arguments{ \item{lang}{A BCP47 language code like "en" (English), "fr" (French), "fr_CA" (French Canadian). Formally, this is a lower case two letter \href{https://en.wikipedia.org/wiki/List_of_ISO_639-1_codes}{ISO 639 country code}, optionally followed by "_" or "-" and an upper case two letter \href{https://en.wikipedia.org/wiki/ISO_3166-2}{ISO 3166 region code}.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \description{ Temporarily change the language used for translations. } \examples{ with_language("en", try(mean[[1]])) with_language("fr", try(mean[[1]])) with_language("es", try(mean[[1]])) } withr/man/with_package.Rd0000644000175000017500000000660613615130050015233 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/namespace.R \name{with_package} \alias{with_package} \alias{local_package} \alias{with_namespace} \alias{local_namespace} \alias{with_environment} \alias{local_environment} \title{Execute code with a modified search path} \usage{ with_package( package, code, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = FALSE, quietly = TRUE, verbose = getOption("verbose") ) local_package( package, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = FALSE, quietly = TRUE, verbose = getOption("verbose"), .local_envir = parent.frame() ) with_namespace(package, code, warn.conflicts = FALSE) local_namespace(package, .local_envir = parent.frame(), warn.conflicts = FALSE) with_environment( env, code, pos = 2L, name = format(env), warn.conflicts = FALSE ) local_environment( env, pos = 2L, name = format(env), warn.conflicts = FALSE, .local_envir = parent.frame() ) } \arguments{ \item{package}{\code{[character(1)]}\cr package name to load.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{pos}{the position on the search list at which to attach the loaded namespace. Can also be the name of a position on the current search list as given by \code{\link[base]{search}()}.} \item{lib.loc}{a character vector describing the location of \R library trees to search through, or \code{NULL}. The default value of \code{NULL} corresponds to all libraries currently known to \code{\link[base]{.libPaths}()}. Non-existent library trees are silently ignored.} \item{character.only}{a logical indicating whether \code{package} or \code{help} can be assumed to be character strings.} \item{logical.return}{logical. If it is \code{TRUE}, \code{FALSE} or \code{TRUE} is returned to indicate success.} \item{warn.conflicts}{logical. If \code{TRUE}, warnings are printed about \code{\link[base]{conflicts}} from attaching the new package. A conflict is a function masking a function, or a non-function masking a non-function. The default is \code{TRUE} unless specified as \code{FALSE} in the \code{conflicts.policy} option. } \item{quietly}{a logical. If \code{TRUE}, no message confirming package attaching is printed, and most often, no errors/warnings are printed if package attaching fails.} \item{verbose}{a logical. If \code{TRUE}, additional diagnostics are printed.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} \item{env}{\code{[environment()]}\cr Environment to attach.} \item{name}{name to use for the attached database. Names starting with \code{package:} are reserved for \code{\link[base]{library}}.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ \code{with_package()} attaches a package to the search path, executes the code, then removes the package from the search path. The package namespace is \emph{not} unloaded however. \code{with_namespace()} does the same thing, but attaches the package namespace to the search path, so all objects (even unexported ones) are also available on the search path. } \examples{ \dontrun{ with_package("ggplot2", { ggplot(mtcars) + geom_point(aes(wt, hp)) }) } } \seealso{ \code{\link{withr}} for examples } withr/man/with_tempfile.Rd0000644000175000017500000000373414205130072015444 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tempfile.R \name{with_tempfile} \alias{with_tempfile} \alias{local_tempfile} \alias{with_tempdir} \alias{local_tempdir} \title{Temporary files} \usage{ with_tempfile( new, code, envir = parent.frame(), .local_envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "" ) local_tempfile( new = NULL, lines = NULL, envir = parent.frame(), .local_envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "" ) with_tempdir( code, clean = TRUE, pattern = "file", tmpdir = tempdir(), fileext = "" ) local_tempdir( pattern = "file", tmpdir = tempdir(), fileext = "", .local_envir = parent.frame(), clean = TRUE ) } \arguments{ \item{new}{\verb{[character vector]}\cr (Deprecated for \code{local_tempfile()}) Names of temporary file handles to create.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{envir}{\verb{[environment]}\cr Deprecated in favor of \code{.local_envir}.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} \item{pattern}{a non-empty character vector giving the initial part of the name.} \item{tmpdir}{a non-empty character vector giving the directory name} \item{fileext}{a non-empty character vector giving the file extension} \item{lines}{Optionally, supply lines to be fed into} \item{clean}{\verb{[logical(1)]}\cr A logical indicating if the temporary directory should be deleted after use (\code{TRUE}, default) or left alone (\code{FALSE}).} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily create a tempfile, which is automatically removed afterwards. } \examples{ # check how big iris would be if written as csv vs RDS tf <- with_tempfile("tf", {write.csv(iris, tf); file.size(tf)}) tf <- with_tempfile("tf", {saveRDS(iris, tf); file.size(tf)}) } \seealso{ \code{\link{withr}} for examples } withr/man/withr.Rd0000644000175000017500000000623314165531434013752 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/with.R \docType{package} \name{withr} \alias{withr} \alias{withr-package} \title{Execute code in temporarily altered environment} \description{ All functions prefixed by \code{with_} work as follows. First, a particular aspect of the global environment is modified (see below for a list). Then, custom code (passed via the \code{code} argument) is executed. Upon completion or error, the global environment is restored to the previous state. Each \code{with_} function has a \code{local_} variant, which instead resets the state when the current evaluation context ends (such as the end of a function). } \section{Arguments pattern}{ \tabular{lll}{ \code{new} \tab \verb{[various]} \tab Values for setting \cr \code{code} \tab \verb{[any]} \tab Code to execute in the temporary environment \cr \code{...} \tab \tab Further arguments \cr } } \section{Usage pattern}{ \code{with_...(new, code, ...)} } \section{withr functions}{ \itemize{ \item \code{\link[=with_collate]{with_collate()}}: collation order \item \code{\link[=with_dir]{with_dir()}}: working directory \item \code{\link[=with_envvar]{with_envvar()}}: environment variables \item \code{\link[=with_libpaths]{with_libpaths()}}: library paths, replacing current libpaths \item \code{\link[=with_locale]{with_locale()}}: any locale setting \item \code{\link[=with_makevars]{with_makevars()}}: Makevars variables \item \code{\link[=with_options]{with_options()}}: options \item \code{\link[=with_par]{with_par()}}: graphics parameters \item \code{\link[=with_path]{with_path()}}: \code{PATH} environment variable \item \code{\link[=with_sink]{with_sink()}}: output redirection } } \section{Creating new "with" functions}{ All \code{with_} functions are created by a helper function, \code{\link[=with_]{with_()}}. This functions accepts two arguments: a setter function and an optional resetter function. The setter function is expected to change the global state and return an "undo instruction". This undo instruction is then passed to the resetter function, which changes back the global state. In many cases, the setter function can be used naturally as resetter. } \examples{ getwd() with_dir(tempdir(), getwd()) getwd() Sys.getenv("WITHR") with_envvar(c("WITHR" = 2), Sys.getenv("WITHR")) Sys.getenv("WITHR") with_envvar(c("A" = 1), with_envvar(c("A" = 2), action = "suffix", Sys.getenv("A")) ) # local variants are best used within other functions f <- function(x) { local_envvar(c("WITHR" = 2)) Sys.getenv("WITHR") } Sys.getenv("WITHR") } \seealso{ Useful links: \itemize{ \item \url{https://withr.r-lib.org} \item \url{https://github.com/r-lib/withr#readme} \item Report bugs at \url{https://github.com/r-lib/withr/issues} } } \author{ \strong{Maintainer}: Lionel Henry \email{lionel@rstudio.com} Authors: \itemize{ \item Jim Hester \item Kirill Müller \email{krlmlr+r@mailbox.org} \item Kevin Ushey \email{kevinushey@gmail.com} \item Hadley Wickham \email{hadley@rstudio.com} \item Winston Chang } Other contributors: \itemize{ \item Jennifer Bryan [contributor] \item Richard Cotton [contributor] \item RStudio [copyright holder] } } withr/man/with_connection.Rd0000644000175000017500000000203013670443075016001 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/connection.R \name{with_connection} \alias{with_connection} \alias{local_connection} \title{Connections which close themselves} \usage{ with_connection(con, code) local_connection(con, .local_envir = parent.frame()) } \arguments{ \item{con}{For \code{with_connection()} a named list with the connection(s) to create. For \code{local_connection()} the code to create a single connection, which is then returned.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ R file connections which are automatically closed. } \examples{ with_connection(list(con = file("foo", "w")), { writeLines(c("foo", "bar"), con) }) read_foo <- function() { readLines(local_connection(file("foo", "r"))) } read_foo() unlink("foo") } \seealso{ \code{\link{withr}} for examples } withr/man/with_temp_libpaths.Rd0000644000175000017500000000164713615130050016473 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/libpaths.R \name{with_temp_libpaths} \alias{with_temp_libpaths} \alias{local_temp_libpaths} \title{Library paths} \usage{ with_temp_libpaths(code, action = "prefix") local_temp_libpaths(action = "prefix", .local_envir = parent.frame()) } \arguments{ \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{\verb{[character(1)]}\cr should new values \code{"replace"}, \code{"prefix"} or \code{"suffix"} existing paths.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily prepend a new temporary directory to the library paths. } \seealso{ \code{\link{withr}} for examples \code{\link[=.libPaths]{.libPaths()}} Other libpaths: \code{\link{with_libpaths}()} } \concept{libpaths} withr/man/with_sink.Rd0000644000175000017500000000276013735322666014624 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sink.R \name{with_sink} \alias{with_sink} \alias{with_output_sink} \alias{local_output_sink} \alias{with_message_sink} \alias{local_message_sink} \title{Output redirection} \usage{ with_output_sink(new, code, append = FALSE, split = FALSE) local_output_sink( new = list(), append = FALSE, split = FALSE, .local_envir = parent.frame() ) with_message_sink(new, code, append = FALSE) local_message_sink(new = list(), append = FALSE, .local_envir = parent.frame()) } \arguments{ \item{new}{\verb{[character(1)|connection]}\cr A writable \link{connection} or a character string naming the file to write to. Passing \code{NULL} will throw an error.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{append}{logical. If \code{TRUE}, output will be appended to \code{file}; otherwise, it will overwrite the contents of \code{file}.} \item{split}{logical: if \code{TRUE}, output will be sent to the new sink and to the current output stream, like the Unix program \code{tee}.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily divert output to a file via \code{\link[=sink]{sink()}}. For sinks of type \code{message}, an error is raised if such a sink is already active. } \seealso{ \code{\link{withr}} for examples \code{\link[=sink]{sink()}} } withr/man/with_libpaths.Rd0000644000175000017500000000211313735322666015456 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/libpaths.R \name{with_libpaths} \alias{with_libpaths} \alias{local_libpaths} \title{Library paths} \usage{ with_libpaths(new, code, action = "replace") local_libpaths(new = list(), action = "replace", .local_envir = parent.frame()) } \arguments{ \item{new}{\verb{[character]}\cr New library paths} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{\verb{[character(1)]}\cr should new values \code{"replace"}, \code{"prefix"} or \code{"suffix"} existing paths.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change library paths. } \examples{ .libPaths() new_lib <- tempfile() dir.create(new_lib) with_libpaths(new_lib, print(.libPaths())) unlink(new_lib, recursive = TRUE) } \seealso{ \code{\link{withr}} for examples \code{\link[=.libPaths]{.libPaths()}} Other libpaths: \code{\link{with_temp_libpaths}()} } \concept{libpaths} withr/man/with_envvar.Rd0000644000175000017500000000255513735322666015163 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/env.R \name{with_envvar} \alias{with_envvar} \alias{local_envvar} \title{Environment variables} \usage{ with_envvar(new, code, action = "replace") local_envvar( .new = list(), ..., action = "replace", .local_envir = parent.frame() ) } \arguments{ \item{new, .new}{\verb{[named character]}\cr New environment variables} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{should new values \code{"replace"}, \code{"prefix"} or \code{"suffix"} existing variables with the same name.} \item{...}{Named arguments with new environment variables.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change system environment variables. } \details{ if \code{NA} is used those environment variables will be unset. If there are any duplicated variable names only the last one is used. } \examples{ with_envvar(new = c("GITHUB_PAT" = "abcdef"), Sys.getenv("GITHUB_PAT")) # with_envvar unsets variables after usage Sys.getenv("TEMP_SECRET") with_envvar(new = c("TEMP_SECRET" = "secret"), Sys.getenv("TEMP_SECRET")) Sys.getenv("TEMP_SECRET") } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setenv]{Sys.setenv()}} } withr/man/with_collate.Rd0000644000175000017500000000156613735322666015306 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/collate.R \name{with_collate} \alias{with_collate} \alias{local_collate} \title{Collation Order} \usage{ with_collate(new, code) local_collate(new = list(), .local_envir = parent.frame()) } \arguments{ \item{new}{\verb{[character(1)]}\cr New collation order} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change collation order by changing the value of the \code{LC_COLLATE} locale. } \examples{ # Modify collation order: x <- c("bernard", "bérénice", "béatrice", "boris") with_collate("fr_FR", sort(x)) with_collate("C", sort(x)) } \seealso{ \code{\link{withr}} for examples } withr/man/with_options.Rd0000644000175000017500000000312213735322666015344 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{with_options} \alias{with_options} \alias{local_options} \title{Options} \usage{ with_options(new, code) local_options(.new = list(), ..., .local_envir = parent.frame()) } \arguments{ \item{new, .new}{\verb{[named list]}\cr New options and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{...}{Additional options and their values} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change global options. } \examples{ # number of significant digits to print getOption("digits") # modify temporarily the number of significant digits to print with_options(list(digits = 3), getOption("digits")) with_options(list(digits = 3), print(pi)) # modify temporarily the character to be used as the decimal point getOption("digits") with_options(list(OutDec = ","), print(pi)) # modify temporarily multiple options with_options(list(OutDec = ",", digits = 3), print(pi)) # modify, within the scope of the function, the number of # significant digits to print print_3_digits <- function(x) { # assign 3 to the option "digits" for the rest of this function # after the function exits, the option will return to its previous # value local_options(list(digits = 3)) print(x) } print_3_digits(pi) # returns 3.14 print(pi) # returns 3.141593 } \seealso{ \code{\link{withr}} for examples \code{\link[=options]{options()}} } withr/man/with_par.Rd0000644000175000017500000000214513735322666014437 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/par.R \name{with_par} \alias{with_par} \alias{local_par} \title{Graphics parameters} \usage{ with_par(new, code, no.readonly = FALSE) local_par( .new = list(), ..., no.readonly = FALSE, .local_envir = parent.frame() ) } \arguments{ \item{new, .new}{\verb{[named list]}\cr New graphics parameters and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{no.readonly}{\verb{[logical(1)]}\cr see \code{\link[=par]{par()}} documentation.} \item{...}{Additional graphics parameters and their values.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change graphics parameters. } \examples{ old <- par("col" = "black") # This will be in red with_par(list(col = "red", pch = 19), plot(mtcars$hp, mtcars$wt) ) # This will still be in black plot(mtcars$hp, mtcars$wt) par(old) } \seealso{ \code{\link{withr}} for examples \code{\link[=par]{par()}} } withr/man/set_makevars.Rd0000644000175000017500000000172713670443075015307 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/makevars.R \name{set_makevars} \alias{set_makevars} \title{Create a new \code{Makevars} file, by adding new variables} \usage{ set_makevars( variables, old_path = makevars_user(), new_path = tempfile(), assignment = c("=", ":=", "?=", "+=") ) } \arguments{ \item{variables}{\verb{[named character]}\cr new variables and their values} \item{old_path}{\verb{[character(1)]}\cr location of existing \code{Makevars} file to modify.} \item{new_path}{\verb{[character(1)]}\cr location of the new \code{Makevars} file} \item{assignment}{\verb{[character(1)]}\cr assignment type to use.} } \description{ You probably want \code{\link[=with_makevars]{with_makevars()}} instead of this function. } \details{ Unlike \code{\link[=with_makevars]{with_makevars()}}, it does not activate the new \code{Makevars} file, i.e. it does not set the \code{R_MAKEVARS_USER} environment variable. } \keyword{internal} withr/man/with_locale.Rd0000644000175000017500000000315013735322666015111 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/locale.R \name{with_locale} \alias{with_locale} \alias{local_locale} \title{Locale settings} \usage{ with_locale(new, code) local_locale(.new = list(), ..., .local_envir = parent.frame()) } \arguments{ \item{new, .new}{\verb{[named character]}\cr New locale settings} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{...}{Additional arguments with locale settings.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change locale settings. } \details{ Setting the \code{LC_ALL} category is currently not implemented. } \examples{ ## Change locale for time: df <- data.frame( stringsAsFactors = FALSE, date = as.Date(c("2019-01-01", "2019-02-01")), value = c(1, 2) ) with_locale(new = c("LC_TIME" = "es_ES"), code = plot(df$date, df$value)) ## Compare with: # plot(df$date, df$value) ## Month names: with_locale(new = c("LC_TIME" = "en_GB"), format(ISOdate(2000, 1:12, 1), "\%B")) with_locale(new = c("LC_TIME" = "es_ES"), format(ISOdate(2000, 1:12, 1), "\%B")) ## Change locale for currencies: with_locale(new = c("LC_MONETARY" = "it_IT"), Sys.localeconv()) with_locale(new = c("LC_MONETARY" = "en_US"), Sys.localeconv()) ## Ordering: x <- c("bernard", "bérénice", "béatrice", "boris") with_locale(c(LC_COLLATE = "fr_FR"), sort(x)) with_locale(c(LC_COLLATE = "C"), sort(x)) } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setlocale]{Sys.setlocale()}} } withr/man/with_seed.Rd0000644000175000017500000000322014205720724014556 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/seed.R \name{with_seed} \alias{with_seed} \alias{local_seed} \alias{with_preserve_seed} \alias{local_preserve_seed} \title{Random seed} \usage{ with_seed( seed, code, .rng_kind = NULL, .rng_normal_kind = NULL, .rng_sample_kind = NULL ) local_seed( seed, .local_envir = parent.frame(), .rng_kind = NULL, .rng_normal_kind = NULL, .rng_sample_kind = NULL ) with_preserve_seed(code) local_preserve_seed(.local_envir = parent.frame()) } \arguments{ \item{seed}{\verb{[integer(1)]}\cr The random seed to use to evaluate the code.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.rng_kind, .rng_normal_kind, .rng_sample_kind}{\verb{[character(1)]}\cr Kind of RNG to use. Passed as the \code{kind}, \code{normal.kind}, and \code{sample.kind} arguments of \code{\link[=RNGkind]{RNGkind()}}.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ \code{with_seed()} runs code with a specific random seed and resets it afterwards. \code{with_preserve_seed()} runs code with the current random seed and resets it afterwards. } \examples{ # Same random values: with_preserve_seed(runif(5)) with_preserve_seed(runif(5)) # Use a pseudorandom value as seed to advance the RNG and pick a different # value for the next call: with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5)) with_seed(seed, runif(5)) with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5)) } \seealso{ \code{\link{withr}} for examples } withr/man/devices.Rd0000644000175000017500000002050313735322666014242 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/devices.R \name{devices} \alias{devices} \alias{with_dev} \alias{with_device} \alias{with_bmp} \alias{local_bmp} \alias{with_cairo_pdf} \alias{local_cairo_pdf} \alias{with_cairo_ps} \alias{local_cairo_ps} \alias{with_pdf} \alias{local_pdf} \alias{with_postscript} \alias{local_postscript} \alias{with_svg} \alias{local_svg} \alias{with_tiff} \alias{local_tiff} \alias{with_xfig} \alias{local_xfig} \alias{with_png} \alias{local_png} \alias{with_jpeg} \alias{local_jpeg} \title{Graphics devices} \usage{ with_bmp(new, code, ...) local_bmp(new = list(), ..., .local_envir = parent.frame()) with_cairo_pdf(new, code, ...) local_cairo_pdf(new = list(), ..., .local_envir = parent.frame()) with_cairo_ps(new, code, ...) local_cairo_ps(new = list(), ..., .local_envir = parent.frame()) with_pdf( new, code, width, height, onefile, family, title, fonts, version, paper, encoding, bg, fg, pointsize, pagecentre, colormodel, useDingbats, useKerning, fillOddEven, compress ) local_pdf( new = list(), width, height, onefile, family, title, fonts, version, paper, encoding, bg, fg, pointsize, pagecentre, colormodel, useDingbats, useKerning, fillOddEven, compress, .local_envir = parent.frame() ) with_postscript( new, code, onefile, family, title, fonts, encoding, bg, fg, width, height, horizontal, pointsize, paper, pagecentre, print.it, command, colormodel, useKerning, fillOddEven ) local_postscript( new = list(), onefile, family, title, fonts, encoding, bg, fg, width, height, horizontal, pointsize, paper, pagecentre, print.it, command, colormodel, useKerning, fillOddEven, .local_envir = parent.frame() ) with_svg( new, code, width = 7, height = 7, pointsize = 12, onefile = FALSE, family = "sans", bg = "white", antialias = c("default", "none", "gray", "subpixel"), ... ) local_svg( new = list(), width = 7, height = 7, pointsize = 12, onefile = FALSE, family = "sans", bg = "white", antialias = c("default", "none", "gray", "subpixel"), ..., .local_envir = parent.frame() ) with_tiff(new, code, ...) local_tiff(new = list(), ..., .local_envir = parent.frame()) with_xfig( new, code, onefile = FALSE, encoding = "none", paper = "default", horizontal = TRUE, width = 0, height = 0, family = "Helvetica", pointsize = 12, bg = "transparent", fg = "black", pagecentre = TRUE, defaultfont = FALSE, textspecial = FALSE ) local_xfig( new = list(), onefile = FALSE, encoding = "none", paper = "default", horizontal = TRUE, width = 0, height = 0, family = "Helvetica", pointsize = 12, bg = "transparent", fg = "black", pagecentre = TRUE, defaultfont = FALSE, textspecial = FALSE, .local_envir = parent.frame() ) with_png(new, code, ...) local_png(new = list(), ..., .local_envir = parent.frame()) with_jpeg(new, code, ...) local_jpeg(new = list(), ..., .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[named character]}\cr New graphics device} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{...}{Additional arguments passed to the graphics device.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} \item{width}{the width of the device in inches.} \item{height}{the height of the device in inches.} \item{onefile}{should all plots appear in one file or in separate files?} \item{family}{one of the device-independent font families, \code{"sans"}, \code{"serif"} and \code{"mono"}, or a character string specify a font family to be searched for in a system-dependent way. On unix-alikes (incl.\\ Mac), see the \sQuote{Cairo fonts} section in the help for \code{\link[grDevices]{X11}}. } \item{title}{title string to embed as the \samp{/Title} field in the file. Defaults to \code{"R Graphics Output"}.} \item{fonts}{a character vector specifying \R graphics font family names for additional fonts which will be included in the PDF file. Defaults to \code{NULL}.} \item{version}{a string describing the PDF version that will be required to view the output. This is a minimum, and will be increased (with a warning) if necessary. Defaults to \code{"1.4"}, but see \sQuote{Details}.} \item{paper}{the target paper size. The choices are \code{"a4"}, \code{"letter"}, \code{"legal"} (or \code{"us"}) and \code{"executive"} (and these can be capitalized), or \code{"a4r"} and \code{"USr"} for rotated (\sQuote{landscape}). The default is \code{"special"}, which means that the \code{width} and \code{height} specify the paper size. A further choice is \code{"default"}; if this is selected, the papersize is taken from the option \code{"papersize"} if that is set and as \code{"a4"} if it is unset or empty. Defaults to \code{"special"}. } \item{encoding}{the name of an encoding file. See \code{\link[grDevices]{postscript}} for details. Defaults to \code{"default"}.} \item{bg}{the initial background colour: can be overridden by setting par("bg").} \item{fg}{the initial foreground color to be used. Defaults to \code{"black"}.} \item{pointsize}{the default pointsize of plotted text (in big points).} \item{pagecentre}{logical: should the device region be centred on the page? -- is only relevant for \code{paper != "special"}. Defaults to \code{TRUE}.} \item{colormodel}{a character string describing the color model: currently allowed values are \code{"srgb"}, \code{"gray"} (or \code{"grey"}) and \code{"cmyk"}. Defaults to \code{"srgb"}. See section \sQuote{Color models}.} \item{useDingbats}{logical. Should small circles be rendered \emph{via} the Dingbats font? Defaults to \code{FALSE}. If \code{TRUE}, this can produce smaller and better output, but there can font display problems in broken PDF viewers: although this font is one of the 14 guaranteed to be available in all PDF viewers, that guarantee is not always honoured. For Unix-alikes (including macOS) see the \sQuote{Note} for a possible fix for some viewers.} \item{useKerning}{logical. Should kerning corrections be included in setting text and calculating string widths? Defaults to \code{TRUE}.} \item{fillOddEven}{logical controlling the polygon fill mode: see \code{\link{polygon}} for details. Defaults to \code{FALSE}.} \item{compress}{logical. Should PDF streams be generated with Flate compression? Defaults to \code{TRUE}.} \item{horizontal}{the orientation of the printed image, a logical. Defaults to true, that is landscape orientation on paper sizes with width less than height.} \item{print.it}{logical: should the file be printed when the device is closed? (This only applies if \code{file} is a real file name.) Defaults to false.} \item{command}{the command to be used for \sQuote{printing}. Defaults to \code{"default"}, the value of option \code{"printcmd"}. The length limit is \code{2*PATH_MAX}, typically 8096 bytes on unix systems and 520 bytes on windows.} \item{antialias}{string, the type of anti-aliasing (if any) to be used; defaults to \code{"default"}.} \item{defaultfont}{logical: should the device use xfig's default font?} \item{textspecial}{logical: should the device set the textspecial flag for all text elements. This is useful when generating pstex from xfig figures.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily use a graphics device. } \section{Functions}{ \itemize{ \item \code{with_bmp}: BMP device \item \code{with_cairo_pdf}: CAIRO_PDF device \item \code{with_cairo_ps}: CAIRO_PS device \item \code{with_pdf}: PDF device \item \code{with_postscript}: POSTSCRIPT device \item \code{with_svg}: SVG device \item \code{with_tiff}: TIFF device \item \code{with_xfig}: XFIG device \item \code{with_png}: PNG device \item \code{with_jpeg}: JPEG device }} \examples{ # dimensions are in inches with_pdf(file.path(tempdir(), "test.pdf"), width = 7, height = 5, plot(runif(5)) ) # dimensions are in pixels with_png(file.path(tempdir(), "test.png"), width = 800, height = 600, plot(runif(5)) ) } \seealso{ \code{\link{withr}} for examples \code{\link[grDevices]{Devices}} } withr/man/with_makevars.Rd0000644000175000017500000000323713735322666015471 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/makevars.R \name{with_makevars} \alias{with_makevars} \alias{local_makevars} \title{Makevars variables} \usage{ with_makevars( new, code, path = makevars_user(), assignment = c("=", ":=", "?=", "+=") ) local_makevars( .new = list(), ..., .path = makevars_user(), .assignment = c("=", ":=", "?=", "+="), .local_envir = parent.frame() ) } \arguments{ \item{new, .new}{\verb{[named character]}\cr New variables and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{path, .path}{\verb{[character(1)]}\cr location of existing \code{Makevars} file to modify.} \item{assignment, .assignment}{\verb{[character(1)]}\cr assignment type to use.} \item{...}{Additional new variables and their values.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change contents of an existing \code{Makevars} file. } \details{ If no \code{Makevars} file exists or the fields in \code{new} do not exist in the existing \code{Makevars} file then the fields are added to the new file. Existing fields which are not included in \code{new} are appended unchanged. Fields which exist in \code{Makevars} and in \code{new} are modified to use the value in \code{new}. } \examples{ writeLines("void foo(int* bar) { *bar = 1; }\n", "foo.c") system("R CMD SHLIB --preclean -c foo.c") with_makevars(c(CFLAGS = "-O3"), system("R CMD SHLIB --preclean -c foo.c")) unlink(c("foo.c", "foo.so")) } \seealso{ \code{\link{withr}} for examples } withr/man/with_file.Rd0000644000175000017500000000165713735322666014603 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/file.R \name{with_file} \alias{with_file} \alias{local_file} \title{Files which delete themselves} \usage{ with_file(file, code) local_file(.file, ..., .local_envir = parent.frame()) } \arguments{ \item{file, .file}{\verb{[named list]}\cr Files to create.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{...}{Additional (possibly named) arguments of files to create.} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Create files, which are then automatically removed afterwards. } \examples{ with_file("file1", { writeLines("foo", "file1") readLines("file1") }) with_file(list("file1" = writeLines("foo", "file1")), { readLines("file1") }) } \seealso{ \code{\link{withr}} for examples } withr/man/with_rng_version.Rd0000644000175000017500000000302113615130050016157 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rng.R \name{with_rng_version} \alias{with_rng_version} \alias{local_rng_version} \title{RNG version} \usage{ with_rng_version(version, code) local_rng_version(version, .local_envir = parent.frame()) } \arguments{ \item{version}{\verb{[character(1)]} an R version number, e.g. \code{"3.5.0"}, to switch to the RNG this version of R uses. See \code{\link[=RNGversion]{RNGversion()}}.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{The environment to apply the change to.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Change the RNG version and restore it afterwards. } \details{ \code{with_rng_version()} runs the code with the specified RNG version and resets it afterwards. \code{local_rng_version()} changes the RNG version for the caller execution environment. } \examples{ RNGkind() with_rng_version("3.0.0", RNGkind()) with_rng_version("1.6.0", RNGkind()) with_rng_version("3.0.0", with_seed(42, sample(1:100, 3))) with_rng_version("1.6.0", with_seed(42, sample(1:100, 3))) RNGkind() fun1 <- function() { local_rng_version("3.0.0") with_seed(42, sample(1:100, 3)) } fun2 <- function() { local_rng_version("1.6.0") with_seed(42, sample(1:100, 3)) } RNGkind() fun1() fun2() RNGkind() } \seealso{ \code{\link{withr}} for examples \code{\link[=RNGversion]{RNGversion()}}, \code{\link[=RNGkind]{RNGkind()}}, \code{\link[=with_seed]{with_seed()}}. } withr/man/with_gctorture2.Rd0000644000175000017500000000136413615130050015734 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/torture.R \name{with_gctorture2} \alias{with_gctorture2} \title{Torture Garbage Collector} \usage{ with_gctorture2(new, code, wait = new, inhibit_release = FALSE) } \arguments{ \item{new}{\verb{[integer]}\cr run GC every 'step' allocations.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{wait}{integer; number of allocations to wait before starting GC torture.} \item{inhibit_release}{logical; do not release free objects for re-use: use with caution.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily turn gctorture2 on. } \seealso{ \code{\link{withr}} for examples } withr/man/with_dir.Rd0000644000175000017500000000136313735322666014434 0ustar nileshnilesh% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dir.R \name{with_dir} \alias{with_dir} \alias{local_dir} \title{Working directory} \usage{ with_dir(new, code) local_dir(new = list(), .local_envir = parent.frame()) } \arguments{ \item{new}{\verb{[character(1)]}\cr New working directory} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\verb{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily change the current working directory. } \examples{ getwd() with_dir(tempdir(), getwd()) } \seealso{ \code{\link{withr}} for examples \code{\link[=setwd]{setwd()}} } withr/man/figures/0000755000175000017500000000000014205721143013757 5ustar nileshnileshwithr/man/figures/logo.png0000644000175000017500000003512413615130050015425 0ustar nileshnileshPNG  IHDRxb]egAMA a cHRMz&u0`:pQ<bKGDtIME -8Ϫ93IDATxw]}97; 4rp9DJ$%ʔ+lkibmj]6a.juIkZ%Ѵ(R!9 r^~{}xhf松{C1Ohs@e˿~A`I pkF;3V|>\/ܵ Jw76H~[<2˯[~ 7յ ogߖ ><| B!Bl꧁_mx;#xxGĊTbRC%TUaeJ"$_#oڽ:4(94M "&쎳m9چ я<? ,pt5RJ4]PR.0-p^@Rculj3ݟٵ :я4Ձo{>_JPA&fh@*D5nvYYR56ϯ}(H<`>Il! uEy@.AQ;pwHjY^nuܨw|opmF#Eb't`:RB1nwFakMV8o׀ x']#DTr,r+a]TVT+u|/L>_!;Q \ nb{+$EN') He̼YYHmz06"Z[~uIC#x=F,<V¤TΓgb6:HjY]nٛ xx$8% g5RnhY =xbo)AԫM*+u\W~a1s6H ͥ)rr>4u}un&%ב{'7^Rš鞜RD1d)%vǡ\l=[|n<4(sb9 @FR BPM~{f(sev'g-+6<7r:''T!֞X>7jM L>ܒ7P_۰D1`0%Sc%JCtS݁ "V`l(R fE&3!: ;p05lAoCuT&A"iE!ģ&A%ֺV>rW/lkݫO7t ,|M芆ht'RRro ګ\o-. {9[BQ֦ @(ZM$~Gvm7GݬgPjqlwn_\p 77hB&&_avgV"y#"Qڴ#$^&Sskء B`:~tɻPK1H *n/ >1PNHkq@`mߡ]d֢Ymc;fnݒD#L_2h̋$er vwNh !Bjٝ!\ߠy!d4YdwzD2JVE 5^!4hh6uQHQ/w-U4FlM%6~*v ^e龫^'(|ڏG1@&EB NaNjI&c2sT&J!8TCʱԩv+*Iբ~@FSQ7h""BER]$cfB")Ƭ"s l+a!nc'\-["xĆ x?, QQ-HYeR )=AH79PwpC۹ir~wDP &TځMH4T U{٩ DNt*Eqɑ$؞Ko 05R$!a0hni`7j׸U7%xLjc>K )+%Q퀩^طMTE`~b[Ef b#HkYE'0TMQdHFO)*Ir(?y3E4PZXߕ&BGS1Re-(LgvҩbK?PXIT&P' XĦOt}hH<bsヮBL'(c9o. MQ f'$Bb.UAũ>i-XL9i6^Su ' aLzC0N S3yc, Ȳ'3RB۳&ОV=4H 5tEG$%r ?"W[s(WwTU!RRJ/`.C؅~pt=7#6cas })XIL&0(NF O>vLLU']/MSǎ=sM(D"QQPիa>42Mrc,U#d$f`i3hğ]#S %Ni L&l{cdWxi?fWXrA % bi=h6@>`-)e0y^-|?Wurd-RC) NHT!HIZ~K74]Ժa:i= jS5ؗp*V:i3ŰU`wV𣀂5 !7<7z3+N't4aѮp|x? gWHIMx=I ӕKƲS! 4 +N 7{φW5]` U!8vv اI %FZ'OY7'u$#T w ;(+}:pxDHD)7- Pq ?i/.$&SQfY(vi;pIMLdFlH)A'rI8t\wyv8ny^IRJ?*Sx**2˝*e^~($0Rvm`y o='SD!Е}Pb](d8D*DS5)%f**deQnڞX7fOҊl(`*ڴCI7Br8.TFR%nW2bOȥ,V ;r78WzHd6_(DJXh~݋ /=@5TC)̴]u;LLBI2cY2A6ءD! ?'I:$ڸa̷WHkIV:UUc$YD*uI]娞:/xK5Hh&ڨBEW4~LԽAwF Zcr@r}0{/"T=MNh[ oDyC+x?Їz/HУIBgPF,RJ|lঽu8zڬu+\`,=ySE,d*;H"֎=c//yؾCi` x~q0@x%^ע5x|1s Ru7ujۿ~߆V(3k6J"eLr(-_oW8ca7} )e{hj3]s#κTu(&3E^OsztƎsȻG0g\2þnZJ#0.ۼ8 )P?HYIJf,9ZQ;h6כ4f R}r"ρ$YV*32$5j2,+*NJӤ S3xsBlN(R ^&|Ȝďbѷ72rm*:PIrz r7V!d214y=. f]!JfIup#J ڼp%E?3A\km>0nH0-a~sv-6v? H'vfLVM1ZDҰH Q4X, ~n+1ɱB$mf`on'V.0Z"k1NE,ګʌr;|KLeTI"'Ij9#/6G"k `e-rHJbK@ǗrB tMu(9 U84vim*nhO QNyckءL>+6=˼JH/;A!#A􁔒@qܖG腷쉷uIr K+'XujnF!j`KNk{(î`|pz|UQ(*vWތG4ٓdP C&k */ͽ,Dg1R(^[:"{2g1jN]8z2Xk@EʼnhFJOR6r,pN\m͡k:Cy3CRH7iRwglj"G x<2Zĉ|*^CJxv ySx2p~'+ R"hĥ n H+K jיJEU:jƩY7x,6WH)vL DM*$|jp~cjKK6H C(MF 5]A: ~5FS()>N]avGxyMfZy~ǸXP""|6׆^U zՙC`fX+E#? (' g8'.A"$P024c!~pC^Ȳ]\lm%nNU.('$5"nV'ە`;pQuD׊Cjz8RM EݛVqf+ 7Z̴dȗ8^ǡU<'W/b.GӬUqb#h3.S[,s E+ˉs̵I&^A:Tz% h$#>iZ̟\*(A(MӰ6m:%+xD" <"H .>,Խ6jXq?5blvQlэ\뇫f/-7N73'իO39\o %v ثʤ[,t+LdG|M>6ߜ=#G M۷1:ԪOd/̞.>0PY}Ew8W j^&k؛#Ao G0ı]İT7Cĕ>95CȠw3cSe4U(b"5HܮP epo}e,Yl*NqȾ{c̵WhIV:Ws|b}bȅ {Vgf_n7I⥙׹^w=[ +*ό'xuM;}iD^ȥwpC? Bh, b߶ܷ%4{8S̵ۋ芊%3OOaZsg0$5brIJ_E*F>9#Moc>|{i/1,q9ǰU`dbM7.!4WO +pzի$t o7Ԝ&é"GK\:_{;D"CL_A:ԩR *vn?}G F2d"A(#ZaV؉-;MRT2;(Jq,2B0f8Y$kIk <* K /-NCUlfwDlWiGqR9c,w:5+L2d23S#G|ŵP ]")['o3^&Y^2,.^#BDUa,Yf,QbwjV79Wx2؛Őg]FsS9RڋyE{>ƞD ^xP>I^ynOfq.+? LiI%#>pצY"cz F[wc8Q\*~E(7;@Ŀ7E1^Fk(OCJle <:6Xtk /Í|J"}{Gp|HRMCLvѰ/9Fer1(!U 'iqB--F(~΃&Z0HƎ"e,YfOnl"=jcZ0hvgGq"ƫ8|:F"ٗ`oF Y)f'k -õΜ/.}WOґ.̶S YQ,vVֻ@6+n͹80,Ģ*>pa3^8"{C=$Wsl'm-іN;PLtB_O|kߵCzƍ<:C)|E<@I % 4o/Nb-;=2Jc8;Қ'Y&KԜ&RJz*srbbG],WHh&E3GR1JNq1$ [zhD$[\xy=W:1 /CN,'X*-əeg*W8~nzn6vQ2s(R` &d\n2dIRu9Dzᅋ/rby+ˋo0.snqP ϥ v : n-HRzX8[i :(KvM0e^&e$HSul|N𘾟ci"ܛ}{xk^\UzqɚIn zK-Ac:&JX lix$'WXO1bM*2DHp<!xM\U4.HnKtpNXO`ɮr(?7Oq>F=h#?Tvv)b捥s8{K+pjm`F)PaʅK*6n`Mw@Pʌ$J L 3q % CJ q#*ӹX""QZ-MSr;Y>DR4A/bf+iٝ2e{cq:NJxj}I˴]+ O>_"~}KUI\*8odHh~6D;3ǧ'̓^HF|xmm=}۾iBԩOO莊@ةPu̶pW!)[\+B@~O=OP[H)M?5d7ܾroNѕ@|׉dv}o/uoW'e$>e44RC̶&>9#v=Or`gpo덾Xɺuʈ!FyC [>^Dy\Z!CE|w2 Uu5G$ "j V+Dgn6/Ͻɮ0C7Z=`h؟MJ𣀪ӤkW.a$Yl*Z8(@@MZbu+!i=HDmln z]( + și2F\CK9X6Fڍn %pȾ 3VN ? RjcO}V"F>5CHf-N3\sC=BJHO8^^l"u"=̱>G̵T=C9S̚+IqެY߉74U7i<5ͤj؁h- O gw+UE+GH1#%N bŮݴ ފq?ݶ/ߡ6фJo';ξN ,Z~e؛IV2%xvgFhxmtH |? se+TPg9#pHV#i4Ejc;p!ũ.Sr,7\HFO1U5([9ޡq .ɰb׸TAJ\{ɡC % +v5ɱ>w JH nMѨyM.fV} =}4N1, ,A7hhxn}A3͍icqոÇO"*93CRܘ۳H Oكxi?jEqgr0̵ eHRKqոh6G{Hh+hzmSCQ%X>Gm7g̶\AV"*see(Ǎ<,`4Uuk/';NB3Y+wTDST!{_zU!:v6 D^5<[;C#UUki)@@~c}@Q{-VzRwy-")qe؊ o1qC[/쿋XS/N@һ^Ln+ݓf^g' &^{k]'^X \{lk})\]Bպ'?/RuTi*'7sݸD vO^;ֽi$#(sO8ך|kt!?bi(w ȧlW֜J}_'ofe:z)wdc[줷FfGWO>1fpsN\`\koz|+co ,{֥A7Ɨ&.ߣwXr6"BA;vXz=󧥚Sh/^ d*;ƧHFaWp")ٝ~N'ӽIɡz/ ] |`S,W_cxG {8ZG^5{c}|ߞq0?Il*_"3gORC|m>#{=-_~C')b(QFk?=}^"wSG/yrWN|8Ix;/}jyK<7rh}Lg'PJc/^yowy~732>\|7+>9Lkz WG`E;+Zć'~^R=<;rCyQpZJOx_?W^ux+<=q97N_q՟ϴT<)^{/]{N!~'ؓ?=i!'O ?&/\C 5Kg)%chx-Jp % {n¸}8.[Eu.֮Yo^:+_fqE~D}b?ďAfwqr"w+:E~ԟ`n7oR?u=z|c$'W/,: 0O[㼟uŪSGYhxqn0@r@" VCmD+( #-ZK-wg8;x|E(&/r}KX>G<=|[V84ŷeLndɒl]GW:4皱p귾L$q.&MԐϿc]v& s:1 ":sM܆|\Zs]afy 8utXiGhkghn)k ^ˣ1ߤ8k8 6/Wf4Z4Z|~jn+Hh&ύxi?j3]CCi<;rJqCo- ](J7vqR^?ɟ^NqCc( ~^.f{bwp' \ ~ۧмn OOؽ bGL ='oI)' &N{PVjcp<vr1ӋRM2!B.opva,5G6o;j]ST2c|{[GAa"=LLSq̷WC/Į9 7 ί ୵ &+x (sƒ= B͞j<\ho Do͊SeVWx o WWXox:Ubs̚͟(^$fR8Z&YhFmpf2jvCn(g% b ΐ a2`6g?OZ#ٳ8xz( $!3K;opv V,g7_!^S4G-9Y#^tU#'{-TVj-[x;>LͯhB {Uh̍k --]v [R"QBp ?-;ԝs+K*,ܣo ;썃fq ?DzfSt2 j;exܗoH&nɟ"K"[tKFR-v9\܃^Uj8\n_Nmx~Ͱn88jP\nrfJi̶v 4=l[RJɞ89|+jN2)-wKI ]:UnT Cq6['I=g-)SwqN)a爗 ݒBev̍Sx  ;) ܒ7Px;w=ܥ[v ({ sKx΀wޑٜ~XMav>q1%tEXtdate:create2018-05-24T14:45:56-04:00T%tEXtdate:modify2018-05-24T14:45:56-04:00tEXtSoftwareAdobe ImageReadyqe<IENDB`withr/man/figures/README-unnamed-chunk-3-1.png0000644000175000017500000005673014205721143020466 0ustar nileshnileshPNG  IHDRz4iCCPkCGColorSpaceGenericRGB8U]hU>+$΃Ԧ5lRфem,lAݝi&3i)>A['!j-P(G 3k~s ,[%,-:t} }-+*&¿ gPG݅ج8"eŲ]A b ;l õWϙ2_E,(ۈ#Zsێ<5)"E6N#ӽEkۃO0}*rUt.iei #]r >cU{t7+ԙg߃xuWB_-%=^ t0uvW9 %/VBW'_tMۓP\>@y0`D i|[` hh)Tj0B#ЪhU# ~yhu fp#1I/I"0! 'Sdd:J5ǖ"sdy#R7wAgdJ7kʕn^:}nWFVst$gj-tԝr_װ_7Z ~V54V }o[G=Nd>-UlaY5V}xg[?k&>srq߀].r_r_qsGjy4k iQܟBZ-<(d=dKO a/zv7]ǰod}sn?TF'|3Nn#I?"mzv~K=گsl<b|_|4>?pߋQrib 2* (Ѧh{28oIyes8';Z9h6g>xRx'b8ՃWOϫ[xn%|^z}%x c8eXIfMM*i_@IDATxE&*`A@A"**XQTwDE]Q^|ĆXHSTzd3{$^I.g^-3]:I"!  %@a@@@@@*@Un  @5  UЬrs0@@P@@ f! r  dU4 @@k@@ Y`  \  Y *7C@ @@ȪhV9  (  @V@@@@@@*@Un  @5  UЬrs0@@P@@ f! r  dU4 @@k@@ Y`  \  Y *7C@ @@ȪhV9  (  @V@@@@@@*@Un  @5  UЬrs0@@P@@ f! r  dU4 @@k@@ Y`  \  Y *7C@ @@ȪhV9  (  @V@@@@@@*@Un  @5  UЬrs0@@P@@ f! r  dU4 @@k@@ Y`  \  Y *7C@ @@ȪhV9  (  @V@@@@@@*@Un  @5  UЬrs0@@P@@ f! r  dU4 @@k@@ Y`  \  Y *7C@Aj+RÆe^  @&jRprDiɓ4E3#6Th {4cԥs&OK2V&A9wK5C@/о]LsM3(! T,@Zk@@,@fPC@Xb" YAHi%;@ _pXwi:ys9f% H-P$@ ܉jBm:* T1Y-ThUs\@ Gٳeiiji*iЈ9Zj~ ٢ @BǞ(˵I Fn"&BҔW5~=k@$@@b@|5&  "@Ҙ~SrD|+%lM˗Kږ]37VZfIes&E\<+ B+mg1(/IK5jOd**Rp9jUFL Tp%S$_@\p:WN;IvO*ڶK=8PxXQr-OjZHf Y  @ 8+էdZ";!vwK u1$+Z@tR@ }6tmqv^Iψ_2>kOEG|/f iEA Qp@)'IujǮqmX  @i ?BOR脓\;^zZlF~i„ ڵkt[^  Tвd>w?ꢋ.N;aÆ驧.OŚ5kt҄]ZAm[  @IK,_N3\SL6w\{zgtǖ.o@@Zwn͇zH=zڵkUZ5M>ݳ筳O?  eפ2| Dϟp8-Zd|;Ù&s@@Qn xBNΕ/h, jSfbf  @|Q @@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7@@@Ssc/@@@Sc7Uoo5RE[QrC85D2,@a`G &+{OÏKsɽ? 5n*wVR#9"@#'b @˗+mZV^R@@bb#($/ cWy:={K@ M@V j¬'!,Wʕ+o pv̭s @ȫW_Վ;\ #l)爾׺Rױ@ )jImC :Tf͊Y_~E .N:bnB@"ȧZDh5)9U+@.4iy5jH͛7/U%b#3mI5k,>7?pE!V,! SqT7Ν+ԯ':u|Z#䎀Б#Gsκ[tI'K/U Pܓg_.e^5Qa:-[4fG 8-Z@'@^{&NXvYϞ=_qgzA! 6]vI  )3]cslWXB-Ҵit:kFjР7 ,9h Y>#ٺ/ЃD;SBv[Y] >@v.wݺ<1A w @m#.'L|P=yU^]y$@/gLU}rDu,@{dF֖E}XHOLvO;_Ԏ;W_}U/fdddBE&WpKQjkRjj[s$ _|)w(W `}},@SfΜ1cxHj! Y㾝QF^wީoէ Pptڙ 3Ĭz𺫽ǟ{M?A7ж}5Q]0,mcucD ?v_ 6AhntjȑaCZ @ ؖP)lKgނA{N;EU'07oӐn5kVu @6`#-YH_@ _d7lPxjDI^#@8&KU  o3ʕ+>M6UzԿo.@@:m&s~5  b'OVv4n8-]Z|o貣: <Ӑ.2; R @ 8M G @ ļOh}om[ ,жn{G~zǏ׾ V[E𻀝^ޔLk׮4x`'!U~")_>;p]QSU(>)='wMTTQ֥4<zɶzvAxdj"! !%Ԧ܇3Z]"ByrO?[nS<p׬QoV2ZW:'zٳF!C~袋K/gc^!@A όn$/(*r:N邚;ysy@Cn{ ޹t |O o[_|Q?6l-Zx&vҰah+M1fn{xEeN:mK3ӝ4Y=p#+Re{e m#V}*c%c 8mNQ;n]Һur.-7fN*\h,hlp @fxD>|_r>|WsxFXa2#s>mI`y\[W\Vfb} @F}uOq3^eO_*xTFO. اx:%I#{q{:^$q'#\bC}1o.r69v]nq/辛Դd[7,Y|k@ $ltk„ ^<[o@8͛+8{ g+8W/ 3S e!c0xr=z'缳cӹ<s]U.tL㋃ck~jy19*DZ@H:~xMKt3b׶znf#9|=\͘aF cGpWѭy͔rl*g z*d˺,l<93gW-61}t!gL@|H.X@mJe-_|^zkUVtw{C]Ȗ@ٖӏgp9lpNrk@2,6l3c6mV~цVsFV@@ =z{r)##Fx}A ݒ$@@HG?~m-4ζ>m.]gmbБ@@HB aP1}*h&?'O{ｧwY[N0l  @@Pk{5{loMƍ3@@@rI{jodoF:uҰae@@ $ @N>țt~w}>HKi pNQ[GXT  e}@ǎnݺ}v'jРA3gڶm[n=  7˽u䘿׊ͼ''eyH@(#_>lz7AI IU/~ ?@EVrͫB'{Қ _skG@heb0`>IMQF?7ByjBW_14#w߫P6r#TI 7{gڽs coR@b~)_]k%!P  oתUK&L!=~Gx"^W@x(7V6I{+8'9 ^ϻ*jE[G>C/b+@`>,ϛFۈSd>0]{~Ӳ%N@cjռ'G[o3fDJ9^cO/aQH_5*4mYEvPZlxľW[[|ƴa!T(:ܧ1{VK|HvW-ZCA$'gϞ¿u[A_PHχvEZ}1__ʽA6 LәStt.}W[_@kԘwboa>o_%I'+VhѢE^σ>T탟Y ̭Fڋ7hZ}X]'5 nB0- :8?z XOUR"[nTogڵ̀5 .%F+HN4EjhE-]V~hNȿV+ʒB-m}4ny??v=S ς(. Lvg=bR;ʗ W1վJGsARϽ R˩[7L  [?nuzy.N~L> }Zӧ^=qc,zuVlɗ/7M}|i:ZIl{i-g5 hvϒ%K矛__(j*grm%K9RWiMMZSb%3` e @N8q 0jGWelPR 8mȹ༪/HK`\:ˁ{cŹ&eƔa!@r`fLʹn30.ٮ?$] aW_yO>=z$!P+.UhJ7ImG~֮s wv{Er\cwU8!KIȌ@tرN8̔\HA x5r<͌٣ $  } gϞ駟b> >#yi|+@r] a hCyKi8\'C@r3? G~ʖ=WАז9b˞"# 9#رce}饗H?ٮ 2^]ӘZ5mTq͚5obq<@@$iݩS'}< >c͙3{2=ܣo]C 񦋲]v(;oinr@@ "0ի.b͘1C[WeNgV͚5uꬳ5\㵈ڂ 4ț2; /PzZk&'! TN aZ<Ѷ&ږ~e˖+*wԍv8S6qǕ~'xGZj,Xp? 9%! TN a_^r}cK.o~e[:6l]f_L2EoyeɼIy n$fG@(#0ݻ.5ϑd[:w_p jteQfܹs>O=|b~# @Q9Rh1_|?uȋ#GuꩧF@@ GH9KEy?˦OkT>k+Ԯf̛О)4rS|e@ DV t)Ȍz+W [Wn9 @@bЊ}X[ͭbR}C Q@*-@Zi2v(( S8 wf% )@ZZ'+}[_b}5,C@ @+a;o{ > rj @*)y@+YG6G %w#ի+\U鿴IC9w QȾ)N!Z%G9QA`f< !d\4_)ԲnJ_r}QG(x҉~e `PǮ%ҲerkՔr Y|9$U3 >#xy&GgyUncio^yʕIg(<5 dN4scÏ'U_~k RMgzmwOϘ@z6k_Ϛpg6he9+: E4-doN%/0VZ\ξZ2?h.`xɮ'!dT4dWMcyq9-[\pvմ`ǟ>+pٹ_ J\'gF13~3;:/@Q TNr^l]`/~d}FҬY&Bu@xЍ7$|X,~W=k@@ hL"A`S,6ڴ5  S4& (\u|CȱOI"! @_).6.4 2S.-{ERR : PpkA}@HhZ$# 3}GUrz&gn\e @F@3K"n-CB@  @%h殀;w?%eKuvS2@ XO~Tݝ9Sv$;/}\fg8|&@@ o70+.ZPkPe&5@ Z# 9|r(Zbͷuco8 ?Hu,E@* 2z<{rg͎e  PUϡ U Nrڵ  PeUFρ!vtg,]8yg0 i M#&Ye_iHo'V5kJk+XS@H((~l@8͛+hQ/ܖON9SF  c+ 8n*g>EG@p_85u\o+P@ UPϼm.{(mf-:,f% K[:_YZw /T172U7_.T@ 3W@yOsmY&Ͽ(O,- h. ֯vϾ  9yZ(T)zqn7 ^$?K@U\=3+*8`3IK70A+  9|r(ZsYR ɹj9wE  zf(WT ;9'5nlnM@\΃*xͿ@!4L8O]JwL{A:MjZ+]ۍ7[8=wI  KO?+n fTBޠ(.eV  @&\Ɲ3G]%3]|ڂ]7cE\  yzb#r_|%4EՂ ?ldS~# Y|V |-:3ԩe{w< aCrɩQ@h|M+kKW/yڶ-<I}9@C!ir~/'G˜l@_p )B:m<2pqVVЁ}vTq%^iKjIwWm8: lF[+Մ֬w ɴ~>Hζr.W ^R@}q6NϘӥmZ)x9m\۝4E}>.-pX__@oNfԠI_xxǫg֓@@܂߂;ͤv8{X5,F@?,XM6Q׺V-skT~K@@79UU@hOCmL(p`0- y&@<;TgTm|uA@#@ (  @V|ڧK͓ @@ |1BۘijA)=zЧ~ZN:-g  @ .}e˖˵h"޺V# $%AH?z~۫7ިkVT7O>c=<3O?H  ]:{RA8 tgyKײ~zpMP[ip\7O/ɝ5Ki=v9+  P8 @m .(unfo:ZW7mLPiS։6ˉy{yyVk't+9wȉ2R@(FvN2ԙz'ԳgO>J+73v{i /6<2uWӦ* F@*]zqk3ˉ]E {K@@ f6gmJc',m[>ƽ+DB@([Y4ڷRݺyo&Le|Rp@-@ _һЖO'HL+WJ̠#~8-~ǿ  @V@ʝŃMZZ87{K@@ fwQgnJaW PI  @VzV&@jd֓@@* l٣iIο  @f@3[e;+8vLV.^Tee  Py|)9G۴$<5UC@\`\?CY>v F  @hM%9! $!@  O4}  hHl  >Y  @I   @)})~o--Y*g]?^N͚)ǎ  @. V ]wۇJ다PHSHErׯqx@@ ܂Oi9xJ7KkzZ:(rLPJB@L OhxGiO?^R@@Uy,Ξ=k@@ VrG_ZV-g   S*Knen+PK.5  -[ _N4g(f+ͭ?  r! PIV *## PXumz4~iCp@@ @R 8*ҋn!9Sأ˯c  D7D7xB-˽}dr>C_YvS# @2 E Y 8eH  P)nW@@6Vtc@wC5IDAT@Rbc@@ XAG@h@@`cڵr}$wTsгώTcsIXxyrfHMTI L6Um۶A]sQFhdP d>7̙m&G!k+kIߋӑKF M7pz'$zI /[}$ږ _Hm4L3)U/w}(m(uu zmz&P_Yp[68sjr%'Yw`RӑUp\2;W(駟U+-2A!C62'vO$AHi_q_~gFq4-mw#VESO>SN9%-I 4%D@J4N'A@r_4%D@J4N'A@r_4%D@J4N'A@r_4%D@J4N'A@r_С9'!5IH[u9),$$;=)ss_~QGHRf'!խ[f9r'ͩAa@@|cj hN  hcj hN  hcj hN  hcj hN  hcj hN  hcus4)}^u8d{Zzꍮ-70k1Lf N늕I6$@+hm-cGҔ)St 'QFjݺn*~'_ v:r[&62.?6tr_rnrgvŊ+ծ];5nXGyz^HFRNTfMܹsK$s&ML 썽^/R5kLժUS˖-u7(*6t+~[sׯ^w}wm^~iSuѮqƕˇ"&LЪUti* 4m>hu]~wy޺?֮]j̘1:Kmk2۔ʴ߼u )|w矽/zE׷m6zyzUF Kqvb߿N=T=_u뭷ĉ=dd)TH=\曺+~_wuZfMD6/hsQ~>0?#ޱ˼^?csy.]>8K!`ISN9%AnpMKk>xQZ|)dM75h qMfR%K&0}C:k.`Ji..0T@}ף'/OCtY!ݻ6۔"x<>[6R`ol/T͏:(s$06tD*38mӦkF·kdW9oF/̝4Z p >'w;<wU>}TV?\2^xԼysMvXn)۷[o]V/lwY2{tRw2k2۔j?VuGD/gG)gs .ԢEi/j#uMN$M6M-Z~&?)e{)%]vd\٦l~v_{+-^RLl?fۧnС`tԩlͼ dB"INȑ#>;Ｓ<5mJǶx t>^B,%5±*M3g??sծ)k[#0D_<_&۷ga̛7L?x-[ lV^%[lQ]ɸ&M kIÆ A1^_~%1d5mTno7۲d&U)~o ~'s&M#R~.vmB2\_/fR?0 sծI&} a[XwoSfo1w}׿>s믿^/Qv`i Rjvtk"dI腳9x-v=%oEt5^Y It衇ʶ>#5m ͳqJvjS2\^gGۥec=駟z Wަ|~;Z@3xZjn([zkȶhťJa:{/Ry@2l sKaEψz/^eqι#bſm[;2cmHJzMfH~۶|ڑ1hd>#Z):w|a|ޏ3jT#MhϝS0K7:g?ކ/ON,k2$>RaoaQvnŒ)`[*었TW=XlKa?L\lS2B}mOi[HR |nsM"Nf-[l]4dmFD4~##l?:2~};SkYn]Edyu2l@ivu5)7vyl'O̞=[UOEm`E;/plJzMfÇ{}c[6%5]V{{gΦ<؉Wڻ;dw()9?%]35OqDݮH1͍hkbpmLL뚎g}6E쟊VqIM߭r&6U\:]wTL.fTkz⚁s蚧ft[e?\3ƴ/ܡ >9V}Q׌~/3}tO!5m 4f5ϟYkٲd>m\1 M7]37y"RtdWkd\qq̈́yXCXkHʠOV[y(dfnRG|7\Q52\s[58\36/+['6\XkbV<=׸68$d?4۠Ⱥ1sF}^&a0O҉l͜H2\_<1j۬o-]R5|O=T,xSǖ\ Xb7WbOKmt&XFƗ]qMfԎ^X{AEZVg?WvW,60U⚮ZY_sddWT;5[oٍ>   3Fy@@ R|@@o~;c@O G@&@3Fy@@ R|@@o~;c@O G@&@3Fy@@ R|@@o~;c@O G@&@3Fy@@ R|@@o~;c@O G@&@3Fy@@ R|@@o~;c@O G@&@3Fy@@ R|@@o~;c@O G@&@3Fy@ EEE4p@^@79UZ?SO=UwiӦ馛k-н-;#q4k֬2^ "P-W B9@\8쳽SN9JW_+ԍ7ި-[zAf8uk6qp@ -XlAmUVZK 69sfU# @ݻƍɓ'gϞm۷r޼y^/B}?~u x'N;λ T#_מ{c-9Z]wEs7~ە<:t蠺uk׮{l^Kl vGծξ_:n&^G]o[P* >\ڵS6m@vʕmxdB49-tRؽ{6}:#uQGiwngW;L[VVt~ޭoP._\?k/ 4H?+#8B:uó:K6Lj$G's=M4ћo?.otEEjԨڀdԹsgoҺut1h.gmлKzW{l QoVn+ ,K.qM}߯_?w۷oB2O}ݽ=蠃싛o;ŋ'|~nweE2޾#FD}g^l=4hڲL:5>R믿>ޱ^xo駟.?f̘16&@. nZ@3ޓ9{-;ྲྀ-Լys.HI~꽵z-_%w3ߪU"xv{{nw!x-&XՐ!C4`6 7|Czr?a^"/[Zn# ;FުO>]R] @ |j9cCr]ddoGRdY}߶_iuL%)-YDw5k&oގAM5!V[m}m_>v~OʩN8Aoh߾}NKnlۛVLo^rw[5jIem)C4V-lmMIK5khٲe"bi)lkG/:Vk5vX/>ho{;ǧpT2v_rqQ.\k@ P$(ۂXrmnGԗLÆ F%فIv o6/ YrFW^doہO&Mxo[Tm+mL) mPڥKdö @@+ PӶ0~'4Hf̠o*kܸqިy3H 6kzwpB/9rdt:i_A> f{io]Vz+tW~TSd[;vJ*;oG>$@ S%_;N:Iv@_z}:m뤝'@d}dFk:;m{yq}@(3]f޴K6fD[v$;9Ckmŵ-v(9Q_z%mLXa PRK.5 @|iPE-oemStIeW%|?w\/͗M,iG׬Y&?3vNT?o7%!H~KF @ ’-dKM6*-ZƖޖO0lY6S;JdK4[Ȁ @I 3Fy@4 vڨmۦ)GA MΉ@@$(4A   @r9  @@I6   &V  i M$  $'@[! I4Md  hrNl  &4A   @r9  @@I6   &V  i M$  $'@[! I4Md  hrNl  &4A   @r9  @@I6   ?jtIENDB`withr/vignettes/0000755000175000017500000000000014210227535013552 5ustar nileshnileshwithr/vignettes/changing-and-restoring-state.Rmd0000644000175000017500000002570013735322666021704 0ustar nileshnilesh--- title: "Changing and restoring state" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Changing and restoring state} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(withr) ``` This article explains the type of problem withr solves and shows typical patterns of usage. It also compares withr's functionality to the `on.exit()` function from base R. ## It's dangerous to change state Whenever possible, it is desirable to write so-called **pure** functions. The property we focus on here is that the function should not change the surrounding R landscape, i.e. it should not change things like the search path, global options, or the working directory. If the behaviour of *other* functions differs before and after running your function, you've modified the landscape. Changing the landscape is bad because it makes code much harder to understand. Here's a `sloppy()` function that prints a number with a specific number of significant digits, by adjusting R's global "digits" option. ```{r include = FALSE} op <- options() ``` ```{r} sloppy <- function(x, sig_digits) { options(digits = sig_digits) print(x) } pi sloppy(pi, 2) pi ``` ```{r include = FALSE} options(op) ``` Notice how `pi` prints differently before and after the call to `sloppy()`? Calling `sloppy()` has a side effect: it changes the "digits" option globally, not just within its own scope of operations. This is what we want to avoid. *Don't worry, we're restoring global state (specifically, the "digits" option) behind the scenes here.* Sometimes you cannot avoid modifying the state of the world, in which case you just have to make sure that you put things back the way you found them. This is what the withr package is for. ## The base solution: `on.exit()` The first function to know about is base R's `on.exit()`. Inside your function body, every time you do something that should be undone **on exit**, you immediately register the cleanup code with `on.exit(expr, add = TRUE)`[^on-exit-add]. [^on-exit-add]: It's too bad `add = TRUE` isn't the default, because you almost always want this. Without it, each call to `on.exit()` clobbers the effect of previous calls. `neat()` is an improvement over `sloppy()`, because it uses `on.exit()` to ensure that the "digits" option is restored to its original value. ```{r} neat <- function(x, sig_digits) { op <- options(digits = sig_digits) on.exit(options(op), add = TRUE) print(x) } pi neat(pi, 2) pi ``` `on.exit()` also works when you exit the function abnormally, i.e. due to error. This is why official tools, like `on.exit()`, are a better choice than any do-it-yourself solution to this problem. `on.exit()` is a very useful function, but it's not very flexible. The withr package provides an extensible `on.exit()`-inspired toolkit. ## `defer()` is the foundation of withr `defer()` is the core function of withr and is very much like `on.exit()`, i.e. it schedules the execution of arbitrary code when the current function exits: ```{r} neater <- function(x, sig_digits) { op <- options(digits = sig_digits) defer(options(op)) print(x) } pi neater(pi, 2) pi ``` `withr::defer()` is basically a drop-in substitute for `on.exit()`, but with three key differences we explore below: 1. Different default behaviour around the effect of a series of two or more calls 1. Control over the environment the deferred events are associated with 1. Ability to work with the global environment Here we focus on using withr inside your functions. See the blog post [Self-cleaning test fixtures](https://www.tidyverse.org/blog/2020/04/self-cleaning-test-fixtures/) or the testthat vignette [Test fixtures](https://testthat.r-lib.org/articles/test-fixtures.html) for how to use withr inside tests. ## Last-in, first-out If you make more than one call to `defer()`, by default, it **adds** expressions to the **top** of the stack of deferred actions. ```{r} defer_stack <- function() { cat("put on socks\n") defer(cat("take off socks\n")) cat("put on shoes\n") defer(cat("take off shoes\n")) } defer_stack() ``` In contrast, by default, a subsequent call to `on.exit()` **overwrites** the deferred actions registered in the previous call. ```{r} on_exit_last_one_wins <- function() { cat("put on socks\n") on.exit(cat("take off socks\n")) cat("put on shoes\n") on.exit(cat("take off shoes\n")) } on_exit_last_one_wins() ``` Oops, we still have our socks on! The last-in, first-out, stack-like behaviour of `defer()` tends to be what you want in most applications. To get such behaviour with `on.exit()`, remember to call it with `add = TRUE, after = FALSE`[^on-exit-after]. [^on-exit-after]: Note: the `after` argument of `on.exit()` first appeared in R 3.5.0. ```{r, eval = getRversion() >= "3.5.0"} on_exit_stack <- function() { cat("put on socks\n") on.exit(cat("take off socks\n"), add = TRUE, after = FALSE) cat("put on shoes\n") on.exit(cat("take off shoes\n"), add = TRUE, after = FALSE) } on_exit_stack() ``` Conversely, if you want `defer()` to have first-in, first-out behaviour, specify `priority = "last"`. ```{r} defer_queue <- function() { cat("Adam gets in line for ice cream\n") defer(cat("Adam gets ice cream\n"), priority = "last") cat("Beth gets in line for ice cream\n") defer(cat("Beth gets ice cream\n"), priority = "last") } defer_queue() ``` ## "Local" functions (and "with" functions) Both `on.exit()` and `withr::defer()` schedule actions to be executed when a certain environment goes out of scope, most typically the execution environment of a function. But the `envir` argument of `withr::defer()` lets you specify a *different* environment, which makes it possible to create customised `on.exit()` extensions. Let's look at the `neater()` function again. ```{r} neater <- function(x, sig_digits) { op <- options(digits = sig_digits) # record orig. "digits" & change "digits" defer(options(op)) # schedule restoration of "digits" print(x) } ``` The first two lines are typical `on.exit()` maneuvers where, in some order, you record an original state, arrange for its eventual restoration, and change it. In real life, this can be much more involved and you might want to wrap this logic up into a helper function. You can't wrap `on.exit()` in this way, because there's no way to reach back up into the correct parent frame and schedule cleanup there. But with `defer()`, we can! Here is such a custom helper, called `local_digits()`. ```{r} local_digits <- function(sig_digits, envir = parent.frame()) { op <- options(digits = sig_digits) defer(options(op), envir = envir) } ``` We can use `local_digits()` to keep any manipulation of `digits` local to a function. ```{r} neato <- function(x, digits) { local_digits(digits) print(x) } pi neato(pi, 2) neato(pi, 4) ``` You can even call `local_digits()` multiple times inside a function. Each call to `local_digits()` is in effect until the next or until the function exits, which ever comes first. ```{r} neatful <- function(x) { local_digits(1) print(x) local_digits(3) print(x) local_digits(5) print(x) } neatful(pi) ``` Certain state changes, such as modifying global options, come up so often that withr offers pre-made helpers. These helpers come in two forms: `local_*()` functions, like the one we just made, and `with_*()` functions, which we explain below. Here are the state change helpers in withr that you are most likely to find useful: | Do / undo this | withr functions | |-----------------------------|-------------------------------------| | Set an R option | `local_options()`,`with_options()` | | Set an environment variable | `local_envvar()`, `with_envvar()` | | Change working directory | `local_dir()`, `with_dir()` | | Set a graphics parameter | `local_par()`, `with_par()` | We didn't really need to write our own `local_digits()` helper, because the built-in `withr::local_options()` also gets the job done: ```{r} neatest <- function(x, sig_digits) { local_options(list(digits = sig_digits)) print(x) } pi neatest(pi, 2) neatest(pi, 4) ``` The `local_*()` functions target a slightly different use case from the `with_*()` functions, which are inspired by base R's `with()` function: * `with_*()` functions are best for executing a small snippet of code with a modified state ```{r eval = FALSE} neat_with <- function(x, sig_digits) { # imagine lots of code here withr::with_options( list(digits = sig_digits), print(x) ) # ... and a lot more code here } ``` * `local_*()` functions are best for modifying state "from now until the function exits" ```{r eval = FALSE} neat_local <- function(x, sig_digits) { withr::local_options(list(digits = sig_digits)) print(x) # imagine lots of code here } ``` It's best to minimize the footprint of your state modifications. Therefore, use `with_*()` functions where you can. But when this forces you to put lots of (indented) code inside `with_*()`, e.g. most of your function's body, then it's better to use `local_*()`. ## Deferring events on the global environment Here is one last difference between `withr::defer()` and `on.exit()`: the ability to defer events on the global environment[^withr-2-2-0]. [^withr-2-2-0]: This feature first appeared in withr v2.2.0. At first, it sounds pretty weird to propose scheduling deferred actions on the global environment. It's not ephemeral, the way function execution environments are. It goes out of scope very rarely, i.e. when you exit R. Why would you want this? The answer is: for development purposes. If you are developing functions or tests that use withr, it's very useful to be able to execute that code interactively, without error, and with the ability to trigger the deferred events. It's hard to develop with functions that work one way inside a function, but another way in the global environment (or, worse, throw an error). Here's how `defer()` (and all functions based on it) works in an interactive session. ```{r eval = FALSE} library(withr) defer(print("hi")) #> Setting deferred event(s) on global environment. #> * Execute (and clear) with `withr::deferred_run()`. #> * Clear (without executing) with `withr::deferred_clear()`. pi #> [1] 3.141593 # this adds another deferred event, but does not re-message local_digits(3) pi #> [1] 3.14 deferred_run() #> [1] "hi" pi #> [1] 3.141593 ``` When you defer events on the global environment, you get a message that alerts you to the situation. If you add subsequent events, the message is *not* repeated. Since the global environment isn't perishable, like a test environment is, you have to call `deferred_run()` explicitly to execute the deferred events. You can also clear them, without running, with `deferred_clear()`. withr/build/0000755000175000017500000000000014210227534012640 5ustar nileshnileshwithr/build/vignette.rds0000644000175000017500000000034114210227534015175 0ustar nileshnilesh} 0 k>cЗxeT:ڂ'Nev@ҤiB6B#b`MHM| n ,88" %in% search()) with_namespace("tools", { expect_true("" %in% search()) # .check_packages is a non-exported object in tools expect_true(is.function(.check_packages)) }) # tools namespace still not attached to the search path expect_false("" %in% search()) }) test_that("local_namespace works", { # tools package not attached to the search path expect_false("" %in% search()) f <- function() { local_namespace("tools") expect_true("" %in% search()) # .check_packages is a non-exported object in tools expect_true(is.function(.check_packages)) } f() # tools namespace still not attached to the search path expect_false("" %in% search()) }) test_that("with_environment works", { e <- new.env() e$a <- 1 # environment not attached to the search path expect_false(format(e) %in% search()) with_environment(e, { # environment attached to the search path expect_true(format(e) %in% search()) expect_equal(a, 1) }) # environment not attached to the search path expect_false(format(e) %in% search()) }) test_that("local_environment works", { e <- new.env() e$a <- 1 # environment not attached to the search path expect_false(format(e) %in% search()) f <- function() { local_environment(e) # environment attached to the search path expect_true(format(e) %in% search()) expect_equal(a, 1) } f() # environment not attached to the search path expect_false(format(e) %in% search()) }) withr/tests/testthat/test-with.R0000644000175000017500000001210514205720724016620 0ustar nileshnileshtest_that("with_options works", { expect_false(identical(getOption("scipen"), 999)) expect_equal(with_options(c(scipen=999), getOption("scipen")), 999) expect_false(identical(getOption("scipen"), 999)) expect_false(identical(getOption("zyxxyzyx"), "qwrbbl")) expect_equal(with_options(c(zyxxyzyx="qwrbbl"), getOption("zyxxyzyx")), "qwrbbl") expect_false(identical(getOption("zyxxyzyx"), "qwrbbl")) }) test_that("with_libpaths works and resets library", { lib <- .libPaths() new_lib <- "." with_libpaths( new_lib, { expect_equal(normalizePath(new_lib), normalizePath(.libPaths()[[1L]])) } ) expect_equal(lib, .libPaths()) }) test_that("with_temp_libpaths works and resets library", { lib <- .libPaths() with_temp_libpaths( expect_equal(.libPaths()[-1], lib) ) expect_equal(lib, .libPaths()) }) test_that("with_temp_libpaths has an action argument", { lib <- .libPaths() with_temp_libpaths( action = "suffix", expect_equal(.libPaths()[-length(.libPaths())], lib) ) expect_equal(lib, .libPaths()) }) test_that("with_ works", { res <- NULL set <- function(new) { res <<- c(res, 1L) } reset <- function(old) { res <<- c(res, 3L) } with_res <- with_(set, reset) with_res(NULL, res <- c(res, 2L)) expect_equal(res, 1L:3L) }) test_that("with_ works on functions without arguments", { res <- NULL set <- function() { res <<- c(res, 1L) } reset <- function(x) { res <<- c(res, 3L) } with_res <- with_(set, reset) with_res(res <- c(res, 2L)) expect_equal(res, 1L:3L) }) test_that("with_libpaths works and resets library", { lib <- .libPaths() new_lib <- "." with_libpaths( new_lib, { expect_equal(normalizePath(new_lib), normalizePath(.libPaths()[[1L]])) } ) expect_equal(lib, .libPaths()) }) test_that("with_makevars works and resets the Makevars file", { current <- tempfile() writeLines(con = current, c("CFLAGS=-O3"), sep = "\n") new <- c(CFLAGS = "-O0") with_makevars( new, path = current, { expect_equal("CFLAGS=-O0", readLines(Sys.getenv("R_MAKEVARS_USER"))) } ) expect_equal("CFLAGS=-O3", readLines(current)) }) test_that("with_makevars changes only the defined variables", { current_name <- tempfile() current <- c("CFLAGS=-O3", "LDFLAGS=-lz") writeLines(con = current_name, current, sep = "\n") new <- c(CFLAGS = "-O0") with_makevars( new, path = current_name, { expect_equal(c("CFLAGS=-O0", "LDFLAGS=-lz"), readLines(Sys.getenv("R_MAKEVARS_USER"))) } ) expect_equal(current, readLines(current_name)) }) test_that("with_makevars works with alternative assignments", { current <- tempfile() writeLines(con = current, c("CFLAGS=-O3"), sep = "\n") new <- c(CFLAGS = "-O0") with_makevars( new, path = current, assignment = "+=", { expect_equal("CFLAGS+=-O0", readLines(Sys.getenv("R_MAKEVARS_USER"))) } ) expect_equal("CFLAGS=-O3", readLines(current)) }) test_that("with_makevars uses the existing R_MAKEVARS_USER by default", { tf <- tempfile() local_envvar("R_MAKEVARS_USER" = tf) on.exit(unlink(tf)) writeLines(con = tf, c("CFLAGS=-O3", "CXXFLAGS=-O3"), sep = "\n") new <- c(CFLAGS = "-O0") with_makevars( new, { expect_equal(readLines(Sys.getenv("R_MAKEVARS_USER")), c("CFLAGS=-O0", "CXXFLAGS=-O3")) } ) expect_equal(readLines(tf), c("CFLAGS=-O3", "CXXFLAGS=-O3")) }) test_that("set_makevars works as expected", { expect_equal(set_makevars(character(0)), NULL) tmp_old <- tempfile() tmp_new <- tempfile() # empty old file set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new) expect_equal(readLines(tmp_new), c("CFLAGS=-O3")) # non-empty old file without new field writeLines(con=tmp_old, c("LDFLAGS=-lz")) set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new) expect_equal(readLines(tmp_new), c("LDFLAGS=-lz", "CFLAGS=-O3")) # non-empty old file without multiple field definitions (error) writeLines(con=tmp_old, c("CFLAGS=-O0", "CFLAGS=-O1")) expect_error(set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new)) unlink(tmp_old) unlink(tmp_new) }) test_that("with_dir works as expected", { old <- normalizePath(getwd()) with_dir("..", { expect_equal(normalizePath(getwd()), normalizePath(file.path(old, ".."))) }) expect_equal(normalizePath(getwd()), normalizePath(old)) }) test_that("with_par works as expected", { tmp <- tempfile() pdf(tmp) on.exit(unlink(tmp), add = TRUE) old <- par("pty") with_par(list(pty = "s"), { expect_equal(par("pty"), "s") }) expect_equal(par("pty"), old) dev.off() }) test_that("supplying a getter to `with_()` shields against early exits", { my_get <- function(x) { out <- as.list(state)[names(x)] names(out) <- names(x) out } my_set <- function(x) { old <- my_get(x) mapply(function(nm, val) state[[nm]] <- val, names(x), x) rlang::signal("", "my_cnd") invisible(old) } state <- new.env() my_with_unsafe <- withr::with_(my_set) my_with_safe <- withr::with_(my_set, get = my_get) expect_safe_and_unsafe_unwinding( state, my_with_unsafe, my_with_safe ) }) withr/tests/testthat/test-tempfile.R0000644000175000017500000000312014205130072017436 0ustar nileshnileshtest_that("with_tempfile works", { f1 <- character() f2 <- character() with_tempfile("file1", { writeLines("foo", file1) expect_equal(readLines(file1), "foo") with_tempfile("file2", { writeLines("bar", file2) expect_equal(readLines(file1), "foo") expect_equal(readLines(file2), "bar") f2 <<- file2 }) expect_false(file.exists(f2)) f1 <<- file1 }) expect_false(file.exists(f1)) }) test_that("local_tempfile with `new` works with a warning", { f1 <- character() f2 <- character() f <- function() { expect_warning( local_tempfile("file1"), "is deprecated" ) writeLines("foo", file1) expect_equal(readLines(file1), "foo") expect_warning( local_tempfile("file2"), "is deprecated" ) writeLines("bar", file2) expect_equal(readLines(file1), "foo") expect_equal(readLines(file2), "bar") f1 <<- file1 f2 <<- file2 } f() expect_false(file.exists(f1)) expect_false(file.exists(f2)) }) test_that("local_tempfile works", { f1 <- character() f2 <- character() f <- function() { file1 <- local_tempfile() writeLines("foo", file1) expect_equal(readLines(file1), "foo") file2 <- local_tempfile() writeLines("bar", file2) expect_equal(readLines(file1), "foo") expect_equal(readLines(file2), "bar") f1 <<- file1 f2 <<- file2 } f() expect_false(file.exists(f1)) expect_false(file.exists(f2)) }) test_that("local_tempfile() can add data", { path <- local_tempfile(lines = c("a", "b")) expect_equal(readLines(path), c("a", "b")) }) withr/tests/testthat/test-language.R0000644000175000017500000000125514165531434017437 0ustar nileshnileshtest_that("can temporarily change language", { skip_if_not(has_nls()) expect_error(with_language("en", mean[[1]]), "not subsettable") expect_error(with_language("fr", mean[[1]]), "non indi\u00e7able") expect_error(with_language("es", mean[[1]]), "no es subconjunto") # can use either _ or - expect_error(with_language("pt_BR", mean[[1]]), "não possível dividir") expect_error(with_language("pt-BR", mean[[1]]), "não possível dividir") }) test_that("warns if LANG=C", { skip_if_not(has_nls()) local_envvar(LANG = "C") expect_warning(with_language("en", "x"), "has no effect") }) test_that("checks input", { expect_snapshot_error(with_language(1, "x")) }) withr/tests/testthat/test-tempdir.R0000644000175000017500000000170314165531434017316 0ustar nileshnileshtest_that("clean needs to be a single logical", { expect_error(with_tempdir(clean = "sparkling"), "TRUE or FALSE") expect_error(with_tempdir(clean = c(TRUE, FALSE)), "TRUE or FALSE") }) test_that("tempdir cleans up after itself", { tmp <- with_tempdir(getwd()) expect_false(file.exists(tmp)) }) test_that("tempdir will leave the directory alone if clean = FALSE", { tmp <- with_tempdir({ cat("x\n", file = "hello.txt") getwd() }, clean = FALSE) expect_equal(readLines(file.path(tmp, "hello.txt")), "x") }) test_that("local_tempdir cleans up after itself", { dir <- character() local({ dir <<- local_tempdir() expect_true(dir.exists(dir)) }) expect_false(dir.exists(dir)) }) test_that("local_tempdir leaves the directory if `clean = FALSE`", { dir <- character() local({ dir <<- local_tempdir(clean = FALSE) expect_true(dir.exists(dir)) }) expect_true(dir.exists(dir)) unlink(dir, recursive = TRUE) }) withr/tests/testthat/test-db.R0000644000175000017500000000445114165531434016242 0ustar nileshnileshdescribe("with_db_connection", { #it("errors if connection is not named", { #expect_error({ #with_db_connection(list(TRUE), TRUE) #}, "all(is.named(con)) is not TRUE", fixed = TRUE) #}) #it("errors if connection is not a DBI connection", { #expect_error({ #with_db_connection(list(con = TRUE), TRUE) #}, "all(vlapply(con, methods::is, \"DBIConnection\")) is not TRUE", fixed = TRUE) #}) it("creates a single connection", { db <- tempfile() on.exit(unlink(db)) expect_false(exists("con")) with_db_connection( list(con = DBI::dbConnect(RSQLite::SQLite(), db)), { DBI::dbWriteTable(con, "test", data.frame(a = 1:2, b = 3:4)) }) expect_false(exists("con")) con2 <- DBI::dbConnect(RSQLite::SQLite(), db) on.exit(DBI::dbDisconnect(con2), add = TRUE) expect_equal(DBI::dbReadTable(con2, "test"), data.frame(a = 1:2, b = 3:4)) }) it("creates multiple connections", { db <- tempfile() db2 <- tempfile() on.exit(unlink(c(db, db2))) expect_false(exists("con")) expect_false(exists("con2")) with_db_connection( list(con = DBI::dbConnect(RSQLite::SQLite(), db), con2 = DBI::dbConnect(RSQLite::SQLite(), db2)), { DBI::dbWriteTable(con, "test", data.frame(a = 1:2, b = 3:4)) DBI::dbWriteTable(con2, "test", data.frame(c = 5:6, d = 7:8)) }) expect_false(exists("con")) expect_false(exists("con2")) con3 <- DBI::dbConnect(RSQLite::SQLite(), db) con4 <- DBI::dbConnect(RSQLite::SQLite(), db2) on.exit({ DBI::dbDisconnect(con3) DBI::dbDisconnect(con4) }, add = TRUE) expect_equal(DBI::dbReadTable(con3, "test"), data.frame(a = 1:2, b = 3:4)) expect_equal(DBI::dbReadTable(con4, "test"), data.frame(c = 5:6, d = 7:8)) }) }) describe("local_db_connection", { it("creates a single connection", { db <- tempfile() on.exit(unlink(db)) expect_false(exists("con")) (function() { con <- local_db_connection(DBI::dbConnect(RSQLite::SQLite(), db)) DBI::dbWriteTable(con, "test", data.frame(a = 1:2, b = 3:4)) })() expect_false(exists("con")) con2 <- DBI::dbConnect(RSQLite::SQLite(), db) on.exit(DBI::dbDisconnect(con2), add = TRUE) expect_equal(DBI::dbReadTable(con2, "test"), data.frame(a = 1:2, b = 3:4)) }) }) withr/tests/testthat/test-locale.R0000644000175000017500000000056514205720724017113 0ustar nileshnileshtest_that("with_locale works and resets locales", { current <- Sys.getlocale("LC_CTYPE") new <- "C" with_locale( c(LC_CTYPE = new), { expect_equal(new, Sys.getlocale("LC_CTYPE")) } ) expect_equal(current, Sys.getlocale("LC_CTYPE")) }) test_that("with_locale fails with LC_ALL", { expect_error(with_locale(c(LC_ALL = "C"), NULL), "LC_ALL") }) withr/tests/testthat/helper.R0000644000175000017500000000203614207453244016153 0ustar nileshnileshexpect_no_output <- function(...) { testthat::expect_output(..., regexp = NA) } expect_safe_and_unsafe_unwinding <- function(state, with_unsafe, with_safe) { early_exit <- function(expr) { tryCatch(expr, my_cnd = identity) } with_unsafe(list("var" = "foo"), NULL) expect_null(state[["var"]]) with_safe(list("var" = "foo"), NULL) expect_null(state[["var"]]) early_exit(with_safe(list("var" = "foo"), NULL)) expect_null(state[["var"]]) # Problematic behaviour with unsafe variant early_exit(with_unsafe(list("var" = "foo"), NULL)) expect_equal(state[["var"]], "foo") } en_locale_or_skip <- function() { tryCatch( error = function(...) skip("Can't set locale"), warning = function(...) skip("Can't set locale"), with_collate("en_US.UTF-8", NULL) ) "en_US.UTF-8" } skip_if_cannot_knit <- function() { skip_if_not_installed("knitr") skip_if_not_installed("rmarkdown") skip_if(!rmarkdown::pandoc_available()) } withr/tests/testthat/test-connection.R0000644000175000017500000000371014165531434020011 0ustar nileshnileshdescribe("with_connection", { it("errors if connection is not named", { expect_error({ with_connection(list(TRUE), TRUE) }, "all(is.named(con)) is not TRUE", fixed = TRUE) }) it("creates a single connection", { tmp <- tempfile() on.exit(unlink(tmp)) expect_false(exists("con")) with_connection(list(con = file(tmp, "w")), { writeLines(c("foo", "bar"), con) }) expect_false(exists("con")) expect_equal(readLines(tmp), c("foo", "bar")) }) it("creates multiple connections", { tmp <- tempfile() tmp2 <- tempfile() on.exit(unlink(c(tmp, tmp2))) expect_false(exists("con")) expect_false(exists("con2")) with_connection(list(con = file(tmp, "w"), con2 = file(tmp2, "w")), { writeLines(c("foo", "bar"), con) writeLines(c("baz", "qux"), con2) }) expect_false(exists("con")) expect_false(exists("con2")) expect_equal(readLines(tmp), c("foo", "bar")) expect_equal(readLines(tmp2), c("baz", "qux")) }) it("works if there is an existing object with the same name", { tmp <- tempfile() con <- "foo" with_connection(list(con = file(tmp, "w")), { writeLines("foo", con) }) expect_true(exists("con")) expect_equal(readLines(tmp), "foo") }) it("works if there is an existing connection with the same name", { tmp <- tempfile() tmp2 <- tempfile() con <- file(tmp, "w") writeLines("foo", tmp) with_connection(list(con = file(tmp2, "w")), { writeLines("bar", con) }) close(con) expect_equal(readLines(tmp), "foo") expect_equal(readLines(tmp2), "bar") }) }) describe("local_connection", { it("creates a single connection", { tmp <- tempfile() on.exit(unlink(tmp)) expect_false(exists("con")) (function() { con <- local_connection(file(tmp, "w")) writeLines(c("foo", "bar"), con) })() expect_false(exists("con")) expect_equal(readLines(tmp), c("foo", "bar")) }) }) withr/tests/testthat/test-devices.R0000644000175000017500000000520114165531434017271 0ustar nileshnileshneeds_cairo <- function(fn) fn %in% c("with_cairo_pdf", "with_cairo_ps", "with_svg", "local_cairo_pdf", "local_cairo_ps", "local_svg") skip_if_needs_cairo <- function(fn) { if (!capabilities("cairo") && needs_cairo(fn)) { skip("cairo not available") } } test_that("with_*device* functions create a plot file", { # A plot p <- lattice::xyplot(y ~ x, data.frame(x = -2:2, y = dnorm(-2:2))) # A directory to store the plots plot_dir <- tempfile("withr-test-plots-") dir.create(plot_dir) fn_names <- c("with_bmp", "with_jpeg", "with_pdf", "with_png", "with_tiff", "with_xfig", "with_svg", "with_cairo_pdf", "with_cairo_ps") fns <- mget(fn_names, envir = asNamespace("withr")) extensions <- c("bmp", "pdf", "ps", "jpg", "pdf", "png", "tiff", "xfig", "svg", "pdf", "ps") for (i in seq_along(fns)) { skip_if_needs_cairo(fn_names[[i]]) filename <- file.path(plot_dir, paste0("test-", fn_names[i], ".", extensions[i])) info <- paste0("function = ", fn_names[i], "; filename = ", filename) if (fn_names[i] == "with_xfig") { # grDevices::xfig weirdly gives a warning with the default inputs expect_warning( fns[[i]](filename, print(p)), "will only return the last plot" ) } else { expect_silent(fns[[i]](filename, print(p))) } expect_true(file.exists(filename), info = info) expect_gt(file.info(filename)$size, 0, label = info) } unlink(plot_dir) }) test_that("local_device functions create a plot file", { # A plot p <- lattice::xyplot(y ~ x, data.frame(x = -2:2, y = dnorm(-2:2))) # A directory to store the plots plot_dir <- tempfile("withr-test-plots-local-") dir.create(plot_dir) fn_names <- c("local_bmp", "local_jpeg", "local_pdf", "local_png", "local_tiff", "local_xfig", "local_svg", "local_cairo_pdf", "local_cairo_ps") fns <- mget(fn_names, envir = asNamespace("withr")) extensions <- c("bmp", "pdf", "ps", "jpg", "pdf", "png", "tiff", "xfig", "svg", "pdf", "ps") for (i in seq_along(fns)) { skip_if_needs_cairo(fn_names[[i]]) filename <- file.path(plot_dir, paste0("test-", fn_names[i], ".", extensions[i])) info <- paste0("function = ", fn_names[i], "; filename = ", filename) (function(i) { if (fn_names[i] == "local_xfig") { # grDevices::xfig weirdly gives a warning with the default inputs expect_warning( fns[[i]](filename), "will only return the last plot") } else { expect_silent(fns[[i]](filename)) } print(p) })(i) expect_true(file.exists(filename), info = info) expect_gt(file.info(filename)$size, 0, label = info) } unlink(plot_dir) }) withr/tests/testthat/test-local.R0000644000175000017500000001344114205720724016743 0ustar nileshnileshtest_that("local_options works", { expect_false(getOption("scipen") == 999) local({ local_options(c(scipen=999)) expect_equal(getOption("scipen"), 999) }) expect_false(getOption("scipen") == 999) expect_false(identical(getOption("zyxxyzyx"), "qwrbbl")) local({ local_options(c(zyxxyzyx="qwrbbl")) expect_equal(getOption("zyxxyzyx"), "qwrbbl") }) expect_false(identical(getOption("zyxxyzyx"), "qwrbbl")) }) test_that("local_options(error = ) works", { f <- function(...) 1 oopt <- options("error") on.exit(options(oopt)) options(error = f) local({ local_options(list(error = function(...) 2)) expect_identical(2, eval(getOption("error"))) }) expect_identical(1, eval(getOption("error"))) }) test_that("local_libpaths works and resets library", { lib <- .libPaths() new_lib <- "." local({ local_libpaths(new_lib) expect_equal(normalizePath(new_lib), normalizePath(.libPaths()[[1L]])) }) expect_equal(lib, .libPaths()) }) test_that("local_temp_libpaths works and resets library", { lib <- .libPaths() local({ local_temp_libpaths() expect_equal(.libPaths()[-1], lib) }) expect_equal(lib, .libPaths()) }) test_that("local_ works", { res <- NULL set <- function(new) { res <<- c(res, 1L) } reset <- function(old) { res <<- c(res, 3L) } local_res <- local_(set, reset) local({ local_res(NULL) res <<- c(res, 2L) }) expect_equal(res, 1L:3L) }) test_that("local_ works on functions without arguments", { res <- NULL set <- function() { res <<- c(res, 1L) } reset <- function(x) { res <<- c(res, 3L) } local_res <- local_(set, reset) local({ local_res() res <<- c(res, 2L) }) expect_equal(res, 1L:3L) }) test_that("local_libpaths works and resets library", { lib <- .libPaths() new_lib <- "." local({ local_libpaths(new_lib) expect_equal(normalizePath(new_lib), normalizePath(.libPaths()[[1L]], mustWork = FALSE)) }) expect_equal(lib, .libPaths()) }) test_that("local_locale works and resets locales", { current <- Sys.getlocale("LC_CTYPE") new <- "C" local({ local_locale(c(LC_CTYPE = new)) expect_equal(new, Sys.getlocale("LC_CTYPE")) }) expect_equal(current, Sys.getlocale("LC_CTYPE")) }) test_that("local_locale fails with LC_ALL", { local({ expect_error(local_locale(c(LC_ALL = "C")), "LC_ALL") }) }) test_that("local_collate works and resets collate", { current <- Sys.getlocale("LC_COLLATE") new <- "C" local({ local_collate(new) expect_equal(new, Sys.getlocale("LC_COLLATE")) }) expect_equal(current, Sys.getlocale("LC_COLLATE")) }) test_that("local_makevars works and resets the Makevars file", { current <- tempfile() writeLines(con = current, c("CFLAGS=-03"), sep = "\n") new <- c(CFLAGS = "-O0") local({ local_makevars(new, .path = current) expect_equal("CFLAGS=-O0", readLines(Sys.getenv("R_MAKEVARS_USER"))) }) expect_equal("CFLAGS=-03", readLines(current)) }) test_that("local_makevars changes only the defined variables", { current_name <- tempfile() current <- c("CFLAGS=-03", "LDFLAGS=-lz") writeLines(con = current_name, current, sep = "\n") new <- c(CFLAGS = "-O0") local({ local_makevars(new, .path = current_name) expect_equal(c("CFLAGS=-O0", "LDFLAGS=-lz"), readLines(Sys.getenv("R_MAKEVARS_USER"))) }) expect_equal(current, readLines(current_name)) }) test_that("local_makevars works with alternative assignments", { current <- tempfile() writeLines(con = current, c("CFLAGS=-03"), sep = "\n") new <- c(CFLAGS = "-O0") local({ local_makevars(new, .path = current, .assignment = "+=") expect_equal("CFLAGS+=-O0", readLines(Sys.getenv("R_MAKEVARS_USER"))) }) expect_equal("CFLAGS=-03", readLines(current)) }) test_that("local_makevars uses the existing R_MAKEVARS_USER by default", { tf <- tempfile() local_envvar("R_MAKEVARS_USER" = tf) on.exit(unlink(tf)) writeLines(con = tf, c("CFLAGS=-O3", "CXXFLAGS=-O3"), sep = "\n") new <- c(CFLAGS = "-O0") local({ local_makevars(new) expect_equal(readLines(Sys.getenv("R_MAKEVARS_USER")), c("CFLAGS=-O0", "CXXFLAGS=-O3")) }) expect_equal(readLines(tf), c("CFLAGS=-O3", "CXXFLAGS=-O3")) }) test_that("local_dir works as expected", { old <- normalizePath(getwd()) local({ local_dir("..") expect_equal(normalizePath(getwd()), normalizePath(file.path(old, ".."))) }) expect_equal(normalizePath(getwd()), normalizePath(old)) }) test_that("local_par works as expected", { tmp <- tempfile() pdf(tmp) on.exit(unlink(tmp), add = TRUE) old <- par("pty") local({ local_par(list(pty = "s")) expect_equal(par("pty"), "s") }) expect_equal(par("pty"), old) dev.off() }) test_that("supplying a getter to `local_()` shields against early exits", { my_get <- function(x) { out <- as.list(state)[names(x)] names(out) <- names(x) out } my_set <- function(x) { old <- my_get(x) mapply(function(nm, val) state[[nm]] <- val, names(x), x) rlang::signal("", "my_cnd") invisible(old) } state <- new.env() my_local_unsafe <- withr::local_(my_set) my_local_safe <- withr::local_(my_set, get = my_get) my_with_unsafe <- function(new, expr) { my_local_unsafe(new) expr } my_with_safe <- function(new, expr) { my_local_safe(new) expr } expect_safe_and_unsafe_unwinding( state, my_with_unsafe, my_with_safe ) # `...` code path state <- new.env() my_local_unsafe <- withr::local_(my_set, dots = TRUE) my_local_safe <- withr::local_(my_set, get = my_get, dots = TRUE) my_with_unsafe <- function(new, expr) { my_local_unsafe(new) expr } my_with_safe <- function(new, expr) { my_local_safe(new) expr } expect_safe_and_unsafe_unwinding( state, my_with_unsafe, my_with_safe ) }) withr/tests/testthat/test-timezone.R0000644000175000017500000000242314165531434017504 0ustar nileshnileshdescribe("with_timezone", { it("changes the time zone", { expect_equal(with_timezone("CET", Sys.timezone()), "CET") expect_equal(with_timezone("GMT", Sys.timezone()), "GMT") expect_true( with_timezone("CET", format(Sys.time(), "%Z")) %in% c("CET", "CEST")) expect_true( with_timezone("US/Pacific", format(Sys.time(), "%Z")) %in% c("PDT", "PST")) }) it("restores the time zone", { cur <- Sys.timezone() expect_equal(with_timezone("CET", Sys.timezone()), "CET") expect_identical(cur, Sys.timezone()) cur <- Sys.timezone() expect_equal(with_timezone("US/Pacific", Sys.timezone()), "US/Pacific") expect_identical(cur, Sys.timezone()) }) }) describe("local_timezone", { it("changes the time zone", { fun <- function(tzone) { local_timezone(tzone) Sys.timezone() } expect_identical( with_timezone("CET", Sys.timezone()), fun("CET")) expect_identical( with_timezone("US/Pacific", Sys.timezone()), fun("US/Pacific")) }) it("restores the time zone", { cur <- Sys.timezone() fun <- function(tzone) { local_timezone(tzone) "foobar" } fun("CET") expect_identical(cur, Sys.timezone()) fun("US/Pacific") expect_identical(cur, Sys.timezone()) }) }) withr/tests/testthat/test-path.R0000644000175000017500000000436114205720724016606 0ustar nileshnileshtest_that("`action` is checked", { expect_snapshot_error(with_path("foo", NULL, action = "Suffix")) }) test_that("with_path works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") with_path( new_path, { expect_equal(normalizePath(new_path), head(get_path(), n = 1)) expect_equal(length(get_path()), length(current) + 1L) } ) expect_equal(current, get_path()) }) test_that("with_path with suffix action works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") with_path( new_path, action = "suffix", { expect_equal(normalizePath(new_path), tail(get_path(), n = 1)) expect_equal(length(get_path()), length(current) + 1L) } ) expect_equal(current, get_path()) }) test_that("with_path with replace action works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") with_path( new_path, action = "replace", { expect_equal(normalizePath(new_path), get_path()) expect_equal(length(get_path()), 1L) } ) expect_equal(current, get_path()) }) test_that("local_path works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") local({ local_path(new_path) expect_equal(normalizePath(new_path), head(get_path(), n = 1)) expect_equal(length(get_path()), length(current) + 1L) }) expect_equal(current, get_path()) }) test_that("local_path with suffix action works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") local({ local_path(new_path, action = "suffix") expect_equal(normalizePath(new_path), tail(get_path(), n = 1)) expect_equal(length(get_path()), length(current) + 1L) }) expect_equal(current, get_path()) }) test_that("local_path with replace action works and resets path", { current <- normalizePath(get_path(), mustWork = FALSE) new_path <- normalizePath(".") local({ local_path(new_path, action = "replace") expect_equal(normalizePath(new_path), get_path()) expect_equal(length(get_path()), 1L) }) expect_equal(current, get_path()) }) withr/tests/testthat/test-options.R0000644000175000017500000000065614165531434017353 0ustar nileshnileshtest_that("local_options lets you unset an option (#156)", { expect_true(is.null(getOption("x"))) local({ local_options(foo = "bar") expect_equal(getOption("foo"), "bar") }) expect_true(is.null(getOption("x"))) local({ local_options(foo = "bar") expect_equal(getOption("foo"), "bar") local_options(foo = NULL) expect_true(is.null(getOption("x"))) }) expect_true(is.null(getOption("x"))) }) withr/tests/testthat/test-file.R0000644000175000017500000000407214165531434016573 0ustar nileshnileshdescribe("with_file", { it("can use unnamed arguments", { with_file("file1", { writeLines("foo", "file1") expect_equal(readLines("file1"), "foo") with_file("file2", { writeLines("bar", "file2") expect_equal(readLines("file1"), "foo") expect_equal(readLines("file2"), "bar") }) expect_false(file.exists("file2")) }) expect_false(file.exists("file1")) }) it("can use named arguments", { with_file(list("file1" = writeLines("foo", "file1")), { expect_equal(readLines("file1"), "foo") with_file(list("file2" = writeLines("bar", "file2")), { expect_equal(readLines("file1"), "foo") expect_equal(readLines("file2"), "bar") }) expect_false(file.exists("file2")) }) expect_false(file.exists("file1")) }) it("works with multiple files", { with_file( list("file1" = writeLines("foo", "file1"), "file2", "file3" = writeLines("baz", "file3")), { writeLines("bar", "file2") expect_equal(readLines("file1"), "foo") expect_equal(readLines("file2"), "bar") expect_equal(readLines("file3"), "baz") }) expect_false(file.exists("file1")) expect_false(file.exists("file2")) expect_false(file.exists("file3")) }) }) describe("local_file", { it("works with unnamed arguments", { f <- function() { local_file("file1") writeLines("foo", "file1") expect_equal(readLines("file1"), "foo") } expect_no_output(f()) expect_false(file.exists("file1")) }) it("works with named arguments", { f <- function() { local_file(list("file1" = writeLines("foo", "file1"))) expect_equal(readLines("file1"), "foo") } expect_no_output(f()) expect_false(file.exists("file1")) }) it("can delete directories", { path <- character() f <- function() { path <<- local_file(tempfile()) dir.create(path) file.create(file.path(path, "foo")) expect_true(file.exists(path)) } expect_no_output(f()) expect_false(file.exists(path)) }) }) withr/tests/testthat/test-rng.R0000644000175000017500000000137514165531434016445 0ustar nileshnileshdescribe("with_rng_version", { it("changes the RNG", { cur <- RNGkind() old <-with_rng_version("1.6.0", RNGkind()) expect_equal(old[1], "Marsaglia-Multicarry") expect_true(old[1] != cur[1]) }) it("restores the RNG", { cur <- RNGkind() with_rng_version("1.6.0", RNGkind()) expect_identical(cur, RNGkind()) }) }) describe("local_rng_version", { it("changes the RNG", { fun <- function() { local_rng_version("1.6.0") RNGkind() } expect_identical( with_rng_version("1.6.0", RNGkind()), fun() ) }) it("restores the RNG", { cur <- RNGkind() fun <- function() { local_rng_version("1.6.0") "foobar" } expect_identical( cur, RNGkind() ) }) }) withr/tests/testthat/_snaps/0000755000175000017500000000000014210204046016017 5ustar nileshnileshwithr/tests/testthat/_snaps/language.md0000644000175000017500000000005514210166565020141 0ustar nileshnilesh# checks input `lang` must be a string withr/tests/testthat/_snaps/path.md0000644000175000017500000000012114210166566017305 0ustar nileshnilesh# `action` is checked 'arg' should be one of "prefix", "suffix", "replace" withr/tests/testthat/_snaps/defer.md0000644000175000017500000000056514210204311017427 0ustar nileshnilesh# defer()'s global env facilities work Code defer(print("howdy"), envir = globalenv()) Message Setting global deferred event(s). i These will be run: * Automatically, when the R session ends. * On demand, if you call `withr::deferred_run()`. i Use `withr::deferred_clear()` to clear them without executing. withr/tests/testthat.R0000644000175000017500000000006613043754137014677 0ustar nileshnileshlibrary(testthat) library(withr) test_check("withr") withr/R/0000755000175000017500000000000014210204346011736 5ustar nileshnileshwithr/R/makevars.R0000644000175000017500000000722514165531434013712 0ustar nileshnilesh#' @include with_.R NULL # Makevars -------------------------------------------------------------------- #' Create a new `Makevars` file, by adding new variables #' #' You probably want [with_makevars()] instead of this function. #' #' Unlike [with_makevars()], it does not activate the new `Makevars` #' file, i.e. it does not set the `R_MAKEVARS_USER` environment variable. #' #' @param variables `[named character]`\cr new variables and their values #' @param old_path `[character(1)]`\cr location of existing `Makevars` #' file to modify. #' @param new_path `[character(1)]`\cr location of the new `Makevars` file #' @param assignment `[character(1)]`\cr assignment type to use. #' #' @keywords internal #' @export set_makevars <- function(variables, old_path = makevars_user(), new_path = tempfile(), assignment = c("=", ":=", "?=", "+=")) { if (length(variables) == 0) { return() } stopifnot(is.named(variables)) assignment <- match.arg(assignment) old <- NULL if (length(old_path) == 1 && file.exists(old_path)) { lines <- readLines(old_path) old <- lines for (var in names(variables)) { loc <- grep(paste(c("^[[:space:]]*", var, "[[:space:]]*", "="), collapse = ""), lines) if (length(loc) == 0) { lines <- append(lines, paste(sep = assignment, var, variables[var])) } else if(length(loc) == 1) { lines[loc] <- paste(sep = assignment, var, variables[var]) } else { stop("Multiple results for ", var, " found, something is wrong.", .call = FALSE) } } } else { lines <- paste(names(variables), variables, sep = assignment) } if (!identical(old, lines)) { writeLines(con = new_path, lines) } old } #' Makevars variables #' #' Temporarily change contents of an existing `Makevars` file. #' #' @details If no `Makevars` file exists or the fields in `new` do #' not exist in the existing `Makevars` file then the fields are added to #' the new file. Existing fields which are not included in `new` are #' appended unchanged. Fields which exist in `Makevars` and in `new` #' are modified to use the value in `new`. #' #' @template with #' @param new,.new `[named character]`\cr New variables and their values #' @param path,.path `[character(1)]`\cr location of existing `Makevars` file to modify. #' @param ... Additional new variables and their values. #' @param assignment,.assignment `[character(1)]`\cr assignment type to use. #' @inheritParams with_collate #' @examples #' writeLines("void foo(int* bar) { *bar = 1; }\n", "foo.c") #' system("R CMD SHLIB --preclean -c foo.c") #' with_makevars(c(CFLAGS = "-O3"), system("R CMD SHLIB --preclean -c foo.c")) #' unlink(c("foo.c", "foo.so")) #' @export with_makevars <- function(new, code, path = makevars_user(), assignment = c("=", ":=", "?=", "+=")) { assignment <- match.arg(assignment) makevars_file <- tempfile() on.exit(unlink(makevars_file), add = TRUE) force(path) with_envvar(c(R_MAKEVARS_USER = makevars_file), { set_makevars(new, path, makevars_file, assignment = assignment) force(code) }) } #' @rdname with_makevars #' @export local_makevars <- function(.new = list(), ..., .path = makevars_user(), .assignment = c("=", ":=", "?=", "+="), .local_envir = parent.frame()) { .new <- utils::modifyList(as.list(.new), list(...)) .new <- as_character(.new) .assignment <- match.arg(.assignment) makevars_file <- tempfile() defer(unlink(makevars_file), envir = .local_envir) force(.path) local_envvar(c(R_MAKEVARS_USER = makevars_file), .local_envir = .local_envir) invisible(set_makevars(.new, .path, makevars_file, assignment = .assignment)) } withr/R/aaa.R0000644000175000017500000000131614205720724012613 0ustar nileshnilesh# From https://github.com/r-lib/rlang/blob/main/R/aaa.R on_load <- function(expr, env = parent.frame(), ns = topenv(env)) { expr <- substitute(expr) force(env) callback <- function() { # Evaluate with promise semantics rather than `base::eval()` do <- NULL do.call(delayedAssign, list("do", expr, env)) do } ns$.__rlang_hook__. <- c(ns$.__rlang_hook__., list(callback)) } run_on_load <- function(ns = topenv(parent.frame())) { hook <- ns$.__rlang_hook__. rm(envir = ns, list = ".__rlang_hook__.") # FIXME: Transform to `while` loop to allow hooking into on-load # from an on-load hook? for (callback in hook) { callback() } } .onLoad <- function(...) { run_on_load() } withr/R/connection.R0000644000175000017500000000175313670443075014243 0ustar nileshnilesh#' Connections which close themselves #' #' R file connections which are automatically closed. #' #' @template with #' @param con For `with_connection()` a named list with the connection(s) to #' create. For `local_connection()` the code to create a single connection, #' which is then returned. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @importFrom stats setNames #' @examples #' with_connection(list(con = file("foo", "w")), { #' writeLines(c("foo", "bar"), con) #' }) #' #' read_foo <- function() { #' readLines(local_connection(file("foo", "r"))) #' } #' read_foo() #' #' unlink("foo") #' @export with_connection <- function(con, code) { stopifnot(all(is.named(con))) on.exit({ for (connection in con) close(connection) }) eval(substitute(code), envir = con, enclos = parent.frame()) } #' @rdname with_connection #' @export local_connection <- function(con, .local_envir = parent.frame()) { defer(close(con), envir = .local_envir) con } withr/R/options.R0000644000175000017500000000324114210200313013542 0ustar nileshnilesh#' @include with_.R # options -------------------------------------------------------------------- get_options <- function(new_options) { do.call(options, as.list(names(new_options))) } set_options <- function(new_options) { do.call(options, as.list(new_options)) } reset_options <- function(old_options) { options(old_options) } #' Options #' #' Temporarily change global options. #' #' @template with #' @param new,.new `[named list]`\cr New options and their values #' @param ... Additional options and their values #' @inheritParams with_collate #' @seealso [options()] #' @examples #' # number of significant digits to print #' getOption("digits") #' # modify temporarily the number of significant digits to print #' with_options(list(digits = 3), getOption("digits")) #' with_options(list(digits = 3), print(pi)) #' #' # modify temporarily the character to be used as the decimal point #' getOption("digits") #' with_options(list(OutDec = ","), print(pi)) #' #' # modify temporarily multiple options #' with_options(list(OutDec = ",", digits = 3), print(pi)) #' #' # modify, within the scope of the function, the number of #' # significant digits to print #' print_3_digits <- function(x) { #' # assign 3 to the option "digits" for the rest of this function #' # after the function exits, the option will return to its previous #' # value #' local_options(list(digits = 3)) #' print(x) #' } #' #' print_3_digits(pi) # returns 3.14 #' print(pi) # returns 3.141593 #' @export with_options <- with_( set_options, reset_options ) #' @rdname with_options #' @export local_options <- local_( set_options, reset_options, get = get_options, dots = TRUE ) withr/R/defer.R0000644000175000017500000000607414205732107013162 0ustar nileshnilesh#' @include compat-defer.R NULL defer_ns <- environment(defer) #' Defer Evaluation of an Expression #' #' Similar to [on.exit()], but allows one to attach #' an expression to be evaluated when exiting any frame currently #' on the stack. This provides a nice mechanism for scoping side #' effects for the duration of a function's execution. #' #' @param expr `[expression]`\cr An expression to be evaluated. #' @param envir `[environment]`\cr Attach exit handlers to this environment. #' Typically, this should be either the current environment or #' a parent frame (accessed through [parent.frame()]). #' @param priority `[character(1)]`\cr Specify whether this handler should #' be executed `"first"` or `"last"`, relative to any other #' registered handlers on this environment. #' #' @details #' #' `defer()` works by attaching handlers to the requested environment (as an #' attribute called `"handlers"`), and registering an exit handler that #' executes the registered handler when the function associated with the #' requested environment finishes execution. #' #' Deferred events can be set on the global environment, primarily to facilitate #' the interactive development of code that is intended to be executed inside a #' function or test. A message alerts the user to the fact that an explicit #' `deferred_run()` is the only way to trigger these deferred events. Use #' `deferred_clear()` to clear them without evaluation. The global environment #' scenario is the main motivation for these functions. #' #' @family local-related functions #' @export #' @examples #' # define a 'local' function that creates a file, and #' # removes it when the parent function has finished executing #' local_file <- function(path) { #' file.create(path) #' defer_parent(unlink(path)) #' } #' #' # create tempfile path #' path <- tempfile() #' #' # use 'local_file' in a function #' local({ #' local_file(path) #' stopifnot(file.exists(path)) #' }) #' #' # file is deleted as we leave 'local' local #' stopifnot(!file.exists(path)) #' #' # investigate how 'defer' modifies the #' # executing function's environment #' local({ #' local_file(path) #' print(attributes(environment())) #' }) #' #' # defer and trigger events on the global environment #' defer(print("one")) #' defer(print("two")) #' deferred_run() #' #' defer(print("three")) #' deferred_clear() #' deferred_run() defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) NULL #' @rdname defer #' @export defer_parent <- function(expr, priority = c("first", "last")) { eval(substitute( defer(expr, envir, priority), list(expr = substitute(expr), envir = parent.frame(2), priority = priority, defer = defer) ), envir = parent.frame()) } #' @rdname defer #' @export deferred_run <- function(envir = parent.frame()) { execute_handlers(envir) deferred_clear(envir) } #' @rdname defer #' @export deferred_clear <- function(envir = parent.frame()) { attr(envir, "withr_handlers") <- NULL invisible() } # Splice `compat-defer.R` into the namespace for (name in names(defer_ns)) { assign(name, defer_ns[[name]]) } withr/R/file.R0000644000175000017500000000216114205720724013007 0ustar nileshnilesh#' Files which delete themselves #' #' Create files, which are then automatically removed afterwards. #' @template with #' @param file,.file `[named list]`\cr Files to create. #' @param ... Additional (possibly named) arguments of files to create. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @examples #' with_file("file1", { #' writeLines("foo", "file1") #' readLines("file1") #' }) #' #' with_file(list("file1" = writeLines("foo", "file1")), { #' readLines("file1") #' }) #' @export with_file <- function(file, code) { file_nms <- names2(file) unnamed <- file_nms == "" file_nms[unnamed] <- as.character(file[unnamed]) on.exit(unlink(file_nms, recursive = TRUE)) force(code) invisible(file) } #' @rdname with_file #' @export local_file <- function(.file, ..., .local_envir = parent.frame()) { .file <- utils::modifyList(as.list(.file), list(...)) .file <- as_character(.file) file_nms <- names2(.file) unnamed <- file_nms == "" file_nms[unnamed] <- as.character(.file[unnamed]) defer(unlink(file_nms, recursive = TRUE), envir = .local_envir) invisible(.file) } withr/R/with_.R0000644000175000017500000001052014205720724013200 0ustar nileshnilesh#' @include local_.R NULL #' Create a new "with" or "local" function #' #' These are constructors for `with_...` or `local_...` functions. #' They are only needed if you want to alter some global state which is not #' covered by the existing `with_...` functions, see \link{withr} #' for an overview. #' #' The `with_...` functions reset the state immediately after the #' `code` argument has been evaluated. The `local_...` functions #' reset their arguments after they go out of scope, usually at the end of the #' function body. #' #' @inheritParams rlang::args_dots_empty #' #' @param set `[function(...)]`\cr Function used to set the state. #' The function can have arbitrarily many arguments, they will be replicated #' in the formals of the returned function. #' @param reset `[function(x)]`\cr Function used to reset the state. #' The first argument can be named arbitrarily, further arguments with default #' values, or a "dots" argument, are supported but not used: The function will #' be called as `reset(old)`. #' @param get `[function(...)]`\cr Optionally, a getter function. If #' supplied, the `on.exit()` restoration is set up _before_ calling #' `set`. This is more robust in edge cases. #' #' For technical reasons, this getter function must have the same #' interface as `set`, which means it is passed the new values as #' well. These can be safely ignored. #' @param envir `[environment]`\cr Environment of the returned function. #' @param new `[logical(1)]`\cr Replace the first argument of the `set` function #' by `new`? Set to `FALSE` if the `set` function only has optional arguments. #' @return `[function(new, code, ...)]` A function with at least two arguments, #' \itemize{ #' \item `new`: New state to use #' \item `code`: Code to run in that state. #' } #' If there are more arguments to the function passed in `set` they are #' added to the returned function. If `set` does not have arguments, #' or `new` is `FALSE`, the returned function does not have a `code` argument. #' @keywords internal #' @examples #' with_(setwd) #' #' global_stack <- list() #' set_global_state <- function(state, msg = "Changing global state.") { #' global_stack <- c(list(state), global_stack) #' message(msg) #' state #' } #' reset_global_state <- function(state) { #' old_state <- global_stack[[1]] #' global_stack <- global_stack[-1] #' stopifnot(identical(state, old_state)) #' } #' with_(set_global_state, reset_global_state) #' @export with_ <- function(set, reset = set, get = NULL, ..., envir = parent.frame(), new = TRUE) { if (!missing(...)) { stop("`...` must be empty.") } fmls <- formals(set) if (length(fmls) > 0L) { # Called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls)) # Special case for dots. If `set()` and/or `get()` take dots, it # is assumed they implement `options()`-like semantic: a list # passed as first argument is automatically spliced in the dots. names(called_fmls)[names(called_fmls) == "..."] <- "" if (new) { # rename first formal to new called_fmls[[1]] <- as.symbol("new") fun_args <- c(alist(new =, code =), fmls[-1L]) } else { fun_args <- c(alist(code =), fmls) } } else { # no formals -- only have code called_fmls <- NULL fun_args <- alist(code =) } set_call <- as.call(c(substitute(set), called_fmls)) reset <- if (missing(reset)) substitute(set) else substitute(reset) if (is.null(get)) { fun <- eval(bquote(function(args) { old <- .(set_call) on.exit(.(reset)(old)) force(code) })) } else { get_call <- as.call(c(substitute(get), called_fmls)) fun <- eval(bquote(function(args) { old <- .(get_call) on.exit(.(reset)(old)) .(set_call) force(code) })) } # substitute does not work on arguments, so we need to fix them manually formals(fun) <- fun_args environment(fun) <- envir fun } merge_new <- function(old, new, action, merge_fun = c) { action <- match.arg(action, c("replace", "prefix", "suffix")) if (action == "suffix") { new <- merge_fun(old, new) } else if (action == "prefix") { new <- merge_fun(new, old) } new } is.named <- function(x) { !is.null(names(x)) && all(names(x) != "") } withr/R/tempfile.R0000644000175000017500000000642014205470757013707 0ustar nileshnilesh#' Temporary files #' #' Temporarily create a tempfile, which is automatically removed afterwards. #' @template with #' @param new `[character vector]`\cr (Deprecated for `local_tempfile()`) Names of temporary file handles to create. #' @param envir `[environment]`\cr Deprecated in favor of `.local_envir`. #' @param clean `[logical(1)]`\cr A logical indicating if the temporary #' directory should be deleted after use (`TRUE`, default) or left alone (`FALSE`). #' @inheritParams with_collate #' @inheritParams base::tempfile #' @examples #' # check how big iris would be if written as csv vs RDS #' tf <- with_tempfile("tf", {write.csv(iris, tf); file.size(tf)}) #' tf <- with_tempfile("tf", {saveRDS(iris, tf); file.size(tf)}) #' @export with_tempfile <- function(new, code, envir = parent.frame(), .local_envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") { if (!missing(envir)) { .Deprecated(msg = "`envir` argument of with_tempfile() is deprecated.\n Use `with_tempfile(.local_envir=)` instead.") .local_envir <- envir } env <- new.env(parent = .local_envir) for (f in new) { assign(f, tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext), envir = env) } on.exit(unlink(mget(new, envir = env), recursive = TRUE)) eval(substitute(code), envir = env) } #' @rdname with_tempfile #' @param lines Optionally, supply lines to be fed into #' @export local_tempfile <- function(new = NULL, lines = NULL, envir = parent.frame(), .local_envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") { if (!missing(envir)) { .Deprecated(msg = "`envir` argument of local_tempfile() is deprecated.\n Use `local_tempfile(.local_envir=)` instead.") .local_envir <- envir } if (is.null(new)) { path <- tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext) if (!is.null(lines)) { writeLines(lines, path) } defer(unlink(path, recursive = TRUE), envir = .local_envir) return(path) } .Deprecated(msg = "`new` argument of local_tempfile() is deprecated.\n Use `path <- local_tempfile()` instead.") for (f in new) { assign(f, tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext), envir = .local_envir) } defer(unlink(mget(new, envir = .local_envir), recursive = TRUE), envir = .local_envir) } #' @rdname with_tempfile #' @export with_tempdir <- function(code, clean = TRUE, pattern = "file", tmpdir = tempdir(), fileext = "") { if (length(clean) > 1 || !is.logical(clean)) { stop("`clean` must be a single TRUE or FALSE", call. = FALSE) } tmp <- tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext) dir.create(tmp) if (clean) { on.exit(unlink(tmp, recursive = TRUE), add = TRUE) } withr::with_dir(tmp, code) } #' @rdname with_tempfile #' @export local_tempdir <- function(pattern = "file", tmpdir = tempdir(), fileext = "", .local_envir = parent.frame(), clean = TRUE) { if (length(clean) > 1 || !is.logical(clean)) { stop("`clean` must be a single TRUE or FALSE", call. = FALSE) } path <- tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext) dir.create(path, recursive = TRUE) if (isTRUE(clean)) { defer(unlink(path, recursive = TRUE), envir = .local_envir) } path } withr/R/with.R0000644000175000017500000000436213670443075013056 0ustar nileshnilesh#' Execute code in temporarily altered environment #' #' All functions prefixed by `with_` work as follows. First, a particular #' aspect of the global environment is modified (see below for a list). #' Then, custom code (passed via the `code` argument) is executed. #' Upon completion or error, the global environment is restored to the previous #' state. Each `with_` function has a `local_` variant, which instead resets #' the state when the current evaluation context ends (such as the end of a #' function). #' #' @section Arguments pattern: #' \tabular{lll}{ #' `new` \tab `[various]` \tab Values for setting \cr #' `code` \tab `[any]` \tab Code to execute in the temporary environment \cr #' `...` \tab \tab Further arguments \cr #' } #' @section Usage pattern: #' `with_...(new, code, ...)` #' @name withr #' @docType package #' @section withr functions: #' \itemize{ #' \item [with_collate()]: collation order #' \item [with_dir()]: working directory #' \item [with_envvar()]: environment variables #' \item [with_libpaths()]: library paths, replacing current libpaths #' \item [with_locale()]: any locale setting #' \item [with_makevars()]: Makevars variables #' \item [with_options()]: options #' \item [with_par()]: graphics parameters #' \item [with_path()]: `PATH` environment variable #' \item [with_sink()]: output redirection #' } #' @section Creating new "with" functions: #' All `with_` functions are created by a helper function, #' [with_()]. This functions accepts two arguments: #' a setter function and an optional resetter function. The setter function is #' expected to change the global state and return an "undo instruction". #' This undo instruction is then passed to the resetter function, which changes #' back the global state. In many cases, the setter function can be used #' naturally as resetter. #' @examples #' getwd() #' with_dir(tempdir(), getwd()) #' getwd() #' #' Sys.getenv("WITHR") #' with_envvar(c("WITHR" = 2), Sys.getenv("WITHR")) #' Sys.getenv("WITHR") #' #' with_envvar(c("A" = 1), #' with_envvar(c("A" = 2), action = "suffix", Sys.getenv("A")) #' ) #' #' # local variants are best used within other functions #' f <- function(x) { #' local_envvar(c("WITHR" = 2)) #' Sys.getenv("WITHR") #' } #' Sys.getenv("WITHR") "_PACKAGE" withr/R/env.R0000644000175000017500000000426514205720724012667 0ustar nileshnilesh# env ------------------------------------------------------------------------ get_envvar <- function(envs, action = "replace") { envs <- as_envvars(envs) Sys.getenv(names(envs), names = TRUE, unset = NA) } set_envvar <- function(envs, action = "replace") { envs <- as_envvars(envs) stopifnot(is.character(action), length(action) == 1) action <- match.arg(action, c("replace", "prefix", "suffix")) if (length(envs) == 0) { return() } old <- Sys.getenv(names(envs), names = TRUE, unset = NA) set <- !is.na(envs) both_set <- set & !is.na(old) if (any(both_set)) { if (action == "prefix") { envs[both_set] <- paste(envs[both_set], old[both_set]) } else if (action == "suffix") { envs[both_set] <- paste(old[both_set], envs[both_set]) } } if (any(set)) do.call("Sys.setenv", as.list(envs[set])) if (any(!set)) Sys.unsetenv(names(envs)[!set]) invisible(old) } as_envvars <- function(envs) { if (length(envs) == 0) { return(envs) } stopifnot(is.named(envs)) # if any envs are null make them NA instead envs[vlapply(envs, is.null)] <- NA # if there are duplicated entries keep only the last one envs <- envs[!duplicated(names(envs), fromLast = TRUE)] envs } #' Environment variables #' #' Temporarily change system environment variables. #' #' @template with #' @param new,.new `[named character]`\cr New environment variables #' @param ... Named arguments with new environment variables. #' @param action should new values `"replace"`, `"prefix"` or #' `"suffix"` existing variables with the same name. #' @inheritParams with_collate #' @details if `NA` is used those environment variables will be unset. #' If there are any duplicated variable names only the last one is used. #' @seealso [Sys.setenv()] #' @examples #' with_envvar(new = c("GITHUB_PAT" = "abcdef"), Sys.getenv("GITHUB_PAT")) #' #' # with_envvar unsets variables after usage #' Sys.getenv("TEMP_SECRET") #' with_envvar(new = c("TEMP_SECRET" = "secret"), Sys.getenv("TEMP_SECRET")) #' Sys.getenv("TEMP_SECRET") #' @export with_envvar <- with_(set_envvar, get = get_envvar) #' @rdname with_envvar #' @export local_envvar <- local_(set_envvar, get = get_envvar, dots = TRUE) withr/R/libpaths.R0000644000175000017500000000315414205720724013701 0ustar nileshnilesh#' @include with_.R # lib ------------------------------------------------------------------------ set_libpaths <- function(paths, action = "replace") { paths <- as_character(paths) paths <- normalizePath(paths, mustWork = TRUE) old <- .libPaths() paths <- merge_new(old, paths, action) .libPaths(paths) invisible(old) } get_libpaths <- function(...) { .libPaths() } set_temp_libpath <- function(action = "prefix") { paths <- tempfile("temp_libpath") dir.create(paths) set_libpaths(paths, action = action) } #' Library paths #' #' Temporarily change library paths. #' #' @template with #' @param new `[character]`\cr New library paths #' @param action `[character(1)]`\cr should new values `"replace"`, `"prefix"` or #' `"suffix"` existing paths. #' @inheritParams with_collate #' @seealso [.libPaths()] #' @family libpaths #' @examples #' .libPaths() #' new_lib <- tempfile() #' dir.create(new_lib) #' with_libpaths(new_lib, print(.libPaths())) #' unlink(new_lib, recursive = TRUE) #' @export with_libpaths <- with_(set_libpaths, .libPaths, get = get_libpaths) #' @rdname with_libpaths #' @export local_libpaths <- local_(set_libpaths, .libPaths, get = get_libpaths) #' Library paths #' #' Temporarily prepend a new temporary directory to the library paths. #' #' @template with #' @seealso [.libPaths()] #' @inheritParams with_libpaths #' @family libpaths #' @export with_temp_libpaths <- with_( set_temp_libpath, .libPaths, get = get_libpaths, new = FALSE ) #' @rdname with_temp_libpaths #' @export local_temp_libpaths <- local_( set_temp_libpath, .libPaths, get = get_libpaths, new = FALSE ) withr/R/seed.R0000644000175000017500000000610414205720724013011 0ustar nileshnilesh#' Random seed #' #' `with_seed()` runs code with a specific random seed and resets it afterwards. #' #' @template with #' @param seed `[integer(1)]`\cr The random seed to use to evaluate the code. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @param .rng_kind,.rng_normal_kind,.rng_sample_kind #' `[character(1)]`\cr Kind of RNG to use. Passed as the `kind`, #' `normal.kind`, and `sample.kind` arguments of [RNGkind()]. #' @examples #' # Same random values: #' with_preserve_seed(runif(5)) #' with_preserve_seed(runif(5)) #' #' # Use a pseudorandom value as seed to advance the RNG and pick a different #' # value for the next call: #' with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5)) #' with_seed(seed, runif(5)) #' with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5)) #' @export with_seed <- function(seed, code, .rng_kind = NULL, .rng_normal_kind = NULL, .rng_sample_kind = NULL) { force(seed) rng_kind <- list(.rng_kind, .rng_normal_kind, .rng_sample_kind) with_preserve_seed({ set_seed(list(seed = seed, rng_kind = rng_kind)) code }) } #' @rdname with_seed #' @export local_seed <- function(seed, .local_envir = parent.frame(), .rng_kind = NULL, .rng_normal_kind = NULL, .rng_sample_kind = NULL) { old_seed <- get_seed() defer(envir = .local_envir, { if (is.null(old_seed)) { on.exit(rm_seed(), add = TRUE) } else { on.exit(set_seed(old_seed), add = TRUE) } }) rng_kind <- list(.rng_kind, .rng_normal_kind, .rng_sample_kind) set_seed(list(seed = seed, rng_kind = rng_kind)) # FIXME invisible(seed) } #' @rdname with_seed #' @description #' `with_preserve_seed()` runs code with the current random seed and resets it #' afterwards. #' #' @export with_preserve_seed <- function(code) { old_seed <- get_seed() if (is.null(old_seed)) { on.exit(rm_seed(), add = TRUE) } else { on.exit(set_seed(old_seed), add = TRUE) } code } #' @rdname with_seed #' @export local_preserve_seed <- function(.local_envir = parent.frame()) { old_seed <- get_seed() defer({ if (is.null(old_seed)) { on.exit(rm_seed(), add = TRUE) } else { on.exit(set_seed(old_seed), add = TRUE) } }, envir = .local_envir) invisible(old_seed) } has_seed <- function() { exists(".Random.seed", globalenv(), mode = "integer", inherits = FALSE) } get_seed <- function() { if (!has_seed()) { return(NULL) } list( random_seed = get(".Random.seed", globalenv(), mode = "integer", inherits = FALSE), rng_kind = RNGkind() ) } set_seed <- function(seed) { restore_rng_kind(seed$rng_kind) if (is.null(seed$seed)) { assign(".Random.seed", seed$random_seed, globalenv()) } else { set.seed(seed$seed) } } rm_seed <- function() { if (!has_seed()) { return(NULL) } set.seed(seed = NULL) # also reset Normal RNG state (cf. #162) rm(".Random.seed", envir = globalenv()) } withr/R/sink.R0000644000175000017500000000521713156012715013037 0ustar nileshnilesh# sink ----------------------------------------------------------------------- # FIXME: Use (a better version of) pryr:::partial2 when available output_sink <- function(file = NULL, append = FALSE, split = FALSE) { sink(file = file, append = append, type = "output", split = split) } message_sink <- function(file = NULL, append = FALSE) { sink(file = file, append = append, type = "message", split = FALSE) } #' @include wrap.R set_output_sink <- wrap( output_sink, if (is.null(file)) { stop("file cannot be NULL", call. = FALSE) }, list(n = sink.number())) set_message_sink <- wrap( message_sink, { if (is.null(file)) { stop("file cannot be NULL,", call. = FALSE) } if (sink.number(type = "message") != 2L) { stop("Cannot establish message sink when another sink is active.", call. = FALSE) } con <- if (is.character(file)) { file <- file(file, if (append) "a" else "w") } }, { list(n = sink.number(type = "message"), con = con) }) reset_output_sink <- function(sink_info) { repeat { n <- sink.number() delta <- n - sink_info$n if (delta >= 0L) { sink() if (delta > 0L) { warning("Removing a different sink.", call. = FALSE) } else { return() } } else { warning("Sink #", sink_info$n, " already removed.", call. = FALSE) return() } } } reset_message_sink <- function(sink_info) { if (!is.null(sink_info$con)) { on.exit(close(sink_info$con), add = TRUE) } do_reset_message_sink(sink_info) } do_reset_message_sink <- function(sink_info) { n <- sink.number(type = "message") if (n == 2L) { warning("No message sink to remove.", call. = FALSE) } else if (n == sink_info$n) { sink(type = "message") } else { warning("Not removing a different message sink.", call. = FALSE) } } #' Output redirection #' #' Temporarily divert output to a file via [sink()]. For #' sinks of type `message`, an error is raised if such a sink is already #' active. #' #' @template with #' @param new `[character(1)|connection]`\cr #' A writable \link{connection} or a character string naming the file to write #' to. Passing `NULL` will throw an error. #' @inheritParams base::sink #' @inheritParams with_collate #' @seealso [sink()] #' @export #' @name with_sink with_output_sink <- with_(set_output_sink, reset_output_sink) #' @rdname with_sink #' @export local_output_sink <- local_(set_output_sink, reset_output_sink) #' @rdname with_sink #' @export with_message_sink <- with_(set_message_sink, reset_message_sink) #' @rdname with_sink #' @export local_message_sink <- local_(set_message_sink, reset_message_sink) withr/R/devices.R0000644000175000017500000001063214205720724013514 0ustar nileshnilesh#' @include with_.R #' @include wrap.R NULL # Internal *_dev functions ------------------------------------------------ pdf_dev <- wrap(grDevices::pdf, NULL, grDevices::dev.cur()) postscript_dev <- wrap(grDevices::postscript, NULL, grDevices::dev.cur()) svg_wrapper <- function(filename, width = 7, height = 7, pointsize = 12, onefile = FALSE, family = "sans", bg = "white", antialias = c("default", "none", "gray", "subpixel"), ...) { grDevices::svg(filename, width, height, pointsize, onefile, family, bg, antialias, ...) } svg_dev <- wrap(svg_wrapper, NULL, grDevices::dev.cur()) xfig_dev <- wrap(grDevices::xfig, NULL, grDevices::dev.cur()) # These functions arguments differ between R versions, so just use ... cairo_pdf_dev <- function(filename, ...) { grDevices::cairo_pdf(filename = filename, ...) grDevices::dev.cur() } cairo_ps_dev <- function(filename, ...) { grDevices::cairo_ps(filename = filename, ...) grDevices::dev.cur() } # These functions arguments differ between unix and windows, so just use ... bmp_dev <- function(filename, ...) { grDevices::bmp(filename = filename, ...) grDevices::dev.cur() } tiff_dev <- function(filename, ...) { grDevices::tiff(filename = filename, ...) grDevices::dev.cur() } png_dev <- function(filename, ...) { grDevices::png(filename = filename, ...) grDevices::dev.cur() } jpeg_dev <- function(filename, ...) { grDevices::jpeg(filename = filename, ...) grDevices::dev.cur() } # User-level with_* fns --------------------------------------------------- #' Graphics devices #' #' Temporarily use a graphics device. #' #' @name devices #' @aliases with_dev with_device #' @template with #' @param new \code{[named character]}\cr New graphics device #' @param ... Additional arguments passed to the graphics device. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @seealso \code{\link[grDevices]{Devices}} #' @examples #' # dimensions are in inches #' with_pdf(file.path(tempdir(), "test.pdf"), width = 7, height = 5, #' plot(runif(5)) #' ) #' #' # dimensions are in pixels #' with_png(file.path(tempdir(), "test.png"), width = 800, height = 600, #' plot(runif(5)) #' ) NULL #' @describeIn devices BMP device #' @export with_bmp <- with_(bmp_dev, grDevices::dev.off) #' @rdname devices #' @export local_bmp <- local_(bmp_dev, grDevices::dev.off) #' @describeIn devices CAIRO_PDF device #' @inheritParams grDevices::cairo_pdf #' @export with_cairo_pdf <- with_(cairo_pdf_dev, grDevices::dev.off) #' @rdname devices #' @export local_cairo_pdf <- local_(cairo_pdf_dev, grDevices::dev.off) #' @describeIn devices CAIRO_PS device #' @inheritParams grDevices::cairo_ps #' @export with_cairo_ps <- with_(cairo_ps_dev, grDevices::dev.off) #' @rdname devices #' @export local_cairo_ps <- local_(cairo_ps_dev, grDevices::dev.off) #' @describeIn devices PDF device #' @inheritParams grDevices::pdf #' @export with_pdf <- with_(pdf_dev, grDevices::dev.off) #' @rdname devices #' @export local_pdf <- local_(pdf_dev, grDevices::dev.off) #' @describeIn devices POSTSCRIPT device #' @inheritParams grDevices::postscript #' @param command the command to be used for \sQuote{printing}. Defaults #' to \code{"default"}, the value of option \code{"printcmd"}. The #' length limit is \code{2*PATH_MAX}, typically 8096 bytes on unix systems and #' 520 bytes on windows. #' @export with_postscript <- with_(postscript_dev, grDevices::dev.off) #' @rdname devices #' @export local_postscript <- local_(postscript_dev, grDevices::dev.off) #' @describeIn devices SVG device #' @inheritParams grDevices::svg #' @export with_svg <- with_(svg_dev, grDevices::dev.off) #' @rdname devices #' @export local_svg <- local_(svg_dev, grDevices::dev.off) #' @describeIn devices TIFF device #' @export with_tiff <- with_(tiff_dev, grDevices::dev.off) #' @rdname devices #' @export local_tiff <- local_(tiff_dev, grDevices::dev.off) #' @describeIn devices XFIG device #' @inheritParams grDevices::xfig #' @export with_xfig <- with_(xfig_dev, grDevices::dev.off) #' @rdname devices #' @export local_xfig <- local_(xfig_dev, grDevices::dev.off) #' @describeIn devices PNG device #' @export with_png <- with_(png_dev, grDevices::dev.off) #' @rdname devices #' @export local_png <- local_(png_dev, grDevices::dev.off) #' @describeIn devices JPEG device #' @export with_jpeg <- with_(jpeg_dev, grDevices::dev.off) #' @rdname devices #' @export local_jpeg <- local_(jpeg_dev, grDevices::dev.off) withr/R/path.R0000644000175000017500000000247414205720724013033 0ustar nileshnilesh# path ----------------------------------------------------------------------- get_path <- function(...) { strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]] } set_path <- function(path, action = c("prefix", "suffix", "replace")) { action <- match.arg(action) path <- as_character(path) path <- normalizePath(path, mustWork = FALSE) old <- get_path() path <- merge_new(old, path, action) path <- paste(path, collapse = .Platform$path.sep) Sys.setenv(PATH = path) invisible(old) } #' PATH environment variable #' #' Temporarily change the system search path. #' #' @template with #' @param new `[character]`\cr New `PATH` entries #' @param action `[character(1)]`\cr Should new values `"replace"`, `"prefix"` #' (the default) or `"suffix"` existing paths #' @inheritParams with_collate #' @seealso [Sys.setenv()] #' @examples #' # temporarily modify the system PATH, *prefixing* the current path #' with_path(getwd(), Sys.getenv("PATH")) #' # temporarily modify the system PATH, *appending* to the current path #' with_path(getwd(), Sys.getenv("PATH"), "suffix") #' @export with_path <- with_( set_path, reset = function(old) set_path(old, "replace"), get = get_path ) #' @rdname with_path #' @export local_path <- local_( set_path, reset = function(old) set_path(old, "replace"), get = get_path ) withr/R/namespace.R0000644000175000017500000000630614205722457014036 0ustar nileshnilesh#' Execute code with a modified search path #' #' `with_package()` attaches a package to the search path, executes the code, then #' removes the package from the search path. The package namespace is _not_ #' unloaded however. `with_namespace()` does the same thing, but attaches the #' package namespace to the search path, so all objects (even unexported ones) are also #' available on the search path. #' @param package \code{[character(1)]}\cr package name to load. #' @param env \code{[environment()]}\cr Environment to attach. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @inheritParams defer #' @inheritParams base::library #' @template with #' @examples #' \dontrun{ #' with_package("ggplot2", { #' ggplot(mtcars) + geom_point(aes(wt, hp)) #' }) #' } #' @export with_package <- function(package, code, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = FALSE, quietly = TRUE, verbose = getOption("verbose")) { # Only try to attach (and detach) the package if it is not already attached. if (!(package %in% .packages())) { suppressPackageStartupMessages( (get("library"))(package, pos = pos, lib.loc = lib.loc, character.only = character.only, logical.return = logical.return, warn.conflicts = warn.conflicts, quietly = quietly, verbose = verbose)) on.exit(detach(paste0("package:", package), character.only = TRUE)) } force(code) } #' @rdname with_package #' @export local_package <- function(package, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = FALSE, quietly = TRUE, verbose = getOption("verbose"), .local_envir = parent.frame()) { suppressPackageStartupMessages( (get("library"))(package, pos = pos, lib.loc = lib.loc, character.only = character.only, logical.return = logical.return, warn.conflicts = warn.conflicts, quietly = quietly, verbose = verbose)) defer(detach(paste0("package:", package), character.only = TRUE), envir = .local_envir) } #' @rdname with_package #' @export with_namespace <- function(package, code, warn.conflicts = FALSE) { ns <- asNamespace(package) name <- format(ns) (get("attach"))(ns, name = name, warn.conflicts = warn.conflicts) on.exit(detach(name, character.only = TRUE)) force(code) } #' @rdname with_package #' @export local_namespace <- function(package, .local_envir = parent.frame(), warn.conflicts = FALSE) { ns <- asNamespace(package) name <- format(ns) (get("attach"))(ns, name = name, warn.conflicts = warn.conflicts) defer(detach(name, character.only = TRUE), envir = .local_envir) } #' @rdname with_package #' @inheritParams base::attach #' @export with_environment <- function(env, code, pos = 2L, name = format(env), warn.conflicts = FALSE) { (get("attach"))(env, name = name, pos = pos, warn.conflicts = warn.conflicts) on.exit(detach(name, character.only = TRUE)) force(code) } #' @rdname with_package #' @export local_environment <- function(env, pos = 2L, name = format(env), warn.conflicts = FALSE, .local_envir = parent.frame()) { (get("attach"))(env, name = name, pos = pos, warn.conflicts = warn.conflicts) defer(detach(name, character.only = TRUE), envir = .local_envir) } withr/R/locale.R0000644000175000017500000000447614210163112013326 0ustar nileshnilesh#' Locale settings #' #' Temporarily change locale settings. #' #' Setting the `LC_ALL` category is currently not implemented. #' #' @template with #' @param new,.new `[named character]`\cr New locale settings #' @param ... Additional arguments with locale settings. #' @inheritParams with_collate #' @seealso [Sys.setlocale()] #' @examples #' #' ## Change locale for time: #' df <- data.frame( #' stringsAsFactors = FALSE, #' date = as.Date(c("2019-01-01", "2019-02-01")), #' value = c(1, 2) #' ) #' with_locale(new = c("LC_TIME" = "es_ES"), code = plot(df$date, df$value)) #' ## Compare with: #' # plot(df$date, df$value) #' #' ## Month names: #' with_locale(new = c("LC_TIME" = "en_GB"), format(ISOdate(2000, 1:12, 1), "%B")) #' with_locale(new = c("LC_TIME" = "es_ES"), format(ISOdate(2000, 1:12, 1), "%B")) #' #' ## Change locale for currencies: #' with_locale(new = c("LC_MONETARY" = "it_IT"), Sys.localeconv()) #' with_locale(new = c("LC_MONETARY" = "en_US"), Sys.localeconv()) #' #' ## Ordering: #' x <- c("bernard", "bérénice", "béatrice", "boris") #' with_locale(c(LC_COLLATE = "fr_FR"), sort(x)) #' with_locale(c(LC_COLLATE = "C"), sort(x)) #' #' @export with_locale <- function(new, code) { local_locale(new) code } #' @rdname with_locale #' @export local_locale <- function(.new = list(), ..., .local_envir = parent.frame()) { new <- list_combine(as.list(.new), list(...)) cats <- as_locale_cats(new) # # R supports setting LC_COLLATE to C via envvar. When that is the # case, it takes precedence over the currently set locale. We need # to set both the envvar and the locale for collate to fully take # effect. if ("LC_COLLATE" %in% names(cats)) { collate <- cats["LC_COLLATE"] local_envvar(collate, .local_envir = .local_envir) } old <- get_locale(cats) defer(set_locale(old), envir = .local_envir) set_locale(cats) invisible(old) } set_locale <- function(cats) { mapply(Sys.setlocale, names(cats), cats) } get_locale <- function(cats) { vapply(names(cats), Sys.getlocale, character(1)) } as_locale_cats <- function(cats) { cats <- as_character(cats) stopifnot(is.named(cats)) if ("LC_ALL" %in% names(cats)) { stop("Setting LC_ALL category not implemented.", call. = FALSE) } cats } withr/R/wrap.R0000644000175000017500000000112013043754137013037 0ustar nileshnileshwrap <- function(f, pre, post, envir = parent.frame()) { fmls <- formals(f) # called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls)) f_call <- as.call(c(substitute(f), called_fmls)) pre <- substitute(pre) post <- substitute(post) fun <- eval(bquote(function(args) { .(pre) .retval <- .(f_call) .(post) }, as.environment(list(f_call = f_call, pre = pre, post = post)))) # substitute does not work on arguments, so we need to fix them manually formals(fun) <- fmls environment(fun) <- envir fun } withr/R/dir.R0000644000175000017500000000072313735322666012662 0ustar nileshnilesh#' @include with_.R NULL # working directory ---------------------------------------------------------- #' Working directory #' #' Temporarily change the current working directory. #' #' @template with #' @param new `[character(1)]`\cr New working directory #' @inheritParams with_collate #' @seealso [setwd()] #' @export #' @examples #' getwd() #' #' with_dir(tempdir(), getwd()) with_dir <- with_(setwd) #' @rdname with_dir #' @export local_dir <- local_(setwd) withr/R/db.R0000644000175000017500000000307614165531434012466 0ustar nileshnilesh#' DBMS Connections which disconnect themselves. #' #' Connections to Database Management Systems which automatically disconnect. In #' particular connections which are created with `DBI::dbConnect()` and closed #' with `DBI::dbDisconnect()`. #' #' @template with #' @param con For `with_db_connection()` a named list with the connection(s) to #' create. For `local_db_connection()` the code to create a single connection, #' which is then returned. #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @importFrom stats setNames #' @examples #' db <- tempfile() #' with_db_connection( #' list(con = DBI::dbConnect(RSQLite::SQLite(), db)), { #' DBI::dbWriteTable(con, "mtcars", mtcars) #' }) #' #' head_db_table <- function(...) { #' con <- local_db_connection(DBI::dbConnect(RSQLite::SQLite(), db)) #' head(DBI::dbReadTable(con, "mtcars"), ...) #' } #' head_db_table() #' unlink(db) #' @export with_db_connection <- function(con, code) { requireNamespace("DBI", quietly = TRUE) stopifnot(all(is.named(con))) stopifnot(all(vlapply(con, methods::is, "DBIConnection"))) nme <- tempfile() (get("attach", baseenv()))(con, name = nme, warn.conflicts = FALSE) on.exit({ for (connection in con) DBI::dbDisconnect(connection) detach(nme, character.only = TRUE) }) force(code) } #' @rdname with_db_connection #' @export local_db_connection <- function(con, .local_envir = parent.frame()) { requireNamespace("DBI", quietly = TRUE) stopifnot(methods::is(con, "DBIConnection")) defer(DBI::dbDisconnect(con), envir = .local_envir) con } withr/R/utils.R0000644000175000017500000000321314210141042013211 0ustar nileshnileshmake_call <- function(...) { as.call(list(...)) } vlapply <- function(X, FUN, ..., FUN.VALUE = logical(1)) { vapply(X, FUN, ..., FUN.VALUE = FUN.VALUE) } names2 <- function(x) { nms <- names(x) if (is.null(nms)) { rep("", length(x)) } else { nms[is.na(nms)] <- "" nms } } #' Shim for tools::makevars_user() #' @keywords internal #' @export makevars_user <- function() { if (getRversion() >= "3.3") { return(tools::makevars_user()) } # Below is tools::makevars_user() from R 3.6.2 m <- character() if (.Platform$OS.type == "windows") { if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) { if (file.exists(f)) m <- f } else if ((Sys.getenv("R_ARCH") == "/x64") && file.exists(f <- path.expand("~/.R/Makevars.win64"))) m <- f else if (file.exists(f <- path.expand("~/.R/Makevars.win"))) m <- f else if (file.exists(f <- path.expand("~/.R/Makevars"))) m <- f } else { if (!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) { if (file.exists(f)) m <- f } else if (file.exists(f <- path.expand(paste0("~/.R/Makevars-", Sys.getenv("R_PLATFORM"))))) m <- f else if (file.exists(f <- path.expand("~/.R/Makevars"))) m <- f } m } as_character <- function(x) { nms <- names(x) res <- as.character(x) names(res) <- nms res } list_combine <- function(rhs, lhs) { for (nme in names(lhs)) { rhs[nme] <- lhs[nme] } rhs } # Helper to implement `options()`-like splicing auto_splice <- function(x) { if (length(x) == 1 && is.null(names(x)) && is.list(x[[1]])) { x[[1]] } else { x } } withr/R/language.R0000644000175000017500000000416514165531434013664 0ustar nileshnilesh#' Language #' #' Temporarily change the language used for translations. #' #' @param lang A BCP47 language code like "en" (English), "fr" (French), #' "fr_CA" (French Canadian). Formally, this is a lower case two letter #' [ISO 639 country code](https://en.wikipedia.org/wiki/List_of_ISO_639-1_codes), #' optionally followed by "_" or "-" and an upper case two letter #' [ISO 3166 region code](https://en.wikipedia.org/wiki/ISO_3166-2). #' @inheritParams with_collate #' @export #' @examples #' with_language("en", try(mean[[1]])) #' with_language("fr", try(mean[[1]])) #' with_language("es", try(mean[[1]])) with_language <- function(lang, code) { local_language(lang) code } #' @export #' @rdname with_language local_language <- function(lang, .local_envir = parent.frame()) { if (!is.character(lang) || length(lang) != 1) { stop("`lang` must be a string") } # https://stackoverflow.com/questions/6152321 lang <- gsub("-", "_", lang, fixed = TRUE) if (!has_nls()) { warning("Changing language has no effect when R installed without NLS") } # > Note: The variable LANGUAGE is ignored if the locale is set to ‘C’. # > In other words, you have to first enable localization, by setting LANG # > (or LC_ALL) to a value other than ‘C’, before you can use a language # > priority list through the LANGUAGE variable. # --- https://www.gnu.org/software/gettext/manual/html_node/The-LANGUAGE-variable.html if (identical(Sys.getenv("LANG"), "C")) { warning("Changing language has no effect when envvar LANG='C'") } local_envvar(LANGUAGE = lang, .local_envir = .local_envir) if (Sys.info()[["sysname"]] != "Windows") { # Reset cache to avoid gettext() retrieving cached value from a previous # language. I think this works because Sys.setlocale() calls setlocale() # which https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=931456 claims # resets the cache. So if there's some OS/setup that this technique fails # on, we might try bindtextdomain() instead or as well. local_locale(c(LC_MESSAGES = ""), .local_envir = .local_envir) } } has_nls <- function() capabilities("NLS")[[1]] withr/R/local_.R0000644000175000017500000000375514205720724013333 0ustar nileshnilesh#' @include aaa.R NULL #' @rdname with_ #' @export local_ <- function(set, reset = set, get = NULL, ..., envir = parent.frame(), new = TRUE, dots = FALSE) { if (!missing(...)) { stop("`...` must be empty.") } fmls <- formals(set) if (length(fmls) > 0L) { # Called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls)) # Special case for dots. If `set()` and/or `get()` take dots, it # is assumed they implement `options()`-like semantic: a list # passed as first argument is automatically spliced in the dots. names(called_fmls)[names(called_fmls) == "..."] <- "" if (new) { if (dots) { called_fmls[[1]] <- as.symbol(".new") fun_args <- c(alist(.new = list(), ... = ), fmls[-1L]) } else { called_fmls[[1]] <- as.symbol("new") fun_args <- c(alist(new = list()), fmls[-1L]) } } else { fun_args <- fmls } } else { # no formals called_fmls <- NULL fun_args <- alist() } set_call <- as.call(c(substitute(set), called_fmls)) reset <- if (missing(reset)) substitute(set) else substitute(reset) if (dots) { modify_call <- quote(.new <- list_combine(as.list(.new), list(...))) } else { modify_call <- NULL } if (is.null(get)) { fun <- eval(bquote(function(args) { .(modify_call) old <- .(set_call) defer(.(reset)(old), envir = .local_envir) invisible(old) })) } else { get_call <- as.call(c(substitute(get), called_fmls)) fun <- eval(bquote(function(args) { .(modify_call) old <- .(get_call) defer(.(reset)(old), envir = .local_envir) .(set_call) invisible(old) })) } # substitute does not work on arguments, so we need to fix them manually formals(fun) <- c(fun_args, alist(.local_envir = parent.frame())) environment(fun) <- envir fun } withr/R/torture.R0000644000175000017500000000056713156012715013602 0ustar nileshnilesh#' Torture Garbage Collector #' #' Temporarily turn gctorture2 on. #' #' @template with #' @param new `[integer]`\cr run GC every 'step' allocations. #' @inheritParams base::gctorture #' @inheritParams local_ with_gctorture2 <- with_(gctorture2) formals(with_gctorture2)[[3]] <- quote(new) local_gctorture2 <- local_(gctorture2) formals(local_gctorture2)[[2]] <- quote(new) withr/R/rng.R0000644000175000017500000000416714205722457012673 0ustar nileshnilesh#' RNG version #' #' Change the RNG version and restore it afterwards. #' #' `with_rng_version()` runs the code with the specified RNG version and #' resets it afterwards. #' #' `local_rng_version()` changes the RNG version for the caller #' execution environment. #' #' @template with #' @param version `[character(1)]` an R version number, e.g. #' `"3.5.0"`, to switch to the RNG this version of R uses. #' See [RNGversion()]. #' #' @seealso [RNGversion()], [RNGkind()], [with_seed()]. #' @export #' @examples #' RNGkind() #' with_rng_version("3.0.0", RNGkind()) #' with_rng_version("1.6.0", RNGkind()) #' #' with_rng_version("3.0.0", #' with_seed(42, sample(1:100, 3))) #' #' with_rng_version("1.6.0", #' with_seed(42, sample(1:100, 3))) #' #' RNGkind() #' with_rng_version <- function(version, code) { old <- RNGkind() on.exit(restore_rng_kind(old), add = TRUE) suppressWarnings(RNGversion(version)) code } #' @rdname with_rng_version #' @param .local_envir The environment to apply the change to. #' @export #' @examples #' fun1 <- function() { #' local_rng_version("3.0.0") #' with_seed(42, sample(1:100, 3)) #' } #' #' fun2 <- function() { #' local_rng_version("1.6.0") #' with_seed(42, sample(1:100, 3)) #' } #' #' RNGkind() #' fun1() #' fun2() #' RNGkind() local_rng_version <- function(version, .local_envir = parent.frame()) { old <- RNGkind() defer(restore_rng_kind(old), envir = .local_envir) suppressWarnings(RNGversion(version)) old } on_load( is_before_3.6 <- getRversion() < "3.6" ) restore_rng_kind <- function(kind) { # Silence static analysis linting about `RNGkind()` signature on old # R versions RNGkind <- get("RNGkind") RNGkind(kind[[1]], normal.kind = kind[[2]]) # No sample argument on old R versions if (is_before_3.6) { return() } # Within a `local_rng_version("3.5.0")`, we restore to `"Rounding"`, # which causes a warning. See https://github.com/r-lib/withr/issues/167 sample_kind <- kind[[3]] if (identical(sample_kind, "Rounding")) { suppressWarnings( RNGkind(sample.kind = sample_kind) ) } else { RNGkind(sample.kind = sample_kind) } NULL } withr/R/par.R0000644000175000017500000000234614205720724012657 0ustar nileshnilesh#' @include with_.R NULL # par ------------------------------------------------------------------------ get_par <- function(...) { new <- auto_splice(list(...)) out <- do.call(graphics::par, as.list(names(new))) # `par()` doesn't wrap in a list if input is length 1 if (length(new) == 1) { out <- list(out) names(out) <- names(new) } out } # `get_par()` must have exactly the same signature as `par()` to be # compatible with `with_()` and `local_()` formals(get_par) <- formals(graphics::par) #' Graphics parameters #' #' Temporarily change graphics parameters. #' #' @template with #' @param new,.new `[named list]`\cr New graphics parameters and their values #' @param no.readonly `[logical(1)]`\cr see [par()] documentation. #' @param ... Additional graphics parameters and their values. #' @inheritParams with_collate #' @seealso [par()] #' @export #' @examples #' old <- par("col" = "black") #' #' # This will be in red #' with_par(list(col = "red", pch = 19), #' plot(mtcars$hp, mtcars$wt) #' ) #' #' # This will still be in black #' plot(mtcars$hp, mtcars$wt) #' #' par(old) with_par <- with_(graphics::par, get = get_par) #' @rdname with_par #' @export local_par <- local_(graphics::par, get = get_par, dots = TRUE) withr/R/collate.R0000644000175000017500000000127714205720724013522 0ustar nileshnilesh#' Collation Order #' #' Temporarily change collation order by changing the value of the #' `LC_COLLATE` locale. #' #' @template with #' @param new `[character(1)]`\cr New collation order #' @param .local_envir `[environment]`\cr The environment to use for scoping. #' @examples #' #' # Modify collation order: #' x <- c("bernard", "bérénice", "béatrice", "boris") #' with_collate("fr_FR", sort(x)) #' with_collate("C", sort(x)) #' #' @export with_collate <- function(new, code) { with_locale(c(LC_COLLATE = new), code) } #' @rdname with_collate #' @export local_collate <- function(new = list(), .local_envir = parent.frame()) { local_locale(c(LC_COLLATE = new), .local_envir = .local_envir) } withr/R/timezone.R0000644000175000017500000000327114165531434013730 0ustar nileshnilesh#' Time zone #' #' Change the time zone, and restore it afterwards. #' #' `with_time_zone()` runs the code with the specified time zone and #' resets it afterwards. #' #' `local_time_zone()` changes the time zone for the caller #' execution environment. #' #' @template with #' @param tz `[character(1)]` a valid time zone specification, note that #' time zone names might be platform dependent. #' #' @seealso [Sys.timezone()]. #' @export #' @examples #' Sys.time() #' with_timezone("Europe/Paris", print(Sys.time())) #' with_timezone("US/Pacific", print(Sys.time())) #' with_timezone <- function(tz, code) { reset_timezone() with_envvar(c(TZ = tz), code) } #' @rdname with_timezone #' @param .local_envir The environment to apply the change to. #' @export #' @examples #' fun1 <- function() { #' local_timezone("CET") #' print(Sys.time()) #' } #' #' fun2 <- function() { #' local_timezone("US/Pacific") #' print(Sys.time()) #' } #' Sys.time() #' fun1() #' fun2() #' Sys.time() local_timezone <- function(tz, .local_envir = parent.frame()) { reset_timezone(envir = .local_envir) local_envvar(c(TZ = tz), .local_envir = .local_envir) } reset_timezone <- function(envir = parent.frame()) { base_env <- baseenv() old <- get0(".sys.timezone", base_env, mode = "character", inherits = FALSE, ifnotfound = NA_character_) is_locked <- bindingIsLocked(".sys.timezone", env = base_env) if (is_locked) { base_env$unlockBinding(".sys.timezone", env = base_env) } defer({ assign(".sys.timezone", old, envir = base_env) if (is_locked) { lockBinding(".sys.timezone", env = base_env) } }, envir = envir) assign(".sys.timezone", NA_character_, envir = base_env) } withr/R/compat-defer.R0000644000175000017500000001245514210204346014436 0ustar nileshnilesh# nocov start --- compat-defer --- # # This drop-in file implements withr::defer(). Please find the most # recent version in withr's repository. # # 2022-03-03 # * Support for `source()` and `knitr::knit()` # * Handlers are now stored in environments instead of lists to avoid # infinite recursion issues. # * The handler list is now soft-namespaced. defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { } local({ defer <<- defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { priority <- match.arg(priority) invisible( add_handler( envir, handler = new_handler(substitute(expr), parent.frame()), front = priority == "first" ) ) } new_handler <- function(expr, envir) { hnd <- new.env(FALSE, size = 2) hnd[["expr"]] <- expr hnd[["envir"]] <- envir hnd } add_handler <- function(envir, handler, front, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { envir <- exit_frame(envir, frames, calls) if (front) { handlers <- c(list(handler), get_handlers(envir)) } else { handlers <- c(get_handlers(envir), list(handler)) } set_handlers(envir, handlers, frames = frames, calls = calls) handler } set_handlers <- function(envir, handlers, frames, calls) { if (is.null(get_handlers(envir))) { # Ensure that list of handlers called when environment "ends" setup_handlers(envir) } attr(envir, "withr_handlers") <- handlers } # Evaluate `frames` lazily setup_handlers <- function(envir, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { if (is_top_level_global_env(envir, frames)) { # For session scopes we use reg.finalizer() if (is_interactive()) { message( sprintf("Setting global deferred event(s).\n"), "i These will be run:\n", " * Automatically, when the R session ends.\n", " * On demand, if you call `withr::deferred_run()`.\n", "i Use `withr::deferred_clear()` to clear them without executing." ) } reg.finalizer(envir, function(env) deferred_run(env), onexit = TRUE) } else { # for everything else we use on.exit() call <- make_call(execute_handlers, envir) # We have to use do.call here instead of eval because of the way on.exit # determines its evaluation context # (https://stat.ethz.ch/pipermail/r-devel/2013-November/067867.html) do.call(base::on.exit, list(call, TRUE), envir = envir) } } exit_frame <- function(envir, frames = as.list(sys.frames()), calls = as.list(sys.calls())) { frame_loc <- frame_loc(envir, frames) if (!frame_loc) { return(envir) } if (in_knitr(envir)) { out <- knitr_frame(envir, frames, calls, frame_loc) if (!is.null(out)) { return(out) } } out <- source_frame(envir, frames, calls, frame_loc) if (!is.null(out)) { return(out) } envir } knitr_frame <- function(envir, frames, calls, frame_loc) { knitr_ns <- asNamespace("knitr") # This doesn't handle correctly the recursive case (knitr called # within a chunk). Handling this would be a little fiddly for an # uncommon edge case. for (i in seq(1, frame_loc)) { if (identical(topenv(frames[[i]]), knitr_ns)) { return(frames[[i]]) } } NULL } source_frame <- function(envir, frames, calls, frame_loc) { i <- frame_loc if (i < 4) { return(NULL) } is_call <- function(x, fn) { is.call(x) && identical(x[[1]], fn) } calls <- as.list(calls) if (!is_call(calls[[i - 3]], quote(source))) { return(NULL) } if (!is_call(calls[[i - 2]], quote(withVisible))) { return(NULL) } if (!is_call(calls[[i - 1]], quote(eval))) { return(NULL) } if (!is_call(calls[[i - 0]], quote(eval))) { return(NULL) } frames[[i - 3]] } frame_loc <- function(envir, frames) { n <- length(frames) if (!n) { return(0) } for (i in seq_along(frames)) { if (identical(frames[[n - i + 1]], envir)) { return(n - i + 1) } } 0 } in_knitr <- function(envir) { knitr_in_progress() && identical(knitr::knit_global(), envir) } is_top_level_global_env <- function(envir, frames) { if (!identical(envir, globalenv())) { return(FALSE) } # Check if another global environment is on the stack !any(vapply(frames, identical, NA, globalenv())) } get_handlers <- function(envir) { attr(envir, "withr_handlers") } execute_handlers <- function(envir) { handlers <- get_handlers(envir) errors <- list() for (handler in handlers) { tryCatch(eval(handler$expr, handler$envir), error = function(e) { errors[[length(errors) + 1]] <<- e } ) } attr(envir, "withr_handlers") <- NULL for (error in errors) { stop(error) } } make_call <- function(...) { as.call(list(...)) } # base implementation of rlang::is_interactive() is_interactive <- function() { opt <- getOption("rlang_interactive") if (!is.null(opt)) { return(opt) } if (knitr_in_progress()) { return(FALSE) } if (identical(Sys.getenv("TESTTHAT"), "true")) { return(FALSE) } interactive() } knitr_in_progress <- function() { isTRUE(getOption("knitr.in.progress")) } }) # defer() namespace # nocov end withr/LICENSE0000644000175000017500000000005314165531434012552 0ustar nileshnileshYEAR: 2020 COPYRIGHT HOLDER: withr authors withr/inst/0000755000175000017500000000000014210227534012516 5ustar nileshnileshwithr/inst/doc/0000755000175000017500000000000014210227534013263 5ustar nileshnileshwithr/inst/doc/changing-and-restoring-state.Rmd0000644000175000017500000002570013735322666021416 0ustar nileshnilesh--- title: "Changing and restoring state" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Changing and restoring state} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ```{r setup} library(withr) ``` This article explains the type of problem withr solves and shows typical patterns of usage. It also compares withr's functionality to the `on.exit()` function from base R. ## It's dangerous to change state Whenever possible, it is desirable to write so-called **pure** functions. The property we focus on here is that the function should not change the surrounding R landscape, i.e. it should not change things like the search path, global options, or the working directory. If the behaviour of *other* functions differs before and after running your function, you've modified the landscape. Changing the landscape is bad because it makes code much harder to understand. Here's a `sloppy()` function that prints a number with a specific number of significant digits, by adjusting R's global "digits" option. ```{r include = FALSE} op <- options() ``` ```{r} sloppy <- function(x, sig_digits) { options(digits = sig_digits) print(x) } pi sloppy(pi, 2) pi ``` ```{r include = FALSE} options(op) ``` Notice how `pi` prints differently before and after the call to `sloppy()`? Calling `sloppy()` has a side effect: it changes the "digits" option globally, not just within its own scope of operations. This is what we want to avoid. *Don't worry, we're restoring global state (specifically, the "digits" option) behind the scenes here.* Sometimes you cannot avoid modifying the state of the world, in which case you just have to make sure that you put things back the way you found them. This is what the withr package is for. ## The base solution: `on.exit()` The first function to know about is base R's `on.exit()`. Inside your function body, every time you do something that should be undone **on exit**, you immediately register the cleanup code with `on.exit(expr, add = TRUE)`[^on-exit-add]. [^on-exit-add]: It's too bad `add = TRUE` isn't the default, because you almost always want this. Without it, each call to `on.exit()` clobbers the effect of previous calls. `neat()` is an improvement over `sloppy()`, because it uses `on.exit()` to ensure that the "digits" option is restored to its original value. ```{r} neat <- function(x, sig_digits) { op <- options(digits = sig_digits) on.exit(options(op), add = TRUE) print(x) } pi neat(pi, 2) pi ``` `on.exit()` also works when you exit the function abnormally, i.e. due to error. This is why official tools, like `on.exit()`, are a better choice than any do-it-yourself solution to this problem. `on.exit()` is a very useful function, but it's not very flexible. The withr package provides an extensible `on.exit()`-inspired toolkit. ## `defer()` is the foundation of withr `defer()` is the core function of withr and is very much like `on.exit()`, i.e. it schedules the execution of arbitrary code when the current function exits: ```{r} neater <- function(x, sig_digits) { op <- options(digits = sig_digits) defer(options(op)) print(x) } pi neater(pi, 2) pi ``` `withr::defer()` is basically a drop-in substitute for `on.exit()`, but with three key differences we explore below: 1. Different default behaviour around the effect of a series of two or more calls 1. Control over the environment the deferred events are associated with 1. Ability to work with the global environment Here we focus on using withr inside your functions. See the blog post [Self-cleaning test fixtures](https://www.tidyverse.org/blog/2020/04/self-cleaning-test-fixtures/) or the testthat vignette [Test fixtures](https://testthat.r-lib.org/articles/test-fixtures.html) for how to use withr inside tests. ## Last-in, first-out If you make more than one call to `defer()`, by default, it **adds** expressions to the **top** of the stack of deferred actions. ```{r} defer_stack <- function() { cat("put on socks\n") defer(cat("take off socks\n")) cat("put on shoes\n") defer(cat("take off shoes\n")) } defer_stack() ``` In contrast, by default, a subsequent call to `on.exit()` **overwrites** the deferred actions registered in the previous call. ```{r} on_exit_last_one_wins <- function() { cat("put on socks\n") on.exit(cat("take off socks\n")) cat("put on shoes\n") on.exit(cat("take off shoes\n")) } on_exit_last_one_wins() ``` Oops, we still have our socks on! The last-in, first-out, stack-like behaviour of `defer()` tends to be what you want in most applications. To get such behaviour with `on.exit()`, remember to call it with `add = TRUE, after = FALSE`[^on-exit-after]. [^on-exit-after]: Note: the `after` argument of `on.exit()` first appeared in R 3.5.0. ```{r, eval = getRversion() >= "3.5.0"} on_exit_stack <- function() { cat("put on socks\n") on.exit(cat("take off socks\n"), add = TRUE, after = FALSE) cat("put on shoes\n") on.exit(cat("take off shoes\n"), add = TRUE, after = FALSE) } on_exit_stack() ``` Conversely, if you want `defer()` to have first-in, first-out behaviour, specify `priority = "last"`. ```{r} defer_queue <- function() { cat("Adam gets in line for ice cream\n") defer(cat("Adam gets ice cream\n"), priority = "last") cat("Beth gets in line for ice cream\n") defer(cat("Beth gets ice cream\n"), priority = "last") } defer_queue() ``` ## "Local" functions (and "with" functions) Both `on.exit()` and `withr::defer()` schedule actions to be executed when a certain environment goes out of scope, most typically the execution environment of a function. But the `envir` argument of `withr::defer()` lets you specify a *different* environment, which makes it possible to create customised `on.exit()` extensions. Let's look at the `neater()` function again. ```{r} neater <- function(x, sig_digits) { op <- options(digits = sig_digits) # record orig. "digits" & change "digits" defer(options(op)) # schedule restoration of "digits" print(x) } ``` The first two lines are typical `on.exit()` maneuvers where, in some order, you record an original state, arrange for its eventual restoration, and change it. In real life, this can be much more involved and you might want to wrap this logic up into a helper function. You can't wrap `on.exit()` in this way, because there's no way to reach back up into the correct parent frame and schedule cleanup there. But with `defer()`, we can! Here is such a custom helper, called `local_digits()`. ```{r} local_digits <- function(sig_digits, envir = parent.frame()) { op <- options(digits = sig_digits) defer(options(op), envir = envir) } ``` We can use `local_digits()` to keep any manipulation of `digits` local to a function. ```{r} neato <- function(x, digits) { local_digits(digits) print(x) } pi neato(pi, 2) neato(pi, 4) ``` You can even call `local_digits()` multiple times inside a function. Each call to `local_digits()` is in effect until the next or until the function exits, which ever comes first. ```{r} neatful <- function(x) { local_digits(1) print(x) local_digits(3) print(x) local_digits(5) print(x) } neatful(pi) ``` Certain state changes, such as modifying global options, come up so often that withr offers pre-made helpers. These helpers come in two forms: `local_*()` functions, like the one we just made, and `with_*()` functions, which we explain below. Here are the state change helpers in withr that you are most likely to find useful: | Do / undo this | withr functions | |-----------------------------|-------------------------------------| | Set an R option | `local_options()`,`with_options()` | | Set an environment variable | `local_envvar()`, `with_envvar()` | | Change working directory | `local_dir()`, `with_dir()` | | Set a graphics parameter | `local_par()`, `with_par()` | We didn't really need to write our own `local_digits()` helper, because the built-in `withr::local_options()` also gets the job done: ```{r} neatest <- function(x, sig_digits) { local_options(list(digits = sig_digits)) print(x) } pi neatest(pi, 2) neatest(pi, 4) ``` The `local_*()` functions target a slightly different use case from the `with_*()` functions, which are inspired by base R's `with()` function: * `with_*()` functions are best for executing a small snippet of code with a modified state ```{r eval = FALSE} neat_with <- function(x, sig_digits) { # imagine lots of code here withr::with_options( list(digits = sig_digits), print(x) ) # ... and a lot more code here } ``` * `local_*()` functions are best for modifying state "from now until the function exits" ```{r eval = FALSE} neat_local <- function(x, sig_digits) { withr::local_options(list(digits = sig_digits)) print(x) # imagine lots of code here } ``` It's best to minimize the footprint of your state modifications. Therefore, use `with_*()` functions where you can. But when this forces you to put lots of (indented) code inside `with_*()`, e.g. most of your function's body, then it's better to use `local_*()`. ## Deferring events on the global environment Here is one last difference between `withr::defer()` and `on.exit()`: the ability to defer events on the global environment[^withr-2-2-0]. [^withr-2-2-0]: This feature first appeared in withr v2.2.0. At first, it sounds pretty weird to propose scheduling deferred actions on the global environment. It's not ephemeral, the way function execution environments are. It goes out of scope very rarely, i.e. when you exit R. Why would you want this? The answer is: for development purposes. If you are developing functions or tests that use withr, it's very useful to be able to execute that code interactively, without error, and with the ability to trigger the deferred events. It's hard to develop with functions that work one way inside a function, but another way in the global environment (or, worse, throw an error). Here's how `defer()` (and all functions based on it) works in an interactive session. ```{r eval = FALSE} library(withr) defer(print("hi")) #> Setting deferred event(s) on global environment. #> * Execute (and clear) with `withr::deferred_run()`. #> * Clear (without executing) with `withr::deferred_clear()`. pi #> [1] 3.141593 # this adds another deferred event, but does not re-message local_digits(3) pi #> [1] 3.14 deferred_run() #> [1] "hi" pi #> [1] 3.141593 ``` When you defer events on the global environment, you get a message that alerts you to the situation. If you add subsequent events, the message is *not* repeated. Since the global environment isn't perishable, like a test environment is, you have to call `deferred_run()` explicitly to execute the deferred events. You can also clear them, without running, with `deferred_clear()`. withr/inst/doc/changing-and-restoring-state.R0000644000175000017500000001034514210227534021057 0ustar nileshnilesh## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(withr) ## ----include = FALSE---------------------------------------------------------- op <- options() ## ----------------------------------------------------------------------------- sloppy <- function(x, sig_digits) { options(digits = sig_digits) print(x) } pi sloppy(pi, 2) pi ## ----include = FALSE---------------------------------------------------------- options(op) ## ----------------------------------------------------------------------------- neat <- function(x, sig_digits) { op <- options(digits = sig_digits) on.exit(options(op), add = TRUE) print(x) } pi neat(pi, 2) pi ## ----------------------------------------------------------------------------- neater <- function(x, sig_digits) { op <- options(digits = sig_digits) defer(options(op)) print(x) } pi neater(pi, 2) pi ## ----------------------------------------------------------------------------- defer_stack <- function() { cat("put on socks\n") defer(cat("take off socks\n")) cat("put on shoes\n") defer(cat("take off shoes\n")) } defer_stack() ## ----------------------------------------------------------------------------- on_exit_last_one_wins <- function() { cat("put on socks\n") on.exit(cat("take off socks\n")) cat("put on shoes\n") on.exit(cat("take off shoes\n")) } on_exit_last_one_wins() ## ---- eval = getRversion() >= "3.5.0"----------------------------------------- on_exit_stack <- function() { cat("put on socks\n") on.exit(cat("take off socks\n"), add = TRUE, after = FALSE) cat("put on shoes\n") on.exit(cat("take off shoes\n"), add = TRUE, after = FALSE) } on_exit_stack() ## ----------------------------------------------------------------------------- defer_queue <- function() { cat("Adam gets in line for ice cream\n") defer(cat("Adam gets ice cream\n"), priority = "last") cat("Beth gets in line for ice cream\n") defer(cat("Beth gets ice cream\n"), priority = "last") } defer_queue() ## ----------------------------------------------------------------------------- neater <- function(x, sig_digits) { op <- options(digits = sig_digits) # record orig. "digits" & change "digits" defer(options(op)) # schedule restoration of "digits" print(x) } ## ----------------------------------------------------------------------------- local_digits <- function(sig_digits, envir = parent.frame()) { op <- options(digits = sig_digits) defer(options(op), envir = envir) } ## ----------------------------------------------------------------------------- neato <- function(x, digits) { local_digits(digits) print(x) } pi neato(pi, 2) neato(pi, 4) ## ----------------------------------------------------------------------------- neatful <- function(x) { local_digits(1) print(x) local_digits(3) print(x) local_digits(5) print(x) } neatful(pi) ## ----------------------------------------------------------------------------- neatest <- function(x, sig_digits) { local_options(list(digits = sig_digits)) print(x) } pi neatest(pi, 2) neatest(pi, 4) ## ----eval = FALSE------------------------------------------------------------- # neat_with <- function(x, sig_digits) { # # imagine lots of code here # withr::with_options( # list(digits = sig_digits), # print(x) # ) # # ... and a lot more code here # } ## ----eval = FALSE------------------------------------------------------------- # neat_local <- function(x, sig_digits) { # withr::local_options(list(digits = sig_digits)) # print(x) # # imagine lots of code here # } ## ----eval = FALSE------------------------------------------------------------- # library(withr) # # defer(print("hi")) # #> Setting deferred event(s) on global environment. # #> * Execute (and clear) with `withr::deferred_run()`. # #> * Clear (without executing) with `withr::deferred_clear()`. # # pi # #> [1] 3.141593 # # # this adds another deferred event, but does not re-message # local_digits(3) # # pi # #> [1] 3.14 # # deferred_run() # #> [1] "hi" # # pi # #> [1] 3.141593 withr/inst/doc/changing-and-restoring-state.html0000644000175000017500000013126714210227534021631 0ustar nileshnilesh Changing and restoring state

Changing and restoring state

library(withr)

This article explains the type of problem withr solves and shows typical patterns of usage. It also compares withr’s functionality to the on.exit() function from base R.

It’s dangerous to change state

Whenever possible, it is desirable to write so-called pure functions. The property we focus on here is that the function should not change the surrounding R landscape, i.e. it should not change things like the search path, global options, or the working directory. If the behaviour of other functions differs before and after running your function, you’ve modified the landscape. Changing the landscape is bad because it makes code much harder to understand.

Here’s a sloppy() function that prints a number with a specific number of significant digits, by adjusting R’s global “digits” option.

sloppy <- function(x, sig_digits) {
  options(digits = sig_digits)
  print(x)
}

pi
#> [1] 3.141593

sloppy(pi, 2)
#> [1] 3.1

pi
#> [1] 3.1

Notice how pi prints differently before and after the call to sloppy()? Calling sloppy() has a side effect: it changes the “digits” option globally, not just within its own scope of operations. This is what we want to avoid.

Don’t worry, we’re restoring global state (specifically, the “digits” option) behind the scenes here.

Sometimes you cannot avoid modifying the state of the world, in which case you just have to make sure that you put things back the way you found them. This is what the withr package is for.

The base solution: on.exit()

The first function to know about is base R’s on.exit(). Inside your function body, every time you do something that should be undone on exit, you immediately register the cleanup code with on.exit(expr, add = TRUE)1.

neat() is an improvement over sloppy(), because it uses on.exit() to ensure that the “digits” option is restored to its original value.

neat <- function(x, sig_digits) {
  op <- options(digits = sig_digits)
  on.exit(options(op), add = TRUE)
  print(x)
}

pi
#> [1] 3.141593

neat(pi, 2)
#> [1] 3.1

pi
#> [1] 3.141593

on.exit() also works when you exit the function abnormally, i.e. due to error. This is why official tools, like on.exit(), are a better choice than any do-it-yourself solution to this problem.

on.exit() is a very useful function, but it’s not very flexible. The withr package provides an extensible on.exit()-inspired toolkit.

defer() is the foundation of withr

defer() is the core function of withr and is very much like on.exit(), i.e. it schedules the execution of arbitrary code when the current function exits:

neater <- function(x, sig_digits) {
  op <- options(digits = sig_digits)
  defer(options(op))
  print(x)
}

pi
#> [1] 3.141593

neater(pi, 2)
#> [1] 3.1

pi
#> [1] 3.141593

withr::defer() is basically a drop-in substitute for on.exit(), but with three key differences we explore below:

  1. Different default behaviour around the effect of a series of two or more calls
  2. Control over the environment the deferred events are associated with
  3. Ability to work with the global environment

Here we focus on using withr inside your functions. See the blog post Self-cleaning test fixtures or the testthat vignette Test fixtures for how to use withr inside tests.

Last-in, first-out

If you make more than one call to defer(), by default, it adds expressions to the top of the stack of deferred actions.

defer_stack <- function() {
  cat("put on socks\n")
  defer(cat("take off socks\n"))
  
  cat("put on shoes\n")
  defer(cat("take off shoes\n"))
}
defer_stack()
#> put on socks
#> put on shoes
#> take off shoes
#> take off socks

In contrast, by default, a subsequent call to on.exit() overwrites the deferred actions registered in the previous call.

on_exit_last_one_wins <- function() {
  cat("put on socks\n")
  on.exit(cat("take off socks\n"))
  
  cat("put on shoes\n")
  on.exit(cat("take off shoes\n"))
}
on_exit_last_one_wins()
#> put on socks
#> put on shoes
#> take off shoes

Oops, we still have our socks on! The last-in, first-out, stack-like behaviour of defer() tends to be what you want in most applications.

To get such behaviour with on.exit(), remember to call it with add = TRUE, after = FALSE2.

on_exit_stack <- function() {
  cat("put on socks\n")
  on.exit(cat("take off socks\n"), add = TRUE, after = FALSE)
  
  cat("put on shoes\n")
  on.exit(cat("take off shoes\n"), add = TRUE, after = FALSE)
}
on_exit_stack()
#> put on socks
#> put on shoes
#> take off shoes
#> take off socks

Conversely, if you want defer() to have first-in, first-out behaviour, specify priority = "last".

defer_queue <- function() {
  cat("Adam gets in line for ice cream\n")
  defer(cat("Adam gets ice cream\n"), priority = "last")

  cat("Beth gets in line for ice cream\n")
  defer(cat("Beth gets ice cream\n"), priority = "last")
}
defer_queue()
#> Adam gets in line for ice cream
#> Beth gets in line for ice cream
#> Adam gets ice cream
#> Beth gets ice cream

“Local” functions (and “with” functions)

Both on.exit() and withr::defer() schedule actions to be executed when a certain environment goes out of scope, most typically the execution environment of a function. But the envir argument of withr::defer() lets you specify a different environment, which makes it possible to create customised on.exit() extensions.

Let’s look at the neater() function again.

neater <- function(x, sig_digits) {
  op <- options(digits = sig_digits) # record orig. "digits" & change "digits"
  defer(options(op))                 # schedule restoration of "digits"
  
  print(x)
}

The first two lines are typical on.exit() maneuvers where, in some order, you record an original state, arrange for its eventual restoration, and change it. In real life, this can be much more involved and you might want to wrap this logic up into a helper function. You can’t wrap on.exit() in this way, because there’s no way to reach back up into the correct parent frame and schedule cleanup there. But with defer(), we can! Here is such a custom helper, called local_digits().

local_digits <- function(sig_digits, envir = parent.frame()) {
  op <- options(digits = sig_digits)
  defer(options(op), envir = envir)
}

We can use local_digits() to keep any manipulation of digits local to a function.

neato <- function(x, digits) {
  local_digits(digits)
  print(x)
}

pi
#> [1] 3.141593

neato(pi, 2)
#> [1] 3.1

neato(pi, 4)
#> [1] 3.142

You can even call local_digits() multiple times inside a function. Each call to local_digits() is in effect until the next or until the function exits, which ever comes first.

neatful <- function(x) {
  local_digits(1)
  print(x)
  local_digits(3)
  print(x)
  local_digits(5)
  print(x)
}

neatful(pi)
#> [1] 3
#> [1] 3.14
#> [1] 3.1416

Certain state changes, such as modifying global options, come up so often that withr offers pre-made helpers. These helpers come in two forms: local_*() functions, like the one we just made, and with_*() functions, which we explain below. Here are the state change helpers in withr that you are most likely to find useful:

Do / undo this withr functions
Set an R option local_options(),with_options()
Set an environment variable local_envvar(), with_envvar()
Change working directory local_dir(), with_dir()
Set a graphics parameter local_par(), with_par()

We didn’t really need to write our own local_digits() helper, because the built-in withr::local_options() also gets the job done:

neatest <- function(x, sig_digits) {
  local_options(list(digits = sig_digits))
  print(x)
}

pi
#> [1] 3.141593

neatest(pi, 2)
#> [1] 3.1

neatest(pi, 4)
#> [1] 3.142

The local_*() functions target a slightly different use case from the with_*() functions, which are inspired by base R’s with() function:

  • with_*() functions are best for executing a small snippet of code with a modified state

    neat_with <- function(x, sig_digits) {
  # imagine lots of code here
  withr::with_options(
    list(digits = sig_digits),
    print(x)
  )
  # ... and a lot more code here
}

  • local_*() functions are best for modifying state “from now until the function exits”

    neat_local <- function(x, sig_digits) {
  withr::local_options(list(digits = sig_digits))
  print(x)
  # imagine lots of code here
}

It’s best to minimize the footprint of your state modifications. Therefore, use with_*() functions where you can. But when this forces you to put lots of (indented) code inside with_*(), e.g. most of your function’s body, then it’s better to use local_*().

Deferring events on the global environment

Here is one last difference between withr::defer() and on.exit(): the ability to defer events on the global environment3.

At first, it sounds pretty weird to propose scheduling deferred actions on the global environment. It’s not ephemeral, the way function execution environments are. It goes out of scope very rarely, i.e. when you exit R. Why would you want this?

The answer is: for development purposes.

If you are developing functions or tests that use withr, it’s very useful to be able to execute that code interactively, without error, and with the ability to trigger the deferred events. It’s hard to develop with functions that work one way inside a function, but another way in the global environment (or, worse, throw an error).

Here’s how defer() (and all functions based on it) works in an interactive session.

library(withr)

defer(print("hi"))
#> Setting deferred event(s) on global environment.
#>   * Execute (and clear) with `withr::deferred_run()`.
#>   * Clear (without executing) with `withr::deferred_clear()`.

pi
#> [1] 3.141593

# this adds another deferred event, but does not re-message
local_digits(3)

pi
#> [1] 3.14

deferred_run()
#> [1] "hi"

pi
#> [1] 3.141593

When you defer events on the global environment, you get a message that alerts you to the situation. If you add subsequent events, the message is not repeated. Since the global environment isn’t perishable, like a test environment is, you have to call deferred_run() explicitly to execute the deferred events. You can also clear them, without running, with deferred_clear().

  1. It’s too bad add = TRUE isn’t the default, because you almost always want this. Without it, each call to on.exit() clobbers the effect of previous calls.↩︎

  2. Note: the after argument of on.exit() first appeared in R 3.5.0.↩︎

  3. This feature first appeared in withr v2.2.0.↩︎

withr/NAMESPACE0000644000175000017500000000331714210225701012756 0ustar nileshnilesh# Generated by roxygen2: do not edit by hand export(defer) export(defer_parent) export(deferred_clear) export(deferred_run) export(local_) export(local_bmp) export(local_cairo_pdf) export(local_cairo_ps) export(local_collate) export(local_connection) export(local_db_connection) export(local_dir) export(local_environment) export(local_envvar) export(local_file) export(local_jpeg) export(local_language) export(local_libpaths) export(local_locale) export(local_makevars) export(local_message_sink) export(local_namespace) export(local_options) export(local_output_sink) export(local_package) export(local_par) export(local_path) export(local_pdf) export(local_png) export(local_postscript) export(local_preserve_seed) export(local_rng_version) export(local_seed) export(local_svg) export(local_temp_libpaths) export(local_tempdir) export(local_tempfile) export(local_tiff) export(local_timezone) export(local_xfig) export(makevars_user) export(set_makevars) export(with_) export(with_bmp) export(with_cairo_pdf) export(with_cairo_ps) export(with_collate) export(with_connection) export(with_db_connection) export(with_dir) export(with_environment) export(with_envvar) export(with_file) export(with_jpeg) export(with_language) export(with_libpaths) export(with_locale) export(with_makevars) export(with_message_sink) export(with_namespace) export(with_options) export(with_output_sink) export(with_package) export(with_par) export(with_path) export(with_pdf) export(with_png) export(with_postscript) export(with_preserve_seed) export(with_rng_version) export(with_seed) export(with_svg) export(with_temp_libpaths) export(with_tempdir) export(with_tempfile) export(with_tiff) export(with_timezone) export(with_xfig) importFrom(stats,setNames)