R/object-from-call.R

In roxygen2: In-Line Documentation for R

object_from_call <- function(call, env, block, file) {
  if (is.character(call)) {
    if (identical(call, "_PACKAGE")) {
      parser_package(file)
    } else {
      parser_data(call, env, file)
    }
  } else if (is_set_call(call)) {
    parser_r6_set(call, env)
  } else if (is.call(call)) {
    if (is_s7_method_call(call)) {
      return(parser_s7_method(call, env, block))
    }

    call <- call_match(call, eval(call[[1]], env))
    name <- deparse(call[[1]])
    switch(
      name,
      "=" = ,
      "<-" = ,
      "<<-" = parser_assignment(call, env, block),
      "delayedAssign" = parser_delayedAssign(call, env, block),
      "::" = parser_import(call, env, block),

      "methods::setClass" = ,
      "setClass" = parser_setClass(call, env, block),
      "methods::setClassUnion" = ,
      "setClassUnion" = parser_setClassUnion(call, env, block),
      "methods::setRefClass" = ,
      "setRefClass" = parser_setRefClass(call, env, block),
      "methods::setGeneric" = ,
      "setGeneric" = parser_setGeneric(call, env, block),
      "methods::setMethod" = ,
      "setMethod" = parser_setMethod(call, env, block),
      "methods::setReplaceMethod" = ,
      "setReplaceMethod" = parser_setReplaceMethod(call, env, block),

      "R.methodsS3::setMethodS3" = ,
      "setMethodS3" = parser_setMethodS3(call, env, block),

      "R.oo::setConstructorS3" = ,
      "setConstructorS3" = parser_setConstructorS3(call, env, block),
      NULL
    )
  } else {
    # Patch @docType package to ensure that it gets a default alias
    # and other "_PACKAGE" features
    if (block_has_tags(block, "docType")) {
      docType <- block_get_tag_value(block, "docType")
      if (docType == "package") {
        warn_roxy_block(
          block,
          c(
            '`@docType "package"` is deprecated',
            i = 'Please document "_PACKAGE" instead.'
          )
        )
        return(parser_package(file))
      }
    }
    NULL
  }
}

object_from_name <- function(name, env, block) {
  value <- get(name, env)
  if (inherits(value, "R6ClassGenerator")) {
    type <- "r6class"
  } else if (methods::is(value, "refObjectGenerator")) {
    value <- methods::getClass(as.character(value@className), where = env)
    type <- "rcclass"
  } else if (methods::is(value, "classGeneratorFunction")) {
    value <- methods::getClass(as.character(value@className), where = env)
    type <- "s4class"
  } else if (methods::is(value, "MethodDefinition")) {
    # S4 methods need munging to get real function def
    value@.Data <- extract_method_fun(value@.Data)
    type <- "s4method"
  } else if (methods::is(value, "standardGeneric")) {
    type <- "s4generic"
  } else if (inherits(value, "S7_class")) {
    type <- "s7class"
  } else if (inherits(value, "S7_generic")) {
    type <- "s7generic"
  } else if (is.function(value)) {
    # Potential S3 methods/generics need metadata added
    method <- block_get_tag_value(block, "method")
    value <- add_s3_metadata(value, name, env, block)
    if (inherits(value, "s3generic")) {
      type <- "s3generic"
    } else if (inherits(value, "s3method")) {
      type <- "s3method"
    } else {
      type <- "function"
    }
  } else {
    type <- "value"
  }

  object(value, name, type)
}

# Parsers for individual calls --------------------------------------------

is_set_call <- function(call) {
  is_call(call) &&
    is_call(call[[1]], "$", n = 2) &&
    is_symbol(call[[1]][[3]], "set")
}

parser_r6_set <- function(call, env) {
  lhs <- call[[1]]

  obj_name <- deparse(lhs[[2]])
  obj <- tryCatch(get(obj_name, envir = env), error = function(e) NULL)
  if (!inherits(obj, "R6ClassGenerator")) {
    return(NULL)
  }
  class_name <- obj$classname

  method_name <- call[[3]]
  if (!is.character(method_name)) {
    return(NULL)
  }

  object(list(class = class_name, method = method_name), NULL, "r6method")
}

parser_data <- function(call, env, block) {
  if (isNamespace(env)) {
    value <- getExportedValue(call, ns = asNamespace(env))
  } else {
    value <- get(call, envir = env)
  }
  object(value, call, type = "data")
}

