Merge pull request #1525 from fweber144/projpred_registerS3

Modernize registration of S3 method for projpred generic

DESCRIPTION

@@ -18,7 +18,7 @@ Authors@R:
       person("Simon C.", "Mills", role = c("ctb")),
       person("Stephen", "Wild", role = c("ctb")))
 Depends:
-    R (>= 3.5.0),
+    R (>= 3.6.0),
     Rcpp (>= 0.12.0),
     methods
 Imports:

NAMESPACE

@@ -221,6 +221,7 @@ S3method(prior_predictor,btl)
 S3method(prior_predictor,btnl)
 S3method(prior_predictor,default)
 S3method(prior_summary,brmsfit)
+S3method(projpred::get_refmodel,brmsfit)
 S3method(r_eff_log_lik,"function")
 S3method(r_eff_log_lik,matrix)
 S3method(ranef,brmsfit)

R/misc.R

@@ -1038,69 +1038,6 @@ expect_match2 <- function(object, regexp, ..., all = TRUE) {
   testthat::expect_match(object, regexp, fixed = TRUE, ..., all = all)
 }
 
-# Copied from package 'vctrs' (more precisely:
-# <https://github.com/r-lib/vctrs/blob/master/R/register-s3.R>, version
-# 0.3.8.9001; identical to the code from version 0.3.8), as offered on the help
-# page for vctrs::s3_register() (version 0.3.8):
-s3_register_cp <- function(generic, class, method = NULL) {
-  stopifnot(is.character(generic), length(generic) == 1)
-  stopifnot(is.character(class), length(class) == 1)
-
-  pieces <- strsplit(generic, "::")[[1]]
-  stopifnot(length(pieces) == 2)
-  package <- pieces[[1]]
-  generic <- pieces[[2]]
-
-  caller <- parent.frame()
-
-  get_method_env <- function() {
-    top <- topenv(caller)
-    if (isNamespace(top)) {
-      asNamespace(environmentName(top))
-    } else {
-      caller
-    }
-  }
-  get_method <- function(method, env) {
-    if (is.null(method)) {
-      get(paste0(generic, ".", class), envir = get_method_env())
-    } else {
-      method
-    }
-  }
-
-  register <- function(...) {
-    envir <- asNamespace(package)
-
-    # Refresh the method each time, it might have been updated by
-    # `devtools::load_all()`
-    method_fn <- get_method(method)
-    stopifnot(is.function(method_fn))
-
-
-    # Only register if generic can be accessed
-    if (exists(generic, envir)) {
-      registerS3method(generic, class, method_fn, envir = envir)
-    } else if (identical(Sys.getenv("NOT_CRAN"), "true")) {
-      warning(sprintf(
-        "Can't find generic `%s` in package %s to register S3 method.",
-        generic,
-        package
-      ))
-    }
-  }
-
-  # Always register hook in case package is later unloaded & reloaded
-  setHook(packageEvent(package, "onLoad"), register)
-
-  # Avoid registration failures during loading (pkgload or regular)
-  if (isNamespaceLoaded(package)) {
-    register()
-  }
-
-  invisible()
-}
-
 # startup messages for brms
 .onAttach <- function(libname, pkgname) {
   version <- utils::packageVersion("brms")
@@ -1122,10 +1059,5 @@ s3_register_cp <- function(generic, class, method = NULL) {
       utils::packageVersion("emmeans") >= "1.4.0") {
     emmeans::.emm_register("brmsfit", pkgname)
   }
-  # dynamically register the 'get_refmodel.brmsfit' method for the
-  # 'get_refmodel' generic from 'projpred', if that package is installed
-  if (requireNamespace("projpred", quietly = TRUE)) {
-    s3_register_cp("projpred::get_refmodel", "brmsfit")
-  }
   invisible(NULL)
 }

R/projpred.R

@@ -55,6 +55,7 @@
 #' summary(cv_vs)
 #' plot(cv_vs)
 #' }
+#' @exportS3Method projpred::get_refmodel brmsfit
 get_refmodel.brmsfit <- function(object, newdata = NULL, resp = NULL,
                                  cvfun = NULL, dis = NULL, latent = FALSE,
                                  brms_seed = NULL, ...) {