globals: Enhanced heuristic for package identification, e.g. data.table

[HenrikBengtsson]

After globalsOf() has gathered all globals and packages it could do another round and look among the generic functions whether there are any S3 methods registered with any of the loaded namespaces not yet in the list of packages, cf. attr(methods("["), "info") (*). That would provide an upper bound of additional packages that need to be loaded. This should for instance pick up the data.table package when [ is in the set of globals.

To make this a bit more conservative, one could, in turn, scan the global variables to identify classes and match those to the table of registered (package, generic, class) methods.

(*) Unfortunately, namespace/package information is lost in methods("[") - we might have to roll our own version where this information is retained. See also https://twitter.com/henrikbengtsson/status/1026745698514087936

> library(data.table)
data.table 1.11.4  Latest news: http://r-datatable.com
> attr(methods("["), "info")
                        visible                      from generic  isS4
[,nonStructure-method      TRUE                                 [  TRUE
[.acf                     FALSE registered S3method for [       [ FALSE
[.AsIs                     TRUE                      base       [ FALSE
[.bibentry                FALSE registered S3method for [       [ FALSE
[.check_details_changes   FALSE registered S3method for [       [ FALSE
[.data.frame               TRUE                      base       [ FALSE
[.data.table              FALSE registered S3method for [       [ FALSE      <====
[.Date                     TRUE                      base       [ FALSE
[.difftime                 TRUE                      base       [ FALSE
[.Dlist                    TRUE                      base       [ FALSE
[.DLLInfoList              TRUE                      base       [ FALSE
[.factor                   TRUE                      base       [ FALSE
[.formula                 FALSE registered S3method for [       [ FALSE
[.getAnywhere             FALSE registered S3method for [       [ FALSE
[.hexmode                  TRUE                      base       [ FALSE
[.ITime                   FALSE registered S3method for [       [ FALSE
[.listof                   TRUE                      base       [ FALSE
[.noquote                  TRUE                      base       [ FALSE
[.numeric_version          TRUE                      base       [ FALSE
[.octmode                  TRUE                      base       [ FALSE
[.pdf_doc                 FALSE registered S3method for [       [ FALSE
[.person                  FALSE registered S3method for [       [ FALSE
[.POSIXct                  TRUE                      base       [ FALSE
[.POSIXlt                  TRUE                      base       [ FALSE
[.raster                  FALSE registered S3method for [       [ FALSE
[.roman                   FALSE registered S3method for [       [ FALSE
[.simple.list              TRUE                      base       [ FALSE
[.table                    TRUE                      base       [ FALSE
[.terms                   FALSE registered S3method for [       [ FALSE
[.ts                      FALSE registered S3method for [       [ FALSE
[.tskernel                FALSE registered S3method for [       [ FALSE
[.warnings                 TRUE                      base       [ FALSE

[HenrikBengtsson]

#' @importFrom utils .S3methods
methods_s3 <- function(generic, base = FALSE) {
  envir <- parent.frame()
  
  s3 <- .S3methods(generic, envir = envir)
  info <- attr(s3, "info")

  unknown <- which(!info$visible)
  ## Nothing todo?
  if (length(unknown) == 0) return(info)

  mthds <- rownames(info)[unknown]
  start <- nchar(generic) + 2L
  classes <- substr(mthds, start = start, stop = nchar(mthds))

  ns <- vapply(classes, FUN = function(class) {
    ns <- environment(getS3method(generic, class = class, envir = envir))
    if (isBaseNamespace(ns)) return("base")
    .getNamespaceInfo(ns, "spec")["name"]
  }, FUN.VALUE = NA_character_, USE.NAMES = FALSE)

  namespace <- as.character(info$from)
  namespace[unknown] <- ns
  info$namespace <- namespace

  if (!base) {
    unamespace <- unique(namespace)
    is_base <- vapply(unamespace, FUN = is_base_pkg, FUN.VALUE = FALSE, USE.NAMES = FALSE)
    unamespace <- unamespace[!is_base]
    if (length(unamespace) == 0) {
      info <- info[integer(0), ]
    } else {
      info <- info[namespace %in% unamespace, ]
    }
  }

  info
}

> library(data.table)
> methods_s3("[")
             visible                      from generic  isS4  namespace
[.data.table   FALSE registered S3method for [       [ FALSE data.table
[.Globals      FALSE registered S3method for [       [ FALSE    globals
[.ITime        FALSE registered S3method for [       [ FALSE data.table

[HenrikBengtsson]

#' @importFrom utils .S3methods
packagesOfS3Methods <- function(generic, base = FALSE) {
  envir <- parent.frame()
  
  s3 <- .S3methods(generic, envir = envir)
  info <- attr(s3, "info")
  namespace <- as.character(info$from)

  unknown <- which(!info$visible)
  if (length(unknown) > 0) {
    mthds <- rownames(info)[unknown]
    start <- nchar(generic) + 2L
    classes <- substr(mthds, start = start, stop = nchar(mthds))
  
    ns <- vapply(classes, FUN = function(class) {
      ns <- environment(getS3method(generic, class = class, envir = envir))
      if (isBaseNamespace(ns)) return("base")
      .getNamespaceInfo(ns, "spec")["name"]
    }, FUN.VALUE = NA_character_, USE.NAMES = FALSE)
    
    namespace[unknown] <- ns
  }

  unamespace <- unique(namespace)
  
  if (!base) {
    is_base <- vapply(unamespace, FUN = is_base_pkg, FUN.VALUE = FALSE, USE.NAMES = FALSE)
    unamespace <- unamespace[!is_base]
  }

  unamespace
}

> library(data.table)
> packagesOfS3Methods("[")
[1] "data.table" "globals"