parser_package <- function(file) {
  pkg_path <- dirname(dirname(file))
  value <- list(
    desc = desc::desc(file = pkg_path),
    path = pkg_path
  )
  object(value, NULL, type = "package")
}

parser_assignment <- function(call, env, block) {
  name <- as.character(call[[2]])

  # If it's a compound assignment like x[[2]] <- ignore it
  if (length(name) > 1) {
    return()
  }

  # If it doesn't exist (any more), don't document it.
  if (!exists(name, env)) {
    return()
  }

  object_from_name(name, env, block)
}

parser_delayedAssign <- function(call, env, block) {
  name <- as.character(call$x)
  object_from_name(name, env, block)
}

parser_setClass <- function(call, env, block) {
  name <- as.character(call$Class)
  value <- methods::getClass(name, where = env)

  object(value, NULL, "s4class")
}

parser_setClassUnion <- function(call, env, block) {
  name <- as.character(call$name)
  value <- methods::getClass(name, where = env)

  object(value, NULL, "s4class")
}

parser_setRefClass <- function(call, env, block) {
  name <- as.character(call$Class)
  value <- methods::getClass(name, where = env)

  object(value, NULL, "rcclass")
}

parser_setGeneric <- function(call, env, block) {
  name <- as.character(call$name)
  value <- methods::getGeneric(name, where = env)

  object(value, NULL, "s4generic")
}

parser_setMethod <- function(call, env, block) {
  name <- as.character(call$f)
  value <- methods::getMethod(name, eval(call$signature), where = env)
  value@.Data <- extract_method_fun(value@.Data)

  object(value, NULL, "s4method")
}

parser_setReplaceMethod <- function(call, env, block) {
  name <- paste0(as.character(call$f), "<-")
  value <- methods::getMethod(name, eval(call[[3]]), where = env)
  value@.Data <- extract_method_fun(value@.Data)

  object(value, NULL, "s4method")
}

parser_import <- function(call, env, block) {
  pkg <- as.character(call[[2]])
  fun <- as.character(call[[3]])

  object(list(pkg = pkg, fun = fun), alias = fun, type = "import")
}

parser_setMethodS3 <- function(call, env, block) {
  # R.methodsS3::setMethodS3(name, class, ...)
  method <- as.character(call[[2]])
  class <- as.character(call[[3]])
  name <- paste(method, class, sep = ".")

  value <- add_s3_metadata(get(name, env), name, env, block)

  object(value, name, "s3method")
}

parser_setConstructorS3 <- function(call, env, block) {
  # R.oo::setConstructorS3(name, ...)
  name <- as.character(call[[2]])
  object(get(name, env), name, "function")
}

# method(generic, class) <- fn
# `<-`(method(generic, class), fn)
is_s7_method_call <- function(call) {
  is_call(call, "<-", n = 2) && is_call(call[[2]], "method", ns = c("", "S7"))
}

parser_s7_method <- function(call, env, block) {
  generic_call <- call[[2]][[2]]
  class_call <- call[[2]][[3]]
  method_call <- call[[3]]

  generic <- eval(generic_call, env)
  if (inherits(generic, "S7_generic")) {
    generic_name <- generic@name
  } else {
    # S3 or S4 generic passed by name
    generic_name <- deparse(generic_call)
  }

  # Evaluate class spec: either a single class, a union, or list() for
  # multi-dispatch
  classes <- eval(class_call, env)
  if (!is_bare_list(classes)) {
    classes <- list(classes)
  }
  class_names <- lapply(classes, s7_class_name, block = block)

  fn <- eval(method_call, env)

  value <- list(fn = fn, generic = generic_name, classes = class_names)
  aliases <- s7_method_aliases(generic_name, class_names)
  object(value, aliases, "s7method")
}

s7_method_aliases <- function(generic, classes) {
  if (!any(lengths(classes) > 1)) {
    return(NULL)
  }

  combos <- expand.grid(classes, stringsAsFactors = FALSE)
  apply(combos, 1, function(row) {
    paste0(generic, ",", paste0(row, collapse = ","), "-method")
  })
}

