withr/0000755000176200001440000000000014151431422011404 5ustar liggesuserswithr/NAMESPACE0000644000176200001440000000331714151210400012616 0ustar liggesusers# 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) withr/LICENSE0000644000176200001440000000005313775602572012430 0ustar liggesusersYEAR: 2020 COPYRIGHT HOLDER: withr authors withr/README.md0000644000176200001440000001171714151230316012671 0ustar liggesusers # withr - run code ‘with’ modified state [![R-CMD-check](https://github.com/r-lib/withr/workflows/R-CMD-check/badge.svg)](https://github.com/r-lib/withr/actions) [![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) ## 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/0000755000176200001440000000000014147463350012171 5ustar liggesuserswithr/man/with_makevars.Rd0000644000176200001440000000323714036304442015322 0ustar liggesusers% 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_locale.Rd0000644000176200001440000000315014036304442014742 0ustar liggesusers% 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/withr.Rd0000644000176200001440000000623314151210274013607 0ustar liggesusers% 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_db_connection.Rd0000644000176200001440000000247514036304442016320 0ustar liggesusers% 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_par.Rd0000644000176200001440000000214514036304442014270 0ustar liggesusers% 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/defer.Rd0000644000176200001440000000513614036304442013543 0ustar liggesusers% 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_language.Rd0000644000176200001440000000172614147463350015304 0ustar liggesusers% 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_dir.Rd0000644000176200001440000000136314036304442014265 0ustar liggesusers% 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/with_envvar.Rd0000644000176200001440000000255514036304442015014 0ustar liggesusers% 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/set_makevars.Rd0000644000176200001440000000172714036304442015144 0ustar liggesusers% 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_options.Rd0000644000176200001440000000312214036304442015175 0ustar liggesusers% 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_package.Rd0000644000176200001440000000660614036304442015107 0ustar liggesusers% 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/devices.Rd0000644000176200001440000002050314036304442014073 0ustar liggesusers% 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_.Rd0000644000176200001440000000447014036304442013570 0ustar liggesusers% 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, envir = parent.frame(), new = TRUE, dots = FALSE) with_(set, reset = set, 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{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_libpaths.Rd0000644000176200001440000000211314036304442015307 0ustar liggesusers% 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_collate.Rd0000644000176200001440000000156614036304442015137 0ustar liggesusers% 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_connection.Rd0000644000176200001440000000203014036304442015636 0ustar liggesusers% 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/makevars_user.Rd0000644000176200001440000000040614036304442015320 0ustar liggesusers% 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/with_tempfile.Rd0000644000176200001440000000362514036304442015317 0ustar liggesusers% 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, 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{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/with_sink.Rd0000644000176200001440000000276014036304442014455 0ustar liggesusers% 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/figures/0000755000176200001440000000000014151210371013621 5ustar liggesuserswithr/man/figures/README-unnamed-chunk-3-1.png0000644000176200001440000005673014151210371020330 0ustar liggesusersPNG  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ȑ#>;S<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/man/figures/logo.png0000644000176200001440000003512413302011111015260 0ustar liggesusersPNG  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/with_gctorture2.Rd0000644000176200001440000000136414036304442015610 0ustar liggesusers% 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_temp_libpaths.Rd0000644000176200001440000000164714036304442016347 0ustar liggesusers% 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_file.Rd0000644000176200001440000000165714036304442014434 0ustar liggesusers% 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_timezone.Rd0000644000176200001440000000235514036304442015343 0ustar liggesusers% 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_seed.Rd0000644000176200001440000000330014036304442014420 0ustar liggesusers% 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 = "default", .rng_normal_kind = "default", .rng_sample_kind = "default" ) local_seed( seed, .local_envir = parent.frame(), .rng_kind = "default", .rng_normal_kind = "default", .rng_sample_kind = "default" ) 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}{\verb{[character(1)]}\cr Kind of (uniform) RNG to use.} \item{.rng_normal_kind}{\verb{[character(1)]}\cr Kind of normal RNG to use.} \item{.rng_sample_kind}{\verb{[character(1)]}\cr Kind of RNG to use for sampling.} \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/with_rng_version.Rd0000644000176200001440000000302114036304442016033 0ustar liggesusers% 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_path.Rd0000644000176200001440000000214314036304442014440 0ustar liggesusers% 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 = "prefix") local_path(new = list(), action = "prefix", .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"} 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, *replacing* 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/DESCRIPTION0000644000176200001440000000465214151431422013121 0ustar liggesusersPackage: withr Title: Run Code 'With' Temporarily Modified Global State Version: 2.4.3 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 = "cph")) 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, rmarkdown, RSQLite, testthat (>= 3.0.0) VignetteBuilder: knitr Encoding: UTF-8 RoxygenNote: 7.1.2 Collate: 'local_.R' 'with_.R' 'collate.R' 'compat-defer.R' 'connection.R' 'db.R' 'defer.R' 'wrap.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 NeedsCompilation: no Packaged: 2021-11-29 19:59:17 UTC; jhester 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] Maintainer: Lionel Henry Repository: CRAN Date/Publication: 2021-11-30 14:20:02 UTC withr/build/0000755000176200001440000000000014151230424012502 5ustar liggesuserswithr/build/vignette.rds0000644000176200001440000000034114151230424015037 0ustar liggesusers} 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-devices.R0000644000176200001440000000520114147463350017140 0ustar liggesusersneeds_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-env.R0000644000176200001440000000444714036326012016307 0ustar liggesuserstest_that("with_envvar sets and unsets variables", { # Make sure the "set_env_testvar" environment var is not set. Sys.unsetenv("set_env_testvar") expect_false("set_env_testvar" %in% names(Sys.getenv())) # Use with_envvar (which calls set_envvar) to temporarily set it to 1 expect_identical("1", with_envvar(c("set_env_testvar" = 1), Sys.getenv("set_env_testvar"))) # set_env_testvar shouldn't stay in the list of environment vars expect_false("set_env_testvar" %in% names(Sys.getenv())) }) test_that("with_envvar respects suffix and prefix", { nested <- function(op1, op2) { with_envvar(c(A = 1), action = op1, with_envvar(c(A = 2), action = op2, Sys.getenv("A")[[1]] ) ) } expect_equal(nested("replace", "suffix"), c("1 2")) expect_equal(nested("replace", "prefix"), c("2 1")) expect_equal(nested("prefix", "suffix"), c("1 2")) expect_equal(nested("prefix", "prefix"), c("2 1")) expect_equal(nested("suffix", "suffix"), c("1 2")) expect_equal(nested("suffix", "prefix"), c("2 1")) }) test_that("local_envvar sets and unsets variables", { # Make sure the "set_env_testvar" environment var is not set. Sys.unsetenv("set_env_testvar") expect_false("set_env_testvar" %in% names(Sys.getenv())) # Use local_envvar (which calls set_envvar) to temporarily set it to 1 local({ local_envvar(c("set_env_testvar" = 1)) expect_identical("1", Sys.getenv("set_env_testvar")) }) # set_env_testvar shouldn't stay in the list of environment vars expect_false("set_env_testvar" %in% names(Sys.getenv())) }) test_that("local_envar respects suffix and prefix", { nested <- function(op1, op2) { local({ local_envvar(c(A = 1), action = op1) local({ local_envvar(c(A = 2), action = op2) Sys.getenv("A")[[1]] }) }) } expect_equal(nested("replace", "suffix"), c("1 2")) expect_equal(nested("replace", "prefix"), c("2 1")) expect_equal(nested("prefix", "suffix"), c("1 2")) expect_equal(nested("prefix", "prefix"), c("2 1")) expect_equal(nested("suffix", "suffix"), c("1 2")) expect_equal(nested("suffix", "prefix"), c("2 1")) }) test_that("local_envvar works with null values", { Sys.setenv("FOOBAR" = 1) local({ local_envvar("FOOBAR" = NULL) expect_false("FOOBAR" %in% names(Sys.getenv())) }) }) withr/tests/testthat/test-language.R0000644000176200001440000000125514147463350017306 0ustar liggesuserstest_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-db.R0000644000176200001440000000445114147463350016111 0ustar liggesusersdescribe("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-tempdir.R0000644000176200001440000000170314147463350017165 0ustar liggesuserstest_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-file.R0000644000176200001440000000407214147463350016442 0ustar liggesusersdescribe("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/helper.R0000644000176200001440000000012213177062746016023 0ustar liggesusersexpect_no_output <- function(...) { testthat::expect_output(..., regexp = NA) } withr/tests/testthat/_snaps/0000755000176200001440000000000014147463350015703 5ustar liggesuserswithr/tests/testthat/_snaps/defer.md0000644000176200001440000000055414147463350017316 0ustar liggesusers# defer()'s global env facilities work Code defer(print("howdy"), envir = globalenv()) Message Setting deferred event(s) on global environment. * Will be run automatically when session ends * Execute (and clear) with `withr::deferred_run()`. * Clear (without executing) with `withr::deferred_clear()`. withr/tests/testthat/_snaps/language.md0000644000176200001440000000005514147463350020010 0ustar liggesusers# checks input `lang` must be a string withr/tests/testthat/test-options.R0000644000176200001440000000065614036303212017205 0ustar liggesuserstest_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-defer.R0000644000176200001440000000324214147463350016606 0ustar liggesuserstest_that("defer_parent works", { 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' scope expect_false(file.exists(path)) }) test_that("defer()'s global env facilities work", { expect_null(get_handlers(globalenv())) Sys.setenv(abcdefg = "abcdefg") expect_snapshot(defer(print("howdy"), envir = globalenv())) expect_message( local_envvar(c(abcdefg = "tuvwxyz"), .local_envir = globalenv()), NA ) h <- get_handlers(globalenv()) expect_length(h, 2) expect_equal(Sys.getenv("abcdefg"), "tuvwxyz") expect_output(deferred_run(globalenv()), "howdy") expect_equal(Sys.getenv("abcdefg"), "abcdefg") expect_message(defer(print("never going to happen"), envir = globalenv())) deferred_clear(globalenv()) h <- get_handlers(globalenv()) expect_null(h) }) test_that("defered actions in global env are run on exit", { path <- local_tempfile() callr::r( function(path) { withr::defer(writeLines("a", path), env = globalenv()) }, list(path = path) ) expect_equal(readLines(path), "a") }) test_that("defer executes all handlers even if there is an error in one of them", { old <- options("test_option" = 1) on.exit(options(old), add = TRUE) f <- function() { defer(stop("hi")) defer(options("test_option" = 2)) } expect_equal(getOption("test_option"), 1) err <- tryCatch(f(), error = identity) expect_equal(conditionMessage(err), "hi") expect_equal(getOption("test_option"), 2) }) withr/tests/testthat/test-with.R0000644000176200001440000001434714147463350016504 0ustar liggesuserstest_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_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("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_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") }) test_that("with_collate works and resets collate", { current <- Sys.getlocale("LC_COLLATE") new <- "C" with_collate( new, { expect_equal(new, Sys.getlocale("LC_COLLATE")) } ) expect_equal(current, Sys.getlocale("LC_COLLATE")) }) 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() }) withr/tests/testthat/test-timezone.R0000644000176200001440000000242314147463350017353 0ustar liggesusersdescribe("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-local.R0000644000176200001440000001336114147463350016616 0ustar liggesuserstest_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_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()) }) 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() }) withr/tests/testthat/test-rng.R0000644000176200001440000000137514147463350016314 0ustar liggesusersdescribe("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.R0000644000176200001440000000006612565664242014552 0ustar liggesuserslibrary(testthat) library(withr) test_check("withr") withr/vignettes/0000755000176200001440000000000014151230425013414 5ustar liggesuserswithr/vignettes/changing-and-restoring-state.Rmd0000644000176200001440000002570013723710332021536 0ustar liggesusers--- 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/R/0000755000176200001440000000000014151230425011605 5ustar liggesuserswithr/R/with.R0000644000176200001440000000436213646345233012724 0ustar liggesusers#' 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/wrap.R0000644000176200001440000000112012652144715012705 0ustar liggesuserswrap <- 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/sink.R0000644000176200001440000000521713134200551012676 0ustar liggesusers# 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/seed.R0000644000176200001440000000633514054232626012666 0ustar liggesusers#' 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 `[character(1)]`\cr Kind of (uniform) RNG to use. #' @param .rng_normal_kind `[character(1)]`\cr Kind of normal RNG to use. #' @param .rng_sample_kind `[character(1)]`\cr Kind of RNG to use for sampling. #' @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 = "default", .rng_normal_kind = "default", .rng_sample_kind = "default") { force(seed) force(.rng_kind) force(.rng_normal_kind) force(.rng_sample_kind) with_preserve_seed({ set_seed(list(seed = seed, rng_kind = c(.rng_kind, .rng_normal_kind, .rng_sample_kind))) code }) } #' @rdname with_seed #' @export local_seed <- function(seed, .local_envir = parent.frame(), .rng_kind = "default", .rng_normal_kind = "default", .rng_sample_kind = "default") { old_seed <- get_seed() set_seed(list(seed = seed, rng_kind = c(.rng_kind, .rng_normal_kind, .rng_sample_kind))) 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(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 <- local({ is_before_3.6 <- getRversion() < "3.6" function(seed) { # Ensure RNGkind() and Normal RNG state is properly reset (cf. #162) if (is_before_3.6) { seed$rng_kind <- seed$rng_kind[1L:2L] } do.call(RNGkind, args = as.list(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/utils.R0000644000176200001440000000273314054232530013076 0ustar liggesusersmake_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 } withr/R/compat-defer.R0000644000176200001440000000410614147463350014311 0ustar liggesusers# nocov start --- compat-defer --- 2020-06-16 # This drop-in file implements withr::defer(). Please find the most # recent version in withr's repository. 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) if (identical(envir, .GlobalEnv) && is.null(get_handlers(envir))) { message( "Setting deferred event(s) on global environment.\n", " * Will be run automatically when session ends\n", " * Execute (and clear) with `withr::deferred_run()`.\n", " * Clear (without executing) with `withr::deferred_clear()`." ) reg.finalizer(envir, function(env) deferred_run(env), onexit = TRUE) } invisible( add_handler( envir, handler = list(expr = substitute(expr), envir = parent.frame()), front = priority == "first" ) ) } get_handlers <- function(envir) { attr(envir, "handlers") } set_handlers <- function(envir, handlers) { has_handlers <- "handlers" %in% names(attributes(envir)) attr(envir, "handlers") <- handlers if (!has_handlers) { 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) } } 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 } ) } for (error in errors) { stop(error) } } add_handler <- function(envir, handler, front) { if (front) { handlers <- c(list(handler), get_handlers(envir)) } else { handlers <- c(get_handlers(envir), list(handler)) } set_handlers(envir, handlers) handler } make_call <- function(...) { as.call(list(...)) } }) # defer() namespace # nocov end withr/R/tempfile.R0000644000176200001440000000621214036304253013541 0ustar liggesusers#' 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 #' @export local_tempfile <- function(new = 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) 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/par.R0000644000176200001440000000145213726445303012526 0ustar liggesusers#' @include with_.R NULL # 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) #' @rdname with_par #' @export local_par <- local_(graphics::par, dots = TRUE) withr/R/devices.R0000644000176200001440000001060613723756323013373 0ustar liggesusers#' @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/connection.R0000644000176200001440000000175313723755624014116 0ustar liggesusers#' 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/dir.R0000644000176200001440000000072313726446016012524 0ustar liggesusers#' @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/makevars.R0000644000176200001440000000722514054166200013550 0ustar liggesusers#' @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/options.R0000644000176200001440000000304614036303212013423 0ustar liggesusers#' @include with_.R # 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, dots = TRUE) withr/R/with_.R0000644000176200001440000000643613726462247013073 0ustar liggesusers#' @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. #' #' @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 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, envir = parent.frame(), new = TRUE) { fmls <- formals(set) if (length(fmls) > 0L) { # called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(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) fun <- eval(bquote(function(args) { old <- .(set_call) on.exit(.(reset)(old)) 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/defer.R0000644000176200001440000000646413723710447013042 0ustar liggesusers#' @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 # Reassign over an empty template so roxygen can figure out the proper # `@usage` and `@name`. The signature above should be kept in sync # with the implementation in compat-defer.R. defer <- defer_ns$defer #' @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, "handlers") <- NULL invisible() } get_handlers <- defer_ns$get_handlers set_handlers <- defer_ns$set_handlers execute_handlers <- defer_ns$execute_handlers add_handler <- defer_ns$add_handler withr/R/namespace.R0000644000176200001440000000626414020430435013672 0ustar liggesusers#' 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 = FALSE) 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 = FALSE) 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/torture.R0000644000176200001440000000056713152342467013456 0ustar liggesusers#' 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/language.R0000644000176200001440000000416514147463350013533 0ustar liggesusers#' 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/rng.R0000644000176200001440000000274213510572467012540 0ustar liggesusers#' 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) { orig <- RNGkind() on.exit(do.call(RNGkind, as.list(orig)), 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()) { orig <- RNGkind() defer(do.call(RNGkind, as.list(orig)), envir = .local_envir) suppressWarnings(RNGversion(version)) orig } withr/R/libpaths.R0000644000176200001440000000272713726445303013560 0ustar liggesusers#' @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) } 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) #' @rdname with_libpaths #' @export local_libpaths <- local_(set_libpaths, .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, new = FALSE) #' @rdname with_temp_libpaths #' @export local_temp_libpaths <- local_(set_temp_libpath, .libPaths, new = FALSE) withr/R/timezone.R0000644000176200001440000000327114036303212013562 0ustar liggesusers#' 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/path.R0000644000176200001440000000226413726445303012702 0ustar liggesusers# path ----------------------------------------------------------------------- get_path <- function() { strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]] } set_path <- function(path, action = "prefix") { 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"` or #' `"suffix"` existing paths #' @inheritParams with_collate #' @seealso [Sys.setenv()] #' @examples #' # temporarily modify the system PATH, *replacing* 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, function(old) set_path(old, "replace")) #' @rdname with_path #' @export local_path <- local_(set_path, function(old) set_path(old, "replace")) withr/R/locale.R0000644000176200001440000000323313726445303013202 0ustar liggesusers# locale --------------------------------------------------------------------- set_locale <- 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) } old <- vapply(names(cats), Sys.getlocale, character(1)) mapply(Sys.setlocale, names(cats), cats) invisible(old) } #' 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 <- with_(set_locale) #' @rdname with_locale #' @export local_locale <- local_(set_locale, dots = TRUE) withr/R/env.R0000644000176200001440000000361314036321743012531 0ustar liggesusers# env ------------------------------------------------------------------------ set_envvar <- function(envs, action = "replace") { if (length(envs) == 0) return() stopifnot(is.named(envs)) stopifnot(is.character(action), length(action) == 1) action <- match.arg(action, c("replace", "prefix", "suffix")) # 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)] 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) } #' 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) #' @rdname with_envvar #' @export local_envvar <- local_(set_envvar, dots = TRUE) withr/R/db.R0000644000176200001440000000307614147463350012335 0ustar liggesusers#' 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/collate.R0000644000176200001440000000133013601500335013347 0ustar liggesusers#' @include with_.R # collate -------------------------------------------------------------------- set_collate <- function(locale) set_locale(c(LC_COLLATE = locale))[[1]] #' 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 <- with_(set_collate) #' @rdname with_collate #' @export local_collate <- local_(set_collate) withr/R/local_.R0000644000176200001440000000262014036303212013156 0ustar liggesusers#' @rdname with_ #' @export local_ <- function(set, reset = set, envir = parent.frame(), new = TRUE, dots = FALSE) { fmls <- formals(set) if (length(fmls) > 0L) { # called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(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(...))) fun <- eval(bquote(function(args) { .(modify_call) old <- .(set_call) defer(.(reset)(old), envir = .local_envir) invisible(old) } )) } else { fun <- eval(bquote(function(args) { old <- .(set_call) defer(.(reset)(old), envir = .local_envir) 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/file.R0000644000176200001440000000216714147463221012664 0ustar liggesusers#' 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)) eval.parent(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/NEWS.md0000644000176200001440000001205314151230316012502 0ustar liggesusers# 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/MD50000644000176200001440000001124114151431422011713 0ustar liggesusers675de3e57a11bae36383f0a235bef500 *DESCRIPTION 6d8b003cc83b1dfced7bd996b18429dc *LICENSE 3d1b502d24fbf44cdade15005f4b62c5 *NAMESPACE c9137ec138f4f28849d5d3a25c94323e *NEWS.md 64ce23327fa1422b0a7184d0dbf83717 *R/collate.R 5b64fa94c3fbe46063bffca87c364595 *R/compat-defer.R 59e090f71fd584df1f32b0ca3591aeae *R/connection.R f5f81ad41ae7c6173c8feec2416cc092 *R/db.R 5cb8f4822e8eb9a4dffb23fb9a9d3b32 *R/defer.R c209e2dea472f8ee387178b6168cd4d3 *R/devices.R ae55b528da3d76997dea1096185a6109 *R/dir.R aca70ffb17ebcc4d68e84934b3b05a04 *R/env.R b50b9d6df3016bb23d0630218f2a421f *R/file.R fc7896ab0777d36fde013f0b83650d24 *R/language.R 922c7b88de6f0d3553c8c875ba14903e *R/libpaths.R 44319c551785e63d68ca54ec873f2ab1 *R/local_.R 27bf951b819c16e6a2cbeff8c3421305 *R/locale.R 58f6c94412d4b32ac3c026273c350915 *R/makevars.R c65338b8d477ff35f7098e93794474f9 *R/namespace.R f14e9c21a2f87d20a58901d4a261054d *R/options.R 1c25590e6a2b3e6b6796bd7b9a24aa6f *R/par.R c6ab7f007fa99ef809f5f6483846d083 *R/path.R 56cf61a22141c1994ffc9b362af9e3cc *R/rng.R d35048b52423d29ac3d6b730190fcd5a *R/seed.R 1939e43a0b29a1a8b446de3e0b33c233 *R/sink.R d7f548538c4ee36365d8a87badd0e282 *R/tempfile.R c18bfd841a74c391d6069333e349995c *R/timezone.R bd03783290e342d399ae55e4b96a5b2b *R/torture.R e8bcb543d012b2b43bc4039c5e5a6e43 *R/utils.R e0d5b47fe55eb6190103480bfe65a731 *R/with.R 74f8d266c2e42349fb9bcc1a8220b2ff *R/with_.R 88e44ec61deb387dd1c2d8a607c420ee *R/wrap.R d2e732a32b77399f3b8675c0cea9e563 *README.md 122fde171e3b5ab974a978249edddc0c *build/vignette.rds 083f07f7273b941c0bc91470ee2c3946 *inst/doc/changing-and-restoring-state.R 513119645a9dd924fef3cd504ef3b3e2 *inst/doc/changing-and-restoring-state.Rmd 9e17c3501056369c887fa3c0331a6e2a *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 f79688efb45233e5bd9fb3dcb23db159 *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 a62807a47fc8077cd0d8d84f76316ace *man/with_path.Rd 224e5389a0136c48b75538b97ff4c28a *man/with_rng_version.Rd 134ad66f8bf4e055300a61625975eb91 *man/with_seed.Rd 07226ad884aff2aede9beadf1d8d0744 *man/with_sink.Rd 88d539e13a56830894b4573782b55761 *man/with_temp_libpaths.Rd 3a1696dc96e88fa548ed2143886063c0 *man/with_tempfile.Rd 374c13c45a2e57b027a3b144cf914151 *man/with_timezone.Rd 092e137de18cd334dbaa9a99170b1885 *man/withr.Rd 70c4d334a0974e15d0309c48ca52ca08 *tests/testthat.R 6c70195b19ec00acaad0a39fc2ccc1f8 *tests/testthat/_snaps/defer.md eda7c5ba53d6983a366d065366b0eb48 *tests/testthat/_snaps/language.md 3cf3c83f8d894870bb07b53fff39bc86 *tests/testthat/helper.R 07ac5f226ff3125685ee361078937b1f *tests/testthat/test-connection.R 841d4018de83c07bb144375f5c7cc88d *tests/testthat/test-db.R c94a04cd944e6606f034ddfe76da48a0 *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 69a37712c726355f112bcd8a2e3b7d90 *tests/testthat/test-local.R 39ba10d7134027cde5af2cc665639192 *tests/testthat/test-namespace.R 4eafa958f3387464ee02799d67cbacd6 *tests/testthat/test-options.R 0a87a8c81cb0bf781c55448c0e91094b *tests/testthat/test-rng.R eed6f9fe60bb78ad16667f52d4adb169 *tests/testthat/test-seed.R e6834df68ee5937018b7f3e8c4d8e71f *tests/testthat/test-sink.R 7824f0a26f8144cbcc16507ec27c144f *tests/testthat/test-tempdir.R 0439c54bdec527f0d4c736bc6b4f1be0 *tests/testthat/test-tempfile.R b844251a3653eb29805f766cb332be3a *tests/testthat/test-timezone.R 24b6146c85187e55b73f37878c214e52 *tests/testthat/test-with.R 022efee96cbc60f103af7e51bb306b4e *tests/testthat/test-wrap.R 513119645a9dd924fef3cd504ef3b3e2 *vignettes/changing-and-restoring-state.Rmd withr/inst/0000755000176200001440000000000014151230424012360 5ustar liggesuserswithr/inst/doc/0000755000176200001440000000000014151230424013125 5ustar liggesuserswithr/inst/doc/changing-and-restoring-state.html0000644000176200001440000013126614151230424021472 0ustar liggesusers 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/inst/doc/changing-and-restoring-state.Rmd0000644000176200001440000002570013723710332021250 0ustar liggesusers--- 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.R0000644000176200001440000001034514151230424020721 0ustar liggesusers## ---- 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