Introducing plotlyProxy and plotlyProxyInvoke; fixes #580

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)

R/proxy.R

@@ -0,0 +1,101 @@
+#' 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)) && 
+      !startsWith(outputId, 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"
+  )
+}
+
+
+#' @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 
+#' @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 <- d[["xaxis.range[0]"]] %||% d[["xaxis.range"]][1]
+    xmax <- d[["xaxis.range[1]"]] %||% 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")) {