1# This source code file is licensed under the unlicense license
2# https://unlicense.org
3#' Register a method for a suggested dependency
4#'
5#' Generally, the recommend way to register an S3 method is to use the
6#' `S3Method()` namespace directive (often generated automatically by the
7#' `@export` roxygen2 tag). However, this technique requires that the generic
8#' be in an imported package, and sometimes you want to suggest a package,
9#' and only provide a method when that package is loaded. `s3_register()`
10#' can be called from your package's `.onLoad()` to dynamically register
11#' a method only if the generic's package is loaded.
12#'
13#' For R 3.5.0 and later, `s3_register()` is also useful when demonstrating
14#' class creation in a vignette, since method lookup no longer always involves
15#' the lexical scope. For R 3.6.0 and later, you can achieve a similar effect
16#' by using "delayed method registration", i.e. placing the following in your
17#' `NAMESPACE` file:
18#'
19#' ```
20#' if (getRversion() >= "3.6.0") {
21#'   S3method(package::generic, class)
22#' }
23#' ```
24#'
25#' @section Usage in other packages:
26#' To avoid taking a dependency on vctrs, you copy the source of
27#' [`s3_register()`](https://github.com/r-lib/vctrs/blob/master/R/register-s3.R)
28#' into your own package. It is licensed under the permissive
29#' [unlicense](https://choosealicense.com/licenses/unlicense/) to make it
30#' crystal clear that we're happy for you to do this. There's no need to include
31#' the license or even credit us when using this function.
32#'
33#' @usage NULL
34#' @param generic Name of the generic in the form `pkg::generic`.
35#' @param class Name of the class
36#' @param method Optionally, the implementation of the method. By default,
37#'   this will be found by looking for a function called `generic.class`
38#'   in the package environment.
39#'
40#'   Note that providing `method` can be dangerous if you use
41#'   devtools. When the namespace of the method is reloaded by
42#'   `devtools::load_all()`, the function will keep inheriting from
43#'   the old namespace. This might cause crashes because of dangling
44#'   `.Call()` pointers.
45#' @export
46#' @examples
47#' # A typical use case is to dynamically register tibble/pillar methods
48#' # for your class. That way you avoid creating a hard dependency on packages
49#' # that are not essential, while still providing finer control over
50#' # printing when they are used.
51#'
52#' .onLoad <- function(...) {
53#'   s3_register("pillar::pillar_shaft", "vctrs_vctr")
54#'   s3_register("tibble::type_sum", "vctrs_vctr")
55#' }
56#' @keywords internal
57# nocov start
58s3_register <- function(generic, class, method = NULL) {
59  stopifnot(is.character(generic), length(generic) == 1)
60  stopifnot(is.character(class), length(class) == 1)
61
62  pieces <- strsplit(generic, "::")[[1]]
63  stopifnot(length(pieces) == 2)
64  package <- pieces[[1]]
65  generic <- pieces[[2]]
66
67  caller <- parent.frame()
68
69  get_method_env <- function() {
70    top <- topenv(caller)
71    if (isNamespace(top)) {
72      asNamespace(environmentName(top))
73    } else {
74      caller
75    }
76  }
77  get_method <- function(method, env) {
78    if (is.null(method)) {
79      get(paste0(generic, ".", class), envir = get_method_env())
80    } else {
81      method
82    }
83  }
84
85  register <- function(...) {
86    envir <- asNamespace(package)
87
88    # Refresh the method each time, it might have been updated by
89    # `devtools::load_all()`
90    method_fn <- get_method(method)
91    stopifnot(is.function(method_fn))
92
93
94    # Only register if generic can be accessed
95    if (exists(generic, envir)) {
96      registerS3method(generic, class, method_fn, envir = envir)
97    } else if (identical(Sys.getenv("NOT_CRAN"), "true")) {
98      warning(sprintf(
99        "Can't find generic `%s` in package %s to register S3 method.",
100        generic,
101        package
102      ))
103    }
104  }
105
106  # Always register hook in case package is later unloaded & reloaded
107  setHook(packageEvent(package, "onLoad"), register)
108
109  # Avoid registration failures during loading (pkgload or regular)
110  if (isNamespaceLoaded(package)) {
111    register()
112  }
113
114  invisible()
115}
116on_load({
117  s3_register <- replace_from("s3_register", "rlang")
118})
119
120knitr_defer <- function(expr, env = caller_env()) {
121  roxy_caller <- detect(sys.frames(), env_inherits, ns_env("knitr"))
122  if (is_null(roxy_caller)) {
123    abort("Internal error: can't find knitr on the stack.")
124  }
125
126  blast(
127    withr::defer(!!substitute(expr), !!roxy_caller),
128    env
129  )
130}
131blast <- function(expr, env = caller_env()) {
132  eval_bare(enexpr(expr), env)
133}
134
135knitr_local_registration <- function(generic, class, env = caller_env()) {
136  stopifnot(is.character(generic), length(generic) == 1)
137  stopifnot(is.character(class), length(class) == 1)
138
139  pieces <- strsplit(generic, "::")[[1]]
140  stopifnot(length(pieces) == 2)
141  package <- pieces[[1]]
142  generic <- pieces[[2]]
143
144  name <- paste0(generic, ".", class)
145  method <- env_get(env, name)
146
147  old <- env_bind(global_env(), !!name := method)
148  knitr_defer(env_bind(global_env(), !!!old))
149}
150
151
152# nocov end
153