From 112c5114f6c3b01c866c722f79327b656e4ea15f Mon Sep 17 00:00:00 2001 From: Joe Cheng Date: Sun, 12 Mar 2017 22:53:46 -0700 Subject: [PATCH] wip --- NAMESPACE | 2 + R/react.R | 49 +++++++++++-- R/shiny.R | 97 +++++++++++++------------ R/shinywrappers.R | 139 +++++++++++++++++++++++++++++------- inst/www/shared/shiny.js | 11 +-- man/createRenderFunction.Rd | 39 ++++++++++ man/session.Rd | 3 +- srcjs/shinyapp.js | 14 ++-- 8 files changed, 267 insertions(+), 87 deletions(-) create mode 100644 man/createRenderFunction.Rd diff --git a/NAMESPACE b/NAMESPACE index 33013e405..8c377cb9f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,6 +56,7 @@ export(code) export(column) export(conditionStackTrace) export(conditionalPanel) +export(createRenderFunction) export(createWebDependency) export(dataTableOutput) export(dateInput) @@ -269,4 +270,5 @@ import(htmltools) import(httpuv) import(methods) import(mime) +import(monads) import(xtable) diff --git a/R/react.R b/R/react.R index 75febccb5..9cc8f616b 100644 --- a/R/react.R +++ b/R/react.R @@ -18,11 +18,14 @@ Context <- R6Class( }, run = function(func) { "Run the provided function under this context." - withReactiveDomain(.domain, { - env <- .getReactiveEnvironment() - .graphEnterContext(id) - on.exit(.graphExitContext(id), add = TRUE) - env$runWith(self, func) + + system2.5::withPromiseDomain(reactivePromiseDomain, { + withReactiveDomain(.domain, { + env <- .getReactiveEnvironment() + .graphEnterContext(id) + on.exit(.graphExitContext(id), add = TRUE) + env$runWith(self, func) + }) }) }, invalidate = function() { @@ -163,3 +166,39 @@ local({ return(dummyContext) } }) + +wrapForContext <- function(func, ctx) { + force(func) + force(ctx) + + function(...) { + args <- list(...) + ctx$run(function() { + captureStackTraces( + do.call(func, args) + ) + }) + } +} + +reactivePromiseDomain <- list( + onThen = function(onFulfilled, onRejected) { + ctx <- getCurrentContext() + + changed <- FALSE + if (is.function(onFulfilled)) { + changed <- TRUE + onFulfilled <- wrapForContext(onFulfilled, ctx) + } + if (is.function(onRejected)) { + changed <- TRUE + onRejected <- wrapForContext(onRejected, ctx) + } + + if (changed) { + list(onFulfilled = onFulfilled, onRejected = onRejected) + } else { + NULL + } + } +) diff --git a/R/shiny.R b/R/shiny.R index 4b77db790..bdd22ec75 100644 --- a/R/shiny.R +++ b/R/shiny.R @@ -301,7 +301,8 @@ workerId <- local({ #' Similar to \code{sendCustomMessage}, but the message must be a raw vector #' and the registration method on the client is #' \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The -#' message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}. +#' message argument on the client will be a +#' \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}. #' } #' \item{sendInputMessage(inputId, message)}{ #' 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) { ns.sep <- "-" +#' @import monads #' @include utils.R ShinySession <- R6Class( 'ShinySession', @@ -1059,56 +1061,63 @@ ShinySession <- R6Class( name = name, status = 'recalculating' )) - value <- tryCatch( - shinyCallingHandlers(func()), - shiny.custom.error = function(cond) { - if (isTRUE(getOption("show.error.messages"))) printError(cond) - structure(list(), class = "try-error", condition = cond) - }, - shiny.output.cancel = function(cond) { - structure(list(), class = "cancel-output") - }, - shiny.silent.error = function(cond) { - # Don't let shiny.silent.error go through the normal stop - # path of try, because we don't want it to print. But we - # do want to try to return the same looking result so that - # the code below can send the error to the browser. - structure(list(), class = "try-error", condition = cond) - }, + p <- system2.5::Promise$new() + tryCatch( + # This shinyCallingHandlers should maybe be at a higher level, + # to include the $then/$catch calls below? + p$resolve(shinyCallingHandlers(func())), error = function(cond) { - if (isTRUE(getOption("show.error.messages"))) printError(cond) - if (getOption("shiny.sanitize.errors", FALSE)) { - cond <- simpleError(paste("An error has occurred. Check your", - "logs or contact the app author for", - "clarification.")) - } - invisible(structure(list(), class = "try-error", condition = cond)) - }, - finally = { - private$sendMessage(recalculating = list( - name = name, status = 'recalculated' - )) + p$reject(cond) } ) - if (inherits(value, "cancel-output")) { - return() - } + p$catch( + function(cond) { + if (inherits(cond, "shiny.custom.error")) { + if (isTRUE(getOption("show.error.messages"))) printError(cond) + structure(list(), class = "try-error", condition = cond) + } else if (inherits(cond, "shiny.output.cancel")) { + structure(list(), class = "cancel-output") + } else if (inherits(cond, "shiny.silent.error")) { + # Don't let shiny.silent.error go through the normal stop + # path of try, because we don't want it to print. But we + # do want to try to return the same looking result so that + # the code below can send the error to the browser. + structure(list(), class = "try-error", condition = cond) + } else { + if (isTRUE(getOption("show.error.messages"))) printError(cond) + if (getOption("shiny.sanitize.errors", FALSE)) { + cond <- simpleError(paste("An error has occurred. Check your", + "logs or contact the app author for", + "clarification.")) + } + invisible(structure(list(), class = "try-error", condition = cond)) + } + } + ) %>>% function(value) { + private$sendMessage(recalculating = list( + name = name, status = 'recalculated' + )) - private$invalidatedOutputErrors$remove(name) - private$invalidatedOutputValues$remove(name) + if (inherits(value, "cancel-output")) { + return() + } - if (inherits(value, 'try-error')) { - cond <- attr(value, 'condition') - type <- setdiff(class(cond), c('simpleError', 'error', 'condition')) - private$invalidatedOutputErrors$set( - name, - list(message = cond$message, - call = utils::capture.output(print(cond$call)), - type = if (length(type)) type)) + private$invalidatedOutputErrors$remove(name) + private$invalidatedOutputValues$remove(name) + + if (inherits(value, 'try-error')) { + cond <- attr(value, 'condition') + type <- setdiff(class(cond), c('simpleError', 'error', 'condition')) + private$invalidatedOutputErrors$set( + name, + list(message = cond$message, + call = utils::capture.output(print(cond$call)), + type = if (length(type)) type)) + } + else + private$invalidatedOutputValues$set(name, value) } - else - private$invalidatedOutputValues$set(name, value) }, suspended=private$shouldSuspend(name), label=label) # If any output attributes were added to the render function attach diff --git a/R/shinywrappers.R b/R/shinywrappers.R index b2439076b..348e8deca 100644 --- a/R/shinywrappers.R +++ b/R/shinywrappers.R @@ -52,6 +52,50 @@ markRenderFunction <- function(uiFunc, renderFunc, outputArgs = list()) { hasExecuted = hasExecuted) } +#' Implement render functions +#' +#' @param func A function without parameters, that returns user data. If the +#' returned value is a promise, then the render function will proceed in async +#' mode. +#' @param transform A function that takes four arguments: \code{value}, +#' \code{session}, \code{name}, and \code{...} (for future-proofing). This +#' function will be invoked each time a value is returned from \code{func}, +#' and is responsible for changing the value into a JSON-ready value to be +#' JSON-encoded and sent to the browser. +#' @param outputFunc The UI function that is used (or most commonly used) with +#' this render function. This can be used in R Markdown documents to create +#' complete output widgets out of just the render function. +#' @param outputArgs A list of arguments to pass to the \code{outputFunc}. +#' Render functions should include \code{outputArgs = list()} in their own +#' parameter list, and pass through the value as this argument, to allow app +#' authors to customize outputs. (Currently, this is only supported for +#' dynamically generated UIs, such as those created by Shiny code snippets +#' embedded in R Markdown documents). +#' @return An annotated render function, ready to be assigned to an +#' \code{output} slot. +#' +#' @export +createRenderFunction <- function( + func, transform = function(value, session, name, ...) value, + outputFunc = NULL, outputArgs = NULL +) { + + renderFunc <- function(shinysession, name, ...) { + res <- func() + if (inherits(res, "Promise")) { + res %>>% + transform(shinysession, name, ...) + } else { + transform(res, shinysession, name, ...) + } + } + + if (!is.null(outputFunc)) + markRenderFunction(outputFunc, renderFunc, outputArgs = outputArgs) + else + renderFunc +} + useRenderFunction <- function(renderFunc, inline = FALSE) { outputFunction <- attr(renderFunc, "outputFunc") outputArgs <- attr(renderFunc, "outputArgs") @@ -214,26 +258,25 @@ renderImage <- function(expr, env=parent.frame(), quoted=FALSE, deleteFile=TRUE, outputArgs=list()) { installExprFunction(expr, "func", env, quoted) - renderFunc <- function(shinysession, name, ...) { - imageinfo <- func() - # Should the file be deleted after being sent? If .deleteFile not set or if - # TRUE, then delete; otherwise don't delete. - if (deleteFile) { - on.exit(unlink(imageinfo$src)) - } + createRenderFunction(func, + transform = function(imageinfo, session, name, ...) { + # Should the file be deleted after being sent? If .deleteFile not set or if + # TRUE, then delete; otherwise don't delete. + if (deleteFile) { + on.exit(unlink(imageinfo$src)) + } - # If contentType not specified, autodetect based on extension - contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src) + # If contentType not specified, autodetect based on extension + contentType <- imageinfo$contentType %OR% getContentType(imageinfo$src) - # Extra values are everything in imageinfo except 'src' and 'contentType' - extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')] + # Extra values are everything in imageinfo except 'src' and 'contentType' + extra_attr <- imageinfo[!names(imageinfo) %in% c('src', 'contentType')] - # Return a list with src, and other img attributes - c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType), - extra_attr) - } - - markRenderFunction(imageOutput, renderFunc, outputArgs = outputArgs) + # Return a list with src, and other img attributes + c(src = shinysession$fileUrl(name, file=imageinfo$src, contentType=contentType), + extra_attr) + }, + imageOutput, outputArgs) } @@ -273,15 +316,58 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE, width = getOption('width'), outputArgs=list()) { installExprFunction(expr, "func", env, quoted) + # TODO: Set a promise domain that sets the console width + # and captures output + # op <- options(width = width) + # on.exit(options(op), add = TRUE) + renderFunc <- function(shinysession, name, ...) { - op <- options(width = width) - on.exit(options(op), add = TRUE) - paste(utils::capture.output(func()), collapse = "\n") + domain <- createRenderPrintPromiseDomain(width) + system2.5::withPromiseDomain(domain, { + p <- system2.5::Promise$new() + p2 <- p$then(function(value) func())$then(function(value) { + res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n") + res + }) + p$resolve(NULL) + p2$catch(function(err) { cat(file=stderr(), "ERROR", err$message) }) + }) } markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs) } +createRenderPrintPromiseDomain <- function(width) { + f <- file() + + list( + conn = f, + onThen = function(onFulfilled, onRejected) { + res <- list(onFulfilled = onFulfilled, onRejected = onRejected) + + if (is.function(onFulfilled)) { + res$onFulfilled = function(result) { + op <- options(width = width) + on.exit(options(op), add = TRUE) + + capture.output(onFulfilled(result), file = f, append = TRUE, split = TRUE) + } + } + + if (is.function(onRejected)) { + res$onRejected = function(reason) { + op <- options(width = width) + on.exit(options(op), add = TRUE) + + capture.output(onRejected(reason), file = f, append = TRUE) + } + } + + res + } + ) +} + #' Text Output #' #' Makes a reactive version of the given function that also uses @@ -313,12 +399,13 @@ renderText <- function(expr, env=parent.frame(), quoted=FALSE, outputArgs=list()) { installExprFunction(expr, "func", env, quoted) - renderFunc <- function(shinysession, name, ...) { - value <- func() - return(paste(utils::capture.output(cat(value)), collapse="\n")) - } - - markRenderFunction(textOutput, renderFunc, outputArgs = outputArgs) + createRenderFunction( + func, + function(value, session, name, ...) { + paste(utils::capture.output(cat(value)), collapse="\n") + }, + textOutput, outputArgs + ) } #' UI Output diff --git a/inst/www/shared/shiny.js b/inst/www/shared/shiny.js index 75636d89c..020bb4df0 100644 --- a/inst/www/shared/shiny.js +++ b/inst/www/shared/shiny.js @@ -1075,12 +1075,13 @@ var _typeof = typeof Symbol === "function" && typeof Symbol.iterator === "symbol // Message handlers ===================================================== addMessageHandler('values', function (message) { - for (var name in this.$bindings) { - if (this.$bindings.hasOwnProperty(name)) this.$bindings[name].showProgress(false); - } - for (var key in message) { - if (message.hasOwnProperty(key)) this.receiveOutput(key, message[key]); + if (message.hasOwnProperty(key)) { + if (this.$bindings.hasOwnProperty(key)) { + this.$bindings[key].showProgress(false); + } + this.receiveOutput(key, message[key]); + } } }); diff --git a/man/createRenderFunction.Rd b/man/createRenderFunction.Rd new file mode 100644 index 000000000..96a2a049c --- /dev/null +++ b/man/createRenderFunction.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/shinywrappers.R +\name{createRenderFunction} +\alias{createRenderFunction} +\title{Implement render functions} +\usage{ +createRenderFunction(func, transform = function(value, session, name, ...) + value, outputFunc = NULL, outputArgs = NULL) +} +\arguments{ +\item{func}{A function without parameters, that returns user data. If the +returned value is a promise, then the render function will proceed in async +mode.} + +\item{transform}{A function that takes four arguments: \code{value}, +\code{session}, \code{name}, and \code{...} (for future-proofing). This +function will be invoked each time a value is returned from \code{func}, +and is responsible for changing the value into a JSON-ready value to be +JSON-encoded and sent to the browser.} + +\item{outputFunc}{The UI function that is used (or most commonly used) with +this render function. This can be used in R Markdown documents to create +complete output widgets out of just the render function.} + +\item{outputArgs}{A list of arguments to pass to the \code{outputFunc}. +Render functions should include \code{outputArgs = list()} in their own +parameter list, and pass through the value as this argument, to allow app +authors to customize outputs. (Currently, this is only supported for +dynamically generated UIs, such as those created by Shiny code snippets +embedded in R Markdown documents).} +} +\value{ +An annotated render function, ready to be assigned to an + \code{output} slot. +} +\description{ +Implement render functions +} + diff --git a/man/session.Rd b/man/session.Rd index b61047f9d..1ca01d795 100644 --- a/man/session.Rd +++ b/man/session.Rd @@ -127,7 +127,8 @@ Similar to \code{sendCustomMessage}, but the message must be a raw vector and the registration method on the client is \code{Shiny.addBinaryMessageHandler(type, function(message){...})}. The - message argument on the client will be a \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}. + message argument on the client will be a + \href{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView}{DataView}. } \item{sendInputMessage(inputId, message)}{ Sends a message to an input on the session's client web page; if the input diff --git a/srcjs/shinyapp.js b/srcjs/shinyapp.js index a579ee541..32f2cacba 100644 --- a/srcjs/shinyapp.js +++ b/srcjs/shinyapp.js @@ -521,20 +521,22 @@ var ShinyApp = function() { // Message handlers ===================================================== addMessageHandler('values', function(message) { - for (var name in this.$bindings) { - if (this.$bindings.hasOwnProperty(name)) - this.$bindings[name].showProgress(false); - } - for (var key in message) { - if (message.hasOwnProperty(key)) + if (message.hasOwnProperty(key)) { + if (this.$bindings.hasOwnProperty(key)) { + this.$bindings[key].showProgress(false); + } this.receiveOutput(key, message[key]); + } } }); addMessageHandler('errors', function(message) { for (var key in message) { if (message.hasOwnProperty(key)) + if (this.$bindings.hasOwnProperty(key)) { + this.$bindings[key].showProgress(false); + } this.receiveError(key, message[key]); } });