R/functionInfo.R

In paodan/funcTools: some useful function tools in practice

#' @name MethodsFunction-class
#' @title MethodsFunction-class
#' @keywords internal
#' @description MethodsFunction is an S3 class
setOldClass("MethodsFunction")

# fcnS is an S4 class
# fcnS includes a list of function and corresponding function S3/S4 method names info (MethodsFunction)
setClass("fcnS", slots = list(fcn = "list", fName = "MethodsFunction"))


# @describeIn functionInfo set a \code{functionInfo} class.
#' @title Generating functionInfo object
#' @description FunctionInfo is an S4 class and a function to generate functionInfo object.
#' @param funName character, the function name.
#' @param typeof character, the result generated by `typeof`` function.
#' @param S3S4  logical, whether the results of \code{\link{.S3methods}}
#' and \code{\link{.S4methods}} exist.
#' @param fcn function, the result shown by `print.function` directly.
#' @param fS3 fcnS object, the information of S3 methods.
#' @param fS4 fcnS object, the information of S4 mehtods.
#' @return a functionInfo object
#' @import methods
#' @examples
#' \dontrun{
#' functionInfo()
#' }
#' @export
functionInfo = setClass(Class = "functionInfo",
                        slots = list(funName = "character", typeof = "character",
                                     S3S4 = "logical", fcn = "function",
                                     fS3 = "fcnS", fS4 = "fcnS"))

#' @name funCode
#' @title Finding function source code\cr
#' @description funCode function is to obtain the source code of an R function
#' @param f a function name with or without quotation
#' @param pattern  regular expression to match the object class.
#' @param envir environment to search
#' @return A \code{\link{functionInfo}} object, containing the function name,
#' function type, whether containing S3 or S4 methods, dirrect function source,
#' S3 methods info, and S4 methods info.
#' @import methods
#' @import utils
#' @export
#' @examples 
#' \dontrun{
#' # The source of print
#' funCode(print)
#' funCode("print")
#'
#' # The source of funCode
#' funCode(funCode)
#' funCode(lm)
#'
#' # The source of plot for data.frame
#' funCode("plot", "data.frame")
#' 
#' # The source of standardGeneric show
#' funCode("show")
#' funCode(show)
#' 
#' # The source of ggproto_method in ggplot2
#' library(ggplot2)
#' funCode(Layout$setup)
#' }
funCode <- function (f, ...) {
  UseMethod("funCode", f)
}

#' @rdname funCode
#' @export
funCode.default = function(f = character(), pattern = NULL,
                   envir = topenv(parent.frame())){
  # get a function name string (f) and a real function (fcn).
  if (is.character(f)) {
    fcn <- get(f, mode = "function", envir = envir, inherits = TRUE)
  } else if (is.function(f)){
    fcn = f
    f = deparse(substitute(f)) # not working outside the function
  } else {
    stop("'f' must be a function or string.")
  }
  type = typeof(fcn)
  
  findGeneric = getFromNamespace("findGeneric", ns = "utils")
  findS3 = findGeneric(f, envir = envir, warnS4only = FALSE)
  
  if (nzchar(findS3)){
    # fNameS3 = .S3methods(f) # S3 methods
    fNameS3 = .S3methods(findS3) # S3 methods
  } else {
    fNameS3 = character()
    class(fNameS3) = "MethodsFunction"
    attr(fNameS3, "info") = data.frame(visible = logical(), 
                                        from = character(),
                                        generic = character(),
                                        isS4 = logical())
    attr(fNameS3, "byclass") = FALSE
  }
  # fNameS3 = suppressWarnings(.S3methods(f)) # S3 methods
  fNameS4 = methods::.S4methods(f) # S4 methods

  S3S4 = c(S3 = length(fNameS3)>0, S4 = length(fNameS4)>0)
  fcnS3 = fcnS4 = list()
  if (S3S4[[1]]){
    names(fNameS3) = sub(paste0(f, "."), "", as.character(fNameS3))
    id = setNames(object = names(fNameS3), nm = names(fNameS3))
    fcnS3 = lapply(id, function(x) {
      getS3method(f = f, class = x, optional = TRUE, envir = envir)})
  }
  if (S3S4[[2]]){
    names(fNameS4) = fNameS4
    # sig = strSplit(strSplit(fNameS4, "-")[,1], ",")[,-1, drop = F]
    sig = strSplit(sub("-method$", "", fNameS4), ",")[,-1, drop = F]
    id = setNames(object = 1:length(fNameS4),
                  nm = apply(sig, 1, paste, collapse = "#"))
    # id = setNames(object = 1:length(fNameS4), nm = sig)
    fcnS4 = lapply(id, function(x) getMethod(f, signature = sig[x,]))
    
    names(fNameS4) = names(id)
  }
  # filtering
  if (!is.null(pattern)){
    id3 = grep(pattern, fNameS3)
    id4 = grep(pattern, fNameS4)
    fcnS3 = fcnS3[id3]
    fcnS4 = fcnS4[id4]
  }
  
  # message
  if (is.element(typeof(fcn), c("special", "builtin"))){
    message(".Primitive and .Internal can be shown by pryr::show_c_source()\n")
  }
  
  resF = new("functionInfo", funName = f,
             typeof = type, S3S4 = S3S4, fcn = fcn,
             fS3 = new("fcnS", fcn = fcnS3, fName = fNameS3),
             fS4 = new("fcnS", fcn = fcnS4, fName = fNameS4))
  
  return(resF)
}

