globalsOf() gained argument addS3=TRUE [#2]

Add c() and unique() for Globals class.
Add internal utility functions isGenericS3(), s3GlobalsOf() and
addS3Methods().

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: globals
-Version: 0.6.1-9000
+Version: 0.6.5-9000
 Depends:
     R (>= 3.1.2)
 Imports:

NAMESPACE

@@ -3,8 +3,10 @@
 S3method("[",Globals)
 S3method(as.Globals,Globals)
 S3method(as.Globals,list)
+S3method(c,Globals)
 S3method(cleanup,Globals)
 S3method(packagesOf,Globals)
+S3method(unique,Globals)
 export(Globals)
 export(as.Globals)
 export(cleanup)
@@ -15,3 +17,4 @@ importFrom(codetools,findLocalsList)
 importFrom(codetools,makeUsageCollector)
 importFrom(codetools,walkCode)
 importFrom(utils,installed.packages)
+importFrom(utils,methods)

NEWS

@@ -1,6 +1,11 @@
 Package: globals
 ================
 
+Version: 0.6.5-9000 [2016-04-10]
+o Now globalsOf() by default also incorporates all known
+  S3 methods if one of the globals is an S3 generic function.
+
+
 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

R/Globals-class.R

@@ -11,7 +11,8 @@
 #' 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
+#' @aliases as.Globals as.Globals.Globals as.Globals.list
+#'          [.Globals c.Globals unique.Globals
 #' @export
 Globals <- function(object, ...) {
   if (!is.list(object)) {
@@ -48,3 +49,51 @@ as.Globals.list <- function(x, ...) {
   class(res) <- class(x)
   res
 }
+
+
+#' @export
+`c.Globals` <- function(x, ...) {
+  args <- list(...)
+
+  ## Drop empty arguments
+  keep <- !unlist(lapply(args, FUN=is.null))
+  args <- args[keep]
+
+  ## Nothing to do?
+  if (length(args) == 0) return(x)
+
+  res <- unclass(x)
+  where <- attr(x, "where")
+
+  for (kk in seq_along(args)) {
+    arg <- args[[kk]]
+    stopifnot(inherits(arg, "Globals"))
+    res <- c(res, arg)
+    where <- c(where, attr(arg, "where"))
+  }
+  attr(res, "where") <- where
+  class(res) <- class(x)
+
+  res
+}
+
+
+#' @export
+`unique.Globals` <- function(x, ...) {
+  res <- unclass(x)
+  where <- attr(x, "where")
+
+  ## Identify unique elements
+  keep <- !(duplicated(names(res)) & duplicated(res))
+
+  ## Nothing to do?
+  if (all(keep)) return(x)
+
+  ## Drop duplicates
+  res <- res[keep]
+  where <- where[keep]
+  attr(res, "where") <- where
+  class(res) <- class(x)
+
+  res
+}

R/globalsOf.R

@@ -13,6 +13,10 @@
 #' @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 addS3 If TRUE and there exist S3 generic functions among the
+#'        identified globals, then all corresponding S3 methods that
+#'        can be located from the \code{envir} environment are also
+#'        appended to the set of globals returned.
 #' @param unlist If TRUE, a list of unique objects is returned.
 #'        If FALSE, a list of \code{length(expr)} sublists.
 #'
@@ -46,7 +50,7 @@
 #'
 #' @aliases findGlobals
 #' @export
-globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "conservative", "liberal"), tweak=NULL, substitute=FALSE, mustExist=TRUE, unlist=TRUE) {
+globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "conservative", "liberal"), tweak=NULL, substitute=FALSE, mustExist=TRUE, addS3=TRUE, unlist=TRUE) {
   method <- match.arg(method)
 
   if (substitute) expr <- substitute(expr)
@@ -91,5 +95,10 @@ globalsOf <- function(expr, envir=parent.frame(), ..., method=c("ordered", "cons
 
   attr(globals, "where") <- where
 
+  if (addS3) {
+    globals <- addS3Methods(globals, envir=envir)
+    globals <- unique(globals)
+  }
+
   globals
 }

R/utils.R

@@ -98,3 +98,190 @@ hexpr <- function(expr, trim=TRUE, collapse="; ", maxHead=6L, maxTail=3L, ...) {
   if (trim) code <- trim(code)
   hpaste(code, collapse=collapse, maxHead=maxHead, maxTail=maxTail, ...)
 } # hexpr()
+
+
+## Adopted from R.methodsS3 v1.7.1 (2016-04-10)
+.findFunction <- function(name, envir, inherits=rep(FALSE, times=length(envir))) {
+  # Argument 'envir':
+  if (!is.list(envir)) envir <- list(envir)
+  n <- length(envir)
+
+  # Argument 'inherits':
+  inherits <- as.logical(inherits)
+  stopifnot(length(inherits) == n)
+
+  fcn <- pkg <- NULL
+  for (kk in seq_along(envir)) {
+    env <- envir[[kk]]
+    inh <- inherits[kk]
+    if (exists(name, mode="function", envir=env, inherits=inh)) {
+      fcn <- get(name, mode="function", envir=env, inherits=inh)
+      pkg <- attr(env, "name")
+      if (is.null(pkg)) {
+        pkg <- "base"
+        if (identical(env, baseenv())) {
+        } else if (identical(env, globalenv())) {
+          pkg <- "<R_GlobalEnv>"
+        }
+      } else {
+        pkg <- gsub("^package:", "", pkg)
+      }
+      break
+    }
+  } # for (kk ...)
+
+  list(fcn=fcn, pkg=pkg)
+} # .findFunction()
+
+## Adopted from R.methodsS3 v1.7.1 (2016-04-10)
+isGenericS3 <- function(fcn, envir=parent.frame(), ...) {
+  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+  # Local functions
+  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+  knownInternalGenericS3 <- function(fcn, which=1:4, ...) {
+    knownGenerics <- NULL
+
+    # Get the name of all known S3 generic functions
+    if (any(which == 1L)) {
+      knownGenerics <- c(knownGenerics, names(.knownS3Generics))
+    }
+
+    if (any(which == 2L)) {
+      knownGenerics <- c(knownGenerics, .S3PrimitiveGenerics)
+    }
+
+    # tools:::.get_internal_S3_generics() if available
+    if (any(which == 3L)) {
+      ns <- getNamespace("tools")
+      if (exists(".get_internal_S3_generics", envir=ns, inherits=FALSE)) {
+        names <- get(".get_internal_S3_generics", envir=ns, inherits=FALSE)()
+        knownGenerics <- c(knownGenerics, names)
+      }
+    }
+
+    # Manually added, cf. ?cbind
+    if (any(which == 4L)) {
+      names <- c("cbind", "rbind")
+      knownGenerics <- c(knownGenerics, names)
+    }
+
+    # Is it one of the known S3 generic functions?
+    knownGenerics <- unique(knownGenerics)
+
+    knownGenerics
+  } # knownInternalGenericS3()
+
+  isNameInternalGenericS3 <- function(fcn, ...) {
+    is.element(fcn, knownInternalGenericS3())
+  } # isNameInternalGenericS3()
+
+  isPrimitive <- function(fcn, ...) {
+    switch(typeof(fcn), special=TRUE, builtin=TRUE, FALSE)
+  } # isPrimitive()
+
+
+  if (is.character(fcn)) {
+    if (isNameInternalGenericS3(fcn)) return(TRUE)
+
+    # Get the function
+    fcn <- .findFunction(fcn, envir=envir, inherits=TRUE)$fcn
+
+    # Does it even exist?
+    if (is.null(fcn)) {
+      return(FALSE)
+    }
+  }
+
+  # Check with codetools::findGlobals(), if available,
+  # otherwise scan the body
+  res <- tryCatch({
+    ns <- getNamespace("codetools")
+    findGlobals <- get("findGlobals", mode="function", envir=ns)
+    fcns <- findGlobals(fcn, merge=FALSE)$functions
+    is.element("UseMethod", fcns)
+  }, error = function(ex) {
+    # Scan the body of the function
+    body <- body(fcn)
+    if (is.call(body))
+      body <- deparse(body)
+    body <- as.character(body)
+    (length(grep("UseMethod[(]", body)) > 0L)
+  })
+  if (isTRUE(res)) return(TRUE)
+
+  # Check primitive functions
+  if (isPrimitive(fcn)) {
+    # Scan the body of the function
+    body <- deparse(fcn)
+    call <- grep(".Primitive[(]", body, value=TRUE)
+    call <- gsub(".Primitive[(]\"", "", call)
+    call <- gsub("\"[)].*", "", call)
+    if (is.element(call, knownInternalGenericS3(2L))) return(TRUE)
+  }
+
+  # Finally, compare to all known internal generics
+  for (name in knownInternalGenericS3()) {
+    if (exists(name, mode="function", inherits=TRUE)) {
+      generic <- get(name, mode="function", inherits=TRUE)
+      if (identical(fcn, generic)) return(TRUE)
+    }
+  }
+
+  FALSE
+} ## isGenericS3()
+
+#' @importFrom utils methods
+s3GlobalsOf <- function(name, envir=parent.frame()) {
+  data <- methods(name)
+  data <- attr(data, "info")
+
+  ## Names of the S3 methods
+  mthds <- rownames(data)
+  names(mthds) <- mthds
+
+  ## Locations of S3 methods
+  where <- as.character(data$from)
+  uwhere <- unique(where)
+  names(uwhere) <- uwhere
+  uwhere <- lapply(uwhere, FUN=function(w) {
+    if (w == ".GlobalEnv") return(.GlobalEnv)
+    asNamespace(w)
+  })
+  where <- uwhere[where]
+  names(where) <- mthds
+
+  ## Import the S3 methods
+  mthds <- mapply(mthds, where, FUN=function(name, envir) {
+    get(name, envir=envir, mode="function")
+  })
+  attr(mthds, "where") <- where
+
+  Globals(mthds)
+} ## s3GlobalsOf()
+
+
+addS3Methods <- function(globals, envir=parent.frame(), recursive=FALSE) {
+  globalsS3 <- vector("list", length=length(globals))
+  names(globalsS3) <- names(globals)
+
+  for (kk in seq_along(globals)) {
+    fcn <- globals[[kk]]
+    if (!isGenericS3(fcn)) next
+    name <- names(globals)[kk]
+    where <- attr(globals, "where")[[kk]]
+    globalsKK <- s3GlobalsOf(name, envir=envir)
+    globalsS3[[kk]] <- globalsKK
+  }
+
+  ## Drop empty sets
+  keep <- !unlist(lapply(globalsS3, FUN=is.null))
+  globalsS3 <- globalsS3[keep]
+
+  ## Nothing to do?
+  if (length(globalsS3) == 0) return(globals)
+
+  globalsS3 <- Reduce(c, globalsS3)
+  globals <- c(globals, globalsS3)
+
+  globals
+} ## addS3Methods()