Whither withr?
Many functions in R modify global state in some fashion. Some common examples are par() for graphics parameters, dir() to change the current directory and options() to set a global option. Using these functions is handy when using R interactively, because you can set them early in your experimentation and they will remain set for the duration of the session. However this makes programming with these settings difficult, because they make your function impure by modifying a global state. Therefore you should always strive to reset the previous state when the function exits.
One common idiom for dealing with this problem is to save the current state, make your change, then restore the previous state.
However this approach can fail if there’s an error before you are able to reset the options.
Using the base function on.exit() is a robust solution to this problem. on.exit() will run the code when the function is exited, regardless of whether it exits normally or with an error.
However this solution is somewhat cumbersome to work with. You need to remember to use an on.exit() call after each stateful call. In addition by default each on.exit() action will overwrite any previous on.exit() action in the same function unless you use the add = TRUE option. add = TRUE also adds additional code to the end of existing code, which means the code is not run in the Last-In, First-Out order you would generally prefer. It is also not possible to have this cleanup code performed before the function has finished.
withr is a solution to these issues. It defines a large set of functions for dealing with global settings in R, such as with_par(). These functions set one of the global settings for the duration of a block of code, then automatically reset it after the block is completed.
#> [1] "black"
par("col")
#> [1] "black"
In addition to the with_* functions there are local_* variants whose effects last until the end of the function they are included in. These work similar to on.exit(), but you can set the options in one call rather than two.
withr/inst/doc/withr.R 0000644 0001762 0000144 00000002553 13252476110 014417 0 ustar ligges users ## ----setup, include = FALSE----------------------------------------------
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
library(withr)
## ------------------------------------------------------------------------
par("col" = "black")
my_plot <- function(new) {
old <- par(col = "red", pch = 19)
plot(mtcars$hp, mtcars$wt)
par(old)
}
my_plot()
par("col")
## ---- error = TRUE-------------------------------------------------------
par("col" = "black")
my_plot <- function(new) {
old <- par(col = "red", pch = 19)
plot(mtcars$hpp, mtcars$wt)
par(old)
}
my_plot()
par("col")
## ---- error = TRUE-------------------------------------------------------
par("col" = "black")
my_plot <- function(new) {
old <- par(col = "red", pch = 19)
on.exit(par(old))
plot(mtcars$hpp, mtcars$wt)
}
my_plot()
par("col")
options(test = 1)
{
print(getOption("test"))
on.exit(options(test = 2))
}
getOption("test")
## ------------------------------------------------------------------------
par("col" = "black")
my_plot <- function(new) {
with_par(list(col = "red", pch = 19),
plot(mtcars$hp, mtcars$wt)
)
par("col")
}
my_plot()
par("col")
## ------------------------------------------------------------------------
par("col" = "black")
my_plot <- function(new) {
local_par(list(col = "red", pch = 19))
plot(mtcars$hp, mtcars$wt)
}
my_plot()
par("col")
withr/tests/ 0000755 0001762 0000144 00000000000 12634157537 012566 5 ustar ligges users withr/tests/testthat.R 0000644 0001762 0000144 00000000066 12565664242 014552 0 ustar ligges users library(testthat)
library(withr)
test_check("withr")
withr/tests/testthat/ 0000755 0001762 0000144 00000000000 13252573074 014421 5 ustar ligges users withr/tests/testthat/test-connection.R 0000644 0001762 0000144 00000002553 13171140516 017654 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000001621 13152261106 017313 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000014111 13044121712 016574 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000004444 13176341636 017153 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000000324 13011171152 016451 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000001642 13216216054 016460 0 ustar ligges users context("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)
})
withr/tests/testthat/test-with.R 0000644 0001762 0000144 00000016504 13252301176 016472 0 ustar ligges users context("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_temp_libpaths has an action argument", {
lib <- .libPaths()
with_temp_libpaths(
action = "suffix",
expect_equal(.libPaths()[-length(.libPaths())], lib)
)
expect_equal(lib, .libPaths())
})
test_that("with_ works", {
res <- NULL
set <- function(new) {
res <<- c(res, 1L)
}
reset <- function(old) {
res <<- c(res, 3L)
}
with_res <- with_(set, reset)
with_res(NULL, res <- c(res, 2L))
expect_equal(res, 1L:3L)
})
test_that("with_ works on functions without arguments", {
res <- NULL
set <- function() {
res <<- c(res, 1L)
}
reset <- function(x) {
res <<- c(res, 3L)
}
with_res <- with_(set, reset)
with_res(res <- c(res, 2L))
expect_equal(res, 1L:3L)
})
test_that("with_path works and resets path", {
current <- normalizePath(get_path(), mustWork = FALSE)
new_path <- normalizePath(".")
with_path(
new_path,
{
expect_equal(normalizePath(new_path), head(get_path(), n = 1))
expect_equal(length(get_path()), length(current) + 1L)
}
)
expect_equal(current, get_path())
})
test_that("with_path with suffix action works and resets path", {
current <- normalizePath(get_path(), mustWork = FALSE)
new_path <- normalizePath(".")
with_path(
new_path,
action = "suffix",
{
expect_equal(normalizePath(new_path), tail(get_path(), n = 1))
expect_equal(length(get_path()), length(current) + 1L)
}
)
expect_equal(current, get_path())
})
test_that("with_path with replace action works and resets path", {
current <- normalizePath(get_path(), mustWork = FALSE)
new_path <- normalizePath(".")
with_path(
new_path,
action = "replace",
{
expect_equal(normalizePath(new_path), get_path())
expect_equal(length(get_path()), 1L)
}
)
expect_equal(current, get_path())
})
test_that("with_libpaths works and resets library", {
lib <- .libPaths()
new_lib <- "."
with_libpaths(
new_lib,
{
expect_equal(normalizePath(new_lib), normalizePath(.libPaths()[[1L]]))
}
)
expect_equal(lib, .libPaths())
})
test_that("with_locale works and resets locales", {
current <- Sys.getlocale("LC_CTYPE")
new <- "C"
with_locale(
c(LC_CTYPE = new),
{
expect_equal(new, Sys.getlocale("LC_CTYPE"))
}
)
expect_equal(current, Sys.getlocale("LC_CTYPE"))
})
test_that("with_locale fails with LC_ALL", {
expect_error(with_locale(c(LC_ALL = "C"), NULL), "LC_ALL")
})
test_that("with_collate works and resets collate", {
current <- Sys.getlocale("LC_COLLATE")
new <- "C"
with_collate(
new,
{
expect_equal(new, Sys.getlocale("LC_COLLATE"))
}
)
expect_equal(current, Sys.getlocale("LC_COLLATE"))
})
test_that("with_makevars works and resets the Makevars file", {
current <- tempfile()
writeLines(con = current, c("CFLAGS=-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.R 0000644 0001762 0000144 00000004470 13171222334 016101 0 ustar ligges users context("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.R 0000644 0001762 0000144 00000000572 13152261106 016577 0 ustar ligges users context("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-file.R 0000644 0001762 0000144 00000003446 13177065114 016444 0 ustar ligges users context("file")
describe("with_file", {
it("can use unnamed arguments", {
with_file("file1", {
writeLines("foo", "file1")
expect_equal(readLines("file1"), "foo")
with_file("file2", {
writeLines("bar", "file2")
expect_equal(readLines("file1"), "foo")
expect_equal(readLines("file2"), "bar")
})
expect_false(file.exists("file2"))
})
expect_false(file.exists("file1"))
})
it("can use named arguments", {
with_file(list("file1" = writeLines("foo", "file1")), {
expect_equal(readLines("file1"), "foo")
with_file(list("file2" = writeLines("bar", "file2")), {
expect_equal(readLines("file1"), "foo")
expect_equal(readLines("file2"), "bar")
})
expect_false(file.exists("file2"))
})
expect_false(file.exists("file1"))
})
it("works with multiple files", {
with_file(
list("file1" = writeLines("foo", "file1"),
"file2",
"file3" = writeLines("baz", "file3")), {
writeLines("bar", "file2")
expect_equal(readLines("file1"), "foo")
expect_equal(readLines("file2"), "bar")
expect_equal(readLines("file3"), "baz")
})
expect_false(file.exists("file1"))
expect_false(file.exists("file2"))
expect_false(file.exists("file3"))
})
})
describe("local_file", {
it("works with unnamed arguments", {
f <- function() {
local_file("file1")
writeLines("foo", "file1")
expect_equal(readLines("file1"), "foo")
}
expect_no_output(f())
expect_false(file.exists("file1"))
})
it("works with named arguments", {
f <- function() {
local_file(list("file1" = writeLines("foo", "file1")))
expect_equal(readLines("file1"), "foo")
}
expect_no_output(f())
expect_false(file.exists("file1"))
})
})
withr/tests/testthat/helper.R 0000644 0001762 0000144 00000000122 13177062746 016023 0 ustar ligges users expect_no_output <- function(...) {
testthat::expect_output(..., regexp = NA)
}
withr/tests/testthat/test-namespace.R 0000644 0001762 0000144 00000004725 13176341636 017467 0 ustar ligges users context("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("