#' @rdname funCode
#' @export
funCode.ggproto_method = function(f){
  wrapper = unclass(f)
  wrappere = environment(wrapper)
  
  inner = wrappere$f
  return(list(wrapper = wrapper, inner = inner))
}


# @name show
#' @title show,functionInfo-method\cr
#' @aliases  show,functionInfo-method
#' @param object an object of functionInfo class
#' @describeIn functionInfo Show the S3 method names in
#' object@@fS3 and S4 method names in object@@fS4
#' @export
setMethod("show", signature = "functionInfo", function(object) {
  cat(object@funName, "= \n")
  if(length(object@fcn)){
    writeLines(paste0("  ", capture.output(print(object@fcn))))
    cat("\n")
  }
  show(list(functionS3 = object@fS3@fName,
            functionS4 = object@fS4@fName))
})


#' @title find dispatched functions for an object
#' @param f function name.
#' @param object the object that the function f is processing
#' @param envir the working environment
#' @return a list of two elements: S3 and S4, which list all methods that 
#' can be dispatched for S3 and S4 objects, respectively. NULL in S3 
#' element means no method is found for this function by treating the "object"
#' as an S3 object. And similar to NULL in S4 element. If both S3 and 
#' S4 elements are NULL, the function \code{f} appears not to be either
#' S3 generic or S4 generic, and the original function without dispatching
#' is applied. The function f can be an alias of another generic function,
#' the attribute "name" of the result is the very original generic function 
#' name. 
#' @export
#' @examples 
#' \dontrun{
#' funDispatch(f = "print", object = "asdf") #ls.default
#' funDispatch("print", object = ~ a + b) #ls.formula
#' 
#' funDispatch("lm", object = ~ a + b) #lm itself
#' 
#' funDispatch("show", object = "asdf") # S4 "ANY"
#' funDispatch(show, object = "asdf") # S4 "ANY"
#' 
#' x = show
#' funDispatch(x, object = "asdf") # S4 "ANY"
#' funDispatch("x", object = "asdf") # S4 "ANY"
#' 
#' y = "show"
#' funDispatch(y, object = "asdf") # S4 "ANY"
#' funDispatch("y", object = "asdf") # Not found
#' 
#' funDispatch("ls", object = .GlobalEnv) # itself
#' 
#' x = ls
#' y = "ls"
#' funDispatch(x, object = .GlobalEnv) # itself
#' funDispatch(y, object = .GlobalEnv) # itself
#' }
funDispatch = function(f, object, envir = topenv(parent.frame())){
  if (is.character(f)) {
    fcn <- get(f, mode = "function", envir = envir, inherits = TRUE)
  } else if (is.function(f)){
    fcn = f
    f = deparse(substitute(f)) # not working outside the function
  } else {
    stop("'f' must be a function or string.")
  }
  
  findGeneric = getFromNamespace("findGeneric", ns = "utils")
  findS3 = findGeneric(f, envir = envir, warnS4only = FALSE)
  # findS4 = ifelse(is(fcn, "standardGeneric"), fcn@generic, "")
  fcnGNR = getGeneric(f, where = envir)
  findS4 = ifelse(is.null(fcnGNR), "", fcnGNR@generic)
  
  findS34 = unique(c(findS3, findS4)[c(findS3, findS4) != ""])
  if(length(findS34) == 0) { # not a generic
    # message("Function ", f, " is not a S3/S4 generic.")
    isDispatched = list(S3 = NULL, S4 = NULL)
    attr(isDispatched, "name") = f
    return(isDispatched)
  }
  funAll = funCode(findS34, envir = envir)
  
  if (length(funAll@fS3@fcn) > 0){
    # classes = names(funAll@fS3@fcn)
    classes = sub(paste0(attr(funAll@fS3@fName, "info")$generic[1], "."), "", names(funAll@fS3@fcn))
    
    
    isDispatched3 = sapply(classes, function(x) is (object, x))
    isDispatched3 = isDispatched3[isDispatched3]
    if (length(isDispatched3) == 0 ){
      # if ("default" %in% names(funAll@fS3@fcn)){
      if ("default" %in% classes){
        isDispatched3 = "default"
      } else {
        # isDispatched3 = "originalFunction"
        isDispatched3 = NULL
      }
    } else {
      isDispatched3 = names(isDispatched3)
    }
  } else {
    isDispatched3 = NULL
  }

  if (length(funAll@fS4@fcn) > 0){
    classes = names(funAll@fS4@fcn)
    isDispatched4 = sapply(classes, function(x) is (object, x))
    isDispatched4 = names(isDispatched4[isDispatched4])
    if(length(isDispatched4) == 0){
      isDispatched4 = "ANY"
    }
  } else {
    isDispatched4 = NULL
  }

  # msg = ifelse (f != findS34, paste0(f, " (", findS34, ")"), f)
  # message("Function ", msg, " dispatching:")
  isDispatched = list(S3 = isDispatched3, S4 = isDispatched4)
  attr(isDispatched, "name") = findS34
  return(isDispatched)
}



