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
|
# 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)
}
is_string <- function(x) {
is.character(x) && length(x) == 1 && !is.na(x)
}
raw_to_utf8 <- function(data) {
res <- rawToChar(data)
Encoding(res) <- "UTF-8"
res
}
read_raw <- function(file) {
readBin(file, "raw", n = file.info(file, extra_cols = FALSE)$size)
}
# Read file as UTF-8
read_utf8 <- function(file) {
res <- read_raw(file)
raw_to_utf8(res)
}
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)
}
)
}
# 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, ...)
}
})
|
