1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
# 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)
}
if (!is.character(version) && !inherits(version, "numeric_version")) {
# Avoid https://bugs.r-project.org/show_bug.cgi?id=18548
alert <- if (identical(Sys.getenv("TESTTHAT"), "true")) stop else warning
alert("`version` must be a character string or a `package_version` or `numeric_version` object.")
version <- numeric_version(sprintf("%0.9g", version))
}
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 package path because
# `system.file()` can be slow. If a package is not installed, the result won't
# be cached.
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)
if (nzchar(pkg_dir)) {
pkg_dir_cache[[package]] <<- pkg_dir
}
} else {
pkg_dir <- pkg_dir_cache[[package]]
}
file.path(pkg_dir, ...)
}
})
|
