@@ -34,32 +34,6 @@ is_installed <- function(pkg, version = NULL) {
3434 installed && isTRUE(get_package_version(pkg ) > = version )
3535}
3636
37- register_s3_method <- function (pkg , generic , class , fun = NULL ) {
38- stopifnot(is.character(pkg ), length(pkg ) == 1 )
39- stopifnot(is.character(generic ), length(generic ) == 1 )
40- stopifnot(is.character(class ), length(class ) == 1 )
41-
42- if (is.null(fun )) {
43- fun <- get(paste0(generic , " ." , class ), envir = parent.frame())
44- } else {
45- stopifnot(is.function(fun ))
46- }
47-
48- if (pkg %in% loadedNamespaces()) {
49- registerS3method(generic , class , fun , envir = asNamespace(pkg ))
50- }
51-
52- # Always register hook in case pkg is loaded at some
53- # point the future (or, potentially, but less commonly,
54- # unloaded & reloaded)
55- setHook(
56- packageEvent(pkg , " onLoad" ),
57- function (... ) {
58- registerS3method(generic , class , fun , envir = asNamespace(pkg ))
59- }
60- )
61- }
62-
6337register_upgrade_message <- function (pkg , version , error = FALSE ) {
6438
6539 msg <- sprintf(
@@ -86,6 +60,73 @@ register_upgrade_message <- function(pkg, version, error = FALSE) {
8660 )
8761}
8862
63+ # Simplified version rlang:::s3_register() that just uses
64+ # warning() instead of rlang::warn() when registration fails
65+ # https://github.com/r-lib/rlang/blob/main/R/compat-s3-register.R
66+ s3_register <- function (generic , class , method = NULL ) {
67+ stopifnot(is.character(generic ), length(generic ) == 1 )
68+ stopifnot(is.character(class ), length(class ) == 1 )
69+
70+ pieces <- strsplit(generic , " ::" )[[1 ]]
71+ stopifnot(length(pieces ) == 2 )
72+ package <- pieces [[1 ]]
73+ generic <- pieces [[2 ]]
74+
75+ caller <- parent.frame()
76+
77+ get_method_env <- function () {
78+ top <- topenv(caller )
79+ if (isNamespace(top )) {
80+ asNamespace(environmentName(top ))
81+ } else {
82+ caller
83+ }
84+ }
85+ get_method <- function (method , env ) {
86+ if (is.null(method )) {
87+ get(paste0(generic , " ." , class ), envir = get_method_env())
88+ } else {
89+ method
90+ }
91+ }
92+
93+ register <- function (... ) {
94+ envir <- asNamespace(package )
95+
96+ # Refresh the method each time, it might have been updated by
97+ # `devtools::load_all()`
98+ method_fn <- get_method(method )
99+ stopifnot(is.function(method_fn ))
100+
101+ # Only register if generic can be accessed
102+ if (exists(generic , envir )) {
103+ registerS3method(generic , class , method_fn , envir = envir )
104+ } else {
105+ warning(
106+ " Can't find generic `" , generic , " ` in package " , package ,
107+ " register S3 method. Do you need to update " , package ,
108+ " to the latest version?" , call. = FALSE
109+ )
110+ }
111+ }
112+
113+ # Always register hook in case package is later unloaded & reloaded
114+ setHook(packageEvent(package , " onLoad" ), function (... ) {
115+ register()
116+ })
117+
118+ # Avoid registration failures during loading (pkgload or regular).
119+ # Check that environment is locked because the registering package
120+ # might be a dependency of the package that exports the generic. In
121+ # that case, the exports (and the generic) might not be populated
122+ # yet (#1225).
123+ if (isNamespaceLoaded(package ) && environmentIsLocked(asNamespace(package ))) {
124+ register()
125+ }
126+
127+ invisible ()
128+ }
129+
89130# Borrowed from pkgload::shim_system.file, with some modifications.
90131# Most notably, if the package isn't loaded via devtools, the package directory
91132# lookup is cached. Also, to keep the implementation simple, it doesn't support
0 commit comments