[med-svn] [r-cran-globals] 01/05: New upstream version 0.10.2
Sébastien Villemot
sebastien at debian.org
Sat Sep 30 11:39:46 UTC 2017
This is an automated email from the git hooks/post-receive script.
sebastien pushed a commit to branch master
in repository r-cran-globals.
commit d31c122f6cc28132d046c3c75e35a00d9169d21e
Author: Sébastien Villemot <sebastien at debian.org>
Date: Sat Sep 30 13:33:55 2017 +0200
New upstream version 0.10.2
---
DESCRIPTION | 17 ++--
MD5 | 48 +++++------
NAMESPACE | 1 +
NEWS | 50 ++++++++++++
R/Globals-class.R | 65 ++++++++-------
R/cleanup.R | 11 +--
R/findGlobals.R | 198 ++++++++++++++++++++++++++++++++------------
R/globalsOf.R | 107 +++++++++++++++++-------
R/packagesOf.R | 3 +-
R/utils.R | 96 ++++++++++++----------
R/walkAST.R | 49 +++++++++--
R/where.R | 44 ++++++++++
man/Globals.Rd | 3 +-
man/cleanup.Globals.Rd | 3 +-
man/globalsByName.Rd | 1 -
man/globalsOf.Rd | 14 ++--
man/packagesOf.Globals.Rd | 3 +-
man/walkAST.Rd | 8 +-
tests/Globals.R | 42 +++++-----
tests/conservative.R | 39 ++++-----
tests/dotdotdot.R | 72 ++++++++--------
tests/formulas.R | 30 +++++++
tests/globalsOf.R | 203 ++++++++++++++++++++++++++--------------------
tests/liberal.R | 39 ++++-----
tests/utils.R | 86 +++++++++++---------
tests/walkAST.R | 105 +++++++++++++++---------
26 files changed, 853 insertions(+), 484 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 7681d9c..900945a 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,24 +1,25 @@
Package: globals
-Version: 0.8.0
+Version: 0.10.2
Depends: R (>= 3.1.2)
Imports: codetools
Title: Identify Global Objects in R Expressions
Authors at R: c(
person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"),
email="henrikb at braju.com"))
-Description: Identifies global ("unknown") objects in R expressions by code
- inspection using various strategies, e.g. conservative or liberal. The objective
- of this package is to make it as simple as possible to identify global objects
- for the purpose of exporting them in distributed compute environments.
+Description: Identifies global ("unknown" or "free") objects in R expressions
+ by code inspection using various strategies, e.g. conservative or liberal.
+ The objective of this package is to make it as simple as possible to
+ identify global objects for the purpose of exporting them in distributed
+ compute environments.
License: LGPL (>= 2.1)
LazyLoad: TRUE
ByteCompile: TRUE
URL: https://github.com/HenrikBengtsson/globals
BugReports: https://github.com/HenrikBengtsson/globals/issues
-RoxygenNote: 5.0.1
+RoxygenNote: 6.0.1
NeedsCompilation: no
-Packaged: 2017-01-16 21:17:30 UTC; hb
+Packaged: 2017-08-08 07:17:15 UTC; hb
Author: Henrik Bengtsson [aut, cre, cph]
Maintainer: Henrik Bengtsson <henrikb at braju.com>
Repository: CRAN
-Date/Publication: 2017-01-17 00:32:07
+Date/Publication: 2017-08-08 13:12:42 UTC
diff --git a/MD5 b/MD5
index c3b93ab..b51154a 100644
--- a/MD5
+++ b/MD5
@@ -1,24 +1,26 @@
-d69d3e82b199a73a6cd3fb860aba4bf1 *DESCRIPTION
-24f2b3be1c6d7a2667c0c0e3a90a9776 *NAMESPACE
-4b82fd577ffd37314cd93194ba8d5551 *NEWS
-e130006674e21564fca015849dfb584f *R/Globals-class.R
-2ff62afe0cc2ab9edb6505a1f5ee5a2c *R/cleanup.R
-4ec85ed048ac5e6547334c9633956bad *R/findGlobals.R
-4f93f392bc2ed30efabaa2360a9bd4d7 *R/globalsOf.R
-872b7b7be000da61e173d5be37df37c1 *R/packagesOf.R
-4e2a5293b057aa77b586cb457cdf634b *R/utils.R
-1759e8aee0418f536cacd508bf33d65b *R/walkAST.R
-9d222e6e9bd19dedcf9398fdefddfe06 *man/Globals.Rd
-6718bae8bf05b1744df49c2a6345251d *man/cleanup.Globals.Rd
-e36067883b9755c96195d9f50b4700d1 *man/globalsByName.Rd
-a30bc35f7e240bcca497bcda1a40ad43 *man/globalsOf.Rd
-937c4cb33fb344a0c74330cd162a285c *man/packagesOf.Globals.Rd
-e4d542b6757e65b7bd8dcee45f46996d *man/walkAST.Rd
-60035e1924551a13e4ad79733e0f48a2 *tests/Globals.R
-0a4fd4c3594bcf15e685886e0475e528 *tests/conservative.R
-b840f7e78850bd3a4af136f8649bf05a *tests/dotdotdot.R
-d7edc642e662195ae2a9f32d4a58169d *tests/globalsOf.R
-04ee391b83ac7278c0040be00d32756b *tests/liberal.R
-24cf238b33f0f3c7b9ae5e05904d40d8 *tests/utils.R
-a7d6108d24e35128697e606d16d3c2e5 *tests/walkAST.R
+f2c2e4944d74ec290572d329bdfc6f40 *DESCRIPTION
+5103aaaf89ff0d14004d90b05fcc644f *NAMESPACE
+86ee49825cba10d85cd3afb38e7d5fa5 *NEWS
+4cae63bc2a767f0522c0943358e99d6f *R/Globals-class.R
+bcb4032fbccd0e0c961146919372ffbc *R/cleanup.R
+f801a77d386300552ddb867996f2aeb7 *R/findGlobals.R
+94d29805f550354c3c1d75fd53eb2f87 *R/globalsOf.R
+a3bb9fec59515b028f65771de5f47315 *R/packagesOf.R
+f878905dff9c939fce69298df7b224be *R/utils.R
+378b34c7d7031f615af88b52de72f936 *R/walkAST.R
+995c6d77b293896d9943e59be4310520 *R/where.R
+abec206d57e9f3f4d34bb4a875d35490 *man/Globals.Rd
+978342cde4007f1977a2a355dabf6ffa *man/cleanup.Globals.Rd
+fc7000ee5990508042e8b53ede23dae1 *man/globalsByName.Rd
+b03448eb49c04241d505d1d570340a33 *man/globalsOf.Rd
+71d33dd463fd36bf678fcf037e0d62aa *man/packagesOf.Globals.Rd
+7520df319b9afd0c632d73ae339af702 *man/walkAST.Rd
+97257c489172ab40d42d209b6ae579ee *tests/Globals.R
+5c5558c14915e4f98844ac49f39be46b *tests/conservative.R
+e373e47a402e06c64c0f7d18b0c78508 *tests/dotdotdot.R
+e3e4b49566be287f8beeeaf1346f6ca9 *tests/formulas.R
+190f42520dc316df82c5353e5c1a246e *tests/globalsOf.R
+574e081fe6528451f152c2c1239ce806 *tests/liberal.R
+3058995bc5b96840c58c0c4219d3e018 *tests/utils.R
+c9bb0296119e85b060ad2a6bce2a4315 *tests/walkAST.R
7af53138f87e6ef0f9333c9b8176c51d *tests/zzz.R
diff --git a/NAMESPACE b/NAMESPACE
index 336617e..ad4d05c 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -20,4 +20,5 @@ export(walkAST)
importFrom(codetools,findLocalsList)
importFrom(codetools,makeUsageCollector)
importFrom(codetools,walkCode)
+importFrom(utils,capture.output)
importFrom(utils,installed.packages)
diff --git a/NEWS b/NEWS
index 2424449..132e9ff 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,56 @@
Package: globals
================
+Version: 0.10.2 [2017-08-08]
+
+BUG FIXES:
+
+ o walkAST() could produce error "Cannot walk expression. Unknown object
+ type '...'" for objects of type 'environment'.
+
+
+Version: 0.10.1 [2017-07-01]
+
+BUG FIXES:
+
+ o walkAST() could produce error "Cannot walk expression. Unknown object
+ type '...'" for objects of type 'list', 'expression' and 'S4'.
+
+
+Version: 0.10.0 [2017-04-16]
+
+NEW FEATURES:
+
+ o Globals that are part of a formula are now identified.
+
+ o findGlobals(..., trace = TRUE) will now show low-level parse information
+ as the abstract syntax tree (AST) is walked.
+
+SOFTWARE QUALITY:
+
+ o Enabled more internal sanity checks.
+
+BUG FIXES:
+
+ o walkAST() could produce error "Cannot walk expression. Unknown object
+ type 'nnn'" for expressions of type 'builtin', 'closure' and 'special'.
+
+
+Version: 0.9.0 [2017-03-09]
+
+NEW FEATURES:
+
+ o Added option 'globals.debug', which when TRUE enables debugging output.
+
+BUG FIXES:
+
+ o globalsOf(..., recursive = TRUE) would in some cases scan an incorrect
+ subset of already identified globals.
+
+ o globalsOf(..., recursive = TRUE) failed to skip objects part of package
+ namespaces that where defined via a local() statement.
+
+
Version: 0.8.0 [2017-01-14]
NEW FEATURES:
diff --git a/R/Globals-class.R b/R/Globals-class.R
index d956793..b8ed359 100644
--- a/R/Globals-class.R
+++ b/R/Globals-class.R
@@ -13,7 +13,7 @@
#'
#' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals names
#' @export
-Globals <- function(object=list(), ...) {
+Globals <- function(object = list(), ...) {
if (!is.list(object)) {
stop("Argument 'object' is not a list: ", class(object)[1])
}
@@ -32,15 +32,14 @@ Globals <- function(object=list(), ...) {
attr(object, "where") <- where <- list()
}
stopifnot(is.list(where))
-
- ## TODO: Add only when future (> 1.0.1) is on CRAN /HB 2016-09-05
-## stopifnot(
-## is.list(where),
-## length(where) == length(object),
-## all(names(where) == names)
-## )
-
- structure(object, class=c("Globals", class(object)))
+
+ stopifnot(
+ is.list(where),
+ length(where) == length(object),
+ length(names(where)) == length(names(object))
+ )
+
+ structure(object, class = c("Globals", class(object)))
}
#' @export
@@ -55,15 +54,15 @@ as.Globals.list <- function(x, ...) {
## (with emptyenv() as the fallback)
where <- attr(x, "where")
if (is.null(where)) {
- where <- lapply(x, FUN=function(obj) {
+ where <- lapply(x, FUN = function(obj) {
e <- environment(obj)
- if (is.null(e)) e <- emptyenv()
- e
+ if (is.null(e)) e <- emptyenv()
+ e
})
names(where) <- names(x)
attr(x, "where") <- where
}
-
+
Globals(x, ...)
}
@@ -83,13 +82,12 @@ as.Globals.list <- function(x, ...) {
attr(res, "where") <- where[i]
class(res) <- class(x)
- ## TODO: Add only when future (> 1.0.1) is on CRAN /HB 2016-09-05
-## where <- attr(res, "where")
-## stopifnot(
-## is.list(where),
-## length(where) == length(res),
-## all(names(where) == names(res))
-## )
+ where <- attr(res, "where")
+ stopifnot(
+ is.list(where),
+ length(where) == length(res),
+ length(names(where)) == length(names(res))
+ )
res
}
@@ -98,7 +96,7 @@ as.Globals.list <- function(x, ...) {
#' @export
`$<-.Globals` <- function(x, name, value) {
where <- attr(x, "where")
-
+
## Remove an element?
if (is.null(value)) {
x[[name]] <- NULL
@@ -107,7 +105,8 @@ as.Globals.list <- function(x, ...) {
## Value must be Globals object of length one
if (inherits(value, "Globals")) {
if (length(value) != 1) {
- stop("Cannot assign Globals object of length different than one: ", length(value))
+ stop("Cannot assign Globals object of length different than one: ",
+ length(value))
}
x[[name]] <- value[[1]]
where[[name]] <- attr(value, "where")[[1]]
@@ -118,7 +117,7 @@ as.Globals.list <- function(x, ...) {
where[[name]] <- w
}
}
-
+
attr(x, "where") <- where
invisible(x)
}
@@ -136,34 +135,34 @@ c.Globals <- function(x, ...) {
for (kk in seq_along(args)) {
g <- args[[kk]]
name <- names(args)[kk]
-
+
if (inherits(g, "Globals")) {
w <- attr(g, "where")
} else if (is.list(g)) {
## Nothing to do?
if (length(g) == 0) next
-
+
names <- names(g)
stopifnot(!is.null(names))
- w <- lapply(g, FUN=function(obj) {
+ w <- lapply(g, FUN = function(obj) {
e <- environment(obj)
- if (is.null(e)) e <- emptyenv()
- e
+ if (is.null(e)) e <- emptyenv()
+ e
})
names(w) <- names
} else {
if (is.null(name)) {
stop("Can only append named objects to Globals list: ", sQuote(mode(g)))
}
- g <- structure(list(g), names=name)
+ g <- structure(list(g), names = name)
e <- environment(g)
if (is.null(e)) e <- emptyenv()
- w <- structure(list(e), names=name)
+ w <- structure(list(e), names = name)
}
where <- c(where, w)
x <- c(x, g)
}
-
+
class(x) <- clazz
attr(x, "where") <- where
@@ -184,7 +183,7 @@ unique.Globals <- function(x, ...) {
where <- where[!dups]
x <- x[!dups]
attr(x, "where") <- where
-
+
stopifnot(
length(where) == length(x),
all(names(where) == names(x))
diff --git a/R/cleanup.R b/R/cleanup.R
index e6fd3b6..4cb4352 100644
--- a/R/cleanup.R
+++ b/R/cleanup.R
@@ -9,11 +9,12 @@ cleanup <- function(...) UseMethod("cleanup")
#'
#' @aliases cleanup
#' @export
-cleanup.Globals <- function(globals, drop=c("missing", "base-packages"), ...) {
+cleanup.Globals <- function(globals, drop = c("missing", "base-packages"),
+ ...) {
where <- attr(globals, "where")
names <- names(globals)
- keep <- rep(TRUE, times=length(globals))
+ keep <- rep(TRUE, times = length(globals))
names(keep) <- names
## Drop non-found objects
@@ -26,7 +27,7 @@ cleanup.Globals <- function(globals, drop=c("missing", "base-packages"), ...) {
## Drop objects that are part of one of the "base" packages
if ("base-packages" %in% drop) {
for (name in names) {
- if (isBasePkgs(environmentName(where[[name]]))) keep[name] <- FALSE
+ if (is_base_pkg(environmentName(where[[name]]))) keep[name] <- FALSE
}
}
@@ -40,7 +41,7 @@ cleanup.Globals <- function(globals, drop=c("missing", "base-packages"), ...) {
## Drop objects that calls .Internal()
if ("internals" %in% drop) {
for (name in names) {
- if (is.internal(globals[[name]])) keep[name] <- FALSE
+ if (is_internal(globals[[name]])) keep[name] <- FALSE
}
}
@@ -49,4 +50,4 @@ cleanup.Globals <- function(globals, drop=c("missing", "base-packages"), ...) {
}
globals
-} # cleanup()
+}
diff --git a/R/findGlobals.R b/R/findGlobals.R
index 0e89ade..f6d43fd 100644
--- a/R/findGlobals.R
+++ b/R/findGlobals.R
@@ -1,10 +1,10 @@
## This function is equivalent to:
-## fun <- asFunction(expr, envir=envir, ...)
-## codetools::findGlobals(fun, merge=TRUE)
+## fun <- as_function(expr, envir = envir, ...)
+## codetools::findGlobals(fun, merge = TRUE)
## but we expand it here to make it more explicit
## what is going on.
#' @importFrom codetools makeUsageCollector findLocalsList walkCode
-findGlobals_conservative <- function(expr, envir, ...) {
+find_globals_conservative <- function(expr, envir, ..., trace = FALSE) {
objs <- character()
enter <- function(type, v, e, w) {
@@ -12,20 +12,23 @@ findGlobals_conservative <- function(expr, envir, ...) {
}
if (is.function(expr)) {
- if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-`
+ if (typeof(expr) != "closure") return(character(0L)) # e.g. `<-`
fun <- expr
- w <- makeUsageCollector(fun, name="<anonymous>", enterGlobal=enter)
- collectUsageFunction(fun, name="<anonymous>", w)
+ w <- makeUsageCollector(fun, name = "<anonymous>", enterGlobal = enter)
+ if (trace) w <- inject_tracer_to_walker(w)
+ collect_usage_function(fun, name = "<anonymous>", w)
} else {
## From codetools::findGlobals():
- fun <- asFunction(expr, envir=envir, ...)
- # codetools::collectUsage(fun, enterGlobal=enter)
+ fun <- as_function(expr, envir = envir, ...)
+ # codetools::collectUsage(fun, enterGlobal = enter)
## The latter becomes equivalent to (after cleanup):
- w <- makeUsageCollector(fun, name="<anonymous>", enterGlobal=enter)
- w$env <- new.env(hash=TRUE, parent=w$env)
+ w <- makeUsageCollector(fun, name = "<anonymous>", enterGlobal = enter)
+ w$env <- new.env(hash = TRUE, parent = w$env)
+ if (trace) w <- inject_tracer_to_walker(w)
+
locals <- findLocalsList(list(expr))
- for (name in locals) assign(name, value=TRUE, envir=w$env)
+ for (name in locals) assign(name, value = TRUE, envir = w$env)
walkCode(expr, w)
}
@@ -34,7 +37,7 @@ findGlobals_conservative <- function(expr, envir, ...) {
#' @importFrom codetools makeUsageCollector walkCode
-findGlobals_liberal <- function(expr, envir, ...) {
+find_globals_liberal <- function(expr, envir, ..., trace = FALSE) {
objs <- character()
enter <- function(type, v, e, w) {
@@ -44,11 +47,13 @@ findGlobals_liberal <- function(expr, envir, ...) {
if (is.function(expr)) {
if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-`
fun <- expr
- w <- makeUsageCollector(fun, name="<anonymous>", enterGlobal=enter)
- collectUsageFunction(fun, name="<anonymous>", w)
+ w <- makeUsageCollector(fun, name = "<anonymous>", enterGlobal = enter)
+ if (trace) w <- inject_tracer_to_walker(w)
+ collect_usage_function(fun, name = "<anonymous>", w)
} else {
- fun <- asFunction(expr, envir=envir, ...)
- w <- makeUsageCollector(fun, name="<anonymous>", enterGlobal=enter)
+ fun <- as_function(expr, envir = envir, ...)
+ w <- makeUsageCollector(fun, name = "<anonymous>", enterGlobal = enter)
+ if (trace) w <- inject_tracer_to_walker(w)
walkCode(expr, w)
}
@@ -57,34 +62,53 @@ findGlobals_liberal <- function(expr, envir, ...) {
#' @importFrom codetools makeUsageCollector walkCode
-findGlobals_ordered <- function(expr, envir, ...) {
+find_globals_ordered <- function(expr, envir, ..., trace = FALSE) {
class <- name <- character()
- enterLocal <- function(type, v, e, w) {
+ enter_local <- function(type, v, e, w) {
class <<- c(class, "local")
name <<- c(name, v)
}
- enterGlobal <- function(type, v, e, w) {
+ enter_global <- function(type, v, e, w) {
class <<- c(class, "global")
name <<- c(name, v)
+
+ ## Also walk formulas to identify globals
+ if (type == "function") {
+ if (v == "~") {
+ stopifnot(identical(e[[1]], as.symbol("~")))
+ expr <- e[-1]
+ for (kk in seq_along(expr)) {
+ globals <- find_globals_ordered(expr = expr[[kk]], envir = w$env)
+ if (length(globals) > 0) {
+ class <<- c(class, rep("global", times = length(globals)))
+ name <<- c(name, globals)
+ }
+ }
+ }
+ }
}
## A function or an expression?
if (is.function(expr)) {
if (typeof(expr) != "closure") return(character(0L)) ## e.g. `<-`
fun <- expr
-
- w <- makeUsageCollector(fun, name="<anonymous>",
- enterLocal=enterLocal, enterGlobal=enterGlobal)
- collectUsageFunction(fun, name="<anonymous>", w)
+
+ w <- makeUsageCollector(fun, name = "<anonymous>",
+ enterLocal = enter_local,
+ enterGlobal = enter_global)
+ if (trace) w <- inject_tracer_to_walker(w)
+ collect_usage_function(fun, name = "<anonymous>", w)
} else {
- fun <- asFunction(expr, envir=envir, ...)
- w <- makeUsageCollector(fun, name="<anonymous>",
- enterLocal=enterLocal, enterGlobal=enterGlobal)
+ fun <- as_function(expr, envir = envir, ...)
+ w <- makeUsageCollector(fun, name = "<anonymous>",
+ enterLocal = enter_local,
+ enterGlobal = enter_global)
+ if (trace) w <- inject_tracer_to_walker(w)
walkCode(expr, w)
}
-
+
## Drop duplicated names
dups <- duplicated(name)
class <- class[!dups]
@@ -95,58 +119,88 @@ findGlobals_ordered <- function(expr, envir, ...) {
#' @export
-findGlobals <- function(expr, envir=parent.frame(), ..., tweak=NULL, dotdotdot=c("warning", "error", "return", "ignore"), method=c("ordered", "conservative", "liberal"), substitute=FALSE, unlist=TRUE) {
+findGlobals <- function(expr, envir = parent.frame(), ..., tweak = NULL,
+ dotdotdot = c("warning", "error", "return", "ignore"),
+ method = c("ordered", "conservative", "liberal"),
+ substitute = FALSE, unlist = TRUE, trace = FALSE) {
method <- match.arg(method)
dotdotdot <- match.arg(dotdotdot)
if (substitute) expr <- substitute(expr)
+ mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ...",
+ dotdotdot, method, unlist)
+
if (is.list(expr)) {
- globals <- lapply(expr, FUN=findGlobals, envir=envir, ..., tweak=tweak, dotdotdot=dotdotdot, substitute=FALSE, unlist=FALSE)
+ mdebug(" - expr: <a list of length %d>", length(expr))
+
+ globals <- lapply(expr, FUN = findGlobals, envir = envir, ...,
+ tweak = tweak, dotdotdot = dotdotdot,
+ substitute = FALSE, unlist = FALSE)
+
+ mdebug(" - preliminary globals found: [%d] %s",
+ length(globals), hpaste(sQuote(names(globals))))
+
if (unlist) {
- needsDotdotdot <- FALSE
+ needs_dotdotdot <- FALSE
for (kk in seq_along(globals)) {
s <- globals[[kk]]
n <- length(s)
if (identical(s[n], "...")) {
- needsDotdotdot <- TRUE
+ needs_dotdotdot <- TRUE
s <- s[-n]
globals[[kk]] <- s
}
}
- globals <- unlist(globals, use.names=TRUE)
+ globals <- unlist(globals, use.names = TRUE)
globals <- sort(unique(globals))
- if (needsDotdotdot) globals <- c(globals, "...")
+ if (needs_dotdotdot) globals <- c(globals, "...")
}
+
+ mdebug(" - globals found: [%d] %s",
+ length(globals), hpaste(sQuote(globals)))
+
+ mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint
return(globals)
}
- if (is.function(tweak)) expr <- tweak(expr)
+ if (is.function(tweak)) {
+ mdebug(" - tweaking expression using function")
+ expr <- tweak(expr)
+ }
if (method == "ordered") {
- findGlobalsT <- findGlobals_ordered
+ find_globals_t <- find_globals_ordered
} else if (method == "conservative") {
- findGlobalsT <- findGlobals_conservative
+ find_globals_t <- find_globals_conservative
} else if (method == "liberal") {
- findGlobalsT <- findGlobals_liberal
+ find_globals_t <- find_globals_liberal
}
## Is there a need for global '...' variables?
- needsDotdotdot <- FALSE
+ needs_dotdotdot <- FALSE
globals <- withCallingHandlers({
- oopts <- options(warn=0L)
+ oopts <- options(warn = 0L)
on.exit(options(oopts))
- findGlobalsT(expr, envir=envir)
- }, warning=function(w) {
+ find_globals_t(expr, envir = envir, trace = trace)
+ }, warning = function(w) {
## Warned about '...'?
+ ## NOTE: The warning we're looking for is the one generated by
+ ## codetools::findGlobals(). That warning is _not_ translated,
+ ## meaning this approach should work as is as long as the message
+ ## is not modified by codetools itself. If codetools ever changes
+ ## this such that the below string matching fails, then the package
+ ## tests (tests/dotdotdot.R) will detect that. In other words,
+ ## such a change will not go unnoticed. /HB 2017-03-08
pattern <- "... may be used in an incorrect context"
- if (grepl(pattern, w$message, fixed=TRUE)) {
- needsDotdotdot <<- TRUE
+ if (grepl(pattern, w$message, fixed = TRUE)) {
+ mdebug(" - detected: %s", dQuote(trim(w$message)))
+ needs_dotdotdot <<- TRUE
if (dotdotdot == "return") {
## Consume / muffle warning
invokeRestart("muffleWarning")
} else if (dotdotdot == "ignore") {
- needsDotdotdot <<- FALSE
+ needs_dotdotdot <<- FALSE
## Consume / muffle warning
invokeRestart("muffleWarning")
} else if (dotdotdot == "error") {
@@ -156,7 +210,11 @@ findGlobals <- function(expr, envir=parent.frame(), ..., tweak=NULL, dotdotdot=c
}
})
- if (needsDotdotdot) globals <- c(globals, "...")
+ if (needs_dotdotdot) globals <- c(globals, "...")
+
+ mdebug(" - globals found: [%d] %s", length(globals), hpaste(sQuote(globals)))
+
+ mdebug("findGlobals(..., dotdotdot = '%s', method = '%s', unlist = %s) ... DONE", dotdotdot, method, unlist) #nolint
globals
}
@@ -164,7 +222,7 @@ findGlobals <- function(expr, envir=parent.frame(), ..., tweak=NULL, dotdotdot=c
## Utility functions adopted from codetools:::dropMissing()
## and codetools:::collectUsageFun()
-dropMissingFormals <- function(x) {
+drop_missing_formals <- function(x) {
nx <- length(x)
ix <- logical(length = nx)
for (i in seq_len(nx)) {
@@ -175,19 +233,55 @@ dropMissingFormals <- function(x) {
}
#' @importFrom codetools walkCode findLocalsList
-collectUsageFunction <- function(fun, name, w) {
+collect_usage_function <- function(fun, name, w) {
formals <- formals(fun)
body <- body(fun)
-
+
w$name <- c(w$name, name)
parnames <- names(formals)
-
- formals_clean <- dropMissingFormals(formals)
+
+ formals_clean <- drop_missing_formals(formals)
locals <- findLocalsList(c(list(body), formals_clean))
-
+
w$env <- new.env(hash = TRUE, parent = w$env)
for (n in c(parnames, locals)) assign(n, TRUE, w$env)
for (a in formals_clean) walkCode(a, w)
-
+
walkCode(body, w)
}
+
+
+inject_tracer_to_function <- function(fcn, name) {
+ b <- body(fcn)
+ f <- formals(fcn)
+ args <- setdiff(names(f), c("w", "..."))
+ title <- sprintf("%s():", name)
+ b <- bquote({
+ message(.(title))
+ if (length(.(args)) > 0) str(mget(.(args)))
+ .(b)
+ })
+ body(fcn) <- b
+ fcn
+}
+
+inject_tracer_to_walker <- function(w) {
+ if (is.null(w$startCollectLocals)) {
+ w$startCollectLocals <- function(parnames, locals, ...) { NULL }
+ }
+ if (is.null(w$finishCollectLocals)) {
+ w$finishCollectLocals <- function(w, ...) { NULL }
+ }
+ if (is.null(w$enterInternal)) {
+ w$enterInternal <- function(type, v, e, ...) { NULL }
+ }
+
+ for (key in names(w)) {
+ fcn <- w[[key]]
+ if (!is.function(fcn)) next
+ fcn <- inject_tracer_to_function(fcn, key)
+ w[[key]] <- fcn
+ }
+
+ w
+}
diff --git a/R/globalsOf.R b/R/globalsOf.R
index 89bf9ce..4f35dc3 100644
--- a/R/globalsOf.R
+++ b/R/globalsOf.R
@@ -6,7 +6,8 @@
#'
#' @param \dots Not used.
#'
-#' @param method A character string specifying what type of search algorithm to use.
+#' @param method A character string specifying what type of search algorithm
+#' to use.
#'
#' @param tweak An optional function that takes an expression
#' and returns a tweaked expression.
@@ -58,47 +59,85 @@
#'
#' @aliases findGlobals
#' @export
-globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "conservative", "liberal"), tweak=NULL, substitute=FALSE, mustExist=TRUE, unlist=TRUE, recursive=TRUE) {
+globalsOf <- function(expr, envir = parent.frame(), ...,
+ method = c("ordered", "conservative", "liberal"),
+ tweak = NULL, substitute = FALSE, mustExist = TRUE,
+ unlist = TRUE, recursive = TRUE) {
method <- match.arg(method)
if (substitute) expr <- substitute(expr)
+ mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ...", method, mustExist, unlist, recursive) #nolint
+
## 1. Identify global variables (static code inspection)
- names <- findGlobals(expr, envir=envir, ..., method=method, tweak=tweak, substitute=FALSE, unlist=unlist)
+ names <- findGlobals(expr, envir = envir, ..., method = method,
+ tweak = tweak, substitute = FALSE, unlist = unlist)
+ mdebug(" - preliminary globals (by name): [%d] %s",
+ length(names), hpaste(sQuote(names)))
## 2. Locate them (run time)
globals <- tryCatch({
- globalsByName(names, envir=envir, mustExist=mustExist)
+ globalsByName(names, envir = envir, mustExist = mustExist)
}, error = function(ex) {
## HACK: Tweak error message to also include the expression inspected.
msg <- conditionMessage(ex)
- msg <- sprintf("Identified global objects via static code inspection (%s). %s", hexpr(expr), msg)
+ msg <- sprintf("Identified global objects via static code inspection (%s). %s", hexpr(expr), msg) #nolint
ex$message <- msg
stop(ex)
})
+ mdebug(" - preliminary globals (by value): [%d] %s",
+ length(globals), hpaste(sQuote(names(globals))))
+
## 3. Among globals that are closures (functions) and that exist outside
## of namespaces ("packages"), check for additional globals?
if (recursive) {
+ mdebug(" - recursive scan of preliminary globals ...")
+
## Don't enter functions in namespaces / packages
- where <- sapply(globals, FUN = function(x) environmentName(environment(x)))
- globalsT <- globals[!(where %in% loadedNamespaces())]
+ where <- attr(globals, "where")
+ stopifnot(length(where) == length(globals))
+ where <- sapply(where, FUN = envname)
+ globals_t <- globals[!(where %in% loadedNamespaces())]
+
+ mdebug(" - subset of globals to be scanned (not in loaded namespaces): [%d] %s", length(globals_t), hpaste(sQuote(names(globals_t)))) #nolint
## Enter only functions
- globalsT <- globals[sapply(globalsT, FUN = typeof) == "closure"]
-
- if (length(globalsT) > 0) {
- for (gg in seq_along(globalsT)) {
- fcn <- globalsT[[gg]]
- globalsGG <- globalsOf(fcn, envir=envir, ..., method=method, tweak=tweak, substitute=FALSE, mustExist=mustExist, unlist=unlist, recursive=recursive)
- if (length(globalsGG) > 0) {
- globals <- c(globals, globalsGG)
- }
+ ## NOTE: This excludes functions "not found", but also primitives
+ ## not dropped above.
+ globals_t <- globals_t[sapply(globals_t, FUN = typeof) == "closure"]
+
+ if (length(globals_t) > 0) {
+ mdebug(" - subset of globals to be scanned: [%d] %s",
+ length(globals_t), hpaste(sQuote(names(globals_t))))
+ names_t <- names(globals_t)
+ for (gg in seq_along(globals_t)) {
+ mdebug(" + scanning global #%d (%s) ...", gg, sQuote(names_t[[gg]]))
+ fcn <- globals_t[[gg]]
+ env <- environment(fcn) ## was 'env <- envir' in globals 0.8.0.
+ globals_gg <- globalsOf(fcn, envir = env, ..., method = method,
+ tweak = tweak, substitute = FALSE,
+ mustExist = mustExist, unlist = unlist,
+ recursive = recursive)
+ if (length(globals_gg) > 0) {
+ globals <- c(globals, globals_gg)
+ }
}
globals <- unique(globals)
+ mdebug(" - updated set of globals found: [%d] %s",
+ length(globals), hpaste(sQuote(names(globals))))
+ } else {
+ mdebug(" - subset of globals to be scanned: [0]")
}
+
+ mdebug(" - recursive scan of preliminary globals ... DONE")
}
+ mdebug(" - globals found: [%d] %s",
+ length(globals), hpaste(sQuote(names(globals))))
+
+ mdebug("globalsOf(..., method = '%s', mustExist = %s, unlist = %s, recursive = %s) ... DONE", method, mustExist, unlist, recursive) #nolint
+
globals
} ## globalsOf()
@@ -117,21 +156,30 @@ globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "cons
#' @return A \link{Globals} object.
#'
#' @export
-globalsByName <- function(names, envir=parent.frame(), mustExist=TRUE, ...) {
+globalsByName <- function(names, envir = parent.frame(), mustExist = TRUE,
+ ...) {
names <- as.character(names)
+ mdebug("globalsByName(<%d names>, mustExist = %s) ...",
+ length(names), mustExist)
+ mdebug("- search from environment: %s", sQuote(envname(envir)))
+
## Locate and retrieve the specified globals
n <- length(names)
- needsDotdotdot <- (identical(names[n], "..."))
- if (needsDotdotdot) names <- names[-n]
+ needs_dotdotdot <- (identical(names[n], "..."))
+ if (needs_dotdotdot) names <- names[-n]
+ mdebug("- dotdotdot: %s", needs_dotdotdot)
- globals <- structure(list(), class=c("Globals", "list"))
+ globals <- structure(list(), class = c("Globals", "list"))
where <- list()
- for (name in names) {
- env <- where(name, envir=envir, inherits=TRUE)
+ for (kk in seq_along(names)) {
+ name <- names[kk]
+ mdebug("- locating #%d (%s)", kk, sQuote(name))
+ env <- where(name, envir = envir, inherits = TRUE)
+ mdebug(" + found in environment: %s", sQuote(envname(env)))
if (!is.null(env)) {
where[[name]] <- env
- value <- get(name, envir=env, inherits=FALSE)
+ value <- get(name, envir = env, inherits = FALSE)
if (is.null(value)) {
globals[name] <- list(NULL)
} else {
@@ -141,15 +189,15 @@ globalsByName <- function(names, envir=parent.frame(), mustExist=TRUE, ...) {
globals[name] <- list(NULL)
where[name] <- list(NULL)
if (mustExist) {
- stop(sprintf("Failed to locate global object in the relevant environments: %s", sQuote(name)))
+ stop(sprintf("Failed to locate global object in the relevant environments: %s", sQuote(name))) #nolint
}
}
}
- if (needsDotdotdot) {
- if (exists("...", envir=envir, inherits=TRUE)) {
- where[["..."]] <- where("...", envir=envir, inherits=TRUE)
- ddd <- evalq(list(...), envir=envir, enclos=envir)
+ if (needs_dotdotdot) {
+ if (exists("...", envir = envir, inherits = TRUE)) {
+ where[["..."]] <- where("...", envir = envir, inherits = TRUE)
+ ddd <- evalq(list(...), envir = envir, enclos = envir)
} else {
where["..."] <- list(NULL)
ddd <- NA
@@ -166,5 +214,8 @@ globalsByName <- function(names, envir=parent.frame(), mustExist=TRUE, ...) {
attr(globals, "where") <- where
+ mdebug("globalsByName(<%d names>, mustExist = %s) ... DONE",
+ length(names), mustExist)
+
globals
} ## globalsByName()
diff --git a/R/packagesOf.R b/R/packagesOf.R
index 728f7c0..7f40548 100644
--- a/R/packagesOf.R
+++ b/R/packagesOf.R
@@ -13,7 +13,7 @@ packagesOf <- function(...) UseMethod("packagesOf")
packagesOf.Globals <- function(globals, ...) {
## Scan 'globals' for which packages needs to be loaded.
## This information is in the environment name of the objects.
- pkgs <- sapply(globals, FUN=function(obj) {
+ pkgs <- sapply(globals, FUN = function(obj) {
environmentName(environment(obj))
})
@@ -34,4 +34,3 @@ packagesOf.Globals <- function(globals, ...) {
pkgs
} # packagesOf()
-
diff --git a/R/utils.R b/R/utils.R
index be1290b..a4e7413 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -1,64 +1,48 @@
-asFunction <- function(expr, envir=parent.frame(), ...) {
- eval(substitute(function() x, list(x=expr)), envir=envir, ...)
+as_function <- function(expr, envir = parent.frame(), ...) {
+ eval(substitute(function() x, list(x = expr)), envir = envir, ...)
}
#' @importFrom utils installed.packages
-findBasePkgs <- local({
+find_base_pkgs <- local({
pkgs <- NULL
function() {
if (length(pkgs) > 0L) return(pkgs)
data <- installed.packages()
- isBase <- (data[,"Priority"] %in% "base")
- pkgs <<- rownames(data)[isBase]
+ is_base <- (data[, "Priority"] %in% "base")
+ pkgs <<- rownames(data)[is_base]
pkgs
}
})
-isBasePkgs <- function(pkgs) {
+is_base_pkg <- function(pkgs) {
pkgs <- gsub("^package:", "", pkgs)
- pkgs %in% findBasePkgs()
+ pkgs %in% find_base_pkgs()
}
# cf. is.primitive()
is.base <- function(x) {
if (typeof(x) != "closure") return(FALSE)
- isBasePkgs(environmentName(environment(x)))
+ is_base_pkg(environmentName(environment(x)))
}
# cf. is.primitive()
-is.internal <- function(x) {
+is_internal <- function(x) {
if (typeof(x) != "closure") return(FALSE)
body <- deparse(body(x))
- any(grepl(".Internal", body, fixed=TRUE))
+ any(grepl(".Internal", body, fixed = TRUE))
}
-## Emulates R internal findVar1mode() function
-## https://svn.r-project.org/R/trunk/src/main/envir.c
-where <- function(x, where=-1, envir=if (missing(frame)) { if (where < 0) parent.frame(-where) else as.environment(where) } else sys.frame(frame), frame, mode="any", inherits=TRUE) {
- tt <- 1
- ## Validate arguments
- stopifnot(is.environment(envir))
- stopifnot(is.character(mode), length(mode) == 1L)
- inherits <- as.logical(inherits)
- stopifnot(inherits %in% c(FALSE, TRUE))
-
- ## Search
- while (!identical(envir, emptyenv())) {
- if (exists(x, envir=envir, mode=mode, inherits=FALSE)) return(envir)
- if (!inherits) return(NULL)
- envir <- parent.env(envir)
- }
-
- NULL
-}
-
-
## From R.utils 2.0.2 (2015-05-23)
-hpaste <- function(..., sep="", collapse=", ", lastCollapse=NULL, maxHead=if (missing(lastCollapse)) 3 else Inf, maxTail=if (is.finite(maxHead)) 1 else Inf, abbreviate="...") {
- if (is.null(lastCollapse)) lastCollapse <- collapse
+hpaste <- function(..., sep="", collapse=", ", last_collapse=NULL,
+ max_head=if (missing(last_collapse)) 3 else Inf,
+ max_tail=if (is.finite(max_head)) 1 else Inf,
+ abbreviate="...") {
+ max_head <- as.double(max_head)
+ max_tail <- as.double(max_tail)
+ if (is.null(last_collapse)) last_collapse <- collapse
# Build vector 'x'
- x <- paste(..., sep=sep)
+ x <- paste(..., sep = sep)
n <- length(x)
# Nothing todo?
@@ -66,24 +50,24 @@ hpaste <- function(..., sep="", collapse=", ", lastCollapse=NULL, maxHead=if (mi
if (is.null(collapse)) return(x)
# Abbreviate?
- if (n > maxHead + maxTail + 1) {
- head <- x[seq_len(maxHead)]
- tail <- rev(rev(x)[seq_len(maxTail)])
+ if (n > max_head + max_tail + 1) {
+ head <- x[seq_len(max_head)]
+ tail <- rev(rev(x)[seq_len(max_tail)])
x <- c(head, abbreviate, tail)
n <- length(x)
}
if (!is.null(collapse) && n > 1) {
- if (lastCollapse == collapse) {
- x <- paste(x, collapse=collapse)
+ if (last_collapse == collapse) {
+ x <- paste(x, collapse = collapse)
} else {
- xT <- paste(x[1:(n-1)], collapse=collapse)
- x <- paste(xT, x[n], sep=lastCollapse)
+ x_head <- paste(x[1:(n - 1)], collapse = collapse)
+ x <- paste(x_head, x[n], sep = last_collapse)
}
}
x
-} # hpaste()
+}
## From future 0.11.0
@@ -93,8 +77,32 @@ trim <- function(s) {
## From future 0.11.0
-hexpr <- function(expr, trim=TRUE, collapse="; ", maxHead=6L, maxTail=3L, ...) {
+hexpr <- function(expr, trim = TRUE, collapse = "; ", max_head = 6L,
+ max_tail = 3L, ...) {
code <- deparse(expr)
if (trim) code <- trim(code)
- hpaste(code, collapse=collapse, maxHead=maxHead, maxTail=maxTail, ...)
+ hpaste(code, collapse = collapse,
+ max_head = max_head, max_tail = max_tail, ...)
} # hexpr()
+
+
+## From future 1.3.0
+mdebug <- function(...) {
+ if (!getOption("globals.debug", FALSE)) return()
+ message(sprintf(...))
+} ## mdebug()
+
+
+#' @importFrom utils capture.output
+envname <- function(env) {
+ name <- environmentName(env)
+ if (name == "") {
+ ## e.g. new.env()
+ name <- capture.output(print(env))
+ name <- gsub("(.*: |>)", "", name)
+ } else {
+ ## e.g. globals:::where("plan")
+ name <- gsub("package:", "", name, fixed = TRUE)
+ }
+ name
+}
diff --git a/R/walkAST.R b/R/walkAST.R
index 56a8372..991390a 100644
--- a/R/walkAST.R
+++ b/R/walkAST.R
@@ -1,17 +1,21 @@
#' Walk the Abstract Syntax Tree (AST) of an R Expression
#'
#' @param expr R \link[base]{expression}.
-#' @param atomic,name,call,pairlist single-argument function that takes an atomic, name, call and pairlist expression, respectively. Have to return a valid R expression.
+#' @param atomic,name,call,pairlist single-argument function that takes an
+#' atomic, name, call and pairlist expression, respectively. Have to
+#' return a valid R expression.
#' @param name single-argument function that takes a name expression.
#' @param call single-argument function that takes a call expression.
#' @param pairlist single-argument function that takes a pairlist expression.
-#' @param substitute If TRUE, \code{expr} is \code{\link[base]{substitute}()}:ed.
+#' @param substitute If TRUE, \code{expr} is
+#' \code{\link[base]{substitute}()}:ed.
#'
#' @return R \link[base]{expression}.
#'
#' @export
#' @keywords programming internal
-walkAST <- function(expr, atomic=NULL, name=NULL, call=NULL, pairlist=NULL, substitute=FALSE) {
+walkAST <- function(expr, atomic = NULL, name = NULL, call = NULL,
+ pairlist = NULL, substitute = FALSE) {
if (substitute) expr <- substitute(expr)
if (is.atomic(expr)) {
@@ -21,9 +25,10 @@ walkAST <- function(expr, atomic=NULL, name=NULL, call=NULL, pairlist=NULL, subs
} else if (is.call(expr)) {
## message("call")
for (cc in seq_along(expr)) {
- ## AD HOC: The following is needed to handle x[,1]. /HB 2016-09-06
+ ## AD HOC: The following is needed to handle x[, 1]. /HB 2016-09-06
if (is.name(expr[[cc]]) && expr[[cc]] == "") next
- e <- walkAST(expr[[cc]], atomic=atomic, name=name, call=call, pairlist=pairlist, substitute=FALSE)
+ e <- walkAST(expr[[cc]], atomic = atomic, name = name, call = call,
+ pairlist = pairlist, substitute = FALSE)
if (is.null(e)) {
expr[cc] <- list(NULL)
} else {
@@ -36,7 +41,8 @@ walkAST <- function(expr, atomic=NULL, name=NULL, call=NULL, pairlist=NULL, subs
for (pp in seq_along(expr)) {
## AD HOC: The following is needed to handle '...'. /HB 2016-09-06
if (is.name(expr[[pp]]) && expr[[pp]] == "") next
- e <- walkAST(expr[[pp]], atomic=atomic, name=name, call=call, pairlist=pairlist, substitute=FALSE)
+ e <- walkAST(expr[[pp]], atomic = atomic, name = name, call = call,
+ pairlist = pairlist, substitute = FALSE)
if (is.null(e)) {
expr[pp] <- list(NULL)
} else {
@@ -48,14 +54,39 @@ walkAST <- function(expr, atomic=NULL, name=NULL, call=NULL, pairlist=NULL, subs
## https://stat.ethz.ch/pipermail/r-devel/2016-October/073263.html
## /HB 2016-10-12
expr <- as.pairlist(expr)
+ } else if (is.list(expr)) {
+ ## FIXME: Should we have a specific function for this, or is atomic() ok?
+ ## https://github.com/HenrikBengtsson/globals/issues/27
+ if (is.function(atomic)) expr <- atomic(expr)
+ } else if (typeof(expr) %in% c("builtin", "closure", "special",
+ "expression", "S4", "environment")) {
+ ## Nothing to do
+ ## FIXME: ... or can closures and specials be "walked"? /HB 2017-03-21
+ ## FIXME: Should "promise", "char", "...", "any", "externalptr",
+ ## "bytecode", and "weakref" (cf. ?typeof) also be added? /2017-07-01
+ return(expr)
} else {
- stop("Cannot walk expression. Unknown object type ", sQuote(typeof(expr)), call.=FALSE)
+ msg <- paste("Cannot walk expression. Unknown object type",
+ sQuote(typeof(expr)))
+ onUnknownType <- getOption("globals.walkAST.onUnknownType", "error")
+ if (onUnknownType == "error") {
+ stop(msg, call. = FALSE)
+ } else if (onUnknownType == "warning") {
+ warning(msg, call. = FALSE)
+ }
+ ## Skip below assertion
+ return(expr)
}
## Assert that the tweak functions return a valid object
if (!missing(expr)) {
- stopifnot(is.atomic(expr) || is.name(expr) || is.call(expr) || is.pairlist(expr))
+ stopifnot(is.atomic(expr) ||
+ is.list(expr) ||
+ is.name(expr) ||
+ is.call(expr) ||
+ is.pairlist(expr) ||
+ typeof(expr) %in% c("builtin", "closure", "special"))
}
-
+
expr
} ## walkAST()
diff --git a/R/where.R b/R/where.R
new file mode 100644
index 0000000..392110e
--- /dev/null
+++ b/R/where.R
@@ -0,0 +1,44 @@
+## Emulates R internal findVar1mode() function
+## https://svn.r-project.org/R/trunk/src/main/envir.c
+where <- function(x, where = -1,
+ envir = if (missing(frame)) {
+ if (where < 0)
+ parent.frame(-where)
+ else as.environment(where)
+ } else sys.frame(frame),
+ frame, mode = "any", inherits = TRUE) {
+ ## Validate arguments
+ stopifnot(is.environment(envir))
+ stopifnot(is.character(mode), length(mode) == 1L)
+ inherits <- as.logical(inherits)
+ stopifnot(inherits %in% c(FALSE, TRUE))
+
+ mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ...",
+ sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits)
+
+ ## Search
+ env <- envir
+ while (!identical(env, emptyenv())) {
+ mdebug("- searching %s: %s", sQuote(envname(env)),
+ hpaste(sQuote(ls(envir = env, all.names = TRUE))))
+ if (exists(x, envir = env, mode = mode, inherits = FALSE)) {
+ mdebug(" + found in location: %s", sQuote(envname(env)))
+ mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint
+ return(env)
+ }
+
+ if (!inherits) {
+ mdebug(" + failed to located: NULL")
+ mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE", sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits) #nolint
+ return(NULL)
+ }
+
+ env <- parent.env(env)
+ }
+
+ mdebug("- failed to located: NULL")
+ mdebug("where(%s, where = %d, envir = %s, mode = %s, inherits = %s) ... DONE",
+ sQuote(x), where, sQuote(envname(envir)), sQuote(mode), inherits)
+
+ NULL
+}
diff --git a/man/Globals.Rd b/man/Globals.Rd
index b559e02..6c5a72d 100644
--- a/man/Globals.Rd
+++ b/man/Globals.Rd
@@ -2,10 +2,10 @@
% Please edit documentation in R/Globals-class.R
\name{Globals}
\alias{Globals}
-\alias{[.Globals}
\alias{as.Globals}
\alias{as.Globals.Globals}
\alias{as.Globals.list}
+\alias{[.Globals}
\alias{names}
\title{A representation of a set of globals}
\usage{
@@ -26,4 +26,3 @@ A representation of a set of globals
The \code{\link{globalsOf}()} function identifies globals
from an R expression and returns a Globals object.
}
-
diff --git a/man/cleanup.Globals.Rd b/man/cleanup.Globals.Rd
index 513406d..aa9c305 100644
--- a/man/cleanup.Globals.Rd
+++ b/man/cleanup.Globals.Rd
@@ -1,8 +1,8 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/cleanup.R
\name{cleanup.Globals}
-\alias{cleanup}
\alias{cleanup.Globals}
+\alias{cleanup}
\title{Drop certain types of globals}
\usage{
\method{cleanup}{Globals}(globals, drop = c("missing", "base-packages"), ...)
@@ -17,4 +17,3 @@
\description{
Drop certain types of globals
}
-
diff --git a/man/globalsByName.Rd b/man/globalsByName.Rd
index 019ec08..bac400a 100644
--- a/man/globalsByName.Rd
+++ b/man/globalsByName.Rd
@@ -23,4 +23,3 @@ A \link{Globals} object.
\description{
Locates and retrieves a set of global variables by their names
}
-
diff --git a/man/globalsOf.Rd b/man/globalsOf.Rd
index 6f831db..e352a88 100644
--- a/man/globalsOf.Rd
+++ b/man/globalsOf.Rd
@@ -1,8 +1,8 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/globalsOf.R
\name{globalsOf}
-\alias{findGlobals}
\alias{globalsOf}
+\alias{findGlobals}
\title{Get all global objects of an expression}
\usage{
globalsOf(expr, envir = parent.frame(), ..., method = c("ordered",
@@ -14,7 +14,10 @@ globalsOf(expr, envir = parent.frame(), ..., method = c("ordered",
\item{envir}{The environment from where to search for globals.}
-\item{method}{A character string specifying what type of search algorithm to use.}
+\item{\dots}{Not used.}
+
+\item{method}{A character string specifying what type of search algorithm
+to use.}
\item{tweak}{An optional function that takes an expression
and returns a tweaked expression.}
@@ -32,8 +35,6 @@ If FALSE, a list of \code{length(expr)} sublists.}
\item{recursive}{If TRUE, globals that are closures (functions) and that
exist outside of namespaces ("packages"), will be recursively
scanned for globals.}
-
-\item{\dots}{Not used.}
}
\value{
A \link{Globals} object.
@@ -69,15 +70,14 @@ b <- 2
expr <- substitute({ a <- b; b <- 1 })
## Will _not_ identify 'b' (because it's also a local)
-globalsC <- globalsOf(expr, method="conservative")
+globalsC <- globalsOf(expr, method = "conservative")
print(globalsC)
## Will identify 'b'
-globalsL <- globalsOf(expr, method="liberal")
+globalsL <- globalsOf(expr, method = "liberal")
print(globalsL)
}
\seealso{
Internally, the \pkg{\link{codetools}} package is utilized for
code inspections.
}
-
diff --git a/man/packagesOf.Globals.Rd b/man/packagesOf.Globals.Rd
index a6ff561..60d7e1c 100644
--- a/man/packagesOf.Globals.Rd
+++ b/man/packagesOf.Globals.Rd
@@ -1,8 +1,8 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/packagesOf.R
\name{packagesOf.Globals}
-\alias{packagesOf}
\alias{packagesOf.Globals}
+\alias{packagesOf}
\title{Identify the packages of the globals}
\usage{
\method{packagesOf}{Globals}(globals, ...)
@@ -18,4 +18,3 @@ Returns a character vector of package names.
\description{
Identify the packages of the globals
}
-
diff --git a/man/walkAST.Rd b/man/walkAST.Rd
index c8ed28f..8fcc5a0 100644
--- a/man/walkAST.Rd
+++ b/man/walkAST.Rd
@@ -10,7 +10,9 @@ walkAST(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL,
\arguments{
\item{expr}{R \link[base]{expression}.}
-\item{atomic, name, call, pairlist}{single-argument function that takes an atomic, name, call and pairlist expression, respectively. Have to return a valid R expression.}
+\item{atomic, name, call, pairlist}{single-argument function that takes an
+atomic, name, call and pairlist expression, respectively. Have to
+return a valid R expression.}
\item{name}{single-argument function that takes a name expression.}
@@ -18,7 +20,8 @@ walkAST(expr, atomic = NULL, name = NULL, call = NULL, pairlist = NULL,
\item{pairlist}{single-argument function that takes a pairlist expression.}
-\item{substitute}{If TRUE, \code{expr} is \code{\link[base]{substitute}()}:ed.}
+\item{substitute}{If TRUE, \code{expr} is
+\code{\link[base]{substitute}()}:ed.}
}
\value{
R \link[base]{expression}.
@@ -28,4 +31,3 @@ Walk the Abstract Syntax Tree (AST) of an R Expression
}
\keyword{internal}
\keyword{programming}
-
diff --git a/tests/Globals.R b/tests/Globals.R
index 9bddef1..edded11 100644
--- a/tests/Globals.R
+++ b/tests/Globals.R
@@ -143,50 +143,50 @@ message("*** Globals() - subsetted assignment ... DONE")
message("*** Globals() - combining ...")
-globalsA <- globals0[1:2]
-globalsB <- globals0[1:2]
-globals <- c(globalsA, globalsB)
+globals_a <- globals0[1:2]
+globals_b <- globals0[1:2]
+globals <- c(globals_a, globals_b)
str(globals)
where <- attr(globals, "where")
stopifnot(
length(globals) == 4L,
length(where) == length(globals),
- all(names(globals) == c(names(globalsA), names(globalsB))),
+ all(names(globals) == c(names(globals_a), names(globals_b))),
all(names(globals) == names(where))
)
-globalsA <- globals0[1:2]
-globalsB <- list(b=1, c=letters)
-globals <- c(globalsA, globalsB)
+globals_a <- globals0[1:2]
+globals_b <- list(b = 1, c = letters)
+globals <- c(globals_a, globals_b)
str(globals)
where <- attr(globals, "where")
stopifnot(
length(globals) == 4L,
length(where) == length(globals),
- all(names(globals) == c(names(globalsA), names(globalsB))),
+ all(names(globals) == c(names(globals_a), names(globals_b))),
all(names(globals) == names(where))
)
-globalsA <- globals0[1:2]
-globalsB <- list()
-globals <- c(globalsA, globalsB)
+globals_a <- globals0[1:2]
+globals_b <- list()
+globals <- c(globals_a, globals_b)
str(globals)
where <- attr(globals, "where")
stopifnot(
length(globals) == 2L,
length(where) == length(globals),
- all(names(globals) == c(names(globalsA), names(globalsB))),
+ all(names(globals) == c(names(globals_a), names(globals_b))),
all(names(globals) == names(where))
)
-globalsA <- globals0[1:2]
-globals <- c(globalsA, b=1, c=letters)
+globals_a <- globals0[1:2]
+globals <- c(globals_a, b = 1, c = letters)
str(globals)
where <- attr(globals, "where")
stopifnot(
length(globals) == 4L,
length(where) == length(globals),
- all(names(globals) == c(names(globalsA), "b", "c")),
+ all(names(globals) == c(names(globals_a), "b", "c")),
all(names(globals) == names(where))
)
@@ -201,7 +201,7 @@ where <- attr(globals, "where")
stopifnot(
length(globals) == 6L,
length(where) == length(globals),
- all(names(globals) == rep(names(globals0), times=3L)),
+ all(names(globals) == rep(names(globals0), times = 3L)),
all(names(globals) == names(where))
)
@@ -226,9 +226,9 @@ stopifnot(identical(globals, globals0))
globals <- as.Globals(unclass(globals0))
stopifnot(identical(globals, globals0))
-globalsT <- unclass(globals0)
-attr(globalsT, "where") <- NULL
-globals <- as.Globals(globalsT)
+globals_t <- unclass(globals0)
+attr(globals_t, "where") <- NULL
+globals <- as.Globals(globals_t)
stopifnot(
length(globals) == length(globals0),
names(globals) == names(globals0)
@@ -251,10 +251,10 @@ message("*** Globals() - exceptions ...")
res <- tryCatch({ Globals(NULL) }, error = identity)
stopifnot(inherits(res, "simpleError"))
-res <- tryCatch({ Globals(list(1,2)) }, error = identity)
+res <- tryCatch({ Globals(list(1, 2)) }, error = identity)
stopifnot(inherits(res, "simpleError"))
-res <- tryCatch({ Globals(list(a=1,2)) }, error = identity)
+res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity)
stopifnot(inherits(res, "simpleError"))
## Assigning more than one element
diff --git a/tests/conservative.R b/tests/conservative.R
index ad71b97..0750b61 100644
--- a/tests/conservative.R
+++ b/tests/conservative.R
@@ -1,35 +1,36 @@
library("globals")
-ovars <- ls(envir=globalenv())
+ovars <- ls(envir = globalenv())
## WORKAROUND: Avoid problem reported in testthat Issue #229, which
## causes covr::package_coverage() to given an error. /HB 2015-02-16
suppressWarnings({
- rm(list=c("a", "b", "c", "x", "y", "z", "square",
+ rm(list = c("a", "b", "c", "x", "y", "z", "square",
"pathname", "url", "filename"))
})
message("Setting up expressions")
exprs <- list(
- A = substitute({ Sys.sleep(1); x <- 0.1 }, env=list()),
- B = substitute({ y <- 0.2 }, env=list()),
- C = substitute({ z <- a+0.3 }, env=list()),
- D = substitute({ pathname <- file.path(dirname(url), filename) }, env=list()),
- E = substitute({ b <- c }, env=list()),
+ A = substitute({ Sys.sleep(1); x <- 0.1 }, env = list()),
+ B = substitute({ y <- 0.2 }, env = list()),
+ C = substitute({ z <- a + 0.3 }, env = list()),
+ D = substitute({ pathname <- file.path(dirname(url), filename) },
+ env = list()),
+ E = substitute({ b <- c }, env = list()),
F = substitute({
a <- { runif(1) }
b <- { rnorm(1) }
- x <- a*b; abs(x)
- }, env=list()),
+ x <- a * b; abs(x)
+ }, env = list()),
G = substitute({
y <- square(a)
- }, env=list()),
+ }, env = list()),
H = substitute({
b <- a
a <- 1
- }, env=list())
+ }, env = list())
)
atleast <- list(
@@ -58,7 +59,7 @@ not <- list(
## Define globals
a <- 3.14
c <- 2.71
-square <- function(x) x^2
+square <- function(x) x ^ 2
filename <- "index.html"
# Yes, pretend we forget 'url'
@@ -69,13 +70,13 @@ for (kk in seq_along(exprs)) {
cat(sprintf("Expression #%d ('%s'):\n", kk, key))
print(expr)
- names <- findGlobals(expr, method="conservative")
- cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse=", ")))
+ names <- findGlobals(expr, method = "conservative")
+ cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", ")))
stopifnot(all(atleast[[key]] %in% names))
stopifnot(!any(names %in% not[[key]]))
- globals <- globalsOf(expr, method="conservative")
- cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse=", ")))
+ globals <- globalsOf(expr, method = "conservative")
+ cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", ")))
stopifnot(all(atleast[[key]] %in% names(globals)))
stopifnot(!any(names(globals) %in% not[[key]]))
str(globals)
@@ -83,9 +84,9 @@ for (kk in seq_along(exprs)) {
cat("\n")
}
-names <- findGlobals(exprs, method="conservative", unlist=TRUE)
-cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse=", ")))
+names <- findGlobals(exprs, method = "conservative", unlist = TRUE)
+cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", ")))
## Cleanup
-rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv())
+rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv())
diff --git a/tests/dotdotdot.R b/tests/dotdotdot.R
index 253580c..86c9629 100644
--- a/tests/dotdotdot.R
+++ b/tests/dotdotdot.R
@@ -1,5 +1,5 @@
library("globals")
-opts <- options(warn=1L)
+opts <- options(warn = 1L)
exprs <- list(
ok = substitute(function(...) sum(x, ...)),
@@ -14,23 +14,23 @@ for (name in names(exprs)) {
expr <- exprs[[name]]
message("\n*** codetools::findGlobals():")
- fun <- globals:::asFunction(expr)
+ fun <- globals:::as_function(expr)
print(fun)
globals <- codetools::findGlobals(fun)
print(globals)
stopifnot(all.equal(globals, c("sum", "x")))
- message("\n*** findGlobals(dotdotdot='ignore'):")
+ message("\n*** findGlobals(dotdotdot = 'ignore'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- findGlobals(expr, dotdotdot="ignore")
+ globals <- findGlobals(expr, dotdotdot = "ignore")
print(globals)
stopifnot(all.equal(globals, c("sum", "x")))
- message("\n*** findGlobals(dotdotdot='return'):")
+ message("\n*** findGlobals(dotdotdot = 'return'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- findGlobals(expr, dotdotdot="return")
+ globals <- findGlobals(expr, dotdotdot = "return")
print(globals)
if (name == "ok") {
stopifnot(all.equal(globals, c("sum", "x")))
@@ -38,10 +38,10 @@ for (name in names(exprs)) {
stopifnot(all.equal(globals, c("sum", "x", "...")))
}
- message("\n*** findGlobals(dotdotdot='warn'):")
+ message("\n*** findGlobals(dotdotdot = 'warn'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- findGlobals(expr, dotdotdot="warn")
+ globals <- findGlobals(expr, dotdotdot = "warn")
print(globals)
if (name == "ok") {
stopifnot(all.equal(globals, c("sum", "x")))
@@ -49,10 +49,10 @@ for (name in names(exprs)) {
stopifnot(all.equal(globals, c("sum", "x", "...")))
}
- message("\n*** findGlobals(dotdotdot='error'):")
+ message("\n*** findGlobals(dotdotdot = 'error'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- try(findGlobals(expr, dotdotdot="error"))
+ globals <- try(findGlobals(expr, dotdotdot = "error"))
if (name == "ok") {
stopifnot(all.equal(globals, c("sum", "x")))
} else {
@@ -60,9 +60,9 @@ for (name in names(exprs)) {
}
} # for (name ...)
-message("\n*** findGlobals(<exprs>, dotdotdot='return'):")
+message("\n*** findGlobals(<exprs>, dotdotdot = 'return'):")
print(exprs)
-globals <- findGlobals(exprs, dotdotdot="return")
+globals <- findGlobals(exprs, dotdotdot = "return")
print(globals)
@@ -77,19 +77,19 @@ x <- 1:2
for (name in names(exprs)) {
expr <- exprs[[name]]
- message("\n*** globalsOf(dotdotdot='ignore'):")
+ message("\n*** globalsOf(dotdotdot = 'ignore'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="ignore")
+ globals <- globalsOf(expr, dotdotdot = "ignore")
print(globals)
stopifnot(all.equal(names(globals), c("sum", "x")))
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='return'):")
+ message("\n*** globalsOf(dotdotdot = 'return'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="return")
+ globals <- globalsOf(expr, dotdotdot = "return")
print(globals)
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
@@ -100,10 +100,10 @@ for (name in names(exprs)) {
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='warn'):")
+ message("\n*** globalsOf(dotdotdot = 'warn'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="warn")
+ globals <- globalsOf(expr, dotdotdot = "warn")
print(globals)
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
@@ -114,10 +114,10 @@ for (name in names(exprs)) {
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='error'):")
+ message("\n*** globalsOf(dotdotdot = 'error'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- try(globalsOf(expr, dotdotdot="error"))
+ globals <- try(globalsOf(expr, dotdotdot = "error"))
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
stopifnot(all.equal(globals$sum, base::sum))
@@ -127,9 +127,9 @@ for (name in names(exprs)) {
}
} # for (name ...)
-message("\n*** globalsOf(<exprs>, dotdotdot='return'):")
+message("\n*** globalsOf(<exprs>, dotdotdot = 'return'):")
print(exprs)
-globals <- globalsOf(exprs, dotdotdot="return")
+globals <- globalsOf(exprs, dotdotdot = "return")
print(globals)
@@ -138,53 +138,53 @@ message("*** globalsOf() ... DONE")
message("*** function(x, ...) globalsOf() ...")
-aux <- function(x, ...) {
+aux <- function(x, ..., exprs) {
args <- list(...)
for (name in names(exprs)) {
expr <- exprs[[name]]
- message("\n*** globalsOf(dotdotdot='ignore'):")
+ message("\n*** globalsOf(dotdotdot = 'ignore'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="ignore")
+ globals <- globalsOf(expr, dotdotdot = "ignore")
print(globals)
stopifnot(all.equal(names(globals), c("sum", "x")))
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='return'):")
+ message("\n*** globalsOf(dotdotdot = 'return'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="return")
+ globals <- globalsOf(expr, dotdotdot = "return")
print(globals)
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
} else {
stopifnot(all.equal(names(globals), c("sum", "x", "...")))
- stopifnot(all.equal(globals$`...`, args, check.attributes=FALSE))
+ stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE))
}
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='warn'):")
+ message("\n*** globalsOf(dotdotdot = 'warn'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- globalsOf(expr, dotdotdot="warn")
+ globals <- globalsOf(expr, dotdotdot = "warn")
print(globals)
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
} else {
stopifnot(all.equal(names(globals), c("sum", "x", "...")))
- stopifnot(all.equal(globals$`...`, args, check.attributes=FALSE))
+ stopifnot(all.equal(globals$`...`, args, check.attributes = FALSE))
}
stopifnot(all.equal(globals$sum, base::sum))
stopifnot(all.equal(globals$x, x))
- message("\n*** globalsOf(dotdotdot='error'):")
+ message("\n*** globalsOf(dotdotdot = 'error'):")
cat(sprintf("Expression '%s':\n", name))
print(expr)
- globals <- try(globalsOf(expr, dotdotdot="error"))
+ globals <- try(globalsOf(expr, dotdotdot = "error"))
if (name == "ok") {
stopifnot(all.equal(names(globals), c("sum", "x")))
stopifnot(all.equal(globals$sum, base::sum))
@@ -194,14 +194,14 @@ for (name in names(exprs)) {
}
} # for (name ...)
-message("\n*** globalsOf(<exprs>, dotdotdot='return'):")
+message("\n*** globalsOf(<exprs>, dotdotdot = 'return'):")
print(exprs)
-globals <- globalsOf(exprs, dotdotdot="return")
+globals <- globalsOf(exprs, dotdotdot = "return")
print(globals)
} # aux()
-aux(x=3:4, y=1, z=42L)
+aux(x = 3:4, y = 1, z = 42L, exprs = exprs)
message("*** function(x, ...) globalsOf() ... DONE")
diff --git a/tests/formulas.R b/tests/formulas.R
new file mode 100644
index 0000000..026a91f
--- /dev/null
+++ b/tests/formulas.R
@@ -0,0 +1,30 @@
+library("globals")
+
+message("findGlobals() with formula ...")
+
+g <- findGlobals(. ~ x + y : z, substitute = TRUE)
+print(g)
+stopifnot(all(c("~", ".", "+", "x", ":", "y", "z") %in% g))
+
+g <- findGlobals(map(1L, ~ typeof(.x)), substitute = TRUE)
+print(g)
+stopifnot(all(c("map", "~", "typeof", ".x") %in% g))
+
+message("findGlobals() with formula ... DONE")
+
+
+message("globalsOf() with formula ...")
+
+foo <- function(x) {
+ map(1L, ~ typeof(x + .x))
+}
+
+g <- globalsOf(foo(1L), substitute = TRUE, mustExist = FALSE)
+str(g)
+stopifnot(all(
+ c("foo", "map", "{", "~", "typeof", "+", "x", ".x") %in% names(g)
+))
+
+message("globalsOf() with formula ... DONE")
+
+rm(list = "g")
diff --git a/tests/globalsOf.R b/tests/globalsOf.R
index 974e770..fcad2ff 100644
--- a/tests/globalsOf.R
+++ b/tests/globalsOf.R
@@ -10,45 +10,57 @@ if (covr) {
b <- 2
c <- 3
d <- NULL
-expr <- substitute({ x <- b; b <- 1; y <- c; z <- d }, env=list())
+expr <- substitute({ x <- b; b <- 1; y <- c; z <- d }, env = list())
message("*** findGlobals() ...")
-message(" ** findGlobals(..., method='conservative'):")
-globalsC <- findGlobals(expr, method="conservative")
-print(globalsC)
-stopifnot(all(globalsC %in% c("{", "<-", "c", "d")))
+message(" ** findGlobals(..., method = 'conservative'):")
+globals_c <- findGlobals(expr, method = "conservative")
+print(globals_c)
+stopifnot(all(globals_c %in% c("{", "<-", "c", "d")))
-message(" ** findGlobals(..., method='liberal'):")
-globalsL <- findGlobals(expr, method="liberal")
-print(globalsL)
-stopifnot(all(globalsL %in% c("{", "<-", "b", "c", "d")))
+message(" ** findGlobals(..., method = 'liberal'):")
+globals_l <- findGlobals(expr, method = "liberal")
+print(globals_l)
+stopifnot(all(globals_l %in% c("{", "<-", "b", "c", "d")))
-message(" ** findGlobals(..., method='ordered'):")
-globalsI <- findGlobals(expr, method="ordered")
-print(globalsI)
-stopifnot(all(globalsI %in% c("{", "<-", "b", "c", "d")))
+message(" ** findGlobals(..., method = 'ordered'):")
+globals_i <- findGlobals(expr, method = "ordered")
+print(globals_i)
+stopifnot(all(globals_i %in% c("{", "<-", "b", "c", "d")))
+
+message(" ** findGlobals(..., tweak):")
+tweak_another_expression <- function(expr) {
+ substitute({ x <- B; B <- 1; y <- C; z <- D }, env = list())
+}
+globals_i <- findGlobals(expr, tweak = tweak_another_expression)
+stopifnot(all(globals_i %in% c("{", "<-", "B", "C", "D")))
+
+message(" ** findGlobals(..., trace = TRUE):")
+globals_i <- findGlobals(expr, trace = TRUE)
+print(globals_i)
+stopifnot(all(globals_i %in% c("{", "<-", "b", "c", "d")))
message("*** findGlobals() ... DONE")
message("*** globalsByName() ...")
-globalsC <- globalsByName(c("{", "<-", "c", "d"))
-str(globalsC)
-stopifnot(all(names(globalsC) %in% c("{", "<-", "c", "d")))
-globalsC <- cleanup(globalsC)
-str(globalsC)
-stopifnot(all(names(globalsC) %in% c("c", "d")))
-where <- attr(globalsC, "where")
+globals_c <- globalsByName(c("{", "<-", "c", "d"))
+str(globals_c)
+stopifnot(all(names(globals_c) %in% c("{", "<-", "c", "d")))
+globals_c <- cleanup(globals_c)
+str(globals_c)
+stopifnot(all(names(globals_c) %in% c("c", "d")))
+where <- attr(globals_c, "where")
stopifnot(
- length(where) == length(globalsC),
+ length(where) == length(globals_c),
identical(where$c, globalenv()),
identical(where$d, globalenv())
)
foo <- globals::Globals
-globals <- globalsByName(c("{", "foo", "list"))
+globals <- globalsByName(c("{", "foo", "list"), recursive = FALSE)
str(globals)
stopifnot(all(names(globals) %in% c("{", "foo", "list")))
where <- attr(globals, "where")
@@ -62,7 +74,7 @@ if (!covr) stopifnot(
globals <- cleanup(globals)
str(globals)
stopifnot(all(names(globals) %in% c("foo")))
-globals <- cleanup(globals, drop="internals")
+globals <- cleanup(globals, drop = "internals")
str(globals)
stopifnot(all(names(globals) %in% c("foo")))
pkgs <- packagesOf(globals)
@@ -73,45 +85,45 @@ message("*** globalsByName() ... DONE")
message("*** globalsOf() ...")
-message(" ** globalsOf(..., method='conservative'):")
-globalsC <- globalsOf(expr, method="conservative")
-str(globalsC)
-stopifnot(all(names(globalsC) %in% c("{", "<-", "c", "d")))
-globalsC <- cleanup(globalsC)
-str(globalsC)
-stopifnot(all(names(globalsC) %in% c("c", "d")))
-where <- attr(globalsC, "where")
+message(" ** globalsOf(..., method = 'conservative'):")
+globals_c <- globalsOf(expr, method = "conservative")
+str(globals_c)
+stopifnot(all(names(globals_c) %in% c("{", "<-", "c", "d")))
+globals_c <- cleanup(globals_c)
+str(globals_c)
+stopifnot(all(names(globals_c) %in% c("c", "d")))
+where <- attr(globals_c, "where")
stopifnot(
- length(where) == length(globalsC),
+ length(where) == length(globals_c),
identical(where$c, globalenv()),
identical(where$d, globalenv())
)
-message(" ** globalsOf(..., method='liberal'):")
-globalsL <- globalsOf(expr, method="liberal")
-str(globalsL)
-stopifnot(all(names(globalsL) %in% c("{", "<-", "b", "c", "d")))
-globalsL <- cleanup(globalsL)
-str(globalsL)
-stopifnot(all(names(globalsL) %in% c("b", "c", "d")))
-where <- attr(globalsL, "where")
+message(" ** globalsOf(..., method = 'liberal'):")
+globals_l <- globalsOf(expr, method = "liberal")
+str(globals_l)
+stopifnot(all(names(globals_l) %in% c("{", "<-", "b", "c", "d")))
+globals_l <- cleanup(globals_l)
+str(globals_l)
+stopifnot(all(names(globals_l) %in% c("b", "c", "d")))
+where <- attr(globals_l, "where")
stopifnot(
- length(where) == length(globalsL),
+ length(where) == length(globals_l),
identical(where$b, globalenv()),
identical(where$c, globalenv()),
identical(where$d, globalenv())
)
-message(" ** globalsOf(..., method='ordered'):")
-globalsL <- globalsOf(expr, method="ordered")
-str(globalsL)
-stopifnot(all(names(globalsL) %in% c("{", "<-", "b", "c", "d")))
-globalsL <- cleanup(globalsL)
-str(globalsL)
-stopifnot(all(names(globalsL) %in% c("b", "c", "d")))
-where <- attr(globalsL, "where")
+message(" ** globalsOf(..., method = 'ordered'):")
+globals_l <- globalsOf(expr, method = "ordered")
+str(globals_l)
+stopifnot(all(names(globals_l) %in% c("{", "<-", "b", "c", "d")))
+globals_l <- cleanup(globals_l)
+str(globals_l)
+stopifnot(all(names(globals_l) %in% c("b", "c", "d")))
+where <- attr(globals_l, "where")
stopifnot(
- length(where) == length(globalsL),
+ length(where) == length(globals_l),
identical(where$b, globalenv()),
identical(where$c, globalenv()),
identical(where$d, globalenv())
@@ -120,45 +132,50 @@ stopifnot(
message(" ** globalsOf() w/ globals in local functions:")
a <- 1
-foo <- function(x) x - a
+bar <- function(x) x - a
+foo <- function(x) bar(x)
for (method in c("ordered", "conservative", "liberal")) {
- globalsL <- globalsOf({ foo(3) }, substitute = TRUE, method = method, recursive = FALSE, mustExist = FALSE)
- stopifnot(all(names(globalsL) %in% c("{", "foo")),
- !any("a" %in% names(globalsL)))
- globalsL <- cleanup(globalsL)
- str(globalsL)
- stopifnot(all(names(globalsL) %in% c("foo"), !any("a" %in% names(globalsL))))
-
- globalsL <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered", recursive = TRUE, mustExist = FALSE)
- stopifnot(all(names(globalsL) %in% c("{", "foo", "-", "a")))
- globalsL <- cleanup(globalsL)
- str(globalsL)
- stopifnot(all(names(globalsL) %in% c("foo", "a")))
-
- globalsL <- globalsOf({ foo(3) }, substitute = TRUE, recursive = TRUE, mustExist = FALSE)
- stopifnot(all(names(globalsL) %in% c("{", "foo", "-", "a")))
- globalsL <- cleanup(globalsL)
- str(globalsL)
- stopifnot(all(names(globalsL) %in% c("foo", "a")))
+ globals_l <- globalsOf({ foo(3) }, substitute = TRUE, method = method,
+ recursive = FALSE, mustExist = FALSE)
+ stopifnot(all(names(globals_l) %in% c("{", "foo")),
+ !any("a" %in% names(globals_l)))
+ globals_l <- cleanup(globals_l)
+ str(globals_l)
+ stopifnot(all(names(globals_l) %in% c("foo"),
+ !any("a" %in% names(globals_l))))
+
+ globals_l <- globalsOf({ foo(3) }, substitute = TRUE, method = "ordered",
+ recursive = TRUE, mustExist = FALSE)
+ stopifnot(all(names(globals_l) %in% c("{", "foo", "bar", "-", "a")))
+ globals_l <- cleanup(globals_l)
+ str(globals_l)
+ stopifnot(all(names(globals_l) %in% c("foo", "bar", "a")))
+
+ globals_l <- globalsOf({ foo(3) }, substitute = TRUE,
+ recursive = TRUE, mustExist = FALSE)
+ stopifnot(all(names(globals_l) %in% c("{", "foo", "bar", "-", "a")))
+ globals_l <- cleanup(globals_l)
+ str(globals_l)
+ stopifnot(all(names(globals_l) %in% c("foo", "bar", "a")))
}
message("*** globalsOf() ... DONE")
message("*** Subsetting of Globals:")
-globalsL <- globalsOf(expr, method="liberal")
-globalsS <- globalsL[-1]
-stopifnot(length(globalsS) == length(globalsL) - 1L)
-stopifnot(identical(class(globalsS), class(globalsL)))
-whereL <- attr(globalsL, "where")
-whereS <- attr(globalsS, "where")
-stopifnot(length(whereS) == length(whereL) - 1L)
-stopifnot(identical(whereS, whereL[-1]))
+globals_l <- globalsOf(expr, method = "liberal")
+globals_s <- globals_l[-1]
+stopifnot(length(globals_s) == length(globals_l) - 1L)
+stopifnot(identical(class(globals_s), class(globals_l)))
+where_l <- attr(globals_l, "where")
+where_s <- attr(globals_s, "where")
+stopifnot(length(where_s) == length(where_l) - 1L)
+stopifnot(identical(where_s, where_l[-1]))
message("*** cleanup() & packagesOf():")
-globals <- globalsOf(expr, method="conservative")
+globals <- globalsOf(expr, method = "conservative")
str(globals)
stopifnot(all(names(globals) %in% c("{", "<-", "c", "d")))
@@ -185,8 +202,8 @@ stopifnot(length(pkgs) == 0L)
message("*** globalsOf() and package functions:")
foo <- globals::Globals
-expr <- substitute({ foo(list(a=1)) })
-globals <- globalsOf(expr)
+expr <- substitute({ foo(list(a = 1)) })
+globals <- globalsOf(expr, recursive = FALSE)
str(globals)
stopifnot(all(names(globals) %in% c("{", "foo", "list")))
where <- attr(globals, "where")
@@ -207,10 +224,17 @@ stopifnot(pkgs == "globals")
message("*** globalsOf() and core-package functions:")
sample2 <- base::sample
sum2 <- base::sum
-expr <- substitute({ x <- sample(10); y <- sum(x); x2 <- sample2(10); y2 <- sum2(x); s <- sessionInfo() }, env=list())
-globals <- globalsOf(expr)
+expr <- substitute({
+ x <- sample(10)
+ y <- sum(x)
+ x2 <- sample2(10)
+ y2 <- sum2(x)
+ s <- sessionInfo()
+}, env = list())
+globals <- globalsOf(expr, recursive = FALSE)
str(globals)
-stopifnot(all(names(globals) %in% c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2")))
+stopifnot(all(names(globals) %in%
+ c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2")))
where <- attr(globals, "where")
stopifnot(length(where) == length(globals))
if (!covr) stopifnot(
@@ -228,17 +252,17 @@ stopifnot(length(where) == length(globals))
if (!covr) stopifnot(identical(where$sample2, globalenv()))
-globals <- cleanup(globals, drop="primitives")
+globals <- cleanup(globals, drop = "primitives")
str(globals)
stopifnot(all(names(globals) %in% c("sample2")))
message("*** globalsOf() - exceptions ...")
-rm(list="a")
+rm(list = "a")
res <- try({
- globals <- globalsOf({ x <- a }, substitute=TRUE, mustExist=TRUE)
-}, silent=TRUE)
+ globals <- globalsOf({ x <- a }, substitute = TRUE, mustExist = TRUE)
+}, silent = TRUE)
stopifnot(inherits(res, "try-error"))
message("*** globalsOf() - exceptions ... DONE")
@@ -249,11 +273,10 @@ message("*** Globals() - exceptions ...")
res <- tryCatch({ Globals(NULL) }, error = identity)
stopifnot(inherits(res, "simpleError"))
-res <- tryCatch({ Globals(list(1,2)) }, error = identity)
+res <- tryCatch({ Globals(list(1, 2)) }, error = identity)
stopifnot(inherits(res, "simpleError"))
-res <- tryCatch({ Globals(list(a=1,2)) }, error = identity)
+res <- tryCatch({ Globals(list(a = 1, 2)) }, error = identity)
stopifnot(inherits(res, "simpleError"))
message("*** Globals() - exceptions ... DONE")
-
diff --git a/tests/liberal.R b/tests/liberal.R
index 06a31c9..90ede5d 100644
--- a/tests/liberal.R
+++ b/tests/liberal.R
@@ -1,35 +1,36 @@
library("globals")
-ovars <- ls(envir=globalenv())
+ovars <- ls(envir = globalenv())
## WORKAROUND: Avoid problem reported in testthat Issue #229, which
## causes covr::package_coverage() to given an error. /HB 2015-02-16
suppressWarnings({
- rm(list=c("a", "b", "c", "x", "y", "z", "square",
+ rm(list = c("a", "b", "c", "x", "y", "z", "square",
"pathname", "url", "filename"))
})
message("Setting up expressions")
exprs <- list(
- A = substitute({ Sys.sleep(1); x <- 0.1 }, env=list()),
- B = substitute({ y <- 0.2 }, env=list()),
- C = substitute({ z <- a+0.3 }, env=list()),
- D = substitute({ pathname <- file.path(dirname(url), filename) }, env=list()),
- E = substitute({ b <- c }, env=list()),
+ A = substitute({ Sys.sleep(1); x <- 0.1 }, env = list()),
+ B = substitute({ y <- 0.2 }, env = list()),
+ C = substitute({ z <- a + 0.3 }, env = list()),
+ D = substitute({ pathname <- file.path(dirname(url), filename) },
+ env = list()),
+ E = substitute({ b <- c }, env = list()),
F = substitute({
a <- { runif(1) }
b <- { rnorm(1) }
- x <- a*b; abs(x)
- }, env=list()),
+ x <- a * b; abs(x)
+ }, env = list()),
G = substitute({
y <- square(a)
- }, env=list()),
+ }, env = list()),
H = substitute({
b <- a
a <- 1
- }, env=list())
+ }, env = list())
)
atleast <- list(
@@ -58,7 +59,7 @@ not <- list(
## Define globals
a <- 3.14
c <- 2.71
-square <- function(x) x^2
+square <- function(x) x ^ 2
filename <- "index.html"
# Yes, pretend we forget 'url'
@@ -69,13 +70,13 @@ for (kk in seq_along(exprs)) {
cat(sprintf("Expression #%d ('%s'):\n", kk, key))
print(expr)
- names <- findGlobals(expr, method="liberal")
- cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse=", ")))
+ names <- findGlobals(expr, method = "liberal")
+ cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", ")))
stopifnot(all(atleast[[key]] %in% names))
stopifnot(!any(names %in% not[[key]]))
- globals <- globalsOf(expr, method="liberal", mustExist=FALSE)
- cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse=", ")))
+ globals <- globalsOf(expr, method = "liberal", mustExist = FALSE)
+ cat(sprintf("Globals: %s\n", paste(sQuote(names(globals)), collapse = ", ")))
stopifnot(all(atleast[[key]] %in% names(globals)))
stopifnot(!any(names(globals) %in% not[[key]]))
str(globals)
@@ -83,9 +84,9 @@ for (kk in seq_along(exprs)) {
cat("\n")
}
-names <- findGlobals(exprs, method="liberal", unlist=TRUE)
-cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse=", ")))
+names <- findGlobals(exprs, method = "liberal", unlist = TRUE)
+cat(sprintf("Globals: %s\n", paste(sQuote(names), collapse = ", ")))
## Cleanup
-rm(list=setdiff(ls(envir=globalenv()), ovars), envir=globalenv())
+rm(list = setdiff(ls(envir = globalenv()), ovars), envir = globalenv())
diff --git a/tests/utils.R b/tests/utils.R
index 7ff0091..2747c86 100644
--- a/tests/utils.R
+++ b/tests/utils.R
@@ -2,12 +2,13 @@ library("globals")
message("*** utils ...")
-asFunction <- globals:::asFunction
-findBasePkgs <- globals:::findBasePkgs
-isBasePkgs <- globals:::isBasePkgs
+as_function <- globals:::as_function
+find_base_pkgs <- globals:::find_base_pkgs
+is_base_pkg <- globals:::is_base_pkg
is.base <- globals:::is.base
-is.internal <- globals:::is.internal
+is_internal <- globals:::is_internal
where <- globals:::where
+mdebug <- globals:::mdebug
## WORKAROUND: Make sure tests also work with 'covr' package
if ("covr" %in% loadedNamespaces()) {
@@ -31,34 +32,34 @@ z <- LETTERS[x]
printf("x = %s.\n", hpaste(x))
## x = 1, 2, 3, ..., 6.
-printf("x = %s.\n", hpaste(x, maxHead=2))
+printf("x = %s.\n", hpaste(x, max_head = 2))
## x = 1, 2, ..., 6.
-printf("x = %s.\n", hpaste(x), maxHead=3) # Default
+printf("x = %s.\n", hpaste(x), max_head = 3) # Default
## x = 1, 2, 3, ..., 6.
# It will never output 1, 2, 3, 4, ..., 6
-printf("x = %s.\n", hpaste(x, maxHead=4))
+printf("x = %s.\n", hpaste(x, max_head = 4))
## x = 1, 2, 3, 4, 5 and 6.
# Showing the tail
-printf("x = %s.\n", hpaste(x, maxHead=1, maxTail=2))
+printf("x = %s.\n", hpaste(x, max_head = 1, max_tail = 2))
## x = 1, ..., 5, 6.
# Turning off abbreviation
-printf("y = %s.\n", hpaste(y, maxHead=Inf))
+printf("y = %s.\n", hpaste(y, max_head = Inf))
## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
## ...or simply
-printf("y = %s.\n", paste(y, collapse=", "))
+printf("y = %s.\n", paste(y, collapse = ", "))
## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
# Change last separator
-printf("x = %s.\n", hpaste(x, lastCollapse=" and "))
+printf("x = %s.\n", hpaste(x, last_collapse = " and "))
## x = 1, 2, 3, 4, 5 and 6.
# No collapse
-stopifnot(all(hpaste(x, collapse=NULL) == x))
+stopifnot(all(hpaste(x, collapse = NULL) == x))
# Empty input
stopifnot(identical(hpaste(character(0)), character(0)))
@@ -66,63 +67,63 @@ stopifnot(identical(hpaste(character(0)), character(0)))
message("* hpaste() ... DONE")
-message("* asFunction() ...")
-fcn <- asFunction({ 1 })
+message("* as_function() ...")
+fcn <- as_function({ 1 })
print(fcn())
stopifnot(fcn() == 1)
-message("* findBasePkgs() & isBasePkgs() ...")
-basePkgs <- findBasePkgs()
-print(basePkgs)
-stopifnot(length(basePkgs) > 1L)
-for (pkg in basePkgs) {
- stopifnot(isBasePkgs(pkg))
+message("* find_base_pkgs() & is_base_pkg() ...")
+base_pkgs <- find_base_pkgs()
+print(base_pkgs)
+stopifnot(length(base_pkgs) > 1L)
+for (pkg in base_pkgs) {
+ stopifnot(is_base_pkg(pkg))
}
-stopifnot(!isBasePkgs("globals"))
+stopifnot(!is_base_pkg("globals"))
-message("* is.base() & is.internal() ...")
+message("* is.base() & is_internal() ...")
stopifnot(is.base(base::library))
stopifnot(!is.base(globals::globalsOf))
stopifnot(!is.base(NULL))
-stopifnot(is.internal(print.default))
-stopifnot(!is.internal(globals::globalsOf))
-stopifnot(!is.internal(NULL))
+stopifnot(is_internal(print.default))
+stopifnot(!is_internal(globals::globalsOf))
+stopifnot(!is_internal(NULL))
message("* where() ...")
-env <- where("sample", where=1L)
+env <- where("sample", where = 1L)
str(env)
-env <- where("sample", frame=1L)
+env <- where("sample", frame = 1L)
str(env)
message("- where('sample') ...")
-env <- where("sample", mode="function")
+env <- where("sample", mode = "function")
print(env)
if (!"covr" %in% loadedNamespaces()) {
stopifnot(identical(env, baseenv()))
}
-obj <- get("sample", mode="function", envir=env, inherits=FALSE)
+obj <- get("sample", mode = "function", envir = env, inherits = FALSE)
stopifnot(identical(obj, base::sample))
-message("- where('sample', mode='integer') ...")
-env <- where("sample", mode="integer")
+message("- where('sample', mode = 'integer') ...")
+env <- where("sample", mode = "integer")
print(env)
stopifnot(is.null(env))
message("- where('sample2') ...")
sample2 <- base::sample
-env <- where("sample2", mode="function")
+env <- where("sample2", mode = "function")
print(env)
stopifnot(identical(env, environment()))
-obj <- get("sample2", mode="function", envir=env, inherits=FALSE)
+obj <- get("sample2", mode = "function", envir = env, inherits = FALSE)
stopifnot(identical(obj, sample2))
@@ -130,8 +131,9 @@ message("- where() - local objects of functions ...")
aa <- 1
foo <- function() {
- bb <- 2
- list(aa=where("aa"), bb=where("bb"), cc=where("cc"), envir=environment())
+ bb <- 2 #nolint
+ list(aa = where("aa"), bb = where("bb"), cc = where("cc"),
+ envir = environment())
}
envs <- foo()
@@ -141,12 +143,20 @@ stopifnot(identical(envs$bb, envs$envir))
stopifnot(is.null(envs$cc))
message("- where() - missing ...")
-env <- where("non-existing-object", inherits=FALSE)
+env <- where("non-existing-object", inherits = FALSE)
stopifnot(is.null(env))
-rm(list=c("aa", "envs", "foo", "env", "obj", "where"))
+rm(list = c("aa", "envs", "foo", "env", "obj", "where"))
message("* where() ... DONE")
-message("*** utils ... DONE")
+message("- mdebug() ...")
+
+mdebug("Message A")
+oopts <- options(globals.debug = TRUE)
+mdebug("Message B")
+options(oopts)
+message("* mdebug() ... DONE")
+
+message("*** utils ... DONE")
diff --git a/tests/walkAST.R b/tests/walkAST.R
index 245c820..f744e48 100644
--- a/tests/walkAST.R
+++ b/tests/walkAST.R
@@ -3,26 +3,38 @@ library("globals")
message("*** walkAST() ...")
exprs <- list(
- null = substitute(NULL),
- atomic = substitute(1),
- atomic = substitute("a"),
- atomic = substitute(TRUE),
- assign = substitute(a <- 1),
- assign = substitute(1 -> a),
- assign = substitute(a <- b + 1),
- assign = substitute(x <- rnorm(20, mu=0)),
- index = substitute(x[1,1]),
- index = substitute(x[1:2,1:2]),
- index = substitute(x[,1:2]),
- index = substitute(x[,1]),
- fcn = substitute(function(a=1, b=2) sum(c(a, b))),
- fcn = substitute(function(a=1, b) sum(c(a, b))),
- fcn = substitute(function(a=1, b=2, ...) sum(c(a, b, ...))),
- fcn = substitute(function(a=NULL) a),
- ok = substitute(function(...) sum(x, ...)),
- warn = substitute(sum(x, ...)),
- null = substitute(NULL)
+ null = substitute(NULL),
+ atomic = substitute(1),
+ atomic = substitute("a"),
+ atomic = substitute(TRUE),
+ assign = substitute(a <- 1),
+ assign = substitute(1 -> a),
+ assign = substitute(a <- b + 1),
+ assign = substitute(x <- rnorm(20, mu = 0)),
+ index = substitute(x[1, 1]),
+ index = substitute(x[1:2, 1:2]),
+ index = substitute(x[, 1:2]),
+ index = substitute(x[, 1]),
+ fcn = substitute(function(a = 1, b = 2) sum(c(a, b))),
+ fcn = substitute(function(a = 1, b) sum(c(a, b))),
+ fcn = substitute(function(a = 1, b = 2, ...) sum(c(a, b, ...))),
+ fcn = substitute(function(a = NULL) a),
+ ok = substitute(function(...) sum(x, ...)),
+ warn = substitute(sum(x, ...)),
+ null = substitute(NULL),
+ builtin = base::length,
+ closure = function() NULL,
+ closure = function() a,
+ closure = function(x = 0) a * x,
+ special = base::log,
+ list = substitute(FUN(a = A), list(A = list())),
+ pairlist = substitute(FUN(a = A), list(A = pairlist(a = 1))),
+ expression = substitute(FUN(a = A), list(A = expression()))
+# environment = new.env()
)
+if (requireNamespace("methods")) {
+ exprs$s4 <- methods::getClass("MethodDefinition")
+}
nullify <- function(e) NULL
@@ -32,8 +44,10 @@ disp <- function(expr) {
cat("str():\n")
str(expr)
cat(sprintf("typeof: %s\n", typeof(expr)))
- cat("as.list():\n")
- str(as.list(expr))
+ if (is.recursive(expr)) {
+ cat("as.list():\n")
+ str(as.list(expr))
+ }
expr
} ## disp()
@@ -41,49 +55,60 @@ for (kk in seq_along(exprs)) {
name <- names(exprs)[kk]
message(sprintf("- walkAST(<expression #%d (%s)>) ...", kk, sQuote(name)))
expr <- exprs[[kk]]
- print(expr)
- str(as.list(expr))
+ disp(expr)
## Assert identity (default behavior)
- exprI <- walkAST(expr)
- str(as.list(exprI))
- res <- all.equal(exprI, expr)
- print(res)
- if (!identical(exprI, expr)) saveRDS(list(expr=expr, exprI=exprI), file="/tmp/foo.rds")
- stopifnot(length(exprI) == length(expr), identical(exprI, expr))
+ expr_i <- walkAST(expr)
+ disp(expr_i)
+ stopifnot(length(expr_i) == length(expr), identical(expr_i, expr))
## Display the AST tree
- walkAST(expr, atomic=disp, name=disp, call=disp, pairlist=disp)
+ walkAST(expr, atomic = disp, name = disp, call = disp, pairlist = disp)
## Nullify
- exprN <- walkAST(expr, atomic=nullify, name=nullify, call=nullify, pairlist=nullify)
- print(exprN)
- str(as.list(exprN))
-
+ expr_n <- walkAST(expr, atomic = nullify, name = nullify,
+ call = nullify, pairlist = nullify)
+ disp(expr_n)
-message("*** walkAST() - nullify ... DONE")
+ message("*** walkAST() - nullify ... DONE")
- message(sprintf("- walkAST(<expression #%d (%s)>) ... DONE", kk, sQuote(name)))
+ message(sprintf("- walkAST(<expression #%d (%s)>) ... DONE",
+ kk, sQuote(name)))
} ## for (name ...)
-message("*** walkAST() - substitute=TRUE ...")
+message("*** walkAST() - substitute = TRUE ...")
-expr <- walkAST(a <- 1, substitute=TRUE)
+expr <- walkAST(a <- 1, substitute = TRUE)
print(expr)
-message("*** walkAST() - substitute=TRUE ... DONE")
+message("*** walkAST() - substitute = TRUE ... DONE")
message("*** walkAST() - exceptions ...")
+f <- function(...) get("...")
+expr <- f(NULL)
+
+options(globals.walkAST.onUnknownType = "error")
res <- tryCatch({
- expr <- walkAST(list())
+ walkAST(expr)
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))
+options(globals.walkAST.onUnknownType = "warning")
+foo <- walkAST(expr)
+
+res <- tryCatch({
+ walkAST(expr)
+}, warning = identity)
+print(res)
+stopifnot(inherits(res, "simpleWarning"))
+
+options(globals.walkAST.onUnknownType = "error")
+
message("*** walkAST() - exceptions ... DONE")
message("*** walkAST() ... DONE")
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-globals.git
More information about the debian-med-commit
mailing list