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
|
# Package extra action registry
#
# Author: renaud
###############################################################################
#' @include registry.R
#' @include devutils.R
NULL
.getExtraEnv <- function(package){
if( missing(package) || is.null(package) ) where <- topns(FALSE)
else if( isString(package) ) {
package <- sub("^package:", "", package)
if( package == 'R_GlobalEnv') where <- .GlobalEnv
else where <- asNamespace(package)
}
else stop("Invalid argument `package`: must be missing or a package name.")
where
}
# extra handler registry
extra_handlers <- setPackageRegistry('extra_handler', 'function'
, description = 'Handler functions for package-specific extra tasks'
, entrydesc = 'extra handler')
# extra action registry
extra_actions <- registry()
extra_actions$set_field("key", type="character", is_key = TRUE, index_FUN = match_exact)
extra_actions$set_field("package", type="character", is_key = TRUE, index_FUN = match_exact)
extra_actions$set_field("handler", type='character', is_mandatory=TRUE, is_key=TRUE)
extra_actions$set_field("args", type='list', default=list())
extra_actions <- setPackageRegistry('extra_action', extra_actions
, description = 'Handler functions for package-specific extra actions'
, entrydesc = 'extra action')
#' Install/Run Extra Things After Standard Package Installation
#'
#' @description
#' These functions define a framework to register actions for which default sets of arguments
#' can be defined when (lazy-)loading a package, and run later on, e.g., after the package
#' is installed using dedicated commands.
#'
#' \code{setPackageExtraHandler} defines main action handler functions, for which
#' actions are defined as a set of arguments and registered using \code{setPackageExtra}.
#'
#' @param handler name of a handler, e.g, \code{'install'}.
#' It must be unique across all handlers registered by any other packages.
#' @param fun handler function that will be called with the arguments registered
#' with \code{packageExtra(name, ...)}
#' @param package package name where to store/look for the internal registries.
#' End users should not need to use this argument.
#'
#' @return the runner function associated with the newly registered handler,
#' as built by \code{packageExtraRunner}.
#'
#' @rdname packageExtra
#' @export
setPackageExtraHandler <- function(handler, fun, ...){
# add entry to the registry
setPackageRegistryEntry('extra_handler', handler, fun, ...)
# build associated runner
runner <- packageExtraRunner(handler)
}
#' @describeIn packageExtra retrieves a given handler from the registry.
#'
#' @param ... extra arguments passed to internal function calls.
#' In \code{packageExtraHandler}, these are passed to \code{\link{pkgreg_fetch}}.
#'
#' In \code{setPackageExtra}, these define default arguments for the handler function.
#' These are overwritten by arguments in the call to runner function if any.
#'
#' @export
packageExtraHandler <- function(handler=NULL, ...){
# load handler from registry
pkgreg_fetch('extra_handler', key=handler, ...)
}
#' @describeIn packageExtra registers extra actions for a given handler.
#'
#' For example, calling \code{setPackageExtra('install', pkgs='non_CRAN_pkg', repos='http://non-standard-repo')}
#' in a source file of package 'myPkg' registers the call
#' \code{install.packages('non_CRAN_pkg', repos='http://non-standard-repo', ...)}
#' in a registry internal to the package.
#' All calls to \code{setPackageExtra('install', ...)} can then be run by the user, as
#' a post installation step via \code{install.extrapackages('myPkg', ..)}.
#'
#' @param extra name of the extra action.
#' @param .wrap logical that indicates if a function that runs the extra action should
#' be returned or only the default arguments
#'
#' @export
setPackageExtra <- function(handler, extra, ...){
# check that a handler is defined in the registry
fhandler <- packageExtraHandler(handler, exact=TRUE, error=FALSE)
if( is.null(fhandler) ){
handlers <- packageExtraHandler()
stop("Could not register action '", extra, "': handler '", handler, "' is not defined"
, if( length(handlers) ){
str_c(".\n Available handlers are: ", str_out(handlers, Inf))
} else " [handler registry is empty]." )
}
args <- list(...)
pkg <- packageName(topenv(parent.frame()), .Global=TRUE)
setPackageRegistryEntry('extra_action', key=extra, handler=handler, args=args
, package = pkg, where = topenv()
, msg=str_c(" for handler '", handler, "'"))
}
.wrapExtra <- function(fhandler, args=list()){
# define wrapper function
f <- function(...){
cl <- match.call()
cl[[1L]] <- as.name('fhandler')
# add default arguments
lapply(names(args), function(a){
if( !a %in% names(cl) )
cl[[a]] <<- as.name(substitute(a, list(a=a)))
})
eval(cl)
}
# set registered arguments as default arguments
formals(f) <- c(args, formals(f))
f
}
#' @describeIn packageExtra retrieve a given extra action, either as its registry entry,
#' or as a function that would perform the given action.
#'
#' @export
packageExtra <- function(handler=NULL, extra=NULL, package=NULL, .wrap=FALSE){
# load extra registry
extras <- pkgreg_fetch('extra_action', key=extra, handler=handler, package=package
, exact=TRUE, all=!.wrap)
# return whole registry if no other argument is provided
if( missing(handler) || is.null(extra) || !.wrap ) return( extras )
args <- extras$args
fhandler <- packageExtraHandler(handler, package='pkgmaker')
if( is.null(fhandler) ){
handlers <- packageExtraHandler(package='pkgmaker')
stop("Could not find action handler '", handler, "' in pkgmaker global handler registry.\n"
, " Available handlers are: ", str_out(handlers, Inf))
}
# define wrapper function
.wrapExtra(fhandler, args)
}
#' @describeIn packageExtra defines a function to run all or some of the actions registered
#' for a given handler in a given package.
#' For example, the function \code{install.extrapackages} is the runner defined for the extra handler \code{'install'}
#' via \code{packageExtraRunner('install')}.
#'
#' @param .verbose logical that indicates if verbose messages about the extra actions being
#' run should be displayed.
#'
#' @export
packageExtraRunner <- function(handler){
.handler <- handler
function(package, extra=NULL, handler=NULL, ..., .verbose=getOption('verbose')){
if( missing(handler) ) handler <- .handler
.local <- function(p, ...){
# load list of extras
extras <- packageExtra(handler=handler, extra=extra, package=p)
# execute extras
sapply(extras,
function(def, ...){
e <- def$key
h <- def$handler
f <- packageExtra(handler=h, extra=e, package=p, .wrap=TRUE)
if( .verbose ){
message("# Running extra action '", h, ':', e, "' ...")
message("# Action: ", str_fun(f))
on.exit( message("# ERROR [", e, "]\n") )
}
res <- f(...)
if( .verbose ){
on.exit()
message("# OK [", e, "]\n")
}
res
}
, ...)
}
invisible(sapply(package, .local, ...))
}
}
#' @describeIn packageExtra runs all extra actions registered for a given package.
#'
#' @export
install.extras <- packageExtraRunner(NULL)
#' @describeIn packageExtra install sets of packages that can enhance a
#' package, but may not be available from CRAN.
#'
#' It is defined as the extra handler for
#' the extra action handler \code{'install.packages'}.
#' All arguments in \code{...} are passed to \code{\link{install.packages}}.
#' By default, packages that are already installed are not re-installed.
#' An extra argument \code{force} allows to force their installation.
#' The packages are loaded if their installation is successful.
#'
#' @export
install.extrapackages <- setPackageExtraHandler('install.packages',
function(pkgs, ..., force=FALSE){
res <- sapply(pkgs, function(pkg, ...){
if( force || !require.quiet(pkg, character.only=TRUE) ){
install.packages(pkg, ...)
require(pkg, character.only=TRUE)
}else message("Loaded extra package: ", pkg)
}, ...)
}
)
|