Nothing
context("caller")
`%||%` <- function(a, b) if (is.null(a)) b else a
expect_throws_if_isnt <- function (object, expected, ...,
info = NULL, label = NULL,
expected.label = NULL)
{
act <- list(val = try(force(object), TRUE),
lab = as.character(label %||% arg_expr(object)))
expected <- list(val = force(expected),
lab = as.character(expected.label %||% arg_expr(expected)))
if (inherits(act$val, "try-error")) {
expect(TRUE, "An error was thrown")
} else {
expect(all.equal(act$val, expected$val),
sprintf("%s not equal to %v", act$label, expected$label))
}
}
`%is%` <- expect_equal
`%is*%` <- expect_throws_if_isnt
test_that("Caller finds caller", ({
f1 <- function() {
where <- "1"
g()
}
f2 <- function() {
where <- "2"
g()
}
g <- function() {
caller(environment())
}
f1()$where %is% "1"
f2()$where %is% "2"
}))
test_that("caller defaults to environment called from", {
f <- function() {
where <- "f"
h()
}
g <- function() {
where <- "g"
h()
}
h <- function() {
caller()
}
f()$where %is% "f"
g()$where %is% "g"
})
test_that("caller of not the immediate environment", {
where <- "e"
f <- function() {
where <- "f"
a <- environment()
g(a)
}
g <- function(a) {
where <- "g"
b <- environment()
h(a, b)
}
h <- function(a, b) {
where <- h
c <- environment()
caller(c)$where %is% "g"
caller(b)$where %is% "f"
caller(a)$where %is% "e"
}
f()
})
test_that("caller of a closed environment (contra parent.frame)", {
where <- "0"
f <- function() {
where <- "f"
g()
}
g <- function(p = parent.frame(), c = caller()) {
where <- "g"
environment()
}
expect_error(caller(f()), "not found")
})
test_that("caller from a lazy argument", {
#baseenv calls "e" which calls "f" which calls "g"
#"caller" is written in the context of "f" so it should return "e"
e <- function() {
where <- "e"
f <- function() {
where <- "f"
g <- function(e) {
where <- "g"
as.list(e)$where
}
g(caller())
}
f()
}
e() %is% "e"
})
test_that("caller from a lazy argument in a closed environment", {
where <- "0"
e <- function() {
where <- "e"
f <- function() {
where <- "f"
g <- function(g) {
where <- "g"
function(f) g
}
g(caller())
}
f()
}
e()() %is*% "e" #example 3
})
test_that("caller from eval and do.call", {
where <- "0"
x <- y <- z <- NULL
e <- function() {
where <- "e"
x <<- environment()
f <- function() {
where <- "f"
y <<- environment()
g <- function() {
where <- "g"
z <<- environment()
caller()$where %is% "f" # example #1
caller(y)$where %is% "e"
eval(quote(caller()))$where %is% "f"
eval(quote(caller()), y)$where %is% "e"
do.call("caller", list())$where %is% "f"
do.call("caller", alist(z))$where %is% "f"
do.call("caller", alist(y))$where %is% "e"
do.call("caller", list(), envir=y)$where %is% "e"
do.call("caller", alist(x), envir=y)$where %is% "0"
do.call("caller", list(z), envir=x)$where %is% "f"
}
g()
}
f()
}
e()
})
test_that("caller from eval and do.call in closed environments", {
where <- "0"
x <- y <- z <- NULL
e <- function() {
where <- "e"
x <<- environment()
f <- function() {
where <- "f"
y <<- environment()
g <- function() {
where <- "g"
z <<- environment()
}
g()
}
f()
}
e()
h <- function() {
caller()$where %is% "0"
caller(y)$where %is*% "e"
eval(quote(caller()))$where %is% "0"
eval(quote(caller()), y)$where %is*% "e" #example 2
do.call("caller", list())$where %is% "0" #example 3
do.call("caller", alist(z))$where %is*% "f"
do.call("caller", alist(y))$where %is*% "e"
do.call("caller", envir=y)$where %is*% "e"
do.call("caller", alist(x), envir=y)$where %is*% "e"
do.call("caller", list(z), envir=x)$where %is*% "f"
}
h()
})
test_that("get_call and get_function", {
where <- "0"
eenv <- NULL
fenv <- NULL
genv <- NULL
henv <- NULL
e <- function() {
where <- "e"
eenv <<- environment()
f(where)
}
f <- function(...) {
where <- "f"
fenv <<- environment()
g(where, ...)
}
g <- function(...) {
where <- "g"
genv <<- environment()
r <- h
(r)(where, ...)
}
h <- function(x, y, z, ...) {
list(get_call(), get_function())
}
c <- e()
cmp <- list(dots_(alist( (r), x=where, y=where, z=where),
list( genv, genv, fenv, eenv)),
h)
c %is% cmp
})
test_that("ifnotfound", {
f <- function(x) {
function(y) caller()
}
caller(environment(f), NULL) %is% NULL
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.