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 <[email protected]> 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@R: c( + person("Henrik", "Bengtsson", role=c("aut", "cre", "cph"), + email="[email protected]")) +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 <[email protected]> +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 _______________________________________________ debian-med-commit mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/debian-med-commit
![https://travis-ci.org/HenrikBengtsson/globals.svg"](https://travis-ci.org/HenrikBengtsson/globals.svg"){kind=link}
![https://coveralls.io/repos/HenrikBengtsson/globals/badge.svg?branch=develop"](https://coveralls.io/repos/HenrikBengtsson/globals/badge.svg?branch=develop"){kind=link}