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
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
# Project: pkgmaker
#
# Author: renaud
# Created: Jul 2, 2014
###############################################################################
#' @include packages.R
NULL
#' User Queries
#'
#' This function is an improved version of \code{userQuery} from Bioconductor \pkg{Biobase}
#' package, which asks the user about some task that needs her intervention to proceed,
#' e.g., ask if one should perform a computation, install a package, etc..
#'
#' @inheritParams Biobase::userQuery
#' @param idefault default response in interactive mode.
#' This answer will be in upper case in the question and will be the one returned if the
#' user simply hits return.
#' @param default default response in non-interactive mode.
#'
#' If \code{NA}, then the user is forced to provide an answer, even in non-interactive mode
#' (e.g., when run through \code{Rscript}).
#'
#' @return the character string typed/agreed by the user or directly the default answer in
#' non-interactive mode.
#'
#' @export
askUser <- function (msg, allowed = c("y", "n"), idefault = "n", default = "n", case.sensitive = FALSE)
{
ucon <- stdin()
if ( !interactive() ) {
if( is_NA(default) ) ucon <- 'stdin'
else return(default)
}
fallowed <- allowed
# add extra info on answer options
if( !is.null(nm <- names(allowed)) ){
allowed[nm != ''] <- nm[nm != '']
}
if( !isFALSE(idefault) )
fallowed[fallowed == idefault] <- toupper(idefault)
repeat {
allowMsg <- paste("[", paste(fallowed, collapse = "/"),
"]: ", sep = "")
outMsg <- paste(msg, allowMsg)
cat("\n", outMsg, sep='')
if (case.sensitive)
ans <- readLines(ucon, n = 1)
else ans <- tolower(readLines(ucon, n = 1))
if( !isFALSE(idefault) && !nchar(ans) )
ans <- idefault
if (ans %in% allowed)
break
else cat(paste(ans, "is not a valid response, try again.\n"))
}
# return answer
ans
}
#' User Data Directory
#'
#' \code{userData} returns the path to a local directory/file where package-related user data can be stored.
#' Note that a base directory is \strong{always} created if necessary (see details).
#'
#' The package-specific user data base directory is the sub-directory \emph{R-data/},
#' located in the user's home or within a diredctory defined by global option 'userData.path'.
#'
#' If in interactive mode, and the base directory does not exist yet,
#' the user is asked if it should be created in his home directory.
#' Otherwise, or if the user does not allow the creation in his home, this directory is created
#' in the current R session's temporary directory.
#'
#' @param ... path parts passed to \code{\link{file.path}} to be appended to
#' the main path.
#' @param create logical that indicates if the \strong{base} directory should be
#' created if it does not exists.
#'
#' Note that directories -- and files -- under the base directory are not automatically
#' created. The user should therefore care of it in the caller function if necessary.
#'
#' If \code{create=TRUE}, then the base directory is forced to be created in the user's home directory.
#' If \code{create=FALSE}, then the base directory is never created.
#'
#' See also section \emph{Details}.
#'
#' @param package name of the package associated with the user data path.
#' It is used to prefix the path, within the user R data directory.
#'
#' @seealso \code{\link{tempdir}}
#'
#' @return Path to the user data directory.
#'
#' @export
userData <- function(..., create=NULL, package = topenv(parent.frame())){
if( is.environment(package) ) package <- utils::packageName(package)
root_dir <- getOption('userData.path', Sys.getenv('HOME'))
p <- file.path(root_dir, 'R-data', package)
# ask the user about creating the directory
if( !file.exists(p) && (is.null(create) || isTRUE(create)) ){
if( is.null(create) ){
ans <- askUser(str_c("The ", package, " user data directory '", p, "' doen't exist. Do you want to create it?")
, idefault='y', default='n')
if( ans == 'n' ){
p <- file.path(tempdir(), 'R-data', package)
}
}
if( !file.exists(p) ){
message("Creating user data directory '", p, "'")
dir.create(p, recursive=TRUE)
}
}
file.path(p, ...)
}
#' Require a Package with User Interaction
#'
#' Like base \code{\link{require}}, \code{irequire} tries to find and load a package,
#' but in an interactive way, i.e. offering the user to install it if not found.
#'
#' @param package name of the package
#' @param lib path to the directory (library) where the package is to be
#' looked for and installed if agreed by the user.
#' @param ... extra arguments passed to \code{\link{install.packages}}.
#' @param load a logical that indicates if the package should be loaded,
#' possibly after installation.
#' @param msg message to display in case the package is not found when first
#' trying to load/find it.
#' This message is appended to the string `"Package '<packagename>' is required"`.
#' @param quiet logical that indicates if loading a package should be done quietly
#' with \code{\link{require.quiet}} or normally with \code{\link{require}}.
#' @param prependLF logical that indicates if the message should start at a new line.
#' @param ptype type of package: from CRAN-like repositories, Bioconductor, Bioconductor software, Bioconductor annotation.
#' Bioconductor packages are installed using \code{biocLite} from the
#' \pkg{BiocInstaller} package or fetched on line at \url{http://bioconductor.org/biocLite.R}.
#' @param autoinstall logical that indicates if missing packages should just be installed
#' without asking with the user, which is the default in non-interactive sessions.
#'
#' @return \code{TRUE} if the package was successfully loaded/found (installed),
#' \code{FALSE} otherwise.
#'
#' @family require
#' @export
irequire <- function(package, lib=NULL, ..., load=TRUE, msg=NULL, quiet=TRUE, prependLF=FALSE
, ptype=c('CRAN-like', 'BioC', 'BioCsoft', 'BioCann')
, autoinstall = !interactive() ){
.reqpkg <- if( quiet ) qrequire else{
if( prependLF ) message()
require
}
reqpkg <- function(...){
.reqpkg(..., lib=lib, character.only=TRUE)
}
# vectorized version
if( length(package) >1L ){
return( all(sapply(package, irequire, lib = lib, ...
, load = load, msg = msg, quiet = quiet
, prependLF = prependLF, autoinstall = autoinstall)) )
}
# try loading it
if( load && reqpkg(package) ) return( TRUE )
# try finding it without loading
else if( length(find.package(package, lib.loc=lib, quiet=TRUE)) ) return( TRUE )
# package was not found: ask to install
msg <- paste0("Package '", package, "' is required",
if( is.null(msg) ) '.' else msg)
# stop if not auto-install and not interactive
if( !interactive() && !autoinstall ) stop(msg)
# non-interactive mode: force CRAN mirror if not already set
if( !interactive() && length(iCRAN <- grep("@CRAN@", getOption('repos'))) ){
repos <- getOption('repos')
repos[iCRAN] <- 'https://cran.rstudio.com'
op <- options(repos = repos)
on.exit(options(op), add = TRUE)
}
# detect annotation packages
if( missing(ptype) && grepl("\\.db$", package) ) ptype <- 'BioCann'
ptype <- match.arg(ptype)
if( !autoinstall ){
msg <- paste0(msg, "\nDo you want to install it from known repositories [", ptype, "]?\n"
, " Package(s) will be installed in '", if(is.null(lib) ) .libPaths()[1L] else lib, "'")
if( quiet && prependLF ) message()
repeat{
ans <- askUser(msg, allowed = c('y', 'n', r='(r)etry'), idefault='y', default = 'y')
if( ans == 'n' ) return( FALSE )
if( ans == 'y' ) break
if( ans == 'r' && reqpkg(package) ) return(TRUE)
}
}
## install
# check Bioconductor repositories
hasRepo <- function(p){ any(grepl(p, getOption('repos'))) }
install_type <- ptype
if( ptype == 'CRAN-like'
|| ( ptype == 'BioC' && hasRepo('/((bioc)|(data/annotation))/?$') )
|| ( ptype == 'BioCsoft' && hasRepo('/bioc/?$') )
|| ( ptype == 'BioCann' && hasRepo('/data/annotation/?$') )
){
install_type <- 'CRAN'
}
if( install_type == 'CRAN' ){
pkginstall <- install.packages
}else{ # Bioconductor
if( testRversion("3.6", -1L) ){ # Before 3.6 use BiocInstaller::biocLite
if( !reqpkg('BiocInstaller') ){
sourceURL("http://bioconductor.org/biocLite.R")
}
pkginstall <- function(...){
f <- ns_get('biocLite', 'BiocInstaller')
f(..., suppressUpdates = TRUE)
}
}else { # >= 3.6 -> use BiocManager::install
irequire("BiocManager", autoinstall = TRUE)
pkginstall <- function(...){
f <- ns_get('install', 'BiocManager')
f(..., update = FALSE)
}
}
}
message()
pkginstall(package, lib=lib, ...)
#
# try reloading
if( load ) reqpkg(package)
else length(find.package(package, lib.loc=lib, quiet=TRUE))
}
|
