tests/testthat/test-defer.R

In renv: Project Environments

test_that("defer evaluates in appropriate environment", {

  foo <- function() {
    writeLines("+ foo")
    defer(writeLines("> foo"),               environment())
    defer(writeLines("> foo.parent"),        parent.frame(1))
    defer(writeLines("> foo.parent.parent"), parent.frame(2))
    writeLines("- foo")
  }

  bar <- function() {
    writeLines("+ bar")
    foo()
    writeLines("- bar")
  }

  baz <- function() {
    writeLines("+ baz")
    bar()
    writeLines("- baz")
  }

  output <- capture.output(baz())
  expected <- c(
    "+ baz",
    "+ bar",
    "+ foo",
    "- foo",
    "> foo",
    "- bar",
    "> foo.parent",
    "- baz",
    "> foo.parent.parent"
  )

  expect_identical(output, expected)

})

test_that("defer runs handles in LIFO order", {
  x <- double()
  local({
    defer(x <<- c(x, 1))
    defer(x <<- c(x, 2))
    defer(x <<- c(x, 3))
  })

  expect_equal(x, c(3, 2, 1))
})

test_that("defer captures arguments properly", {

  foo <- function(x) {
    defer(writeLines(x), scope = parent.frame())
  }

  bar <- function(y) {
    writeLines("+ bar")
    foo(y)
    writeLines("- bar")
  }

  output <- capture.output(bar("> foo"))
  expected <- c("+ bar", "- bar", "> foo")
  expect_identical(output, expected)

})

test_that("defer works with arbitrary expressions", {

  foo <- function(x) {
    defer({
      x + 1
      writeLines("> foo")
    }, scope = parent.frame())
  }

  bar <- function() {
    writeLines("+ bar")
    foo(1)
    writeLines("- bar")
  }

  output <- capture.output(bar())
  expected <- c("+ bar", "- bar", "> foo")
  expect_identical(output, expected)

})


test_that("renv_defer_execute can run handlers earlier", {
  x <- 1
  defer(rm(list = "x"))
  expect_true(exists("x", inherits = FALSE))
  renv_defer_execute(environment())
  expect_false(exists("x", inherits = FALSE))
})

test_that("renv_scope_options inside catch does not leak", {

  wrapper <- function() {
    renv_scope_options(renv.test.option = "original")
    catch({
      renv_scope_options(renv.test.option = "modified")
      expect_equal(getOption("renv.test.option"), "modified")
    })
    getOption("renv.test.option")
  }

  expect_equal(wrapper(), "original")

})

test_that("assignments inside catch are visible to the caller", {

  wrapper <- function() {
    x <- 1
    catch({ x <- 42 })
    x
  }

  expect_equal(wrapper(), 42)

})

test_that("nested catch scopes correctly", {

  wrapper <- function() {
    renv_scope_options(renv.test.option = "outer")
    catch({
      renv_scope_options(renv.test.option = "middle")
      catch({
        renv_scope_options(renv.test.option = "inner")
        expect_equal(getOption("renv.test.option"), "inner")
      })
      expect_equal(getOption("renv.test.option"), "middle")
    })
    getOption("renv.test.option")
  }

  expect_equal(wrapper(), "outer")

})