Skip to content

Commit

Permalink
Add get_quosure function
Browse files Browse the repository at this point in the history
  • Loading branch information
@wch
wch committed Nov 13, 2020
1 parent 6b6ab48 commit 9c915e5
Show file tree
Hide file tree
Showing 10 changed files with 165 additions and 275 deletions.
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -202,6 +202,7 @@ Collate:
'test-server.R'
'test.R'
'update-input.R'
'utils-lang.R'
'viewer.R'
RoxygenNote: 7.1.1
Encoding: UTF-8
Expand Down
1 change: 1 addition & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -401,3 +401,4 @@ importFrom(rlang,is_quosure)
importFrom(rlang,new_function)
importFrom(rlang,new_quosure)
importFrom(rlang,pairlist2)
importFrom(rlang,quo)
89 changes: 0 additions & 89 deletions R/bind-cache.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -564,51 +564,6 @@ bindCache.function <- function(x, ...) {
}


# Return the ... arguments of the caller, as a list of quoted expressions.
dot_exprs <- function() {
match.call(
definition = sys.function(sys.parent()),
call = sys.call(sys.parent()),
expand.dots = FALSE,
envir = parent.frame(2L)
)$...
}

# Given a list of quoted expressions, 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.
exprs_to_func <- function(exprs, env) {
if (length(exprs) == 0) {
stop("Need at least one expression in `...` to use as cache key or event.")
}
if (length(exprs) == 1) {
# Special case for one expr. This is needed for async to work -- that is,
# when the expr 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.)
expr_to_func(exprs[[1]], env)

} else {
funcs <- lapply(exprs, expr_to_func, env = env)
function() {
lapply(funcs, function(f) f())
}
}
}

# Given a quoted expression or quosure, return a zero-arg function that
# evaluates the expression in the given environment. (If it is a quosure, ignore
# the env that's passed in.)
expr_to_func <- function(expr, env) {
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env)
}
f <- as_function(expr)
formals(f) <- list()
f
}

extractCacheHint <- function(func) {
cacheHint <- attr(func, "cacheHint", exact = TRUE)

Expand All @@ -626,47 +581,3 @@ extractCacheHint <- function(func) {

cacheHint
}


# 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(remove_source(x))
)
}

# Remove source refs from a function or language object. utils::removeSource()
# does the same, but only gained support for language objects in R 3.6.0.
remove_source <- function(x) {
if (is.function(x)) {
body(x) <- remove_source(body(x))
x
} else if (is.call(x)) {
attr(x, "srcref") <- NULL
attr(x, "wholeSrcref") <- NULL
attr(x, "srcfile") <- NULL

# `function` calls store the source ref as the fourth element.
# See https://github.com/r-lib/testthat/issues/1228
if (x[[1]] == quote(`function`) && length(x) == 4 &&
inherits(x[[4]], "srcref")) {
x[[4]] <- NULL
}

x[] <- lapply(x, remove_source)
x
} else {
x
}
}

# Need this here until it is part of rlang.
blast <- function(expr, env = parent.frame()) {
rlang::eval_bare(rlang::enexpr(expr), env)
}
107 changes: 6 additions & 101 deletions R/reactives.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -977,23 +977,7 @@ reactive <- function(x, env = parent.frame(), quoted = FALSE,
{
check_dots_empty()

if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) {
x <- substitute(x)
}
x <- new_quosure(x, env)

} else {
x <- substitute(x)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(x)) {
x <- new_quosure(x, env = parent.frame())
}
}

x <- get_quosure(x, env, quoted)
fun <- as_function(x)
# as_function returns a function that takes `...`. We need one that takes no
# args.
Expand Down Expand Up @@ -1415,23 +1399,7 @@ observe <- function(x, env = parent.frame(), quoted = FALSE,
{
check_dots_empty()

if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) {
x <- substitute(x)
}
x <- new_quosure(x, env)

} else {
x <- substitute(x)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(x)) {
x <- new_quosure(x, env = parent.frame())
}
}

x <- get_quosure(x, env, quoted)
fun <- as_function(x)
# as_function returns a function that takes `...`. We need one that takes no
# args.
Expand Down Expand Up @@ -2273,40 +2241,8 @@ observeEvent <- function(eventExpr, handlerExpr,
{
check_dots_empty()

if (!missing(event.env) || !missing(event.quoted)) {
deprecatedEnvQuotedMessage("event.env", "event.quoted")
if (!event.quoted) {
eventExpr <- substitute(eventExpr)
}
eventExpr <- new_quosure(eventExpr, event.env)

} else {
eventExpr <- substitute(eventExpr)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(eventExpr)) {
eventExpr <- new_quosure(eventExpr, env = parent.frame())
}
}

if (!missing(handler.env) || !missing(handler.quoted)) {
deprecatedEnvQuotedMessage("handler.env", "handler.quoted")
if (!handler.quoted) {
handlerExpr <- substitute(handlerExpr)
}
handlerExpr <- new_quosure(handlerExpr, handler.env)

} else {
handlerExpr <- substitute(handlerExpr)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(handlerExpr)) {
handlerExpr <- new_quosure(handlerExpr, env = parent.frame())
}
}

