globalsOf() now adds locally defined S3 methods [#2]

DESCRIPTION

@@ -18,4 +18,4 @@ LazyLoad: TRUE
 ByteCompile: TRUE
 URL: https://github.com/HenrikBengtsson/globals
 BugReports: https://github.com/HenrikBengtsson/globals/issues
-RoxygenNote: 6.0.1
+RoxygenNote: 6.1.0

NAMESPACE

@@ -22,4 +22,5 @@ importFrom(codetools,makeUsageCollector)
 importFrom(codetools,walkCode)
 importFrom(utils,capture.output)
 importFrom(utils,installed.packages)
+importFrom(utils,methods)
 importFrom(utils,str)

NEWS

@@ -1,10 +1,13 @@
 Package: globals
 ================
 
-Version: 0.12.1-9000 [2018-06-25]
+Version: 0.12.1-9000 [2018-08-06]
+
+NEW FEATURES:
+
+ o globalsOf() now scans for S3 generic function among identified globals and,
+   if found, then adds any locally defined S3 methods with the same name.
 
-  o ...
-
 
 Version: 0.12.1 [2018-06-24]
 

R/globalsOf.R

@@ -12,6 +12,11 @@
 #' @param tweak An optional function that takes an expression
 #'        and returns a tweaked expression.
 #'
+#' @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 substitute If TRUE, the expression is \code{substitute()}:ed,
 #'        otherwise not.
 #'
@@ -64,7 +69,8 @@
 #' @export
 globalsOf <- function(expr, envir = parent.frame(), ...,
                       method = c("ordered", "conservative", "liberal"),
-                      tweak = NULL, substitute = FALSE, mustExist = TRUE,
+                      tweak = NULL, addS3 = TRUE,
+		      substitute = FALSE, mustExist = TRUE,
                       unlist = TRUE, recursive = TRUE, skip = NULL) {
   method <- match.arg(method, choices = c("ordered", "conservative", "liberal"))
 
@@ -151,6 +157,12 @@ globalsOf <- function(expr, envir = parent.frame(), ...,
     mdebug(" - recursive scan of preliminary globals ... DONE")
   }
 
+  if (addS3 && length(globals) > 0) {
+    mdebug(" - Add locally defined S3 methods that may be needed by globals")
+    globals <- addS3Methods(globals, envir = envir)
+    globals <- unique(globals)
+  }
+
   mdebug(" - globals found: [%d] %s",
          length(globals), hpaste(sQuote(names(globals))))
 

R/s3-local.R

@@ -0,0 +1,194 @@
+## 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(), ...) {
+  if (!is.function(fcn)) return(FALSE)
+
+  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+  # 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)
+    w <- sub("package:", "", w, fixed=TRUE)   ## For R (<= 3.1.3)
+    w <- sub("namespace:", "", w, fixed=TRUE) ## Just in case
+    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) {
+  n_globals <- length(globals)
+
+  ## Nothing to do?
+  if (n_globals == 0L) return(globals)
+
+  globalsS3 <- vector("list", length=n_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()

tests/globalsOf,localS3.R

@@ -0,0 +1,33 @@
+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)
+}
+
+
+message("*** globalsOf() w/ locally defined S3 methods ...")
+
+foo <- function(x, ...) UseMethod("foo")
+
+foo.integer <- function(x, ...) {
+  sum(x == 1L)
+}
+
+foo.numeric <- function(x, ...) {
+  sum(abs(x - 3.14) < 0.1)
+}
+
+x <- 0:2
+globals <- globalsOf({
+  foo(x)
+}, substitute = TRUE)
+str(globals)
+globals <- cleanup(globals)
+str(globals)
+stopifnot(all(c("foo", "x", "foo.integer", "foo.numeric") %in% names(globals)))
+stopifnot(length(packagesOf(globals)) == 0L)
+
+message("*** globalsOf() w/ locally defined S3 methods ... DONE")