find.R

# Modified from sloop::methods_generic
methods_find <- function(x) {
  if (is_s7_generic(x)) {
    return(methods_find_s7(match.fun(x), x))
  }

  info <- attr(utils::methods(x), "info")

  if (nrow(info) == 0) {
    info$topic <- character()
    return(info)
  }

  info$method <- rownames(info)
  rownames(info) <- NULL

  # Simply class and source
  generic_esc <- gsub("\\.", "\\\\.", x)
  info$class <- gsub(paste0("^", generic_esc, "[.,]"), "", info$method)
  info$class <- gsub("-method$", "", info$class)
  info$source <- gsub(paste0(" for ", generic_esc), "", info$from)

  # Find package
  info$package <- lookup_package(x, info$class, info$isS4)

  # Find help topic
  info$topic <- help_topic(info$method, info$package)

  info[c("method", "class", "package", "topic", "visible", "source")]
}

help_topic <- function(x, package) {
  path <- help_path(x, package)
  pieces <- strsplit(path, "/")
  vapply(pieces, last, character(1))
}

help_path <- function(x, package) {
  help <- mapply(locate_help_doc, x, package, SIMPLIFY = FALSE)

  vapply(
    help,
    function(x) {
      if (length(x) == 0) {
        NA_character_
      } else if (inherits(x, "dev_topic")) {
        sub("[.]Rd$", "", x$path)
      } else {
        as.character(x)
      }
    },
    FUN.VALUE = character(1)
  )
}

locate_help_doc <- function(x, package) {
  help <- if (requireNamespace("pkgload", quietly = TRUE)) {
    shim_help <- get("shim_help", asNamespace("pkgload"))
    function(x, package = NULL) {
      tryCatch(
        expr = shim_help(x, (package)),
        error = function(e) character()
      )
    }
  } else {
    utils::help
  }

  if (is.na(package)) {
    help(x)
  } else {
    help(x, (package))
  }
}

lookup_package <- function(generic, class, is_s4) {
  lookup_single_package <- function(generic, class, is_s4) {
    if (is_s4) {
      class <- strsplit(class, ",")[[1]]
      fn <- methods::getMethod(generic, class, optional = TRUE)
    } else {
      fn <- utils::getS3method(generic, class, optional = TRUE)
    }

    if (is.null(fn)) {
      return(NA_character_)
    }

    fn_package(fn)
  }

  pkgs <- mapply(lookup_single_package, generic, class, is_s4, SIMPLIFY = FALSE)
  as.vector(pkgs, "character")
}