Merge pull request #1040 from ropensci/feature/proxy

Modify plotly graphs in shiny via plotly.js

Author: cpsievert

NAMESPACE

@@ -172,6 +172,8 @@ export(plot_ly)
 export(plot_mapbox)
 export(plotly)
 export(plotlyOutput)
+export(plotlyProxy)
+export(plotlyProxyInvoke)
 export(plotly_IMAGE)
 export(plotly_POST)
 export(plotly_build)

NEWS.md

@@ -2,9 +2,9 @@
 
 ## NEW FEATURES & IMPROVEMENTS
 
+* It is now possible to modify (i.e., update without a full redraw) plotly graphs inside of a shiny app via the new `plotlyProxy()` and `plotlyProxyInvoke()` functions. For examples, see `demo("proxy-relayout", package = "plotly")` and `demo("proxy-mapbox", package = "plotly")`. Closes #580. 
 * The `schema()` function now returns the plot schema (rather just printing it), making it easier to acquire/use values from the official plot schema. See `help(schema)` for an example. Fixes #1038.
 
-
 ## CHANGES
 
 ## BUG FIXES

R/proxy.R

@@ -0,0 +1,106 @@
+#' Modify a plotly object inside a shiny app
+#'
+#' @param outputId single-element character vector indicating the output ID
+#'   map to modify (if invoked from a Shiny module, the namespace will be added
+#'   automatically)
+#' @param session the Shiny session object to which the map belongs; usually the
+#'   default value will suffice.
+#' @param deferUntilFlush indicates whether actions performed against this
+#'   instance should be carried out right away, or whether they should be held
+#'   until after the next time all of the outputs are updated.
+#' @rdname plotlyProxy
+#' @export 
+#' @examples
+#' 
+#' demo("proxy-mapbox", package = "plotly")
+#' demo("proxy-relayout", package = "plotly")
+plotlyProxy <- function(outputId, session = shiny::getDefaultReactiveDomain(), 
+                        deferUntilFlush = TRUE) {
+  
+  # implementation very similar to leaflet::leafletProxy & DT:dataTableProxy
+  if (is.null(session)) {
+    stop("plotlyProxy must be called from the server function of a Shiny app")
+  }
+  
+  if (!is.null(session$ns) && nzchar(session$ns(NULL)) && 
+      # TODO: require a recent version of R and use startsWith()?
+      substring(outputId, 1, nchar(session$ns(""))) != session$ns("")) {
+    outputId <- session$ns(outputId)
+  }
+  structure(
+    list(
+      session = session, 
+      id = outputId,
+      deferUntilFlush = deferUntilFlush
+      # TODO: is there actually a use-case for this?
+      #x = structure(list(), leafletData = data), 
+      #dependencies = NULL
+    ), 
+    class = "plotly_proxy"
+  )
+}
+
+
+# ----------------------------------------------------------------------
+# TODO: implement some higher-level functions, say `plotlyProxyLayout()`,
+# `plotlyProxyAddTraces()`, `plotlyProxyStyle()`, that pick the right
+# method, except formula/data mappings, and possibly some argument checking 
+# ----------------------------------------------------------------------
+
+
+#' @param p a plotly proxy object (created with \code{plotlyProxy})
+#' @param method a plotlyjs method to invoke. For a list of options,
+#' visit the \href{https://plot.ly/javascript/plotlyjs-function-reference}{plotlyjs function reference}
+#' @param ... unnamed arguments passed onto the plotly.js method
+#' @rdname plotlyProxy
+#' @export
+plotlyProxyInvoke <- function(p, method, ...) {
+  
+  if (!is.proxy(p))
+    stop("p must be a proxy object. See `help(plotlyProxy)`", call. = FALSE)
+  
+  if (missing(method))
+    stop(
+      "Must provide a plotly.js method (as a character string of length 1).\n", 
+      sprintf("Valid options include: '%s'", 
+              paste(plotlyjs_methods(), collapse = "', '")),
+      call. = FALSE
+    )
+  
+  method <- match.arg(method, plotlyjs_methods())
+  
+  msg <- list(
+    id = p$id,
+    method = method,
+    # TODO: can we leverage the plotly_build() infrastructure in a smart way?
+    #  args = evalFormula(list(...), data)
+    args = list(...)
+  )
+  
+  if (isTRUE(p$deferUntilFlushed)) {
+    
+    p$session$onFlushed(function() {
+      p$session$sendCustomMessage("plotly-calls", msg)
+    }, once = TRUE)
+    
+  } else {
+    
+    p$session$sendCustomMessage("plotly-calls", msg)
+    
+  }
+  
+  p
+}
+
+
+plotlyjs_methods <- function() {
+  c(
+    "restyle", "relayout", "update", "addTraces", "deleteTraces", "moveTraces",
+    "extendTraces", "prependTraces", "purge", "toImage", "downloadImage"
+  )
+}
+
+
+is.proxy <- function(x) {
+  inherits(x, "plotly_proxy")
+}

