withr/0000755000176200001440000000000013176366662011427 5ustar liggesuserswithr/tests/0000755000176200001440000000000012634157537012566 5ustar liggesuserswithr/tests/testthat.R0000644000176200001440000000006612565664242014552 0ustar liggesuserslibrary(testthat) library(withr) test_check("withr") withr/tests/testthat/0000755000176200001440000000000013176366662014431 5ustar liggesuserswithr/tests/testthat/test-connection.R0000644000176200001440000000255313171140516017654 0ustar liggesuserscontext("connection") describe("with_connection", { it("errors if connection is not named", { expect_error({ with_connection(list(TRUE), TRUE) }, "all(is.named(con)) is not TRUE", fixed = TRUE) }) it("creates a single connection", { tmp <- tempfile() on.exit(unlink(tmp)) expect_false(exists("con")) with_connection(list(con = file(tmp, "w")), { writeLines(c("foo", "bar"), con) }) expect_false(exists("con")) expect_equal(readLines(tmp), c("foo", "bar")) }) it("creates multiple connections", { tmp <- tempfile() tmp2 <- tempfile() on.exit(unlink(c(tmp, tmp2))) expect_false(exists("con")) expect_false(exists("con2")) with_connection(list(con = file(tmp, "w"), con2 = file(tmp2, "w")), { writeLines(c("foo", "bar"), con) writeLines(c("baz", "qux"), con2) }) expect_false(exists("con")) expect_false(exists("con2")) expect_equal(readLines(tmp), c("foo", "bar")) expect_equal(readLines(tmp2), c("baz", "qux")) }) }) describe("local_connection", { it("creates a single connection", { tmp <- tempfile() on.exit(unlink(tmp)) expect_false(exists("con")) (function() { con <- local_connection(file(tmp, "w")) writeLines(c("foo", "bar"), con) })() expect_false(exists("con")) expect_equal(readLines(tmp), c("foo", "bar")) }) }) withr/tests/testthat/test-tempfile.R0000644000176200001440000000162113152261106017313 0ustar liggesuserscontext("tempfile") test_that("with_tempfile works", { f1 <- character() f2 <- character() with_tempfile("file1", { writeLines("foo", file1) expect_equal(readLines(file1), "foo") with_tempfile("file2", { writeLines("bar", file2) expect_equal(readLines(file1), "foo") expect_equal(readLines(file2), "bar") f2 <<- file2 }) expect_false(file.exists(f2)) f1 <<- file1 }) expect_false(file.exists(f1)) }) test_that("local_tempfile works", { f1 <- character() f2 <- character() f <- function() { local_tempfile("file1") writeLines("foo", file1) expect_equal(readLines(file1), "foo") local_tempfile("file2") writeLines("bar", file2) expect_equal(readLines(file1), "foo") expect_equal(readLines(file2), "bar") f1 <<- file1 f2 <<- file2 } f() expect_false(file.exists(f1)) expect_false(file.exists(f2)) }) withr/tests/testthat/test-local.R0000644000176200001440000001411113044121712016574 0ustar liggesuserscontext("local") 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_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_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_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-devices.R0000644000176200001440000000444413176341636017153 0ustar liggesuserscontext("devices") 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_cairo_pdf", "with_cairo_ps", "with_jpeg", "with_pdf", "with_png", "with_svg", "with_tiff", "with_xfig") fns <- mget(fn_names, envir = asNamespace("withr")) extensions <- c("bmp", "pdf", "ps", "jpg", "pdf", "png", "svg", "tiff", "xfig") for (i in seq_along(fns)) { 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_cairo_pdf", "local_cairo_ps", "local_jpeg", "local_pdf", "local_png", "local_svg", "local_tiff", "local_xfig") fns <- mget(fn_names, envir = asNamespace("withr")) extensions <- c("bmp", "pdf", "ps", "jpg", "pdf", "png", "svg", "tiff", "xfig") for (i in seq_along(fns)) { 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-wrap.R0000644000176200001440000000032413011171152016451 0ustar liggesuserscontext("wrap") test_that("wrap works", { v <- c(0, 0, 0) set <- function(x) v[2] <<- x f <- wrap(set, v[1] <<- v[1] + 1, v[3] <<- v[3] + 3) expect_equal(v, c(0, 0, 0)) f(2) expect_equal(v, 1:3) }) withr/tests/testthat/test-sink.R0000644000176200001440000000534313152261105016456 0ustar liggesuserscontext("With sink") test_that("with_output_sink works as expected", { tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) tmp2 <- tempfile() on.exit(unlink(tmp2), add = TRUE) tmp3 <- tempfile() on.exit(unlink(tmp3), add = TRUE) expect_identical(sink.number(), 0L) with_output_sink(tmp, { expect_identical(sink.number(), 1L) cat("output\n") }) expect_identical(readLines(tmp), "output") expect_identical(sink.number(), 0L) with_output_sink(tmp, append = TRUE, { expect_identical(sink.number(), 1L) cat("output 2\n") }) expect_identical(readLines(tmp), c("output", "output 2")) expect_identical(sink.number(), 0L) expect_warning( with_output_sink(tmp, { sink() }), "already removed" ) expect_identical(sink.number(), 0L) expect_error( with_output_sink(NULL, { NULL }), "cannot be NULL" ) expect_identical(sink.number(), 0L) }) # don't use test_that() here to avoid any message redirection local({ tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) tmp2 <- tempfile() on.exit(unlink(tmp2), add = TRUE) tmp3 <- tempfile() on.exit(unlink(tmp3), add = TRUE) expect_identical(sink.number(type = "message"), 2L) with_message_sink(tmp, { expect_gt(sink.number(type = "message"), 2L) message("message") }) expect_identical(sink.number(type = "message"), 2L) expect_identical(readLines(tmp), "message") with_message_sink(tmp, append = TRUE, { expect_gt(sink.number(type = "message"), 2L) message("message 2") }) expect_identical(sink.number(type = "message"), 2L) expect_identical(readLines(tmp), c("message", "message 2")) # Message and output sinks don't interfere with_message_sink(tmp, { sink(tmp2) }) expect_identical(sink.number(type = "message"), 2L) expect_identical(sink.number(), 1L) sink() con <- file(tmp2, "w") on.exit(close(con), add = TRUE) expect_warning( with_message_sink(tmp, { sink(con, type = "message") }), "Not removing a different" ) expect_gt(sink.number(type = "message"), 2L) sink(type = "message") expect_warning( with_message_sink(tmp, { sink(type = "message") }), "No message sink to remove" ) expect_identical(sink.number(type = "message"), 2L) expect_warning( with_message_sink(tmp, { expect_error( with_message_sink(tmp2, NULL), "Cannot establish message sink when another sink is active." ) }), NA ) expect_identical(sink.number(type = "message"), 2L) expect_error( with_message_sink(NULL, { NULL }), "cannot be NULL" ) expect_identical(sink.number(type = "message"), 2L) # Enable to check that test actually reaches this point #expect_true(FALSE) }) withr/tests/testthat/test-with.R0000644000176200001440000001614713134200551016467 0ustar liggesuserscontext("With") test_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_envar 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("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_ 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=-03"), sep = "\n") new <- c(CFLAGS = "-O0") with_makevars( new, path = current, { expect_equal("CFLAGS=-O0", readLines(Sys.getenv("R_MAKEVARS_USER"))) } ) expect_equal("CFLAGS=-03", readLines(current)) }) test_that("with_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") 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=-03"), 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=-03", readLines(current)) }) test_that("set_makevars works as expected", { expect_equal(set_makevars(character(0)), NULL) tmp_old <- tempfile() tmp_new <- tempfile() # empty old file set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new) expect_equal(readLines(tmp_new), c("CFLAGS=-O3")) # non-empty old file without new field writeLines(con=tmp_old, c("LDFLAGS=-lz")) set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new) expect_equal(readLines(tmp_new), c("LDFLAGS=-lz", "CFLAGS=-O3")) # non-empty old file without multiple field definitions (error) writeLines(con=tmp_old, c("CFLAGS=-O0", "CFLAGS=-O1")) expect_error(set_makevars(c(CFLAGS = "-O3"), tmp_old, tmp_new)) unlink(tmp_old) unlink(tmp_new) }) test_that("with_dir works as expected", { old <- normalizePath(getwd()) with_dir("..", { expect_equal(normalizePath(getwd()), normalizePath(file.path(old, ".."))) }) expect_equal(normalizePath(getwd()), normalizePath(old)) }) test_that("with_par works as expected", { tmp <- tempfile() pdf(tmp) on.exit(unlink(tmp), add = TRUE) old <- par("pty") with_par(list(pty = "s"), { expect_equal(par("pty"), "s") }) expect_equal(par("pty"), old) dev.off() }) test_that("with_seed works as expected", { expect_identical( with_preserve_seed(runif(10L)), runif(10L)) expect_identical( with_preserve_seed(runif(10L)), with_preserve_seed(runif(10L))) expect_identical( with_seed(1L, runif(10L)), with_seed(1L, runif(10L))) expect_false(with_seed(1L, runif(1L)) == runif(1L)) expect_false(with_seed(sample.int(.Machine$integer.max, 1), runif(1L)) == with_seed(sample.int(.Machine$integer.max, 1), runif(1L))) }) withr/tests/testthat/test-db.R0000644000176200001440000000447013171222334016101 0ustar liggesuserscontext("db") describe("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-defer.R0000644000176200001440000000057213152261106016577 0ustar liggesuserscontext("defer") test_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)) }) withr/tests/testthat/test-namespace.R0000644000176200001440000000472513176341636017467 0ustar liggesuserscontext("namespace") test_that("with_package works", { # tools package not attached to the search path expect_false("package:tools" %in% search()) with_package("tools", # SIGINT is an exported object in tools expect_equal(SIGINT, 2)) # tools package still not attached to the search path expect_false("package:tools" %in% search()) }) test_that("local_package works", { # tools package not attached to the search path expect_false("package:tools" %in% search()) f <- function() { local_package("tools") # SIGINT is an exported object in tools expect_equal(SIGINT, 2) } f() # tools package still not attached to the search path expect_false("package:tools" %in% search()) }) test_that("with_namespace works", { # tools package not attached to the search path expect_false("" %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/NAMESPACE0000644000176200001440000000255513171222334012633 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(defer) export(defer_parent) 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_jpeg) export(local_libpaths) export(local_locale) 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_svg) export(local_temp_libpaths) export(local_tempfile) export(local_tiff) export(local_xfig) 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_jpeg) 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_seed) export(with_svg) export(with_temp_libpaths) export(with_tempfile) export(with_tiff) export(with_xfig) importFrom(stats,runif) importFrom(stats,setNames) withr/NEWS.md0000644000176200001440000000220213176362731012512 0ustar liggesusers# 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). # 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). # 1.0.2 - `with_makevars()` gains an `assignment` argument to allow specifying additional assignment types. # 1.0.1 - Relaxed R version requirement to 3.0.2 (#35, #39). - New `with_output_sink()` and `with_message_sink()` (#24). # 1.0.0 First Public Release withr/R/0000755000176200001440000000000013176363442011621 5ustar liggesuserswithr/R/db.R0000644000176200001440000000303613171222334012320 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") 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") stopifnot(methods::is(con, "DBIConnection")) defer(DBI::dbDisconnect(con), envir = .local_envir) con } withr/R/locale.R0000644000176200001440000000140213134200551013161 0ustar liggesusers# locale --------------------------------------------------------------------- set_locale <- function(cats) { stopifnot(is.named(cats), is.character(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 `[named character]`\cr New locale settings #' @inheritParams with_collate #' @seealso [Sys.setlocale()] #' @export with_locale <- with_(set_locale) #' @rdname with_locale #' @export local_locale <- local_(set_locale) 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/connection.R0000644000176200001440000000204713171670227014103 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() #' @export with_connection <- function(con, code) { stopifnot(all(is.named(con))) nme <- tempfile() (get("attach", baseenv()))(con, name = nme, warn.conflicts = FALSE) on.exit({ for (connection in con) close(connection) detach(nme, character.only = TRUE) }) force(code) } #' @rdname with_connection #' @export local_connection <- function(con, .local_envir = parent.frame()) { defer(close(con), envir = .local_envir) con } withr/R/utils.R0000644000176200001440000000023713171222334013073 0ustar liggesusersmake_call <- function(...) { as.call(list(...)) } vlapply <- function(X, FUN, ..., FUN.VALUE = logical(1)) { vapply(X, FUN, ..., FUN.VALUE = FUN.VALUE) } withr/R/tempfile.R0000644000176200001440000000200113176363241013537 0ustar liggesusers#' Temporary files #' #' Temporarily create a tempfile, which is automatically removed afterwards. #' @template with #' @param new `[character vector]`\cr Names of temporary file handles to create. #' @param envir `[environment]`\cr Environment in which to define the temporary files. #' @inheritParams base::tempfile #' @export with_tempfile <- function(new, code, envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") { env <- new.env(parent = envir) for (f in new) { assign(f, tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext), envir = env) } on.exit(unlink(mget(new, envir = env))) eval(substitute(code), envir = env) } #' @rdname with_tempfile #' @export local_tempfile <- function(new, envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") { for (f in new) { assign(f, tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext), envir = envir) } defer(unlink(mget(new, envir = envir)), envir = envir) } withr/R/with_.R0000644000176200001440000000607213152066044013053 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-package} #' 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. #' @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, #' the returned function only has 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()) { fmls <- formals(set) if (length(fmls) > 0L) { # called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls)) # rename first formal to new called_fmls[[1]] <- as.symbol("new") fun_args <- c(alist(new =, code =), fmls[-1L]) } else { # no formals -- only have code called_fmls <- NULL fun_args <- alist(code =) } set_call <- as.call(c(substitute(set), called_fmls)) fun <- eval(bquote(function(args) { old <- .(set_call) on.exit(.(reset)(old)) force(code) }, as.environment(list(set_call = set_call, reset = if (missing(reset)) substitute(set) else substitute(reset))))) # 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/env.R0000644000176200001440000000272713134200551012525 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 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 `[named character]`\cr 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()] #' @export with_envvar <- with_(set_envvar) #' @rdname with_envvar #' @export local_envvar <- local_(set_envvar) withr/R/collate.R0000644000176200001440000000105713134200551013353 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. #' @export with_collate <- with_(set_collate) #' @rdname with_collate #' @export local_collate <- local_(set_collate) withr/R/par.R0000644000176200001440000000076213134200551012514 0ustar liggesusers#' @include with_.R NULL # par ------------------------------------------------------------------------ #' Graphics parameters #' #' Temporarily change graphics parameters. #' #' @template with #' @param new `[named list]`\cr New graphics parameters and their values #' @param no.readonly `[logical(1)]`\cr see [par()] documentation. #' @inheritParams with_collate #' @seealso [par()] #' @export with_par <- with_(graphics::par) #' @rdname with_par #' @export local_par <- local_(graphics::par) withr/R/namespace.R0000644000176200001440000000563713176363220013705 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, help, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = TRUE, quietly = TRUE, verbose = getOption("verbose")) { suppressPackageStartupMessages( (get("library"))(package, help = help, 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, help, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = TRUE, quietly = TRUE, verbose = getOption("verbose"), .local_envir = parent.frame()) { suppressPackageStartupMessages( (get("library"))(package, help = help, 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) { ns <- asNamespace(package) name <- format(ns) (get("attach"))(ns, name = name) on.exit(detach(name, character.only = TRUE)) force(code) } #' @rdname with_package #' @export local_namespace <- function(package, .local_envir = parent.frame()) { ns <- asNamespace(package) name <- format(ns) (get("attach"))(ns, name = name) 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) 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) defer(detach(name, character.only = TRUE), envir = .local_envir) } withr/R/seed.R0000644000176200001440000000255013176337143012665 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. #' @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) { force(seed) with_preserve_seed({ set.seed(seed) code }) } #' @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_valid_seed() on.exit(assign(".Random.seed", old_seed, globalenv()), add = TRUE) code } #' @importFrom stats runif get_valid_seed <- function() { seed <- get_seed() if (is.null(seed)) { # Trigger initialisation of RNG runif(1L) seed <- get_seed() } seed } get_seed <- function() { if (!exists(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)) { return(NULL) } get(".Random.seed", globalenv(), mode = "integer", inherits = FALSE) } withr/R/defer.R0000644000176200001440000000655113156036363013035 0ustar liggesusers#' 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. #' #' @family local-related functions #' @export #' @author Kevin Ushey #' @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 <- function(expr, envir = parent.frame(), priority = c("first", "last")) { if (identical(envir, .GlobalEnv)) stop("attempt to defer event on global environment") priority <- match.arg(priority) front <- priority == "first" invisible(add_handler(envir, list(expr = substitute(expr), envir = parent.frame()), front)) } #' @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) ), envir = parent.frame()) } ## Handlers used for 'defer' calls. Attached as a list of expressions for the ## 'handlers' attribute on the environment, with 'on.exit' called to ensure ## those handlers get executed on exit. get_handlers <- function(envir) { as.list(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(substitute(call), TRUE), envir = envir) } } execute_handlers <- function(envir) { handlers <- get_handlers(envir) for (handler in handlers) tryCatch(eval(handler$expr, handler$envir), error = identity) } add_handler <- function(envir, handler, front) { handlers <- if (front) c(list(handler), get_handlers(envir)) else c(get_handlers(envir), list(handler)) set_handlers(envir, handlers) handler } withr/R/options.R0000644000176200001440000000075413134200551013426 0ustar liggesusers#' @include with_.R # options -------------------------------------------------------------------- set_options <- function(new_options) { do.call(options, as.list(new_options)) } #' Options #' #' Temporarily change global options. #' #' @template with #' @param new `[named list]`\cr New options and their values #' @inheritParams with_collate #' @seealso [options()] #' @export with_options <- with_(set_options) #' @rdname with_options #' @export local_options <- local_(set_options) withr/R/path.R0000644000176200001440000000163413134200551012665 0ustar liggesusers# path ----------------------------------------------------------------------- get_path <- function() { strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]] } set_path <- function(path, action = "prefix") { 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()] #' @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/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/libpaths.R0000644000176200001440000000235713134200551013542 0ustar liggesusers#' @include with_.R # lib ------------------------------------------------------------------------ set_libpaths <- function(paths, action = "replace") { paths <- normalizePath(paths, mustWork = TRUE) old <- .libPaths() paths <- merge_new(old, paths, action) .libPaths(paths) invisible(old) } set_temp_libpath <- function() { paths <- tempfile("temp_libpath") dir.create(paths) set_libpaths(paths, action = "prefix") } #' 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 #' @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_collate #' @family libpaths #' @export with_temp_libpaths <- with_(set_temp_libpath, .libPaths) #' @rdname with_temp_libpaths #' @export local_temp_libpaths <- local_(set_temp_libpath, .libPaths) withr/R/with.R0000644000176200001440000000435413152075036012716 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") NULL withr/R/local_.R0000644000176200001440000000167713152070002013165 0ustar liggesusers#' @rdname with_ #' @export local_ <- function(set, reset = set, envir = parent.frame()) { fmls <- formals(set) if (length(fmls) > 0L) { # called pass all extra formals on called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls)) # rename first formal to new called_fmls[[1]] <- as.symbol("new") fun_args <- c(alist(new =), fmls[-1L]) } else { # no formals called_fmls <- NULL fun_args <- alist() } set_call <- as.call(c(substitute(set), called_fmls)) fun <- eval(bquote(function(args) { old <- .(set_call) defer(.(reset)(old), envir = .local_envir) old }, as.environment(list(set_call = set_call, reset = if (missing(reset)) substitute(set) else substitute(reset))))) # 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/dir.R0000644000176200001440000000063013134200551012502 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 with_dir <- with_(setwd) #' @rdname with_dir #' @export local_dir <- local_(setwd) 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/devices.R0000644000176200001440000001016313176337143013366 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_dev <- wrap(grDevices::svg, 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/makevars.R0000644000176200001440000000506713134200551013546 0ustar liggesusers#' @include with_.R # Makevars -------------------------------------------------------------------- set_makevars <- function(variables, old_path = file.path("~", ".R", "Makevars"), new_path = tempfile(), assignment = c("=", ":=", "?=", "+=")) { if (length(variables) == 0) { return() } stopifnot(is.named(variables)) assignment <- match.arg(assignment) old <- NULL if (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 `[named character]`\cr New variables and their values #' @param path `[character(1)]`\cr location of existing `Makevars` file to modify. #' @param assignment `[character(1)]`\cr assignment type to use. #' @export with_makevars <- function(new, code, path = file.path("~", ".R", "Makevars"), assignment = c("=", ":=", "?=", "+=")) { assignment <- match.arg(assignment) makevars_file <- tempfile() on.exit(unlink(makevars_file), add = TRUE) with_envvar(c(R_MAKEVARS_USER = makevars_file), { set_makevars(new, path, makevars_file, assignment = assignment) force(code) }) } local_makevars <- function(new, path = file.path("~", ".R", "Makevars"), assignment = c("=", ":=", "?=", "+="), .local_envir = parent.frame()) { assignment <- match.arg(assignment) makevars_file <- tempfile() defer(unlink(makevars_file), envir = .local_envir) local_envvar(c(R_MAKEVARS_USER = makevars_file), .local_envir = .local_envir) set_makevars(new, path, makevars_file, assignment = assignment) } withr/README.md0000644000176200001440000000562513167744220012704 0ustar liggesusers Withr - Run Code 'With' Modified State ====================================== [![Travis-CI Build Status](https://travis-ci.org/r-lib/withr.svg?branch=master)](https://travis-ci.org/r-lib/withr) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/r-lib/withr?branch=master&svg=true)](https://ci.appveyor.com/project/jimhester/withr) [![Coverage status](https://codecov.io/gh/r-lib/withr/branch/master/graph/badge.svg)](https://codecov.io/github/r-lib/withr?branch=master) [![CRAN Version](http://www.r-pkg.org/badges/version/withr)](http://www.r-pkg.org/pkg/withr) A set of functions to run code 'with' safely and temporarily modified global state. 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. Many of these functions were originally a part of the [devtools](https://github.com/hadley/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()` - 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 connections. - `with_package()`, `with_namespace()` and `with_environment()` - to run code with modified object search paths. - `with_tempfile()` / `local_tempfile()` - Create and clean up a temp file. 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" ``` local functions --------------- These functions are variants of the corresponding `with_()` function, but rather than resetting the value at the end of the function call they reset when the current context goes out of scope. This is most useful for using within functions. ``` r f <- function(x) { local_envvar(c("WITHR" = 2)) Sys.getenv("WITHR") } Sys.getenv("WITHR") #> [1] "" ``` See Also ======== - [Devtools](https://github.com/hadley/devtools) withr/MD50000644000176200001440000000565713176366662011754 0ustar liggesusersb6b2b96cd51e2bef3378be4d6488ea61 *DESCRIPTION 623a71222d1762b1832dece24ecfb76e *NAMESPACE cff7da751ab4a717a8a33dbce795e1d6 *NEWS.md e1cbb655f59eff445b7950e74e535fd8 *R/collate.R d21aa3dfe1f98bf20fcca6f3bace2cf9 *R/connection.R 5367808d24945c8a3cfffd992a0a0f4b *R/db.R ba35bf8d7954ce170ed6046af5c0644a *R/defer.R b112ddd38b7d221237767da419766c0e *R/devices.R a2d830766da6848a85c7ddc774ccea71 *R/dir.R 4b5c0d27740b8f7cf5c0b65ebeb432ac *R/env.R bbfed680ded5b3a3b556a87b8726962b *R/libpaths.R 5d19050a3db8359979ce44a699cde614 *R/local_.R 5df03f3868961416b20e8f3f4f1afe55 *R/locale.R 35cfe7b2305b7d09f59d5fd0d911f0fc *R/makevars.R 01e0fd8d70b6ad11ded553539ea1000b *R/namespace.R 0ffde56e2ef1adc0b3ba462c78556212 *R/options.R 188e3db591fcbb3744adbc9eac9ba076 *R/par.R 25aa34b8e8e014b2e88e276602d05018 *R/path.R 04c7d8612b078effbb76e6dbec2fe564 *R/seed.R 1939e43a0b29a1a8b446de3e0b33c233 *R/sink.R dc01411e0ee843eebd65900889e03c91 *R/tempfile.R bd03783290e342d399ae55e4b96a5b2b *R/torture.R 96b6a06d1a0f0b41dc52da05bdb80b83 *R/utils.R 79d8537ea64031d18a07c7c594ae9f15 *R/with.R 11a3ff1b263fafab1bc53c61d18d0b81 *R/with_.R 88e44ec61deb387dd1c2d8a607c420ee *R/wrap.R 1101d10acc3aed4269f1c217b609d308 *README.md ec146ff954b93557f07c608514109318 *man/defer.Rd 5d7f68ad3e0895931de77ee9dd2f0196 *man/devices.Rd d686b8ad2f1cfc8efa5cb931ae12e29d *man/with_.Rd 0b9c878587610015751f3fbbf64b4c09 *man/with_collate.Rd 8ab578f58534056d1b9d11f44de62af4 *man/with_connection.Rd f4409fea8292158fa660931fd52cfa72 *man/with_db_connection.Rd b215321be57c6be7e0cda435ed396a67 *man/with_dir.Rd 9b23b3d00276f924d91a40d0d6a09d32 *man/with_envvar.Rd 2a33569b52280c025e40f0a8a00498ed *man/with_gctorture2.Rd 7d6b9ba2e7eeecca182e147423e351ab *man/with_libpaths.Rd c163c7dedf9d85b0c54d9b17f385afd4 *man/with_locale.Rd b72a85d8789a8b1741d045ac84e73600 *man/with_makevars.Rd 7b6f676c325ff2822e64a6245c9a1f81 *man/with_options.Rd 5b43ec495a4f914616c0cc4ec71b82f2 *man/with_package.Rd 2f95ec870ee579deb0801fcecfe823f0 *man/with_par.Rd b98fbc3f8b613b49e76ad97be57a0aa1 *man/with_path.Rd 007fd826d391517d74b124aff1e5c725 *man/with_seed.Rd 5ea9bddb1beb3dacf1380f7792b5cbc2 *man/with_sink.Rd 65227756fd433ef3bf81eefdc021ee00 *man/with_temp_libpaths.Rd e29f4500358c94da6f964bb9f820c008 *man/with_tempfile.Rd aeceda0f70c58facc5a31a8093a72d22 *man/withr.Rd 70c4d334a0974e15d0309c48ca52ca08 *tests/testthat.R 4219376f4cfaccbaeccc614ba9e9866c *tests/testthat/test-connection.R d2ed51542e4abe02bb3b1b3d8f5aec8d *tests/testthat/test-db.R 5989fee73522cde134a8bf71815c7352 *tests/testthat/test-defer.R c5cae288b0b53b6ca2e48d021e2e5d28 *tests/testthat/test-devices.R d575d8af40350566635a5a45c5262de4 *tests/testthat/test-local.R 95249441369039d904fa844406f0e057 *tests/testthat/test-namespace.R a71a65191ace70d64dd670ebf8f8bdb2 *tests/testthat/test-sink.R 83c5918263499305b818480c00e86f3d *tests/testthat/test-tempfile.R 7eb747a52816e57e84a0ada71fdfecee *tests/testthat/test-with.R 0effd9528f896e3322dfeb26a0fdc7d5 *tests/testthat/test-wrap.R withr/DESCRIPTION0000644000176200001440000000326313176366662013141 0ustar liggesusersEncoding: UTF-8 Package: withr Title: Run Code 'With' Temporarily Modified Global State Version: 2.1.0 Authors@R: c( person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre")), person("Kirill", "Müller", , "krlmlr+r@mailbox.org", role = "aut"), person("Kevin", "Ushey", email = "kevinushey@gmail.com", role = c("aut")), person("Hadley", "Wickham", , "hadley@rstudio.com", role = "aut"), person("Winston", "Chang", role = "aut"), person("Richard", "Cotton", role = c("ctb")), person("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. URL: http://github.com/r-lib/withr#readme BugReports: http://github.com/r-lib/withr/issues Depends: R (>= 3.0.2) License: GPL (>= 2) LazyData: true Imports: stats, lattice, graphics, grDevices Suggests: testthat, covr, DBI, RSQLite, methods RoxygenNote: 6.0.1 Collate: 'local_.R' 'with_.R' 'collate.R' 'connection.R' 'db.R' 'defer.R' 'wrap.R' 'devices.R' 'dir.R' 'env.R' 'libpaths.R' 'locale.R' 'makevars.R' 'namespace.R' 'options.R' 'par.R' 'path.R' 'seed.R' 'sink.R' 'tempfile.R' 'torture.R' 'utils.R' 'with.R' NeedsCompilation: no Packaged: 2017-11-01 15:24:18 UTC; jhester Author: Jim Hester [aut, cre], Kirill Müller [aut], Kevin Ushey [aut], Hadley Wickham [aut], Winston Chang [aut], Richard Cotton [ctb], RStudio [cph] Maintainer: Jim Hester Repository: CRAN Date/Publication: 2017-11-01 15:52:18 UTC withr/man/0000755000176200001440000000000013176337143012172 5ustar liggesuserswithr/man/with_envvar.Rd0000644000176200001440000000202413152330153014777 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, action = "replace", .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[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{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setenv]{Sys.setenv()}} } withr/man/devices.Rd0000644000176200001440000001764613176337143014121 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, ..., .local_envir = parent.frame()) with_cairo_pdf(new, code, ...) local_cairo_pdf(new, ..., .local_envir = parent.frame()) with_cairo_ps(new, code, ...) local_cairo_ps(new, ..., .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, 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, 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, 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, ..., .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, 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, ..., .local_envir = parent.frame()) with_jpeg(new, code, ...) local_jpeg(new, ..., .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}{\code{[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. See, the \sQuote{Cairo fonts} section in the help for \code{\link{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{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{TRUE}, which produces smaller and better output. Setting this to \code{FALSE} can work around 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. 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_options.Rd0000644000176200001440000000130113152330153015166 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, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[named list]}\cr New options and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=options]{options()}} } withr/man/with_sink.Rd0000644000176200001440000000273013152330153014446 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, append = FALSE, split = FALSE, .local_envir = parent.frame()) with_message_sink(new, code, append = FALSE) local_message_sink(new, append = FALSE, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[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}{\code{[environment]}\cr The environment to use for scoping.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily divert output to a file via \code{\link[=sink]{sink()}}. For sinks of type \code{message}, an error is raised if such a sink is already active. } \seealso{ \code{\link{withr}} for examples \code{\link[=sink]{sink()}} } withr/man/with_gctorture2.Rd0000644000176200001440000000136613152340523015610 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}{\code{[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/withr.Rd0000644000176200001440000000505213152330153013604 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 \code{[various]} \tab Values for setting \cr \code{code} \tab \code{[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") } withr/man/with_locale.Rd0000644000176200001440000000143113152330153014736 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, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[named character]}\cr New locale settings} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setlocale]{Sys.setlocale()}} } withr/man/with_par.Rd0000644000176200001440000000150113152330153014257 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, no.readonly = FALSE, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[named list]}\cr New graphics parameters and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{no.readonly}{\code{[logical(1)]}\cr see \code{\link[=par]{par()}} documentation.} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=par]{par()}} } withr/man/with_temp_libpaths.Rd0000644000176200001440000000135513152330153016337 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) local_temp_libpaths(.local_envir = parent.frame()) } \arguments{ \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\code{[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}} } withr/man/with_dir.Rd0000644000176200001440000000127113152330153014257 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, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[character(1)]}\cr New working directory} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=setwd]{setwd()}} } withr/man/with_.Rd0000644000176200001440000000410113044121712013552 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()) with_(set, reset = set, envir = parent.frame()) } \arguments{ \item{set}{\code{[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}{\code{[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}{\code{[environment]}\cr Environment of the returned function.} } \value{ \code{[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, the returned function only has 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-package} 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_db_connection.Rd0000644000176200001440000000247713171222334016320 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}{\code{[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_libpaths.Rd0000644000176200001440000000163613152330153015314 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, action = "replace", .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[character]}\cr New library paths} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{\code{[character(1)]}\cr should new values \code{"replace"}, \code{"prefix"} or \code{"suffix"} existing paths.} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=.libPaths]{.libPaths()}} Other libpaths: \code{\link{with_temp_libpaths}} } withr/man/with_connection.Rd0000644000176200001440000000201313171222334015635 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}{\code{[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() } \seealso{ \code{\link{withr}} for examples } withr/man/with_path.Rd0000644000176200001440000000155613152330153014443 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, action = "prefix", .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[character]}\cr New \code{PATH} entries} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{action}{\code{[character(1)]}\cr Should new values \code{"replace"}, \code{"prefix"} or \code{"suffix"} existing paths} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples \code{\link[=Sys.setenv]{Sys.setenv()}} } withr/man/defer.Rd0000644000176200001440000000357413152261106013544 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/defer.R \name{defer} \alias{defer} \alias{defer_parent} \title{Defer Evaluation of an Expression} \usage{ defer(expr, envir = parent.frame(), priority = c("first", "last")) defer_parent(expr, priority = c("first", "last")) } \arguments{ \item{expr}{\code{[expression]}\cr An expression to be evaluated.} \item{envir}{\code{[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}{\code{[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. } \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())) }) } \author{ Kevin Ushey } withr/man/with_makevars.Rd0000644000176200001440000000220513152330153015310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/makevars.R \name{with_makevars} \alias{with_makevars} \title{Makevars variables} \usage{ with_makevars(new, code, path = file.path("~", ".R", "Makevars"), assignment = c("=", ":=", "?=", "+=")) } \arguments{ \item{new}{\code{[named character]}\cr New variables and their values} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{path}{\code{[character(1)]}\cr location of existing \code{Makevars} file to modify.} \item{assignment}{\code{[character(1)]}\cr assignment type to use.} } \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}. } \seealso{ \code{\link{withr}} for examples } withr/man/with_package.Rd0000644000176200001440000000660313176363252015114 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, help, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = TRUE, quietly = TRUE, verbose = getOption("verbose")) local_package(package, help, pos = 2, lib.loc = NULL, character.only = TRUE, logical.return = FALSE, warn.conflicts = TRUE, quietly = TRUE, verbose = getOption("verbose"), .local_envir = parent.frame()) with_namespace(package, code) local_namespace(package, .local_envir = parent.frame()) 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{help}{the name of a package, given as a \link{name} or literal character string, or a character string, depending on whether \code{character.only} is \code{FALSE} (default) or \code{TRUE}).} \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{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{.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{conflicts}} from attaching the new package. A conflict is a function masking a function, or a non-function masking a non-function. } \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}{\code{[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{library}}.} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ \code{with_package()} attaches a package to the search path, executes the code, then removes the package from the search path. The package namespace is \emph{not} unloaded however. \code{with_namespace()} does the same thing, but attaches the package namespace to the search path, so all objects (even unexported ones) are also available on the search path. } \examples{ \dontrun{ with_package("ggplot2", { ggplot(mtcars) + geom_point(aes(wt, hp)) }) } } \seealso{ \code{\link{withr}} for examples } withr/man/with_tempfile.Rd0000644000176200001440000000212313176363252015317 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} \title{Temporary files} \usage{ with_tempfile(new, code, envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") local_tempfile(new, envir = parent.frame(), pattern = "file", tmpdir = tempdir(), fileext = "") } \arguments{ \item{new}{\code{[character vector]}\cr Names of temporary file handles to create.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{envir}{\code{[environment]}\cr Environment in which to define the temporary files.} \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} } \value{ \code{[any]}\cr The results of the evaluation of the \code{code} argument. } \description{ Temporarily create a tempfile, which is automatically removed afterwards. } \seealso{ \code{\link{withr}} for examples } withr/man/with_seed.Rd0000644000176200001440000000206213152330153014420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/seed.R \name{with_seed} \alias{with_seed} \alias{with_preserve_seed} \title{Random seed} \usage{ with_seed(seed, code) with_preserve_seed(code) } \arguments{ \item{seed}{\code{[integer(1)]}\cr The random seed to use to evaluate the code.} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} } \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_collate.Rd0000644000176200001440000000132613152070002015117 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, .local_envir = parent.frame()) } \arguments{ \item{new}{\code{[character(1)]}\cr New collation order} \item{code}{\code{[any]}\cr Code to execute in the temporary environment} \item{.local_envir}{\code{[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. } \seealso{ \code{\link{withr}} for examples }