Skip to content

Commit 112c511

Browse files
jcheng5jcheng5
committed
wip
1 parent a2745a4 commit 112c511

File tree

8 files changed

+271
-91
lines changed

8 files changed

+271
-91
lines changed

‎NAMESPACE

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ export(code)
5656
export(column)
5757
export(conditionStackTrace)
5858
export(conditionalPanel)
59+
export(createRenderFunction)
5960
export(createWebDependency)
6061
export(dataTableOutput)
6162
export(dateInput)
@@ -269,4 +270,5 @@ import(htmltools)
269270
import(httpuv)
270271
import(methods)
271272
import(mime)
273+
import(monads)
272274
import(xtable)

‎R/react.R

Lines changed: 44 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -18,11 +18,14 @@ Context <- R6Class(
1818
},
1919
run = function(func) {
2020
"Run the provided function under this context."
21-
withReactiveDomain(.domain, {
22-
env <- .getReactiveEnvironment()
23-
.graphEnterContext(id)
24-
on.exit(.graphExitContext(id), add = TRUE)
25-
env$runWith(self, func)
21+
22+
system2.5::withPromiseDomain(reactivePromiseDomain, {
23+
withReactiveDomain(.domain, {
24+
env <- .getReactiveEnvironment()
25+
.graphEnterContext(id)
26+
on.exit(.graphExitContext(id), add = TRUE)
27+
env$runWith(self, func)
28+
})
2629
})
2730
},
2831
invalidate = function() {
@@ -163,3 +166,39 @@ local({
163166
return(dummyContext)
164167
}
165168
})
169+
170+
wrapForContext <- function(func, ctx) {
171+
force(func)
172+
force(ctx)
173+
174+
function(...) {
175+
args <- list(...)
176+
ctx$run(function() {
177+
captureStackTraces(
178+
do.call(func, args)
179+
)
180+
})
181+
}
182+
}
183+
184+
reactivePromiseDomain <- list(
185+
onThen = function(onFulfilled, onRejected) {
186+
ctx <- getCurrentContext()
187+
188+
changed <- FALSE
189+
if (is.function(onFulfilled)) {
190+
changed <- TRUE
191+
onFulfilled <- wrapForContext(onFulfilled, ctx)
192+
}
193+
if (is.function(onRejected)) {
194+
changed <- TRUE
195+
onRejected <- wrapForContext(onRejected, ctx)
196+
}
197+
198+
if (changed) {
199+
list(onFulfilled = onFulfilled, onRejected = onRejected)
200+
} else {
201+
NULL
202+
}
203+
}
204+
)

‎R/shiny.R

Lines changed: 54 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -301,7 +301,8 @@ workerId <- local({
301301
#' Similar to \code{sendCustomMessage}, but the message must be a raw vector
302302
#' and the registration method on the client is
303303
#' \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The
304-
#' message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
304+
#' message argument on the client will be a
305+
#' \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}.
305306
#' }
306307
#' \item{sendInputMessage(inputId, message)}{
307308
#' Sends a message to an input on the session's client web page; if the input
@@ -389,6 +390,7 @@ NS <- function(namespace, id = NULL) {
389390
ns.sep <- "-"
390391

391392

393+
#' @import monads
392394
#' @include utils.R
393395
ShinySession <- R6Class(
394396
'ShinySession',
@@ -1059,56 +1061,63 @@ ShinySession <- R6Class(
10591061
name = name, status = 'recalculating'
10601062
))
10611063

1062-
value <- tryCatch(
1063-
shinyCallingHandlers(func()),
1064-
shiny.custom.error = function(cond) {
1065-
if (isTRUE(getOption("show.error.messages"))) printError(cond)
1066-
structure(list(), class = "try-error", condition = cond)
1067-
},
1068-
shiny.output.cancel = function(cond) {
1069-
structure(list(), class = "cancel-output")
1070-
},
1071-
shiny.silent.error = function(cond) {
1072-
# Don't let shiny.silent.error go through the normal stop
1073-
# path of try, because we don't want it to print. But we
1074-
# do want to try to return the same looking result so that
1075-
# the code below can send the error to the browser.
1076-
structure(list(), class = "try-error", condition = cond)
1077-
},
1064+
p <- system2.5::Promise$new()
1065+
tryCatch(
1066+
# This shinyCallingHandlers should maybe be at a higher level,
1067+
# to include the $then/$catch calls below?
1068+
p$resolve(shinyCallingHandlers(func())),
10781069
error = function(cond) {
1079-
if (isTRUE(getOption("show.error.messages"))) printError(cond)
1080-
if (getOption("shiny.sanitize.errors", FALSE)) {
1081-
cond <- simpleError(paste("An error has occurred. Check your",
1082-
"logs or contact the app author for",
1083-
"clarification."))
1084-
}
1085-
invisible(structure(list(), class = "try-error", condition = cond))
1086-
},
1087-
finally = {
1088-
private$sendMessage(recalculating = list(
1089-
name = name, status = 'recalculated'
1090-
))
1070+
p$reject(cond)
10911071
}
10921072
)
10931073

1094-
if (inherits(value, "cancel-output")) {
1095-
return()
1096-
}
1074+
p$catch(
1075+
function(cond) {
1076+
if (inherits(cond, "shiny.custom.error")) {
1077+
if (isTRUE(getOption("show.error.messages"))) printError(cond)
1078+
structure(list(), class = "try-error", condition = cond)
1079+
} else if (inherits(cond, "shiny.output.cancel")) {
1080+
structure(list(), class = "cancel-output")
1081+
} else if (inherits(cond, "shiny.silent.error")) {
1082+
# Don't let shiny.silent.error go through the normal stop
1083+
# path of try, because we don't want it to print. But we
1084+
# do want to try to return the same looking result so that
1085+
# the code below can send the error to the browser.
1086+
structure(list(), class = "try-error", condition = cond)
1087+
} else {
1088+
if (isTRUE(getOption("show.error.messages"))) printError(cond)
1089+
if (getOption("shiny.sanitize.errors", FALSE)) {
1090+
cond <- simpleError(paste("An error has occurred. Check your",
1091+
"logs or contact the app author for",
1092+
"clarification."))
1093+
}
1094+
invisible(structure(list(), class = "try-error", condition = cond))
1095+
}
1096+
}
1097+
) %>>% function(value) {
1098+
private$sendMessage(recalculating = list(
1099+
name = name, status = 'recalculated'
1100+
))
1101+
1102+
if (inherits(value, "cancel-output")) {
1103+
return()
1104+
}
10971105

1098-
private$invalidatedOutputErrors$remove(name)
1099-
private$invalidatedOutputValues$remove(name)
1100-
1101-
if (inherits(value, 'try-error')) {
1102-
cond <- attr(value, 'condition')
1103-
type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
1104-
private$invalidatedOutputErrors$set(
1105-
name,
1106-
list(message = cond$message,
1107-
call = utils::capture.output(print(cond$call)),
1108-
type = if (length(type)) type))
1106+
private$invalidatedOutputErrors$remove(name)
1107+
private$invalidatedOutputValues$remove(name)
1108+
1109+
if (inherits(value, 'try-error')) {
1110+
cond <- attr(value, 'condition')
1111+
type <- setdiff(class(cond), c('simpleError', 'error', 'condition'))
1112+
private$invalidatedOutputErrors$set(
1113+
name,
1114+
list(message = cond$message,
1115+
call = utils::capture.output(print(cond$call)),
1116+
type = if (length(type)) type))
1117+
}
1118+
else
1119+
private$invalidatedOutputValues$set(name, value)
11091120
}
1110-
else
1111-
private$invalidatedOutputValues$set(name, value)
11121121
}, suspended=private$shouldSuspend(name), label=label)
11131122

11141123
# If any output attributes were added to the render function attach

‎R/shinywrappers.R

Lines changed: 116 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,50 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) {
5252
hasExecuted = hasExecuted)
5353
}
5454

55+
#' Implement render functions
56+
#'
57+
#' @param func A function without parameters, that returns user data. If the
58+
#' returned value is a promise, then the render function will proceed in async
59+
#' mode.
60+
#' @param transform A function that takes four arguments: \code{value},
61+
#' \code{session}, \code{name}, and \code{...} (for future-proofing). This
62+
#' function will be invoked each time a value is returned from \code{func},
63+
#' and is responsible for changing the value into a JSON-ready value to be
64+
#' JSON-encoded and sent to the browser.
65+
#' @param outputFunc The UI function that is used (or most commonly used) with
66+
#' this render function. This can be used in R Markdown documents to create
67+
#' complete output widgets out of just the render function.
68+
#' @param outputArgs A list of arguments to pass to the \code{outputFunc}.
69+
#' Render functions should include \code{outputArgs = list()} in their own
70+
#' parameter list, and pass through the value as this argument, to allow app
71+
#' authors to customize outputs. (Currently, this is only supported for
72+
#' dynamically generated UIs, such as those created by Shiny code snippets
73+
#' embedded in R Markdown documents).
74+
#' @return An annotated render function, ready to be assigned to an
75+
#' \code{output} slot.
76+
#'
77+
#' @export
78+
createRenderFunction <- function(
79+
func, transform = function(value, session, name, ...) value,
80+
outputFunc = NULL, outputArgs = NULL
81+
) {
82+
83+
renderFunc <- function(shinysession, name, ...) {
84+
res <- func()
85+
if (inherits(res, "Promise")) {
86+
res %>>%
87+
transform(shinysession, name, ...)
88+
} else {
89+
transform(res, shinysession, name, ...)
90+
}
91+
}
92+
93+
if (!is.null(outputFunc))
94+
markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs)
95+
else
96+
renderFunc
97+
}
98+
5599
useRenderFunction <- function(renderFunc, inline = FALSE) {
56100
outputFunction <- attr(renderFunc, "outputFunc")
57101
outputArgs <- attr(renderFunc, "outputArgs")
@@ -214,26 +258,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE,
214258
deleteFile=TRUE, outputArgs=list()) {
215259
installExprFunction(expr, "func", env, quoted)
216260

217-
renderFunc <- function(shinysession, name, ...) {
218-
imageinfo <- func()
219-
# Should the file be deleted after being sent? If .deleteFile not set or if
220-
# TRUE, then delete; otherwise don't delete.
221-
if (deleteFile) {
222-
on.exit(unlink(imageinfo$src))
223-
}
224-
225-
# If contentType not specified, autodetect based on extension
226-
contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
227-
228-
# Extra values are everything in imageinfo except 'src' and 'contentType'
229-
extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
230-
231-
# Return a list with src, and other img attributes
232-
c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
233-
extra_attr)
234-
}
235-
236-
markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs)
261+
createRenderFunction(func,
262+
transform = function(imageinfo, session, name, ...) {
263+
# Should the file be deleted after being sent? If .deleteFile not set or if
264+
# TRUE, then delete; otherwise don't delete.
265+
if (deleteFile) {
266+
on.exit(unlink(imageinfo$src))
267+
}
268+
269+
# If contentType not specified, autodetect based on extension
270+
contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src)
271+
272+
# Extra values are everything in imageinfo except 'src' and 'contentType'
273+
extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')]
274+
275+
# Return a list with src, and other img attributes
276+
c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType),
277+
extra_attr)
278+
},
279+
imageOutput, outputArgs)
237280
}
238281