#' @title get the dispatched S3 or S4 method of a function
#' @param f function or function name.
#' @param object the object that the function f is processing.
#' @param returnAll Whether all possibly existed \code{origin}al functions 
#' \code{S3} method and \code{S4} method are returned as a list. The default
#' is FALSE, meaning returning \code{S3} method first if exists, followed by 
#' \code{S4} method if exists while \code{S3} method not exists. If both 
#' \code{S3} and \code{S4} methods do not exist, \code{origin}al function 
#' appears to be not a generic function so the \code{origin}al source is
#' returned.
#' @param envir the working environment.
#' @return either a list of length 3, containing \code{origin}al function,
#' \code{S3} method and \code{S4} method, or a function object.
#' @examples
#' \dontrun{
#' # print from base package is a S3 generic
#' detachPackages("Matrix")
#' funWhich(print, "asdfasdfasd", TRUE)
#' funWhich(print, "asdfasdfasd")
#' 
#' library(Matrix) # print becomes a S4 standardGeneric
#' funWhich(print, "asdfasdfasd", TRUE)
#' funWhich(print, "asdfasdfasd") # if S3 and S4 both exists, then S3 is shown.
#'
#' fit <- lm(Sepal.Length ~ Petal.Length + Petal.Width + Species, 
#'           data = datasets::iris)
#' resFun = funWhich(print, fit)
#' resFun
#' resFun(fit)
#' stats:::print.lm(fit)
#'
#' funWhich(show, object = ~ a + b, T)
#' funWhich(show, object = ~ a + b)
#' funWhich(showDefault, object = ~ a + b)
#' 
#' x = show
#' funWhich(x, object = ~ a + b, T)
#' funWhich(x, object = ~ a + b)
#' xw = funWhich("x", object = ~ a + b)
#' xw
#' attributes(xw)
#' }
#' @export
funWhich = function(f, object, returnAll = FALSE,
                    envir = topenv(parent.frame())){
  if (is.character(f)) {
    f = f
  } else if (is.function(f)){
    f = deparse(substitute(f)) # not working outside the function
  } else {
    stop("'f' must be a function or string.")
  }
  
  fdp = funDispatch(f, object, envir = topenv(parent.frame()))
  resAll = funCode(f, envir = envir)
  
  res = list()
  res$origin = resAll@fcn
  res["S3"] = if (is.null(fdp$S3[1])) list(NULL) else list(resAll@fS3@fcn[[fdp$S3[1]]])
  res["S4"] = if (is.null(fdp$S4[1])) list(NULL) else list(resAll@fS4@fcn[[fdp$S4[1]]])
  
  if (!returnAll){
    if(is.null(fdp$S3) && is.null(fdp$S4)){
      # message("original function: ", f, "\n")
      res = res$origin
      attr(res, "type") = "origin"
      attr(res, "method") = NULL
    } else if (!is.null(fdp$S3)){
      # message("S3 function: ", f, ".", fdp$S3, "\n")
      res = res$S3
      attr(res, "type") = "S3"
      attr(res, "method") = fdp$S3
    } else if(!is.null(fdp$S4)){
      # message("S4 method: ", fdp$S4, "\n")
      res = res$S4
      attr(res, "type") = "S4"
      attr(res, "method") = fdp$S4
    }
  }
  attr(res, "name") = fdp$name
  return(res)
}