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