239282

@@ -273,15 +316,58 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
273316
width = getOption('width'), outputArgs=list()) {
274317
installExprFunction(expr, "func", env, quoted)
275318

319+
# TODO: Set a promise domain that sets the console width
320+
# and captures output
321+
# op <- options(width = width)
322+
# on.exit(options(op), add = TRUE)
323+
276324
renderFunc <- function(shinysession, name, ...) {
277-
op <- options(width = width)
278-
on.exit(options(op), add = TRUE)
279-
paste(utils::capture.output(func()), collapse = "\n")
325+
domain <- createRenderPrintPromiseDomain(width)
326+
system2.5::withPromiseDomain(domain, {
327+
p <- system2.5::Promise$new()
328+
p2 <- p$then(function(value) func())$then(function(value) {
329+
res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
330+
res
331+
})
332+
p$resolve(NULL)
333+
p2$catch(function(err) { cat(file=stderr(), "ERROR", err$message) })
334+
})
280335
}
281336

282337
markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
283338
}
284339

340+
createRenderPrintPromiseDomain <- function(width) {
341+
f <- file()
342+
343+
list(
344+
conn = f,
345+
onThen = function(onFulfilled, onRejected) {
346+
res <- list(onFulfilled = onFulfilled, onRejected = onRejected)
347+
348+
if (is.function(onFulfilled)) {
349+
res$onFulfilled = function(result) {
350+
op <- options(width = width)
351+
on.exit(options(op), add = TRUE)
352+
353+
capture.output(onFulfilled(result), file = f, append = TRUE, split = TRUE)
354+
}
355+
}
356+
357+
if (is.function(onRejected)) {
358+
res$onRejected = function(reason) {
359+
op <- options(width = width)
360+
on.exit(options(op), add = TRUE)
361+
362+
capture.output(onRejected(reason), file = f, append = TRUE)
363+
}
364+
}
365+
366+
res
367+
}
368+
)
369+
}
370+
285371
#' Text Output
286372
#'
287373
#' Makes a reactive version of the given function that also uses
@@ -313,12 +399,13 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE,
313399
outputArgs=list()) {
314400
installExprFunction(expr, "func", env, quoted)
315401

316-
renderFunc <- function(shinysession, name, ...) {
317-
value <- func()
318-
return(paste(utils::capture.output(cat(value)), collapse="\n"))
319-
}
320-
321-
markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs)
402+
createRenderFunction(
403+
func,
404+
function(value, session, name, ...) {
405+
paste(utils::capture.output(cat(value)), collapse="\n")
406+
},
407+
textOutput, outputArgs
408+
)
322409
}
323410

324411
#' UI Output

‎inst/www/shared/shiny.js

Lines changed: 6 additions & 5 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)