[med-svn] [r-cran-globals] 01/02: Imported Upstream version 0.6.1
Michael Crusoe
misterc-guest at moszumanska.debian.org
Sat Jun 25 23:55:08 UTC 2016
This is an automated email from the git hooks/post-receive script.
misterc-guest pushed a commit to branch master
in repository r-cran-globals.
commit 8e1a0f2de6b66daa1f7497fc870cb7eb9cf42dab
Author: Michael R. Crusoe <crusoe at ucdavis.edu>
Date: Sat Jun 25 16:36:18 2016 -0700
Imported Upstream version 0.6.1
---
DESCRIPTION | 24 ++++++
MD5 | 19 +++++
NAMESPACE | 17 ++++
NEWS | 72 ++++++++++++++++
R/Globals-class.R | 50 +++++++++++
R/cleanup.R | 45 ++++++++++
R/findGlobals.R | 140 +++++++++++++++++++++++++++++++
R/globalsOf.R | 95 +++++++++++++++++++++
R/packagesOf.R | 37 ++++++++
R/utils.R | 100 ++++++++++++++++++++++
README.md | 19 +++++
man/Globals.Rd | 28 +++++++
man/cleanup.Globals.Rd | 20 +++++
man/globalsOf.Rd | 76 +++++++++++++++++
man/packagesOf.Globals.Rd | 21 +++++
tests/conservative.R | 91 ++++++++++++++++++++
tests/dotdotdot.R | 209 ++++++++++++++++++++++++++++++++++++++++++++++
tests/globalsOf.R | 180 +++++++++++++++++++++++++++++++++++++++
tests/liberal.R | 91 ++++++++++++++++++++
tests/utils.R | 136 ++++++++++++++++++++++++++++++
20 files changed, 1470 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..0f9a11e
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,24 @@
+Package: globals
+Version: 0.6.1
+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.
+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
+NeedsCompilation: no
+Packaged: 2016-02-03 06:35:36 UTC; hb
+Author: Henrik Bengtsson [aut, cre, cph]
+Maintainer: Henrik Bengtsson <henrikb at braju.com>
+Repository: CRAN
+Date/Publication: 2016-02-03 12:26:20
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..58acd95
--- /dev/null
+++ b/MD5
@@ -0,0 +1,19 @@
+ff516fd4c49cfd3807baa82d4d0cd113 *DESCRIPTION
+fa86d5707883f776e460df2d0ab86403 *NAMESPACE
+63820c16cc7597cd5233728495f1e1eb *NEWS
+7556d0412a854a17730afcac56259e6f *R/Globals-class.R
+d0e7cb156704a70b97e50e3bd7c8c34e *R/cleanup.R
+8d3fe54f9457bec3553e7d32dd8da76c *R/findGlobals.R
+6c662e51ebb5f4e10bda6aaf595dd7bd *R/globalsOf.R
+872b7b7be000da61e173d5be37df37c1 *R/packagesOf.R
+f5298931e3d28825ed127ab1426fd2b9 *R/utils.R
+55017055e1f1b4d3b56e75cceaf29c16 *README.md
+7e270fef5b03b44d97fd1076681eca76 *man/Globals.Rd
+8ff7d3934be276a7df5b3b993d4b8ef2 *man/cleanup.Globals.Rd
+79e73476957d6fa97778691ab9b30516 *man/globalsOf.Rd
+937c4cb33fb344a0c74330cd162a285c *man/packagesOf.Globals.Rd
+0a4fd4c3594bcf15e685886e0475e528 *tests/conservative.R
+b840f7e78850bd3a4af136f8649bf05a *tests/dotdotdot.R
+a54c80af61326308c5d6625b712021d3 *tests/globalsOf.R
+04ee391b83ac7278c0040be00d32756b *tests/liberal.R
+c2774d49049724b5e147ddccc793e9e4 *tests/utils.R
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..9778d5f
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,17 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method("[",Globals)
+S3method(as.Globals,Globals)
+S3method(as.Globals,list)
+S3method(cleanup,Globals)
+S3method(packagesOf,Globals)
+export(Globals)
+export(as.Globals)
+export(cleanup)
+export(findGlobals)
+export(globalsOf)
+export(packagesOf)
+importFrom(codetools,findLocalsList)
+importFrom(codetools,makeUsageCollector)
+importFrom(codetools,walkCode)
+importFrom(utils,installed.packages)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..754bb06
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,72 @@
+Package: globals
+================
+
+Version: 0.6.1 [2016-01-31]
+o Now the error message of globalsOf(..., mustExist=TRUE) when
+ it fails to locate a global also gives information on the
+ expression that is problematic.
+o BUG FIX: cleanup() for Globals did not cleanup functions
+ in core package environments named 'package:<name>'.
+
+
+Version: 0.6.0 [2015-12-12]
+o findGlobals() is updated to handle the case where a local
+ variable is overwriting a global one with the same name,
+ e.g. { a <- b; b <- 1 }. Now 'b' is correctly identified
+ as a global object. Previously it would have been missed.
+ For backward compatibility, the previous behavior can be
+ obtained using argument method="conservative".
+
+
+Version: 0.5.0 [2015-10-13]
+o globalsOf() now returns attribute 'where' specifying where
+ each global object is located.
+o BUG FIX: cleanup() now only drops objects that are *located*
+ in one of the "base" packages; previously it would also drop
+ copies of such objects, e.g. FUN <- base::sample.
+
+
+Version: 0.4.1 [2015-10-05]
+o BUG FIX: globalsOf() failed to return global variables
+ with value NULL. They were identified but silently dropped.
+
+
+Version: 0.4.0 [2015-09-12]
+o findGlobals() and globalsOf() gained argument 'dotdotdot'.
+o Explicit namespace imports also from 'utils' package.
+
+
+Version: 0.3.1 [2015-06-10]
+o More test coverage.
+
+
+Version: 0.3.0 [2015-06-08]
+o Renamed getGlobals() to globalsOf().
+
+
+Version: 0.2.3 [2015-06-08]
+o Added [() for Globals.
+o findGlobals() and getGlobals() gained argument 'substitute'.
+o Added cleanup(..., method="internals").
+
+
+Version: 0.2.2 [2015-05-20]
+o Added Globals class with methods cleanup() and packagesOf().
+ Added as.Globals() to coerce lists to Globals objects.
+
+
+Version: 0.2.1 [2015-05-20]
+o getGlobals() gained argument 'mustExist' for controlling whether
+ to give an error when the corresponding object for an identified
+ global cannot be found or to silently drop the missing global.
+o findGlobals() and getGlobals() gained argument 'method' for
+ controlling whether a "conservative" or a "liberal" algorithm
+ for identifying true globals should be used.
+
+
+Version: 0.2.0 [2015-05-19]
+o Moved globals function from an in-house package to this package.
+
+
+Version: 0.1.0 [2015-02-07]
+o Created.
diff --git a/R/Globals-class.R b/R/Globals-class.R
new file mode 100644
index 0000000..1313f37
--- /dev/null
+++ b/R/Globals-class.R
@@ -0,0 +1,50 @@
+#' A representation of a set of globals
+#'
+#' @usage Globals(object, ...)
+#'
+#' @param object A named list.
+#' @param \dots Not used.
+#'
+#' @return An object of class \code{Future}.
+#'
+#' @seealso
+#' The \code{\link{globalsOf}()} function identifies globals
+#' from an R expression and returns a Globals object.
+#'
+#' @aliases as.Globals as.Globals.Globals as.Globals.list [.Globals
+#' @export
+Globals <- function(object, ...) {
+ if (!is.list(object)) {
+ stop("Argument 'object' is not a list: ", class(object)[1])
+ }
+
+ names <- names(object)
+ if (is.null(names)) {
+ stop("Argument 'object' must be a named list.")
+ } else if (!all(nzchar(names))) {
+ stop("Argument 'object' specifies globals with empty names.")
+ }
+
+ structure(object, class=c(class(object), "Globals"))
+}
+
+#' @export
+as.Globals <- function(x, ...) UseMethod("as.Globals")
+
+#' @export
+as.Globals.Globals <- function(x, ...) x
+
+#' @export
+as.Globals.list <- function(x, ...) {
+ Globals(x, ...)
+}
+
+
+#' @export
+`[.Globals` <- function(x, i) {
+ where <- attr(x, "where")
+ res <- NextMethod("[")
+ attr(res, "where") <- where[i]
+ class(res) <- class(x)
+ res
+}
diff --git a/R/cleanup.R b/R/cleanup.R
new file mode 100644
index 0000000..caba05f
--- /dev/null
+++ b/R/cleanup.R
@@ -0,0 +1,45 @@
+#' @export
+cleanup <- function(...) UseMethod("cleanup")
+
+#' Drop certain types of globals
+#'
+#' @param globals A Globals object.
+#' @param drop A character vector specifying what type of globals to drop.
+#' @param \dots Not used
+#'
+#' @aliases cleanup
+#' @export
+cleanup.Globals <- function(globals, drop=c("base-packages"), ...) {
+ where <- attr(globals, "where")
+
+ names <- names(globals)
+ keep <- rep(TRUE, times=length(globals))
+ names(keep) <- names
+
+ ## 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
+ }
+ }
+
+ ## Drop objects that are primitive functions
+ if ("primitives" %in% drop) {
+ for (name in names) {
+ if (is.primitive(globals[[name]])) keep[name] <- FALSE
+ }
+ }
+
+ ## Drop objects that calls .Internal()
+ if ("internals" %in% drop) {
+ for (name in names) {
+ if (is.internal(globals[[name]])) keep[name] <- FALSE
+ }
+ }
+
+ if (!all(keep)) {
+ globals <- globals[keep]
+ }
+
+ globals
+} # cleanup()
diff --git a/R/findGlobals.R b/R/findGlobals.R
new file mode 100644
index 0000000..8bfe7d3
--- /dev/null
+++ b/R/findGlobals.R
@@ -0,0 +1,140 @@
+## This function is equivalent to:
+## fun <- asFunction(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, ...) {
+ objs <- character()
+
+ enter <- function(type, v, e, w) {
+ objs <<- c(objs, v)
+ }
+
+ ## From codetools::findGlobals():
+ fun <- asFunction(expr, envir=envir, ...)
+ # codetools::collectUsage(fun, enterGlobal=enter)
+
+ ## The latter becomes equivalent to (after cleanup):
+ w <- makeUsageCollector(fun, enterGlobal=enter, name="<anonymous>")
+ w$env <- new.env(hash=TRUE, parent=w$env)
+ locals <- findLocalsList(list(expr))
+ for (name in locals) assign(name, value=TRUE, envir=w$env)
+ walkCode(expr, w)
+
+ unique(objs)
+}
+
+
+#' @importFrom codetools makeUsageCollector walkCode
+findGlobals_liberal <- function(expr, envir, ...) {
+ objs <- character()
+
+ enter <- function(type, v, e, w) {
+ objs <<- c(objs, v)
+ }
+
+ fun <- asFunction(expr, envir=envir, ...)
+
+ w <- makeUsageCollector(fun, enterGlobal=enter, name="<anonymous>")
+ walkCode(expr, w)
+
+ unique(objs)
+}
+
+
+#' @importFrom codetools makeUsageCollector walkCode
+findGlobals_ordered <- function(expr, envir, ...) {
+ class <- name <- character()
+
+ enterLocal <- function(type, v, e, w) {
+ class <<- c(class, "local")
+ name <<- c(name, v)
+ }
+
+ enterGlobal <- function(type, v, e, w) {
+ class <<- c(class, "global")
+ name <<- c(name, v)
+ }
+
+ fun <- asFunction(expr, envir=envir, ...)
+
+ w <- makeUsageCollector(fun, name="<anonymous>",
+ enterLocal=enterLocal, enterGlobal=enterGlobal)
+ walkCode(expr, w)
+
+ ## Drop duplicated names
+ dups <- duplicated(name)
+ class <- class[!dups]
+ name <- name[!dups]
+
+ unique(name[class == "global"])
+}
+
+
+#' @export
+findGlobals <- function(expr, envir=parent.frame(), ..., tweak=NULL, dotdotdot=c("warning", "error", "return", "ignore"), method=c("ordered", "conservative", "liberal"), substitute=FALSE, unlist=TRUE) {
+ method <- match.arg(method)
+ dotdotdot <- match.arg(dotdotdot)
+
+ if (substitute) expr <- substitute(expr)
+
+ if (is.list(expr)) {
+ globals <- lapply(expr, FUN=findGlobals, envir=envir, ..., tweak=tweak, dotdotdot=dotdotdot, substitute=FALSE, unlist=FALSE)
+ if (unlist) {
+ needsDotdotdot <- FALSE
+ for (kk in seq_along(globals)) {
+ s <- globals[[kk]]
+ n <- length(s)
+ if (identical(s[n], "...")) {
+ needsDotdotdot <- TRUE
+ s <- s[-n]
+ globals[[kk]] <- s
+ }
+ }
+ globals <- unlist(globals, use.names=TRUE)
+ globals <- sort(unique(globals))
+ if (needsDotdotdot) globals <- c(globals, "...")
+ }
+ return(globals)
+ }
+
+ if (is.function(tweak)) expr <- tweak(expr)
+
+ if (method == "ordered") {
+ findGlobalsT <- findGlobals_ordered
+ } else if (method == "conservative") {
+ findGlobalsT <- findGlobals_conservative
+ } else if (method == "liberal") {
+ findGlobalsT <- findGlobals_liberal
+ }
+
+ ## Is there a need for global '...' variables?
+ needsDotdotdot <- FALSE
+ globals <- withCallingHandlers({
+ oopts <- options(warn=0L)
+ on.exit(options(oopts))
+ findGlobalsT(expr, envir=envir)
+ }, warning=function(w) {
+ ## Warned about '...'?
+ pattern <- "... may be used in an incorrect context"
+ if (grepl(pattern, w$message, fixed=TRUE)) {
+ needsDotdotdot <<- TRUE
+ if (dotdotdot == "return") {
+ ## Consume / muffle warning
+ invokeRestart("muffleWarning")
+ } else if (dotdotdot == "ignore") {
+ needsDotdotdot <<- FALSE
+ ## Consume / muffle warning
+ invokeRestart("muffleWarning")
+ } else if (dotdotdot == "error") {
+ e <- simpleError(w$message, w$call)
+ stop(e)
+ }
+ }
+ })
+
+ if (needsDotdotdot) globals <- c(globals, "...")
+
+ globals
+}
diff --git a/R/globalsOf.R b/R/globalsOf.R
new file mode 100644
index 0000000..a535b23
--- /dev/null
+++ b/R/globalsOf.R
@@ -0,0 +1,95 @@
+#' Get all global objects of an expression
+#'
+#' @param expr An R expression.
+#' @param envir The environment from where to search for globals.
+#' @param \dots Not used.
+#' @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.
+## @param dotdotdot A @character string specifying how to handle a
+## \emph{global} \code{\dots} if one is discovered.
+#' @param substitute If TRUE, the expression is \code{substitute()}:ed,
+#' otherwise not.
+#' @param mustExist If TRUE, an error is thrown if the object of the
+#' identified global cannot be located. Otherwise, the global
+#' is not returned.
+#' @param unlist If TRUE, a list of unique objects is returned.
+#' If FALSE, a list of \code{length(expr)} sublists.
+#'
+#' @return A \link{Globals} object.
+#'
+#' @details
+#' There currently three methods for identifying global objects.
+#'
+#' The \code{"ordered"} search method identifies globals such that
+#' a global variable preceeding a local variable with the same name
+#' is not dropped (which the \code{"conservative"} method would).
+#'
+#' The \code{"conservative"} search method tries to keep the number
+#' of false positive to a minimum, i.e. the identified objects are
+#' most likely true global objects. At the same time, there is
+#' a risk that some true globals are not identified (see example).
+#' This search method returns the exact same result as the
+#' \code{\link[codetools]{findGlobals}()} function of the
+#' \pkg{codetools} package.
+#'
+#' The \code{"liberal"} search method tries to keep the
+#' true-positive ratio as high as possible, i.e. the true globals
+#' are most likely among the identified ones. At the same time,
+#' there is a risk that some false positives are also identified.
+#'
+#' @example incl/globalsOf.R
+#'
+#' @seealso
+#' Internally, the \pkg{\link{codetools}} package is utilized for
+#' code inspections.
+#'
+#' @aliases findGlobals
+#' @export
+globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "conservative", "liberal"), tweak=NULL, substitute=FALSE, mustExist=TRUE, unlist=TRUE) {
+ method <- match.arg(method)
+
+ if (substitute) expr <- substitute(expr)
+
+ names <- findGlobals(expr, envir=envir, ..., method=method, tweak=tweak, substitute=FALSE, unlist=unlist)
+
+ n <- length(names)
+ needsDotdotdot <- (identical(names[n], "..."))
+ if (needsDotdotdot) names <- names[-n]
+
+ globals <- structure(list(), class=c("Globals", "list"))
+ where <- list()
+ for (name in names) {
+ env <- where(name, envir=envir, inherits=TRUE)
+ if (!is.null(env)) {
+ where[[name]] <- env
+ value <- get(name, envir=env, inherits=FALSE)
+ if (is.null(value)) {
+ globals[name] <- list(NULL)
+ } else {
+ globals[[name]] <- value
+ }
+ } else {
+ where[name] <- list(NULL)
+ if (mustExist) {
+ stop(sprintf("Identified a global object via static code inspection (%s), but failed to locate the corresponding object in the relevant environments: %s", hexpr(expr), sQuote(name)))
+ }
+ }
+ }
+
+ if (needsDotdotdot) {
+ 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
+ }
+ class(ddd) <- c("DotDotDotList", class(ddd))
+ globals[["..."]] <- ddd
+ }
+
+ attr(globals, "where") <- where
+
+ globals
+}
diff --git a/R/packagesOf.R b/R/packagesOf.R
new file mode 100644
index 0000000..728f7c0
--- /dev/null
+++ b/R/packagesOf.R
@@ -0,0 +1,37 @@
+#' @export
+packagesOf <- function(...) UseMethod("packagesOf")
+
+#' Identify the packages of the globals
+#'
+#' @param globals A Globals object.
+#' @param \dots Not used.
+#'
+#' @return Returns a character vector of package names.
+#'
+#' @aliases packagesOf
+#' @export
+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) {
+ environmentName(environment(obj))
+ })
+
+ ## Drop "missing" packages, e.g. globals in globalenv().
+ pkgs <- pkgs[nzchar(pkgs)]
+
+ ## Drop global environment
+ pkgs <- pkgs[pkgs != "R_GlobalEnv"]
+
+ ## Keep only names matching loaded namespaces
+ pkgs <- intersect(pkgs, loadedNamespaces())
+
+ ## Packages to be loaded
+ pkgs <- sort(unique(pkgs))
+
+ ## Sanity check
+ stopifnot(all(nzchar(pkgs)))
+
+ pkgs
+} # packagesOf()
+
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 0000000..5590672
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,100 @@
+asFunction <- function(expr, envir=parent.frame(), ...) {
+ eval(substitute(function() x, list(x=expr)), envir=envir, ...)
+}
+
+#' @importFrom utils installed.packages
+findBasePkgs <- local({
+ pkgs <- NULL
+ function() {
+ if (length(pkgs) > 0L) return(pkgs)
+ data <- installed.packages()
+ isBase <- (data[,"Priority"] %in% "base")
+ pkgs <<- rownames(data)[isBase]
+ pkgs
+ }
+})
+
+isBasePkgs <- function(pkgs) {
+ pkgs <- gsub("^package:", "", pkgs)
+ pkgs %in% findBasePkgs()
+}
+
+# cf. is.primitive()
+is.base <- function(x) {
+ if (typeof(x) != "closure") return(FALSE)
+ isBasePkgs(environmentName(environment(x)))
+}
+
+# cf. is.primitive()
+is.internal <- function(x) {
+ if (typeof(x) != "closure") return(FALSE)
+ body <- deparse(body(x))
+ 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
+
+ # Build vector 'x'
+ x <- paste(..., sep=sep)
+ n <- length(x)
+
+ # Nothing todo?
+ if (n == 0) return(x)
+ if (is.null(collapse)) return(x)
+
+ # Abbreviate?
+ if (n > maxHead + maxTail + 1) {
+ head <- x[seq(length=maxHead)]
+ tail <- rev(rev(x)[seq(length=maxTail)])
+ x <- c(head, abbreviate, tail)
+ n <- length(x)
+ }
+
+ if (!is.null(collapse) && n > 1) {
+ if (lastCollapse == collapse) {
+ x <- paste(x, collapse=collapse)
+ } else {
+ xT <- paste(x[1:(n-1)], collapse=collapse)
+ x <- paste(xT, x[n], sep=lastCollapse)
+ }
+ }
+
+ x
+} # hpaste()
+
+
+## From future 0.11.0
+trim <- function(s) {
+ sub("[\t\n\f\r ]+$", "", sub("^[\t\n\f\r ]+", "", s))
+} # trim()
+
+
+## From future 0.11.0
+hexpr <- function(expr, trim=TRUE, collapse="; ", maxHead=6L, maxTail=3L, ...) {
+ code <- deparse(expr)
+ if (trim) code <- trim(code)
+ hpaste(code, collapse=collapse, maxHead=maxHead, maxTail=maxTail, ...)
+} # hexpr()
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..344cba7
--- /dev/null
+++ b/README.md
@@ -0,0 +1,19 @@
+# globals: Identify Global Objects in R Expressions
+
+
+## Installation
+R package globals is available on [CRAN](http://cran.r-project.org/package=globals) and can be installed in R as:
+```r
+install.packages('globals')
+```
+
+
+
+
+## Software status
+
+| Resource: | CRAN | Travis CI | Appveyor |
+| ------------- | ------------------- | ------------- | ---------------- |
+| _Platforms:_ | _Multiple_ | _Linux_ | _Windows_ |
+| R CMD check | <a href="http://cran.r-project.org/web/checks/check_results_globals.html"><img border="0" src="http://www.r-pkg.org/badges/version/globals" alt="CRAN version"></a> | <a href="https://travis-ci.org/HenrikBengtsson/globals"><img src="https://travis-ci.org/HenrikBengtsson/globals.svg" alt="Build status"></a> | <a href="https://ci.appveyor.com/project/HenrikBengtsson/globals"><img src="https://ci.appveyor.com/api/projects/status/github/HenrikBengtsson/globals?svg=true" alt= [...]
+| Test coverage | | <a href="https://coveralls.io/r/HenrikBengtsson/globals"><img src="https://coveralls.io/repos/HenrikBengtsson/globals/badge.svg?branch=develop" alt="Coverage Status"/></a> | |
diff --git a/man/Globals.Rd b/man/Globals.Rd
new file mode 100644
index 0000000..333a25e
--- /dev/null
+++ b/man/Globals.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% 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}
+\title{A representation of a set of globals}
+\usage{
+Globals(object, ...)
+}
+\arguments{
+\item{object}{A named list.}
+
+\item{\dots}{Not used.}
+}
+\value{
+An object of class \code{Future}.
+}
+\description{
+A representation of a set of globals
+}
+\seealso{
+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
new file mode 100644
index 0000000..3810738
--- /dev/null
+++ b/man/cleanup.Globals.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/cleanup.R
+\name{cleanup.Globals}
+\alias{cleanup}
+\alias{cleanup.Globals}
+\title{Drop certain types of globals}
+\usage{
+\method{cleanup}{Globals}(globals, drop = c("base-packages"), ...)
+}
+\arguments{
+\item{globals}{A Globals object.}
+
+\item{drop}{A character vector specifying what type of globals to drop.}
+
+\item{\dots}{Not used}
+}
+\description{
+Drop certain types of globals
+}
+
diff --git a/man/globalsOf.Rd b/man/globalsOf.Rd
new file mode 100644
index 0000000..fc569f8
--- /dev/null
+++ b/man/globalsOf.Rd
@@ -0,0 +1,76 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/globalsOf.R
+\name{globalsOf}
+\alias{findGlobals}
+\alias{globalsOf}
+\title{Get all global objects of an expression}
+\usage{
+globalsOf(expr, envir = parent.frame(), ..., method = c("ordered",
+ "conservative", "liberal"), tweak = NULL, substitute = FALSE,
+ mustExist = TRUE, unlist = TRUE)
+}
+\arguments{
+\item{expr}{An R expression.}
+
+\item{envir}{The environment from where to search for globals.}
+
+\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.}
+
+\item{substitute}{If TRUE, the expression is \code{substitute()}:ed,
+otherwise not.}
+
+\item{mustExist}{If TRUE, an error is thrown if the object of the
+identified global cannot be located. Otherwise, the global
+is not returned.}
+
+\item{unlist}{If TRUE, a list of unique objects is returned.
+If FALSE, a list of \code{length(expr)} sublists.}
+
+\item{\dots}{Not used.}
+}
+\value{
+A \link{Globals} object.
+}
+\description{
+Get all global objects of an expression
+}
+\details{
+There currently three methods for identifying global objects.
+
+The \code{"ordered"} search method identifies globals such that
+a global variable preceeding a local variable with the same name
+is not dropped (which the \code{"conservative"} method would).
+
+The \code{"conservative"} search method tries to keep the number
+of false positive to a minimum, i.e. the identified objects are
+most likely true global objects. At the same time, there is
+a risk that some true globals are not identified (see example).
+This search method returns the exact same result as the
+\code{\link[codetools]{findGlobals}()} function of the
+\pkg{codetools} package.
+
+The \code{"liberal"} search method tries to keep the
+true-positive ratio as high as possible, i.e. the true globals
+are most likely among the identified ones. At the same time,
+there is a risk that some false positives are also identified.
+}
+\examples{
+b <- 2
+expr <- substitute({ a <- b; b <- 1 })
+
+## Will _not_ identify 'b' (because it's also a local)
+globalsC <- globalsOf(expr, method="conservative")
+print(globalsC)
+
+## Will identify 'b'
+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
new file mode 100644
index 0000000..a6ff561
--- /dev/null
+++ b/man/packagesOf.Globals.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/packagesOf.R
+\name{packagesOf.Globals}
+\alias{packagesOf}
+\alias{packagesOf.Globals}
+\title{Identify the packages of the globals}
+\usage{
+\method{packagesOf}{Globals}(globals, ...)
+}
+\arguments{
+\item{globals}{A Globals object.}
+
+\item{\dots}{Not used.}
+}
+\value{
+Returns a character vector of package names.
+}
+\description{
+Identify the packages of the globals
+}
+
diff --git a/tests/conservative.R b/tests/conservative.R
new file mode 100644
index 0000000..ad71b97
--- /dev/null
+++ b/tests/conservative.R
@@ -0,0 +1,91 @@
+library("globals")
+
+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",
+ "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()),
+ F = substitute({
+ a <- { runif(1) }
+ b <- { rnorm(1) }
+ x <- a*b; abs(x)
+ }, env=list()),
+ G = substitute({
+ y <- square(a)
+ }, env=list()),
+ H = substitute({
+ b <- a
+ a <- 1
+ }, env=list())
+)
+
+atleast <- list(
+ A = c(),
+ B = c(),
+ C = c("a"),
+ D = c("filename"),
+ E = c("c"),
+ F = c(),
+ G = c("a", "square"),
+ H = c() ## FIXME: Should be c("a"), cf. Issue #5.
+)
+
+not <- list(
+ A = c("x"),
+ B = c("y"),
+ C = c("z"),
+ D = c("pathname"),
+ E = c("b"),
+ F = c("a", "b", "x"),
+ G = c(),
+ H = c()
+)
+
+
+## Define globals
+a <- 3.14
+c <- 2.71
+square <- function(x) x^2
+filename <- "index.html"
+# Yes, pretend we forget 'url'
+
+message("Find globals")
+for (kk in seq_along(exprs)) {
+ key <- names(exprs)[kk]
+ expr <- exprs[[key]]
+ cat(sprintf("Expression #%d ('%s'):\n", kk, key))
+ print(expr)
+
+ 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=", ")))
+ stopifnot(all(atleast[[key]] %in% names(globals)))
+ stopifnot(!any(names(globals) %in% not[[key]]))
+ str(globals)
+
+ cat("\n")
+}
+
+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())
diff --git a/tests/dotdotdot.R b/tests/dotdotdot.R
new file mode 100644
index 0000000..253580c
--- /dev/null
+++ b/tests/dotdotdot.R
@@ -0,0 +1,209 @@
+library("globals")
+opts <- options(warn=1L)
+
+exprs <- list(
+ ok = substitute(function(...) sum(x, ...)),
+ warn = substitute(sum(x, ...))
+)
+
+
+message("*** findGlobals() ...")
+
+
+for (name in names(exprs)) {
+ expr <- exprs[[name]]
+
+ message("\n*** codetools::findGlobals():")
+ fun <- globals:::asFunction(expr)
+ print(fun)
+ globals <- codetools::findGlobals(fun)
+ print(globals)
+ stopifnot(all.equal(globals, c("sum", "x")))
+
+ message("\n*** findGlobals(dotdotdot='ignore'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- findGlobals(expr, dotdotdot="ignore")
+ print(globals)
+ stopifnot(all.equal(globals, c("sum", "x")))
+
+ message("\n*** findGlobals(dotdotdot='return'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- findGlobals(expr, dotdotdot="return")
+ print(globals)
+ if (name == "ok") {
+ stopifnot(all.equal(globals, c("sum", "x")))
+ } else {
+ stopifnot(all.equal(globals, c("sum", "x", "...")))
+ }
+
+ message("\n*** findGlobals(dotdotdot='warn'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- findGlobals(expr, dotdotdot="warn")
+ print(globals)
+ if (name == "ok") {
+ stopifnot(all.equal(globals, c("sum", "x")))
+ } else {
+ stopifnot(all.equal(globals, c("sum", "x", "...")))
+ }
+
+ message("\n*** findGlobals(dotdotdot='error'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- try(findGlobals(expr, dotdotdot="error"))
+ if (name == "ok") {
+ stopifnot(all.equal(globals, c("sum", "x")))
+ } else {
+ stopifnot(inherits(globals, "try-error"))
+ }
+} # for (name ...)
+
+message("\n*** findGlobals(<exprs>, dotdotdot='return'):")
+print(exprs)
+globals <- findGlobals(exprs, dotdotdot="return")
+print(globals)
+
+
+message("*** findGlobals() ... DONE")
+
+
+
+message("*** globalsOf() ...")
+
+x <- 1:2
+
+for (name in names(exprs)) {
+ expr <- exprs[[name]]
+
+ message("\n*** globalsOf(dotdotdot='ignore'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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(!is.list(globals$`...`) && is.na(globals$`...`))
+ }
+ stopifnot(all.equal(globals$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+
+ message("\n*** globalsOf(dotdotdot='warn'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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(!is.list(globals$`...`) && is.na(globals$`...`))
+ }
+ stopifnot(all.equal(globals$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+
+ message("\n*** globalsOf(dotdotdot='error'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- try(globalsOf(expr, dotdotdot="error"))
+ if (name == "ok") {
+ stopifnot(all.equal(names(globals), c("sum", "x")))
+ stopifnot(all.equal(globals$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+ } else {
+ stopifnot(inherits(globals, "try-error"))
+ }
+} # for (name ...)
+
+message("\n*** globalsOf(<exprs>, dotdotdot='return'):")
+print(exprs)
+globals <- globalsOf(exprs, dotdotdot="return")
+print(globals)
+
+
+message("*** globalsOf() ... DONE")
+
+
+message("*** function(x, ...) globalsOf() ...")
+
+aux <- function(x, ...) {
+ args <- list(...)
+
+for (name in names(exprs)) {
+ expr <- exprs[[name]]
+
+ message("\n*** globalsOf(dotdotdot='ignore'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+
+ message("\n*** globalsOf(dotdotdot='warn'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ 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$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+
+ message("\n*** globalsOf(dotdotdot='error'):")
+ cat(sprintf("Expression '%s':\n", name))
+ print(expr)
+ globals <- try(globalsOf(expr, dotdotdot="error"))
+ if (name == "ok") {
+ stopifnot(all.equal(names(globals), c("sum", "x")))
+ stopifnot(all.equal(globals$sum, base::sum))
+ stopifnot(all.equal(globals$x, x))
+ } else {
+ stopifnot(inherits(globals, "try-error"))
+ }
+} # for (name ...)
+
+message("\n*** globalsOf(<exprs>, dotdotdot='return'):")
+print(exprs)
+globals <- globalsOf(exprs, dotdotdot="return")
+print(globals)
+
+} # aux()
+
+aux(x=3:4, y=1, z=42L)
+message("*** function(x, ...) globalsOf() ... DONE")
+
+
+## Undo
+options(opts)
diff --git a/tests/globalsOf.R b/tests/globalsOf.R
new file mode 100644
index 0000000..25cb708
--- /dev/null
+++ b/tests/globalsOf.R
@@ -0,0 +1,180 @@
+library("globals")
+
+## WORKAROUND: Make sure tests also work with 'covr' package
+covr <- ("covr" %in% loadedNamespaces())
+if (covr) {
+ globalenv <- function() parent.frame()
+ baseenv <- function() environment(base::sample)
+}
+
+b <- 2
+c <- 3
+d <- NULL
+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='liberal'):")
+globalsL <- findGlobals(expr, method="liberal")
+print(globalsL)
+stopifnot(all(globalsL %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() ... 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")
+stopifnot(
+ length(where) == length(globalsC),
+ 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")
+stopifnot(
+ length(where) == length(globalsL),
+ 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")
+stopifnot(
+ length(where) == length(globalsL),
+ identical(where$b, globalenv()),
+ identical(where$c, globalenv()),
+ identical(where$d, globalenv())
+)
+
+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]))
+
+
+message("*** cleanup() & packagesOf():")
+globals <- globalsOf(expr, method="conservative")
+str(globals)
+stopifnot(all(names(globals) %in% c("{", "<-", "c", "d")))
+
+globals <- as.Globals(globals)
+str(globals)
+stopifnot(all(names(globals) %in% c("{", "<-", "c", "d")))
+
+globals <- as.Globals(unclass(globals))
+str(globals)
+stopifnot(all(names(globals) %in% c("{", "<-", "c", "d")))
+
+pkgs <- packagesOf(globals)
+print(pkgs)
+stopifnot(length(pkgs) == 0L)
+
+globals <- cleanup(globals)
+str(globals)
+stopifnot(all(names(globals) %in% c("c", "d")))
+
+pkgs <- packagesOf(globals)
+print(pkgs)
+stopifnot(length(pkgs) == 0L)
+
+
+message("*** globalsOf() and package functions:")
+foo <- globals::Globals
+expr <- substitute({ foo(list(a=1)) })
+globals <- globalsOf(expr)
+str(globals)
+stopifnot(all(names(globals) %in% c("{", "foo", "list")))
+where <- attr(globals, "where")
+stopifnot(
+ length(where) == length(globals),
+ identical(where$`{`, baseenv()),
+ covr || identical(where$foo, globalenv()),
+ identical(where$list, baseenv())
+)
+
+globals <- cleanup(globals)
+str(globals)
+stopifnot(all(names(globals) %in% c("foo")))
+pkgs <- packagesOf(globals)
+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)
+str(globals)
+stopifnot(all(names(globals) %in% c("{", "<-", "sample", "sample2", "sessionInfo", "sum", "sum2")))
+where <- attr(globals, "where")
+stopifnot(
+ length(where) == length(globals),
+ identical(where$`<-`, baseenv()),
+ identical(where$sample, baseenv()),
+ covr || identical(where$sample2, globalenv())
+)
+
+globals <- cleanup(globals)
+str(globals)
+stopifnot(all(names(globals) %in% c("sample2", "sum2")))
+where <- attr(globals, "where")
+stopifnot(
+ length(where) == length(globals),
+ covr || identical(where$sample2, globalenv())
+)
+
+globals <- cleanup(globals, drop="primitives")
+str(globals)
+stopifnot(all(names(globals) %in% c("sample2")))
+
+
+message("*** globalsOf() - exceptions ...")
+
+rm(list="a")
+res <- try({
+ globals <- globalsOf({ x <- a }, substitute=TRUE, mustExist=TRUE)
+}, silent=TRUE)
+stopifnot(inherits(res, "try-error"))
+
+message("*** globalsOf() - exceptions ... DONE")
diff --git a/tests/liberal.R b/tests/liberal.R
new file mode 100644
index 0000000..06a31c9
--- /dev/null
+++ b/tests/liberal.R
@@ -0,0 +1,91 @@
+library("globals")
+
+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",
+ "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()),
+ F = substitute({
+ a <- { runif(1) }
+ b <- { rnorm(1) }
+ x <- a*b; abs(x)
+ }, env=list()),
+ G = substitute({
+ y <- square(a)
+ }, env=list()),
+ H = substitute({
+ b <- a
+ a <- 1
+ }, env=list())
+)
+
+atleast <- list(
+ A = c(),
+ B = c(),
+ C = c("a"),
+ D = c("filename"),
+ E = c("c"),
+ F = c(),
+ G = c("a", "square"),
+ H = c() ## FIXME: Should be c("a"), cf. Issue #5.
+)
+
+not <- list(
+ A = c("x"),
+ B = c("y"),
+ C = c("z"),
+ D = c("pathname"),
+ E = c("b"),
+ F = c(),
+ G = c(),
+ H = c()
+)
+
+
+## Define globals
+a <- 3.14
+c <- 2.71
+square <- function(x) x^2
+filename <- "index.html"
+# Yes, pretend we forget 'url'
+
+message("Find globals")
+for (kk in seq_along(exprs)) {
+ key <- names(exprs)[kk]
+ expr <- exprs[[key]]
+ cat(sprintf("Expression #%d ('%s'):\n", kk, key))
+ print(expr)
+
+ 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=", ")))
+ stopifnot(all(atleast[[key]] %in% names(globals)))
+ stopifnot(!any(names(globals) %in% not[[key]]))
+ str(globals)
+
+ cat("\n")
+}
+
+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())
diff --git a/tests/utils.R b/tests/utils.R
new file mode 100644
index 0000000..c7ac25c
--- /dev/null
+++ b/tests/utils.R
@@ -0,0 +1,136 @@
+library("globals")
+
+message("*** utils ...")
+
+asFunction <- globals:::asFunction
+findBasePkgs <- globals:::findBasePkgs
+isBasePkgs <- globals:::isBasePkgs
+is.base <- globals:::is.base
+is.internal <- globals:::is.internal
+where <- globals:::where
+
+## WORKAROUND: Make sure tests also work with 'covr' package
+if ("covr" %in% loadedNamespaces()) {
+ globalenv <- function() parent.frame()
+ baseenv <- function() environment(base::sample)
+}
+
+message("* hpaste() ...")
+
+printf <- function(...) cat(sprintf(...))
+hpaste <- globals:::hpaste
+
+# Some vectors
+x <- 1:6
+y <- 10:1
+z <- LETTERS[x]
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Abbreviation of output vector
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+printf("x = %s.\n", hpaste(x))
+## x = 1, 2, 3, ..., 6.
+
+printf("x = %s.\n", hpaste(x, maxHead=2))
+## x = 1, 2, ..., 6.
+
+printf("x = %s.\n", hpaste(x), maxHead=3) # Default
+## x = 1, 2, 3, ..., 6.
+
+# It will never output 1, 2, 3, 4, ..., 6
+printf("x = %s.\n", hpaste(x, maxHead=4))
+## x = 1, 2, 3, 4, 5 and 6.
+
+# Showing the tail
+printf("x = %s.\n", hpaste(x, maxHead=1, maxTail=2))
+## x = 1, ..., 5, 6.
+
+# Turning off abbreviation
+printf("y = %s.\n", hpaste(y, maxHead=Inf))
+## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
+
+## ...or simply
+printf("y = %s.\n", paste(y, collapse=", "))
+## y = 10, 9, 8, 7, 6, 5, 4, 3, 2, 1
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Adding a special separator before the last element
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Change last separator
+printf("x = %s.\n", hpaste(x, lastCollapse=" and "))
+## x = 1, 2, 3, 4, 5 and 6.
+
+message("* hpaste() ...")
+
+
+message("* asFunction() ...")
+fcn <- asFunction({ 1 })
+print(fcn())
+stopifnot(fcn() == 1)
+
+
+message("* findBasePkgs() & isBasePkgs() ...")
+basePkgs <- findBasePkgs()
+print(basePkgs)
+stopifnot(length(basePkgs) > 1L)
+for (pkg in basePkgs) {
+ stopifnot(isBasePkgs(pkg))
+}
+stopifnot(!isBasePkgs("globals"))
+
+
+message("* is.base() & is.internal() ...")
+stopifnot(is.base(base::library))
+stopifnot(!is.base(globals::globalsOf))
+stopifnot(is.internal(print.default))
+stopifnot(!is.internal(globals::globalsOf))
+
+
+
+
+message("* where() ...")
+
+message("- where('sample') ...")
+env <- where("sample", mode="function")
+print(env)
+stopifnot(identical(env, baseenv()))
+obj <- get("sample", mode="function", envir=env, inherits=FALSE)
+stopifnot(identical(obj, base::sample))
+
+
+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")
+print(env)
+stopifnot(identical(env, environment()))
+obj <- get("sample2", mode="function", envir=env, inherits=FALSE)
+stopifnot(identical(obj, sample2))
+
+
+message("- where() - local objects of functions ...")
+aa <- 1
+
+foo <- function() {
+ bb <- 2
+ list(aa=where("aa"), bb=where("bb"), cc=where("cc"), envir=environment())
+}
+
+envs <- foo()
+str(envs)
+stopifnot(identical(envs$aa, globalenv()))
+stopifnot(identical(envs$bb, envs$envir))
+stopifnot(is.null(envs$cc))
+
+rm(list=c("aa", "envs", "foo", "env", "obj", "where"))
+
+message("* where() ... DONE")
+
+message("*** utils ... 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