demo/proxy-mapbox.R

@@ -0,0 +1,27 @@
+library(shiny)
+
+# get all the available mapbox styles
+mapStyles <- schema()$layout$layoutAttributes$mapbox$style$values
+
+ui <- fluidPage(
+  selectInput("style", "Select a mapbox style", mapStyles),
+  plotlyOutput("map")
+)
+
+server <- function(input, output, session) {
+  
+  output$map <- renderPlotly({
+    plot_mapbox()
+  })
+  
+  observeEvent(input$style, {
+    plotlyProxy("map", session) %>%
+      plotlyProxyInvoke(
+        "relayout",
+        list(mapbox = list(style = input$style))
+      )
+  })
+  
+}
+
+shinyApp(ui, server)

demo/proxy-relayout.R

@@ -0,0 +1,43 @@
+library(shiny)
+library(plotly)
+
+ui <- fluidPage(
+  plotlyOutput("plot")
+)
+
+server <- function(input, output, session) {
+  
+  p <- ggplot(txhousing) +
+    geom_line(aes(date, median, group = city))
+  
+  output$plot <- renderPlotly({
+    ggplotly(p, dynamicTicks = TRUE) %>% 
+      rangeslider() 
+  })
+  
+  observeEvent(event_data("plotly_relayout"), {
+    d <- event_data("plotly_relayout")
+    xmin <- if (length(d[["xaxis.range[0]"]])) d[["xaxis.range[0]"]] else d[["xaxis.range"]][1]
+    xmax <- if (length(d[["xaxis.range[1]"]])) d[["xaxis.range[1]"]] else d[["xaxis.range"]][2]
+    if (is.null(xmin) || is.null(xmax)) return(NULL)
+    
+    # compute the y-range based on the new x-range
+    idx <- with(txhousing, xmin <= date & date <= xmax)
+    yrng <- extendrange(txhousing$median[idx])
+    
+    plotlyProxy("plot", session) %>%
+      plotlyProxyInvoke("relayout", list(yaxis = list(range = yrng)))
+  })
+  
+  yRange <- range(txhousing$median, na.rm = TRUE)
+  observeEvent(event_data("plotly_doubleclick"), {
+    
+    plotlyProxy("plot", session) %>%
+      plotlyProxyInvoke("relayout", list(yaxis = list(range = yRange)))
+    
+  })
+  
+  
+}
+
+shinyApp(ui, server)

inst/htmlwidgets/plotly.js

@@ -159,6 +159,23 @@ HTMLWidgets.widget({
 
     }
 
+    // Trigger plotly.js calls defined via `plotlyProxy()`
+    plot.then(function() {
+      if (HTMLWidgets.shinyMode) {
+        Shiny.addCustomMessageHandler("plotly-calls", function(msg) {
+          var gd = document.getElementById(msg.id);
+          if (!gd) {
+            throw new Error("Couldn't find plotly graph with id: " + msg.id);
+          }
+          if (!Plotly[msg.method]) {
+            throw new Error("Unknown method " + msg.method);
+          }
+          var args = [gd].concat(msg.args);
+          Plotly[msg.method].apply(null, args);
+        });
+      }
+    });
+    
     // Attach attributes (e.g., "key", "z") to plotly event data
     function eventDataWithKey(eventData) {
       if (eventData === undefined || !eventData.hasOwnProperty("points")) {