File: package-extra.R

package info (click to toggle)
r-cran-pkgmaker 0.27-2
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 1,152 kB
  • sloc: sh: 13; makefile: 2
file content (218 lines) | stat: -rw-r--r-- 8,149 bytes parent folder | download | duplicates (4)
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)
		}, ...)
	}
)