/
define_option.R
211 lines (184 loc) · 6.54 KB
/
define_option.R
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
#' Defining Options
#'
#' Define options which can be used throughout your package.
#'
#' At their simplest, defining options lets you refer to a global option using a
#' shorthand option name throughout your package, with the added benefit of
#' looking for configurations in global options and environment variables.
#'
#' @param option An option name to use
#'
#' @return the package options environment
#'
#' @examples
#' define_options(
#' "Whether execution should emit console output",
#' quiet = FALSE,
#'
#' "Whether to use detailed console output (showcasing additional
#' configuration parameters)",
#' verbose = TRUE,
#' envvar_fn = envvar_is_true()
#' )
#'
#' define_option(
#' "deprecations",
#' desc = "Whether deprecation warnings should be suppressed automatically",
#' default = FALSE,
#' option_name = "MypackageDeprecations",
#' envvar_name = "MYPACKAGE_ENVVARS_DEPRECATIONS"
#' )
#'
#' @name defining_options
#' @rdname defining_options
NULL
#' @describeIn defining_options
#'
#' Define an option. Unlike [define_options()], this function allows detailed
#' customization of all option behaviors. Accepts either an [option_spec()]
#' object, or an option named followed by arguments to provide to
#' [option_spec()].
#'
#' @param ... Additional arguments passed to [option_spec()]
#'
#' @export
define_option <- function(option, ...) {
UseMethod("define_option")
}
#' @inheritParams option_spec
#' @export
define_option.character <- function(
option,
default = bquote(),
...,
quoted = FALSE,
eager = FALSE,
envir = parent.frame()
) {
if (!missing(default) && !quoted && !eager)
default <- match.call()[["default"]]
if (quoted && eager)
default <- eval(default, envir = envir)
define_option(option_spec(
name = option,
default = default,
...,
quoted = TRUE,
envir = envir
))
}
#' @export
define_option.option_spec <- function(option, ...) {
optenv <- get_options_env(option$envir, inherits = TRUE)
do.call(delayedAssign, list(option$name, option$expr, option$envir, optenv))
set_option_spec(option$name, option, env = optenv)
optenv
}
#' @describeIn defining_options
#'
#' Define multiple options. This function provides a shorthand syntax for
#' succinctly defining many options. Arguments are defined in groups, each
#' starting with an unnamed description argument. For more details see Section
#' _Non-Standard Evaluation_.
#'
#' @section Non-Standard Evaluation:
#'
#' `define_options()` accepts arguments in a _non-standard_
#' way, as groups of arguments which each are used to specify an option (See
#' `options_spec()`). Groups of arguments must start with an unnamed argument,
#' which provides the description for the argument, followed immediately by a
#' named argument providing the name of option and default value, followed by
#' any additional arguments to provie to `options_spec()`.
#'
#' The environment in which options are defined is always assumed to be the
#' parent environment. If you'd prefer to specify options in a different
#' environment, this is best done using `define_option()` or
#' `with(<env>, define_options(...))`.
#'
#' Although `define_options()` provides all the functionality of
#' `define_option()` in a succinct shorthand, it is only recommended in cases
#' where the overwhelming majority of your options leverage default behaviors.
#' It is encouraged to use `define_option()` if you repeatedly need more
#' involved definitions to minimize non-standard evaluation bugs.
#'
#' @export
define_options <- function(...) {
eval_env <- parent.frame()
x <- as.list(substitute(...()))
# always use named arguments, even if no names are used
if (is.null(names(x)))
names(x) <- rep("", length(x))
# test against common non-standard eval syntax issues
verify_define_options_syntax(x)
# split arguments into groupings, building `option_spec` args
specs <- lapply(split(x, cumsum(names(x) == "")), function(group) {
# reassign option name, default from second arg in group
args <- list()
args$name <- names(group[2])
args$default <- group[[2]]
# build description from first (unnamed) arg in group
args$desc <- reflow_option_desc(eval(group[[1]], envir = eval_env))[[1]]
# build other arguments from remaining args
other_args <- lapply(group[c(-1, -2)], eval, envir = eval_env)
args[names(other_args)] <- other_args
do.call(option_spec, args, envir = eval_env)
})
for (spec in specs) define_option(spec)
get_options_env(eval_env, inherits = TRUE)
}
verify_define_options_syntax <- function(x) {
no_desc <- names(x)[[1]] != ""
no_arg <- names(x) == "" & vlapply(x, function(i) all(nchar(i) == 0))
no_named_arg <- names(x) == "" & c(names(x)[-1] == "", TRUE)
arg_desc <- c(names(x)[-length(x)] != "" & names(x)[-1] == "desc", FALSE)
arg_name <- c(names(x)[-length(x)] != "" & names(x)[-1] == "name", FALSE)
if (!any(no_desc | no_named_arg | arg_desc | arg_name))
return(TRUE)
# helper for creating an itemized "issue" message as part of error message
opt_n <- cumsum(names(x) != "" & c(TRUE, names(x)[-length(x)] == ""))
issue <- function(at, ..., verbatim = FALSE) {
if (!any(at)) return(NULL)
opts <- paste0(unique(opt_n[which(at)]), collapse = ",")
s <- if (sum(at) > 1) "s" else ""
msg <- paste0(...)
if (!verbatim) msg <- sprintf("option%s (%s) %s", s, opts, msg)
out <- list(paste0(msg, collapse = "\n"))
names(out) <- opts
out
}
issues <- Filter(Negate(is.null), c(
issue(no_arg, verbatim = TRUE,
sprintf("missing argument %s (trailing comma in call)", which(no_arg)[1])
),
issue(no_desc,
"should begin with an unnamed argument, providing a description of the ",
"option's behavior."
),
issue(!no_arg & no_named_arg,
"should always follow the description with a named argument to indicate ",
"the option name and default value."
),
issue(arg_desc,
"should not provide a redundant `desc` argument."
),
issue(arg_name,
"should not provide a redundant `name` argument."
)
))
err("found issues in option definitions", issues, which = -1)
}
#' Reflow multiline strings
#'
#' A small helper function for allowing multiline strings to be collapsed into
#' continuous lines, similar to markdown's paragraph handling.
#'
#' @param x A vector of multiline strings to reflow
#' @return The reflowed strings
#'
#' @keywords internal
reflow_option_desc <- function(x) {
x <- strsplit(x, "\n{2,}\\s*")
x <- lapply(x, paste, collapse = "\n")
x <- lapply(x, gsub, pattern = "^\\s+|\\s+$", replacement = "")
x
}