# https://github.com/RConsortium/S7/issues/594
s7_class_name <- function(cls, block) {
  name <- nameOfClass(cls)
  if (!is.null(name)) {
    # Regular S7 class + base wrappers
    name
  } else if (inherits(cls, "S7_union")) {
    # Unions return vector of member names, recursing for nested types
    unlist(lapply(cls$classes, s7_class_name, block = block))
  } else if (inherits(cls, "S7_S3_class")) {
    cls$class
  } else if (inherits(cls, "S7_any")) {
    "any"
  } else if (inherits(cls, "S7_missing")) {
    "missing"
  } else {
    warn_roxy_block(block, "Unknown S7 class type")
    paste0(deparse(cls), collapse = " ")
  }
}

# helpers -----------------------------------------------------------------

add_s3_metadata <- function(val, name, env, block) {
  if (block_has_tags(block, "method")) {
    method <- block_get_tag_value(block, "method")
    return(s3_method(val, method))
  }

  if (block_has_tags(block, "exportS3Method")) {
    method <- block_get_tag_value(block, "exportS3Method")
    if (length(method) == 1 && grepl("::", method, fixed = TRUE)) {
      generic <- re_split_half(method, "::")[[2]]
      class <- gsub(paste0("^", generic, "\\."), "", name)
      return(s3_method(val, c(generic, class)))
    }
  }

  if (is_s3_generic(name, env)) {
    class(val) <- c("s3generic", "function")
    return(val)
  }

  method <- find_generic(name, env)
  if (is.null(method)) {
    val
  } else {
    s3_method(val, method)
  }
}

# When a generic has ... and a method adds new arguments, the S4 method
# wraps the definition inside another function which has the same arguments
# as the generic. This function figures out if that's the case, and extracts
# the original function if so.
#
# It's based on expression processing based on the structure of the
# constructed method which looks like:
#
# function (x, ...) {
#   .local <- function (x, ..., y = 7) {}
#   .local(x, ...)
# }
extract_method_fun <- function(fun) {
  method_body <- body(fun)
  if (!is_call(method_body, "{")) {
    return(fun)
  }
  if (length(method_body) < 2) {
    return(fun)
  }

  first_line <- method_body[[2]]
  if (!is_call(first_line, name = "<-", n = 2)) {
    return(fun)
  }
  if (!identical(first_line[[2]], quote(`.local`))) {
    return(fun)
  }

  local_fun <- eval(first_line[[3]])
  if (!is.function(local_fun)) {
    return(fun)
  }

  local_fun
}

#' Constructors for S3 object to represent R objects
#'
#' These objects are usually created by the parsers, but it is also
#' useful to generate them by hand for testing.
#'
#' @param value The object itself.
#' @param alias Alias for object being documented, in case you create a
#'   generator function with different name.
#' @export
#' @keywords internal
#' @param type Type of the object, character. E.g. `"data"` or `"s4method"`.
object <- function(value, alias, type) {
  structure(
    list(
      alias = alias,
      value = value,
      methods = if (type == "rcclass") rc_methods(value),
      topic = object_topic(value, alias, type)
    ),
    class = c(type, "object")
  )
}

#' @export
format.object <- function(x, ...) {
  c(
    paste0("<", class(x)[1], "> ", x$name),
    paste0("  $topic ", x$topic),
    if (!is.null(x$alias)) paste0("  $alias ", x$alias)
  )
}

#' @export
print.object <- function(x, ...) {
  cat_line(format(x, ...))
}

object_topic <- function(value, alias, type) {
  switch(
    type,
    s4method = method_topic(value@generic, value@defined),
    s4class = paste0(value@className, "-class"),
    s4generic = value@generic,
    rcclass = paste0(value@className, "-class"),
    r6class = alias,
    r6method = alias,
    rcmethod = value@name,
    s7class = alias,
    s7generic = alias,
    s7method = method_topic(value$generic, value$classes),
    s3generic = alias,
    s3method = alias,
    import = alias,
    `function` = alias,
    package = alias,
    data = alias,
    value = alias,
    cli::cli_abort("Unsupported type {.str {type}}.", .internal = TRUE)
  )
}

method_topic <- function(generic, classes) {
  class_strings <- vapply(classes, paste0, character(1), collapse = "/")
  paste0(generic, ",", paste0(class_strings, collapse = ","), "-method")
}

call_to_object <- function(code, env = pkg_env(), file = NULL) {
  code <- enexpr(code)

  eval(code, envir = env)
  if (is_call(code, "{")) {
    call <- code[[length(code)]]
  } else {
    call <- code
  }
  object_from_call(call, env, block = NULL, file = file)
}