Some steps toward renderPlot working. Move to promise package instead of system2.5.

DESCRIPTION

@@ -72,6 +72,7 @@ Imports:
     htmltools (>= 0.3.5),
     R6 (>= 2.0),
     sourcetools,
+    promise,
     tools
 Suggests:
     datasets,

NAMESPACE

@@ -285,5 +285,4 @@ import(htmltools)
 import(httpuv)
 import(methods)
 import(mime)
-import(monads)
 import(xtable)

R/imageutils.R

@@ -1,3 +1,33 @@
+startPNG <- function(filename, width, height, res, ...) {
+  # If quartz is available, use png() (which will default to quartz).
+  # Otherwise, if the Cairo package is installed, use CairoPNG().
+  # Finally, if neither quartz nor Cairo, use png().
+  if (capabilities("aqua")) {
+    pngfun <- grDevices::png
+  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
+      nchar(system.file(package = "Cairo"))) {
+    pngfun <- Cairo::CairoPNG
+  } else {
+    pngfun <- grDevices::png
+  }
+
+  pngfun(filename=filename, width=width, height=height, res=res, ...)
+  # Call plot.new() so that even if no plotting operations are performed at
+  # least we have a blank background. N.B. we need to set the margin to 0
+  # temporarily before plot.new() because when the plot size is small (e.g.
+  # 200x50), we will get an error "figure margin too large", which is triggered
+  # by plot.new() with the default (large) margin. However, this does not
+  # guarantee user's code in func() will not trigger the error -- they may have
+  # to set par(mar = smaller_value) before they draw base graphics.
+  op <- graphics::par(mar = rep(0, 4))
+  tryCatch(
+    graphics::plot.new(),
+    finally = graphics::par(op)
+  )
+
+  grDevices::dev.cur()
+}
+
 #' Run a plotting function and save the output as a PNG
 #'
 #' This function returns the name of the PNG file that it generates. In
@@ -28,35 +58,57 @@
 #' @export
 plotPNG <- function(func, filename=tempfile(fileext='.png'),
                     width=400, height=400, res=72, ...) {
-  # If quartz is available, use png() (which will default to quartz).
-  # Otherwise, if the Cairo package is installed, use CairoPNG().
-  # Finally, if neither quartz nor Cairo, use png().
-  if (capabilities("aqua")) {
-    pngfun <- grDevices::png
-  } else if ((getOption('shiny.usecairo') %OR% TRUE) &&
-             nchar(system.file(package = "Cairo"))) {
-    pngfun <- Cairo::CairoPNG
-  } else {
-    pngfun <- grDevices::png
-  }
-
-  pngfun(filename=filename, width=width, height=height, res=res, ...)
-  # Call plot.new() so that even if no plotting operations are performed at
-  # least we have a blank background. N.B. we need to set the margin to 0
-  # temporarily before plot.new() because when the plot size is small (e.g.
-  # 200x50), we will get an error "figure margin too large", which is triggered
-  # by plot.new() with the default (large) margin. However, this does not
-  # guarantee user's code in func() will not trigger the error -- they may have
-  # to set par(mar = smaller_value) before they draw base graphics.
-  op <- graphics::par(mar = rep(0, 4))
-  tryCatch(
-    graphics::plot.new(),
-    finally = graphics::par(op)
-  )
-
-  dv <- grDevices::dev.cur()
+  dv <- startPNG(filename, width, height, res, ...)
   on.exit(grDevices::dev.off(dv), add = TRUE)
   func()
 
   filename
 }
+
+plotPNGAsync <- function(func, filename=tempfile(fileext='.png'),
+  width=400, height=400, res=72, ...) {
+
+  dv <- startPNG(filename, width, height, res, ...)
+  domain <- createGraphicsDevicePromiseDomain(dv)
+  p1 <- promise::with_promise_domain(domain, {
+    p2 <- promise::resolved(NULL)
+    p2 <- promise::then(p2, function(value) {
+      func()
+    })
+    p2 <- promise::then(p2, function(value) {
+      filename
+    })
+    p2
+  })
+  p1 <- promise::finally(p1, function() {
+    grDevices::dev.off(dv)
+  })
+  p1
+}
+
+createGraphicsDevicePromiseDomain <- function(which = dev.cur()) {
+  force(which)
+
+  promise::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(value) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onFulfilled(value)
+      }
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      function(reason) {
+        old <- dev.cur()
+        dev.set(which)
+        on.exit(dev.set(old))
+
+        onRejected(reason)
+      }
+    }
+  )
+}

