wip

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)

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
+    }
+  }
+)

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

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

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]);
+        }
       }
     });
 

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
+}
+

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

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]);
     }
   });