# 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))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.