From 7d29df58f12a80fe9288f9294be6a0959d41efb3 Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@rstudio.com>
Date: Mon, 16 Oct 2017 11:31:26 -0700
Subject: [PATCH] Support same-tick execution for synchronous outputs

---
 R/render-plot.R   | 152 ++++++++++++++++++++++++----------------------
 R/shiny.R         | 104 +++++++++++++++----------------
 R/shinywrappers.R |  14 ++---
 TODO-promises.md  |   5 +-
 4 files changed, 141 insertions(+), 134 deletions(-)

diff --git a/R/render-plot.R b/R/render-plot.R
index 9fbc3b892..2e070626c 100644
--- a/R/render-plot.R
+++ b/R/render-plot.R
@@ -97,16 +97,18 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     # Don't invalidate when width/height changes.
     dims <- if (execOnResize) getDims() else isolate(getDims())
     pixelratio <- session$clientData$pixelratio %OR% 1
-    p1 <- drawPlot(outputName, session, func, dims$width, dims$height, pixelratio, res)
-    p1 <- promises::catch(p1, function(reason) {
-      # Non-isolating read. A common reason for errors in plotting is because
-      # the dimensions are too small. By taking a dependency on width/height,
-      # we can try again if the plot output element changes size.
-      getDims()
+    hybrid_chain(
+      drawPlot(outputName, session, func, dims$width, dims$height, pixelratio, res),
+      catch = function(reason) {
+        # Non-isolating read. A common reason for errors in plotting is because
+        # the dimensions are too small. By taking a dependency on width/height,
+        # we can try again if the plot output element changes size.
+        getDims()
 
-      # Propagate the error
-      stop(reason)
-    })
+        # Propagate the error
+        stop(reason)
+      }
+    )
   })
 
   # This function is the one that's returned from renderPlot(), and gets
@@ -115,13 +117,14 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     outputName <<- name
     session <<- shinysession
 
-    p1 <- drawReactive()
-    p1 <- promises::then(p1, function(result) {
-      dims <- getDims()
-      pixelratio <- session$clientData$pixelratio %OR% 1
-      resizeSavedPlot(name, shinysession, result, dims$width, dims$height, pixelratio, res)
-    })
-    p1
+    hybrid_chain(
+      drawReactive(),
+      function(result) {
+        dims <- getDims()
+        pixelratio <- session$clientData$pixelratio %OR% 1
+        resizeSavedPlot(name, shinysession, result, dims$width, dims$height, pixelratio, res)
+      }
+    )
   }
 
   # If renderPlot isn't going to adapt to the height of the div, then the
