From 16242e87a1d5ea5631836a81022db32bb2f44f89 Mon Sep 17 00:00:00 2001 From: Joe Cheng Date: Mon, 10 Apr 2017 19:29:54 -0700 Subject: [PATCH] Some steps toward renderPlot working. Move to promise package instead of system2.5. --- DESCRIPTION | 1 + NAMESPACE | 1 - R/imageutils.R | 106 ++++++++++++++++++++++++++++++++------------ R/react.R | 35 ++++++--------- R/render-plot.R | 109 ++++++++++++++++++++++++---------------------- R/server.R | 14 ++++-- R/shiny.R | 21 ++++----- R/shinywrappers.R | 84 +++++++++++++++++------------------ TODO-promises.md | 4 ++ 9 files changed, 214 insertions(+), 161 deletions(-) create mode 100644 TODO-promises.md diff --git a/DESCRIPTION b/DESCRIPTION index 337208b7a..955cc5c27 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -72,6 +72,7 @@ Imports: htmltools (>= 0.3.5), R6 (>= 2.0), sourcetools, + promise, tools Suggests: datasets, diff --git a/NAMESPACE b/NAMESPACE index 8c2151859..47bb2ce89 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -285,5 +285,4 @@ import(htmltools) import(httpuv) import(methods) import(mime) -import(monads) import(xtable) diff --git a/R/imageutils.R b/R/imageutils.R index 88a923cbc..2b2a52eba 100644 --- a/R/imageutils.R +++ b/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) + } + } + ) +} diff --git a/R/react.R b/R/react.R index 9cc8f616b..abfc11d88 100644 --- a/R/react.R +++ b/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 - } - } -) + ) +} diff --git a/R/render-plot.R b/R/render-plot.R index 3c0a47b73..0f9c95aed 100644 --- a/R/render-plot.R +++ b/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 }) diff --git a/R/server.R b/R/server.R index 352329173..ecbe80ed3 100644 --- a/R/server.R +++ b/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() } diff --git a/R/shiny.R b/R/shiny.R index 871fa58d9..f02cc3439 100644 --- a/R/shiny.R +++ b/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 diff --git a/R/shinywrappers.R b/R/shinywrappers.R index 1a4acf4e1..cf26fa84d 100644 --- a/R/shinywrappers.R +++ b/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 diff --git a/TODO-promises.md b/TODO-promises.md new file mode 100644 index 000000000..967d7a5ab --- /dev/null +++ b/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.