R/react.R

@@ -19,7 +19,7 @@ Context <- R6Class(
     run = function(func) {
       "Run the provided function under this context."
 
-      system2.5::withPromiseDomain(reactivePromiseDomain, {
+      promise::with_promise_domain(reactivePromiseDomain(), {
         withReactiveDomain(.domain, {
           env <- .getReactiveEnvironment()
           .graphEnterContext(id)
@@ -181,24 +181,17 @@ wrapForContext <- function(func, ctx) {
   }
 }
 
-reactivePromiseDomain <- list(
-  onThen = function(onFulfilled, onRejected) {
-    ctx <- getCurrentContext()
-
-    changed <- FALSE
-    if (is.function(onFulfilled)) {
-      changed <- TRUE
-      onFulfilled <- wrapForContext(onFulfilled, ctx)
+reactivePromiseDomain <- function() {
+  promise::new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      ctx <- getCurrentContext()
+      wrapForContext(onFulfilled, ctx)
+    },
+    wrapOnRejected = function(onRejected) {
+      force(onRejected)
+      ctx <- getCurrentContext()
+      wrapForContext(onRejected, ctx)
     }
-    if (is.function(onRejected)) {
-      changed <- TRUE
-      onRejected <- wrapForContext(onRejected, ctx)
-    }
-
-    if (changed) {
-      list(onFulfilled = onFulfilled, onRejected = onRejected)
-    } else {
-      NULL
-    }
-  }
-)
+  )
+}

R/render-plot.R

@@ -122,44 +122,47 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     }
 
     # The reactive that runs the expr in renderPlot()
-    plotData <- plotObj()
+    p1 <- plotObj()
+    p1 <- promise::then(p1, function(plotData) {
 
-    img <- plotData$img
+      img <- plotData$img
 
-    # If only the width/height have changed, simply replay the plot and make a
-    # new img.
-    if (dims$width != img$width || dims$height != img$height) {
-      pixelratio <- session$clientData$pixelratio %OR% 1
+      # If only the width/height have changed, simply replay the plot and make a
+      # new img.
+      if (dims$width != img$width || dims$height != img$height) {
+        pixelratio <- session$clientData$pixelratio %OR% 1
 
-      coordmap <- NULL
-      plotFunc <- function() {
-        ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
+        coordmap <- NULL
+        plotFunc <- function() {
+          ..stacktraceon..(grDevices::replayPlot(plotData$recordedPlot))
 
-        # Coordmap must be recalculated after replaying plot, because pixel
-        # dimensions will have changed.
-        if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
-          coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
-        } else {
-          coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
+          # Coordmap must be recalculated after replaying plot, because pixel
+          # dimensions will have changed.
+          if (inherits(plotData$plotResult, "ggplot_build_gtable")) {
+            coordmap <<- getGgplotCoordmap(plotData$plotResult, pixelratio, res)
+          } else {
+            coordmap <<- getPrevPlotCoordmap(dims$width, dims$height)
+          }
         }
+        outfile <- ..stacktraceoff..(
+          plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
+                  res = res*pixelratio)
+        )
+        on.exit(unlink(outfile))
+
+        img <- dropNulls(list(
+          src = session$fileUrl(name, outfile, contentType='image/png'),
+          width = dims$width,
+          height = dims$height,
+          coordmap = coordmap,
+          # Get coordmap error message if present
+          error = attr(coordmap, "error", exact = TRUE)
+        ))
       }
-      outfile <- ..stacktraceoff..(
-        plotPNG(plotFunc, width = dims$width*pixelratio, height = dims$height*pixelratio,
-                res = res*pixelratio)
-      )
-      on.exit(unlink(outfile))
 
-      img <- dropNulls(list(
-        src = session$fileUrl(name, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present
-        error = attr(coordmap, "error", exact = TRUE)
-      ))
-    }
-
-    img
+      img
+    })
+    p1
   }
 
 
@@ -182,6 +185,7 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     recordedPlot <- NULL
     coordmap <- NULL
     plotFunc <- function() {
+
       success <-FALSE
       tryCatch(
         {
@@ -231,28 +235,31 @@ renderPlot <- function(expr, width='auto', height='auto', res=72, ...,
     # wrapFunctionLabel(..stacktraceon=TRUE) call near the beginning of
     # renderPlot, and by the ..stacktraceon.. in plotFunc where ggplot objects
     # are printed
-    outfile <- ..stacktraceoff..(
-      do.call("plotPNG", c(quote(plotFunc), width=dims$width*pixelratio,
+    p1 <- ..stacktraceoff..({
+      do.call("plotPNGAsync", c(quote(plotFunc), width=dims$width*pixelratio,
         height=dims$height*pixelratio, res=res*pixelratio, args))
-    )
-    on.exit(unlink(outfile))
+    })
+    p1 <- promise::then(p1, function(outfile) {
+      on.exit(unlink(outfile))
 
-    list(
-      # img is the content that gets sent to the client.
-      img = dropNulls(list(
-        src = session$fileUrl(outputName, outfile, contentType='image/png'),
-        width = dims$width,
-        height = dims$height,
-        coordmap = coordmap,
-        # Get coordmap error message if present.
-        error = attr(coordmap, "error", exact = TRUE)
-      )),
-      # Returned value from expression in renderPlot() -- may be a printable
-      # object like ggplot2. Needed just in case we replayPlot and need to get
-      # a coordmap again.
-      plotResult = plotResult,
-      recordedPlot = recordedPlot
-    )
+      list(
+        # img is the content that gets sent to the client.
+        img = dropNulls(list(
+          src = session$fileUrl(outputName, outfile, contentType='image/png'),
+          width = dims$width,
+          height = dims$height,
+          coordmap = coordmap,
+          # Get coordmap error message if present.
+          error = attr(coordmap, "error", exact = TRUE)
+        )),
+        # Returned value from expression in renderPlot() -- may be a printable
+        # object like ggplot2. Needed just in case we replayPlot and need to get
+        # a coordmap again.
+        plotResult = plotResult,
+        recordedPlot = recordedPlot
+      )
+    })
+    p1
   })
 
 

R/server.R

@@ -318,7 +318,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
                 sep=""), con=shiny_stdout)
               flush(shiny_stdout)
 
-              flushReact()
+              runloop()
 
               # eXit a flushReact
               writeLines(paste("_x_flushReact ", get("HTTP_GUID", ws$request),
@@ -326,7 +326,7 @@ createAppHandlers <- function(httpHandlers, serverFuncSource) {
                 sep=""), con=shiny_stdout)
               flush(shiny_stdout)
             } else {
-              flushReact()
+              runloop()
             }
 
             flushAllSessions()
@@ -440,6 +440,14 @@ startApp <- function(appObj, port, host, quiet) {
   }
 }
 
+runloop <- function() {
+  while (TRUE) {
+    flushReact()
+    if (!later::run_now())
+      break
+  }
+}
+
 # Run an application that was created by \code{\link{startApp}}. This
 # function should normally be called in a \code{while(TRUE)} loop.
 serviceApp <- function() {
@@ -448,7 +456,7 @@ serviceApp <- function() {
       shinysession$manageHiddenOutputs()
     }
 
-    flushReact()
+    runloop()
     flushAllSessions()
   }
 

R/shiny.R

@@ -411,7 +411,6 @@ NS <- function(namespace, id = NULL) {
 ns.sep <- "-"
 
 
-#' @import monads
 #' @include utils.R
 ShinySession <- R6Class(
   'ShinySession',
@@ -1131,17 +1130,11 @@ ShinySession <- R6Class(
             name = name, status = 'recalculating'
           ))
 
-          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) {
-              p$reject(cond)
-            }
-          )
+          # This shinyCallingHandlers should maybe be at a higher level,
+          # to include the $then/$catch calls below?
+          p <- promise::resolved(shinyCallingHandlers(func()))
 
-          p$catch(
+          p <- promise::catch(p,
             function(cond) {
               if (inherits(cond, "shiny.custom.error")) {
                 if (isTRUE(getOption("show.error.messages"))) printError(cond)
@@ -1164,7 +1157,9 @@ ShinySession <- R6Class(
                 invisible(structure(list(), class = "try-error", condition = cond))
               }
             }
-          ) %>>% function(value) {
+          )
+
+          p <- promise::then(p, function(value) {
             private$sendMessage(recalculating = list(
               name = name, status = 'recalculated'
             ))
@@ -1187,7 +1182,7 @@ ShinySession <- R6Class(
             }
             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

@@ -82,11 +82,12 @@ createRenderFunction <- function(
 
   renderFunc <- function(shinysession, name, ...) {
     res <- func()
-    if (inherits(res, "Promise")) {
-      res %>>%
-        transform(shinysession, name, ...)
+    if (promise::is.promise(res)) {
+      return(promise::then(res, function(value) {
+        transform(value, shinysession, name, ...)
+      }))
     } else {
-      transform(res, shinysession, name, ...)
+      return(transform(res, shinysession, name, ...))
     }
   }
 
@@ -324,22 +325,28 @@ 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
+  # 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, ...) {
     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) })
-    })
+    system2.5::with_promise_domain(domain, {
+      p <- system2.5::Promise$new()$resolve(NULL)
+      p2 <- p$then(
+        function(value) func()
+      )
+    })$then(function(value) {
+      res <- paste(readLines(domain$conn, warn = FALSE), collapse = "\n")
+      res
+    })$catch(
+      function(err) { cat(file=stderr(), "ERROR", err$message) }
+    )$finally(
+      function() {
+        close(domain$conn)
+      }
+    )
   }
 
   markRenderFunction(verbatimTextOutput, renderFunc, outputArgs = outputArgs)
@@ -348,31 +355,17 @@ renderPrint <- function(expr, env = parent.frame(), quoted = FALSE,
 createRenderPrintPromiseDomain <- function(width) {
   f <- file()
 
-  list(
-    conn = f,
-    onThen = function(onFulfilled, onRejected) {
-      res <- list(onFulfilled = onFulfilled, onRejected = onRejected)
+  new_promise_domain(
+    wrapOnFulfilled = function(onFulfilled) {
+      force(onFulfilled)
+      function(value) {
+        op <- options(width = width)
+        on.exit(options(op), add = TRUE)
 
-      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)
-        }
+        capture.output(onFulfilled(value), 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
-    }
+    },
+    conn = f
   )
 }
 
@@ -458,15 +451,16 @@ renderUI <- function(expr, env=parent.frame(), quoted=FALSE,
                      outputArgs=list()) {
   installExprFunction(expr, "func", env, quoted)
 
-  renderFunc <- function(shinysession, name, ...) {
-    result <- func()
-    if (is.null(result) || length(result) == 0)
-      return(NULL)
+  createRenderFunction(
+    func,
+    function(result, shinysession, name, ...) {
+      if (is.null(result) || length(result) == 0)
+        return(NULL)
 
-    processDeps(result, shinysession)
-  }
-
-  markRenderFunction(uiOutput, renderFunc, outputArgs = outputArgs)
+      processDeps(result, shinysession)
+    },
+    uiOutput, outputArgs
+  )
 }
 
 #' File Downloads

TODO-promises.md

@@ -0,0 +1,4 @@
+# Promises TODO
+
+- [ ] How to handle invisible/withVisible? This is needed for dealing with ggplot2 in renderPlot.
+- [ ] renderPlot is broken. plotFunc is synchronous but calls func() which is potentially asynchronous.