-
Notifications
You must be signed in to change notification settings - Fork 205
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #422 from ramnathv/fast-staticimports
- Loading branch information
Showing
6 changed files
with
221 additions
and
140 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,44 +1,8 @@ | ||
| # Reusable function for registering a set of methods with S3 manually. The | ||
| # methods argument is a list of character vectors, each of which has the form | ||
| # c(package, genname, class). | ||
| registerMethods <- function(methods) { | ||
| lapply(methods, function(method) { | ||
| pkg <- method[[1]] | ||
| generic <- method[[2]] | ||
| class <- method[[3]] | ||
| func <- get(paste(generic, class, sep=".")) | ||
| if (pkg %in% loadedNamespaces()) { | ||
| registerS3method(generic, class, func, envir = asNamespace(pkg)) | ||
| } | ||
| setHook( | ||
| packageEvent(pkg, "onLoad"), | ||
| function(...) { | ||
| registerS3method(generic, class, func, envir = asNamespace(pkg)) | ||
| } | ||
| ) | ||
| }) | ||
| } | ||
|
|
||
| .onLoad <- function(...) { | ||
| # htmlwidgets provides methods for knitr::knit_print, but knitr isn't a Depends or | ||
| # Imports of htmltools, only an Enhances. Therefore, the NAMESPACE file has to | ||
| # declare it as an export, not an S3method. That means that R will only know to | ||
| # use our methods if htmlwidgets is actually attached, i.e., you have to use | ||
| # library(htmlwidgets) in a knitr document or else you'll get escaped HTML in your | ||
| # document. This code snippet manually registers our method(s) with S3 once both | ||
| # htmlwidgets and knitr are loaded. | ||
| registerMethods(list( | ||
| # c(package, genname, class) | ||
| c("knitr", "knit_print", "htmlwidget") | ||
| )) | ||
| } | ||
|
|
||
| .onAttach <- function(...) { | ||
| # warn if the version of shiny is lower than what was specified in DESCRIPTION | ||
| checkShinyVersion(error = FALSE) | ||
| s3_register("knitr::knit_print", "htmlwidget") | ||
| register_upgrade_message("shiny", "1.1", error = TRUE) | ||
| } | ||
|
|
||
| knit_print.htmlwidget <- function(x, ..., options = NULL) { | ||
| knitr::knit_print(toHTML(x, standalone = FALSE, knitrOptions = options), options = options, ...) | ||
| } | ||
|
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,204 @@ | ||
| # Generated by staticimports; do not edit by hand. | ||
| # ====================================================================== | ||
| # Imported from pkg:staticimports | ||
| # ====================================================================== | ||
|
|
||
| `%||%` <- function(a, b) { | ||
| if (is.null(a)) b else a | ||
| } | ||
|
|
||
| # Borrowed from pkgload:::dev_meta, with some modifications. | ||
| # Returns TRUE if `pkg` was loaded with `devtools::load_all()`. | ||
| devtools_loaded <- function(pkg) { | ||
| ns <- .getNamespace(pkg) | ||
| if (is.null(ns) || is.null(ns$.__DEVTOOLS__)) { | ||
| return(FALSE) | ||
| } | ||
| TRUE | ||
| } | ||
|
|
||
| get_package_version <- function(pkg) { | ||
| # `utils::packageVersion()` can be slow, so first try the fast path of | ||
| # checking if the package is already loaded. | ||
| ns <- .getNamespace(pkg) | ||
| if (is.null(ns)) { | ||
| utils::packageVersion(pkg) | ||
| } else { | ||
| as.package_version(ns$.__NAMESPACE__.$spec[["version"]]) | ||
| } | ||
| } | ||
|
|
||
| is_installed <- function(pkg, version = NULL) { | ||
| installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg)) | ||
| if (is.null(version)) { | ||
| return(installed) | ||
| } | ||
| installed && isTRUE(get_package_version(pkg) >= version) | ||
| } | ||
|
|
||
| register_upgrade_message <- function(pkg, version, error = FALSE) { | ||
|
|
||
| msg <- sprintf( | ||
| "This version of '%s' is designed to work with '%s' >= %s. | ||
| Please upgrade via install.packages('%s').", | ||
| environmentName(environment(register_upgrade_message)), | ||
| pkg, version, pkg | ||
| ) | ||
|
|
||
| cond <- if (error) stop else packageStartupMessage | ||
|
|
||
| if (pkg %in% loadedNamespaces() && !is_installed(pkg, version)) { | ||
| cond(msg) | ||
| } | ||
|
|
||
| # Always register hook in case pkg is loaded at some | ||
| # point the future (or, potentially, but less commonly, | ||
| # unloaded & reloaded) | ||
| setHook( | ||
| packageEvent(pkg, "onLoad"), | ||
| function(...) { | ||
| if (!is_installed(pkg, version)) cond(msg) | ||
| } | ||
| ) | ||
| } | ||
|
|
||
| # Simplified version rlang:::s3_register() that just uses | ||
| # warning() instead of rlang::warn() when registration fails | ||
| # https://github.com/r-lib/rlang/blob/main/R/compat-s3-register.R | ||
| s3_register <- 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 { | ||
| warning( | ||
| "Can't find generic `", generic, "` in package ", package, | ||
| " register S3 method. Do you need to update ", package, | ||
| " to the latest version?", call. = FALSE | ||
| ) | ||
| } | ||
| } | ||
|
|
||
| # Always register hook in case package is later unloaded & reloaded | ||
| setHook(packageEvent(package, "onLoad"), function(...) { | ||
| register() | ||
| }) | ||
|
|
||
| # Avoid registration failures during loading (pkgload or regular). | ||
| # Check that environment is locked because the registering package | ||
| # might be a dependency of the package that exports the generic. In | ||
| # that case, the exports (and the generic) might not be populated | ||
| # yet (#1225). | ||
| if (isNamespaceLoaded(package) && environmentIsLocked(asNamespace(package))) { | ||
| register() | ||
| } | ||
|
|
||
| invisible() | ||
| } | ||
|
|
||
| # Borrowed from pkgload::shim_system.file, with some modifications. This behaves | ||
| # like `system.file()`, except that (1) for packages loaded with | ||
| # `devtools::load_all()`, it will return the path to files in the package's | ||
| # inst/ directory, and (2) for other packages, the directory lookup is cached. | ||
| # Also, to keep the implementation simple, it doesn't support specification of | ||
| # lib.loc or mustWork. | ||
| system_file <- function(..., package = "base") { | ||
| if (!devtools_loaded(package)) { | ||
| return(system_file_cached(..., package = package)) | ||
| } | ||
|
|
||
| if (!is.null(names(list(...)))) { | ||
| stop("All arguments other than `package` must be unnamed.") | ||
| } | ||
|
|
||
| # If package was loaded with devtools (the package loaded with load_all), | ||
| # also search for files under inst/, and don't cache the results (it seems | ||
| # more likely that the package path will change during the development | ||
| # process) | ||
| pkg_path <- find.package(package) | ||
|
|
||
| # First look in inst/ | ||
| files_inst <- file.path(pkg_path, "inst", ...) | ||
| present_inst <- file.exists(files_inst) | ||
|
|
||
| # For any files that weren't present in inst/, look in the base path | ||
| files_top <- file.path(pkg_path, ...) | ||
| present_top <- file.exists(files_top) | ||
|
|
||
| # Merge them together. Here are the different possible conditions, and the | ||
| # desired result. NULL means to drop that element from the result. | ||
| # | ||
| # files_inst: /inst/A /inst/B /inst/C /inst/D | ||
| # present_inst: T T F F | ||
| # files_top: /A /B /C /D | ||
| # present_top: T F T F | ||
| # result: /inst/A /inst/B /C NULL | ||
| # | ||
| files <- files_top | ||
| files[present_inst] <- files_inst[present_inst] | ||
| # Drop cases where not present in either location | ||
| files <- files[present_inst | present_top] | ||
| if (length(files) == 0) { | ||
| return("") | ||
| } | ||
| # Make sure backslashes are replaced with slashes on Windows | ||
| normalizePath(files, winslash = "/") | ||
| } | ||
|
|
||
| # A wrapper for `system.file()`, which caches the results, because | ||
| # `system.file()` can be slow. Note that because of caching, if | ||
| # `system_file_cached()` is called on a package that isn't installed, then the | ||
| # package is installed, and then `system_file_cached()` is called again, it will | ||
| # still return "". | ||
| system_file_cached <- local({ | ||
| pkg_dir_cache <- character() | ||
|
|
||
| function(..., package = "base") { | ||
| if (!is.null(names(list(...)))) { | ||
| stop("All arguments other than `package` must be unnamed.") | ||
| } | ||
|
|
||
| not_cached <- is.na(match(package, names(pkg_dir_cache))) | ||
| if (not_cached) { | ||
| pkg_dir <- system.file(package = package) | ||
| pkg_dir_cache[[package]] <<- pkg_dir | ||
| } else { | ||
| pkg_dir <- pkg_dir_cache[[package]] | ||
| } | ||
|
|
||
| file.path(pkg_dir, ...) | ||
| } | ||
| }) |
Oops, something went wrong.