@@ -175,64 +178,69 @@ drawPlot <- function(name, session, func, width, height, pixelratio, res, ...) {
   domain <- createGraphicsDevicePromiseDomain(device)
   grDevices::dev.control(displaylist = "enable")
 
-  p1 <- promises::with_promise_domain(domain, {
-    p2 <- promises::promise(~resolve(func()))
-    p2 <- promises::then(p2, function(value, .visible) {
-      if (.visible) {
-        # A modified version of print.ggplot which returns the built ggplot object
-        # as well as the gtable grob. This overrides the ggplot::print.ggplot
-        # method, but only within the context of renderPlot. The reason this needs
-        # to be a (pseudo) S3 method is so that, if an object has a class in
-        # addition to ggplot, and there's a print method for that class, that we
-        # won't override that method. https://github.com/rstudio/shiny/issues/841
-        print.ggplot <- custom_print.ggplot
+  hybrid_chain(
+    hybrid_chain(
+      promises::with_promise_domain(domain, {
+        hybrid_chain(
+          func(),
+          function(value, .visible) {
+            if (.visible) {
+              # A modified version of print.ggplot which returns the built ggplot object
+              # as well as the gtable grob. This overrides the ggplot::print.ggplot
+              # method, but only within the context of renderPlot. The reason this needs
+              # to be a (pseudo) S3 method is so that, if an object has a class in
+              # addition to ggplot, and there's a print method for that class, that we
+              # won't override that method. https://github.com/rstudio/shiny/issues/841
+              print.ggplot <- custom_print.ggplot
 
-        # Use capture.output to squelch printing to the actual console; we
-        # are only interested in plot output
-        utils::capture.output({
-          # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
-          # the call to plotFunc. The value needs to be printed just in case
-          # it's an object that requires printing to generate plot output,
-          # similar to ggplot2. But for base graphics, it would already have
-          # been rendered when func was called above, and the print should
-          # have no effect.
-          result <- ..stacktraceon..(print(value))
-          # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
-        })
-        result
-      } else {
-        # Not necessary, but I wanted to make it explicit
-        NULL
+              # Use capture.output to squelch printing to the actual console; we
+              # are only interested in plot output
+              utils::capture.output({
+                # This ..stacktraceon.. negates the ..stacktraceoff.. that wraps
+                # the call to plotFunc. The value needs to be printed just in case
+                # it's an object that requires printing to generate plot output,
+                # similar to ggplot2. But for base graphics, it would already have
+                # been rendered when func was called above, and the print should
+                # have no effect.
+                result <- ..stacktraceon..(print(value))
+                # TODO jcheng 2017-04-11: Verify above ..stacktraceon..
+              })
+              result
+            } else {
+              # Not necessary, but I wanted to make it explicit
+              NULL
+            }
+          },
+          function(value) {
+            list(
+              plotResult = value,
+              recordedPlot = grDevices::recordPlot(),
+              coordmap = getCoordmap(value, width, height, pixelratio, res),
+              pixelratio = pixelratio,
+              res = res
+            )
+          }
+        )
+      }),
+      finally = function() {
+        grDevices::dev.off(device)
       }
-    })
-    p2 <- promises::then(p2, function(value) {
-      list(
-        plotResult = value,
-        recordedPlot = grDevices::recordPlot(),
-        coordmap = getCoordmap(value, width, height, pixelratio, res),
-        pixelratio = pixelratio,
-        res = res
-      )
-    })
-    p2
-  })
-  p1 <- promises::finally(p1, function() {
-    grDevices::dev.off(device)
-  })
-  p1 <- promises::then(p1, function(result) {
-    result$img <- dropNulls(list(
-      src = session$fileUrl(name, outfile, contentType='image/png'),
-      width = width,
-      height = height,
-      coordmap = result$coordmap,
-      # Get coordmap error message if present
-      error = attr(result$coordmap, "error", exact = TRUE)
-    ))
-    result
-  })
-  p1 <- promises::finally(p1, function() {
-    unlink(outfile)
-  })
+    ),
+    function(result) {
+      result$img <- dropNulls(list(
+        src = session$fileUrl(name, outfile, contentType='image/png'),
+        width = width,
+        height = height,
+        coordmap = result$coordmap,
+        # Get coordmap error message if present
+        error = attr(result$coordmap, "error", exact = TRUE)
+      ))
+      result
+    },
+    finally = function() {
+      unlink(outfile)
+    }
+  )
 }
 
 # A modified version of print.ggplot which returns the built ggplot object
diff --git a/R/shiny.R b/R/shiny.R
index 47be103fc..bfdcef35c 100644
--- a/R/shiny.R
+++ b/R/shiny.R
@@ -1151,62 +1151,62 @@ ShinySession <- R6Class(
 
           # This shinyCallingHandlers should maybe be at a higher level,
           # to include the $then/$catch calls below?
-          p <- promises::promise(~resolve(shinyCallingHandlers(func())))
-
-          p <- promises::catch(p,
-            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."))
+          hybrid_chain(
+            hybrid_chain(
+              shinyCallingHandlers(func()),
+              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))
                 }
-                invisible(structure(list(), class = "try-error", condition = cond))
               }
+            ),
+            function(value) {
+              # Needed so that Shiny knows to flush the outputs. Even if no
+              # outputs/errors are queued, it's necessary to flush so that the
+              # client knows that progress is over.
+              self$requestFlush()
+
+              private$sendMessage(recalculating = list(
+                name = name, status = 'recalculated'
+              ))
+
+              if (inherits(value, "cancel-output")) {
+                return()
+              }
+
+              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)
             }
           )
-
-          p <- promises::then(p, function(value) {
-            # Needed so that Shiny knows to flush the outputs. Even if no
-            # outputs/errors are queued, it's necessary to flush so that the
-            # client knows that progress is over.
-            self$requestFlush()
-
-            private$sendMessage(recalculating = list(
-              name = name, status = 'recalculated'
-            ))
-
-            if (inherits(value, "cancel-output")) {
-              return()
-            }
-
-            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)
-          })
         }, 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 42f50d871..e7af7fd05 100644
--- a/R/shinywrappers.R
+++ b/R/shinywrappers.R
@@ -81,14 +81,12 @@ createRenderFunction <- function(
 ) {
 
   renderFunc <- function(shinysession, name, ...) {
-    res <- func()
-    if (promises::is.promise(res)) {
-      return(promises::then(res, function(value) {
-        transform(value, shinysession, name, ...)
-      }))
-    } else {
-      return(transform(res, shinysession, name, ...))
-    }
+    hybrid_chain(
+      func(),
+      function(value, .visible) {
+        transform(setVisible(value, .visible), shinysession, name, ...)
+      }
+    )
   }
 
   if (!is.null(outputFunc))
diff --git a/TODO-promises.md b/TODO-promises.md
index fce518426..2f06bad0d 100644
--- a/TODO-promises.md
+++ b/TODO-promises.md
@@ -6,10 +6,11 @@
 - [ ] options(shiny.error) should work in promise handlers
 
 ## Render functions
-- [ ] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
-- [ ] promises::resolved(logic()) should use the current reactive domain to wrap the call to logic()
+- [x] Non-async render functions should have their code all execute on the current tick. Otherwise order of execution will be surprising if they have side effects and explicit priorities.
 - [x] Promise domains should maybe have an onExecute, for the "sync" part that kicks off async operations to also have wrapping behavior (like capturing output). Right now, I have to start off renderPrint with promise(~resolve(TRUE)) and then execute the user code in a then(), just to get the promise behavior. Same will be true when we tackle error handling (stack trace capture).
 - [x] invisible() doesn't seem to be working correctly with renderPrint. .visible doesn't survive promise chaining, e.g. promise(~resolve(promise(~resolve(invisible("Hi"))))) %>% then(function(x, .visible) { cat(.visible) }) will print TRUE, not FALSE.
+- [ ] renderDataTable should support async
+- [ ] App that tests that all built-in render functions support async
 
 ## Flush lifecycle
 - [x] While async operations are running in a session, hold off on any further processing of inputs and scheduled task items until all operations are complete.