eventExpr <- get_quosure(eventExpr, event.env, event.quoted)
handlerExpr <- get_quosure(handlerExpr, handler.env, handler.quoted)

handler <- blast(observe(
!!handlerExpr,
Expand Down Expand Up @@ -2341,39 +2277,8 @@ eventReactive <- function(eventExpr, valueExpr,
{
check_dots_empty()

if (!missing(event.env) || !missing(event.quoted)) {
deprecatedEnvQuotedMessage()
if (!event.quoted) {
eventExpr <- substitute(eventExpr)
}
eventExpr <- new_quosure(eventExpr, event.env)

} else {
eventExpr <- substitute(eventExpr)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(eventExpr)) {
eventExpr <- new_quosure(eventExpr, env = parent.frame())
}
}

if (!missing(value.env) || !missing(value.quoted)) {
deprecatedEnvQuotedMessage()
if (!value.quoted) {
valueExpr <- substitute(valueExpr)
}
valueExpr <- new_quosure(valueExpr, value.env)

} else {
valueExpr <- substitute(valueExpr)

# At this point, x can be a quosure if rlang::blast() is used, but the
# typical case is that x is not a quosure.
if (!is_quosure(valueExpr)) {
valueExpr <- new_quosure(valueExpr, env = parent.frame())
}
}
eventExpr <- get_quosure(eventExpr, event.env, event.quoted)
valueExpr <- get_quosure(valueExpr, value.env, value.quoted)

invisible(blast(bindEvent(
ignoreNULL = ignoreNULL,
Expand Down
12 changes: 1 addition & 11 deletions R/render-plot.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -62,18 +62,8 @@ renderPlot <- function(expr, width = 'auto', height = 'auto', res = 72, ...,
env = parent.frame(), quoted = FALSE,
execOnResize = FALSE, outputArgs = list()
) {
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
# This ..stacktraceon is matched by a ..stacktraceoff.. when plotFunc
# is called
func <- quoToFunction(expr, "renderPlot", ..stacktraceon = TRUE)
Expand Down
13 changes: 1 addition & 12 deletions R/render-table.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -55,18 +55,7 @@ renderTable <- function(expr, striped = FALSE, hover = FALSE,
env = parent.frame(), quoted = FALSE,
outputArgs=list())
{
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderTable")

if (!is.function(spacing)) spacing <- match.arg(spacing)
Expand Down
2 changes: 1 addition & 1 deletion R/shiny.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,7 @@ NULL
#' @importFrom digest digest
#' @importFrom promises promise promise_resolve promise_reject is.promising
#' as.promise
#' @importFrom rlang enquo as_function get_expr get_env new_function enquos
#' @importFrom rlang quo enquo as_function get_expr get_env new_function enquos
#' eval_tidy expr pairlist2 new_quosure enexpr as_quosure is_quosure
#' @importFrom ellipsis check_dots_empty check_dots_unnamed
NULL
Expand Down
65 changes: 5 additions & 60 deletions R/shinywrappers.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -356,18 +356,7 @@ markOutputAttrs <- function(renderFunc, snapshotExclude = NULL,
renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
deleteFile, outputArgs=list())
{
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderImage")

# missing() must be used directly within the function with the given arg
Expand Down Expand Up @@ -503,18 +492,7 @@ isTemp <- function(path, tempDir = tempdir(), mustExist) {
renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
width = getOption('width'), outputArgs=list())
{
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderPrint")

# Set a promise domain that sets the console width
Expand Down Expand Up @@ -600,18 +578,7 @@ createRenderPrintPromiseDomain <- function(width) {
renderText <- function(expr, env=parent.frame(), quoted=FALSE,
outputArgs=list(), sep=" ") {

if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderText")

createRenderFunction(
Expand Down Expand Up @@ -664,18 +631,7 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
renderUI <- function(expr, env = parent.frame(), quoted = FALSE,
outputArgs = list())
{
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderUI")

createRenderFunction(
Expand Down Expand Up @@ -821,18 +777,7 @@ renderDataTable <- function(expr, options = NULL, searchDelay = 500,
env = parent.frame(), quoted = FALSE,
outputArgs=list())
{
if (!missing(env) || !missing(quoted)) {
deprecatedEnvQuotedMessage()
if (!quoted) expr <- substitute(expr)
expr <- new_quosure(expr, env)

} else {
expr <- substitute(expr)
if (!is_quosure(expr)) {
expr <- new_quosure(expr, env = parent.frame())
}
}

expr <- get_quosure(expr, env, quoted)
func <- quoToFunction(expr, "renderDataTable")

renderFunc <- function(shinysession, name, ...) {
Expand Down
Loading

0 comments on commit 9c915e5

Please sign in to comment.