-
Notifications
You must be signed in to change notification settings - Fork 1.9k
/
utils-lang.R
249 lines (224 loc) · 8.13 KB
/
utils-lang.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
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
245
246
247
248
249
# Given a list of quosures, return a function that will evaluate them and return
# a list of resulting values. If the list contains a single expression, unwrap
# it from the list.
quos_to_func <- function(qs) {
if (length(qs) == 0) {
stop("Need at least one item in `...` to use as cache key or event.")
}
if (length(qs) == 1) {
# Special case for one quosure. This is needed for async to work -- that is,
# when the quosure returns a promise. It needs to not be wrapped into a list
# for the hybrid_chain stuff to detect that it's a promise. (Plus, it's not
# even clear what it would mean to mix promises and non-promises in the
# key.)
qs <- qs[[1]]
function() {
eval_tidy(qs)
}
} else {
function() {
lapply(qs, eval_tidy)
}
}
}
# Given a list of quosures, return a string representation of the expressions.
#
# qs <- list(quo(a+1), quo({ b+2; b + 3 }))
# quos_to_label(qs)
# #> [1] "a + 1, {\n b + 2\n b + 3\n}"
quos_to_label <- function(qs) {
res <- lapply(qs, function(q) {
paste(deparse(get_expr(q)), collapse = "\n")
})
paste(res, collapse = ", ")
}
# Get the formals and body for a function, without source refs. This is used for
# consistent hashing of the function.
formalsAndBody <- function(x) {
if (is.null(x)) {
return(list())
}
list(
formals = formals(x),
body = body(zap_srcref(x))
)
}
#' @describeIn createRenderFunction convert a quosure to a function.
#' @param q Quosure of the expression `x`. When capturing expressions to create
#' your quosure, it is recommended to use [`enquo0()`] to not unquote the
#' object too early. See [`enquo0()`] for more details.
#' @inheritParams installExprFunction
#' @export
quoToFunction <- function(
q,
label = sys.call(-1)[[1]],
..stacktraceon = FALSE
) {
func <- quoToSimpleFunction(as_quosure(q))
wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
}
updateFunctionLabel <- function(label) {
badFnName <- "anonymous"
if (all(is.language(label))) {
# Prevent immediately invoked functions like as.language(a()())
if (is.language(label) && length(label) > 1) {
return(badFnName)
}
label <- deparse(label, width.cutoff = 500L)
}
label <- as.character(label)
# Prevent function calls that are over one line; (Assignments are hard to perform)
# Prevent immediately invoked functions like "a()()"
if (length(label) > 1 || grepl("(", label, fixed = TRUE)) {
return(badFnName)
}
if (label == "NULL") {
return(badFnName)
}
label
}
quoToSimpleFunction <- function(q) {
# Should not use `new_function(list(), get_expr(q), get_env(q))` as extra logic
# is done by rlang to convert the quosure to a function within `as_function(q)`
fun <- as_function(q)
# If the quosure is empty, then the returned function can not be called.
# https://github.com/r-lib/rlang/issues/1244
if (quo_is_missing(q)) {
fn_body(fun) <- quote({})
}
# `as_function()` returns a function that takes `...`. We need one that takes no
# args.
fn_fmls(fun) <- list()
fun
}
#' Convert an expression to a function
#'
#' `r lifecycle::badge("superseded")` Please use [`installExprFunction()`] for a better
#' debugging experience (Shiny 0.8.0). If the `expr` and `quoted` parameters are not needed, please see
#' [`quoToFunction()`] (Shiny 1.6.0).
#'
#' Similar to [installExprFunction()] but doesn't register debug hooks.
#'
#' @param expr A quoted or unquoted expression, or a quosure.
#' @param env The desired environment for the function. Defaults to the
#' calling environment two steps back.
#' @param quoted Is the expression quoted?
#' @seealso [`installExprFunction()`] for the modern approach to converting an expression to a function
#' @export
#' @keywords internal
exprToFunction <- function(expr, env = parent.frame(), quoted = FALSE) {
# If `expr` is a raw quosure, must say `quoted = TRUE`; (env is ignored)
# If `inject()` a quosure, env is ignored, and quoted should be FALSE (aka ignored).
# Make article of usage
# * (by joe)
if (!quoted) {
expr <- eval(substitute(substitute(expr)), parent.frame())
}
# MUST call with `quoted = TRUE` as exprToQuo() will not reach high enough
q <- exprToQuo(expr, env, quoted = TRUE)
# MUST call `as_function()`. Can NOT call `new_function()`
# rlang has custom logic for handling converting a quosure to a function
quoToSimpleFunction(q)
}
# For internal use only; External users should be using `exprToFunction()` or `installExprFunction()`
# MUST be the exact same logic as `exprToFunction()`, but without the `quoToSimpleFunction()` call
exprToQuo <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) {
expr <- eval(substitute(substitute(expr)), parent.frame())
}
q <-
if (is_quosure(expr)) {
# inject()ed quosure
# do nothing
expr
} else if (is.language(expr) || rlang::is_atomic(expr) || is.null(expr)) {
# Most common case...
new_quosure(expr, env = env)
} else {
stop("Don't know how to convert '", class(expr)[1], "' to a function; a quosure or quoted expression was expected")
}
q
}
#' @describeIn createRenderFunction converts a user's reactive `expr` into a
#' function that's assigned to a `name` in the `assign.env`.
#'
#' @param name The name the function should be given
#' @param eval.env The desired environment for the function. Defaults to the
#' calling environment two steps back.
#' @param assign.env The environment in which the function should be assigned.
#' @param label A label for the object to be shown in the debugger. Defaults to
#' the name of the calling function.
#' @param wrappedWithLabel,..stacktraceon Advanced use only. For stack manipulation purposes; see
#' [stacktrace()].
#' @inheritParams exprToFunction
#' @export
installExprFunction <- function(expr, name, eval.env = parent.frame(2),
quoted = FALSE,
assign.env = parent.frame(1),
label = sys.call(-1)[[1]],
wrappedWithLabel = TRUE,
..stacktraceon = FALSE) {
if (!quoted) {
quoted <- TRUE
expr <- eval(substitute(substitute(expr)), parent.frame())
}
func <- exprToFunction(expr, eval.env, quoted)
if (length(label) > 1) {
# Just in case the deparsed code is more complicated than we imagine. If we
# have a label with length > 1 it causes warnings in wrapFunctionLabel.
label <- paste0(label, collapse = "\n")
}
wrappedWithLabel <- isTRUE(wrappedWithLabel)
if (wrappedWithLabel) {
func <- wrapFunctionLabel(func, updateFunctionLabel(label), ..stacktraceon = ..stacktraceon, dots = FALSE)
}
assign(name, func, envir = assign.env)
if (!wrappedWithLabel) {
registerDebugHook(name, assign.env, label)
}
invisible(func)
}
# Utility function for creating a debugging label, given an expression.
# `expr` is a quoted expression.
# `function_name` is the name of the calling function.
# `label` is an optional user-provided label. If NULL, it will be inferred.
exprToLabel <- function(expr, function_name, label = NULL) {
srcref <- attr(expr, "srcref", exact = TRUE)
if (is.null(label)) {
label <- rexprSrcrefToLabel(
srcref[[1]],
simpleExprToFunction(expr, function_name)
)
}
if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
label
}
simpleExprToFunction <- function(expr, function_name) {
sprintf('%s(%s)', function_name, paste(deparse(expr), collapse='\n'))
}
installedFuncExpr <- function(func) {
fn_body(attr(func, "wrappedFunc", exact = TRUE))
}
funcToLabelBody <- function(func) {
paste(deparse(installedFuncExpr(func)), collapse='\n')
}
funcToLabel <- function(func, functionLabel, label = NULL) {
if (!is.null(label)) return(label)
sprintf(
'%s(%s)',
functionLabel,
funcToLabelBody(func)
)
}
quoToLabelBody <- function(q) {
paste(deparse(quo_get_expr(q)), collapse='\n')
}
quoToLabel <- function(q, functionLabel, label = NULL) {
if (!is.null(label)) return(label)
sprintf(
'%s(%s)',
functionLabel,
quoToLabelBody(q)
)
}