basic crosstalk implementation

.travis.yml

@@ -28,8 +28,10 @@ before_script:
   - git clone https://github.com/cpsievert/plotly-test-table.git ../plotly-test-table
   - "wget -q -O - https://github.com/yihui/crandalf/raw/master/inst/scripts/install-pandoc | bash"
   - Rscript -e 'if (length(find.package("devtools", quiet = TRUE)) == 0L) { install.packages("devtools", repos = "http://cran.rstudio.com") }'
-  - Rscript -e 'library(devtools);update_packages("devtools", repos = "http://cran.rstudio.com")'
-  - Rscript -e 'library(devtools);install_deps(repos = "http://cran.rstudio.com", dependencies = TRUE)'
+  - Rscript -e 'devtools::update_packages("devtools", repos = "http://cran.rstudio.com")'
+  - Rscript -e 'devtools::install_deps(repos = "http://cran.rstudio.com", dependencies = TRUE)'
+  - Rscript -e 'devtools::install_github("rstudio/crosstalk")'
+  - Rscript -e 'devtools::install_github("cpsievert/htmlwidgets")'
 
 script:
   # run R CMD check on the non-pull request build

DESCRIPTION

@@ -30,6 +30,7 @@ Imports:
     viridis,
     base64enc,
     htmlwidgets,
+    crosstalk,
     plyr
 Suggests:
     dplyr,

R/plotly.R

@@ -19,6 +19,8 @@
 #' @param symbols A character vector of symbol types. Possible values:
 #' 'dot', 'cross', 'diamond', 'square', 'triangle-down', 'triangle-left', 'triangle-right', 'triangle-up' 
 #' @param size A variable name or numeric vector to encode the size of markers.
+#' @param key a selection variable for linked views
+#' @param set share selections across this grouping variable.
 #' @param width	Width in pixels (optional, defaults to automatic sizing).
 #' @param height Height in pixels (optional, defaults to automatic sizing).
 #' @param inherit logical. Should future traces inherit properties from this initial trace?
@@ -64,9 +66,9 @@
 #' }
 #' 
 plot_ly <- function(data = data.frame(), ..., type = "scatter",
-                    group, color, colors, symbol, symbols, size,
-                    width = NULL, height = NULL, inherit = FALSE, 
-                    evaluate = FALSE) {
+                    group, color, colors, symbol, symbols, size, 
+                    key, set = "A", width = NULL, height = NULL, 
+                    inherit = FALSE, evaluate = FALSE) {
   # "native" plotly arguments
   argz <- substitute(list(...))
   # old arguments to this function that are no longer supported
@@ -83,16 +85,19 @@ plot_ly <- function(data = data.frame(), ..., type = "scatter",
   if (!missing(symbol)) argz$symbol <- substitute(symbol)
   if (!missing(symbols)) argz$symbols <- substitute(symbols)
   if (!missing(size)) argz$size <- substitute(size)
+  if (!missing(key)) argz$key <- substitute(key)
   # trace information
   tr <- list(
     type = type,
     args = argz,
     env = list2env(data),    # environment in which to evaluate arguments
     enclos = parent.frame(), # if objects aren't found in env, look here
-    inherit = inherit
+    inherit = inherit,
+    set = set
   )
-  # plotly objects should always have a _list_ of trace(s)
+
   p <- list(
+    # plotly objects should always have a _list_ of trace(s)
     data = list(tr),
     layout = NULL,
     url = NULL,

R/print.R

@@ -49,6 +49,7 @@ as.widget <- function(x, ...) {
       padding = 5, 
       browser.fill = TRUE
     ),
+    dependencies = crosstalk::dependencies,
     ...
   )
 }

R/shiny.R

@@ -7,6 +7,8 @@
 #' @param width,height Must be a valid CSS unit (like \code{"100\%"},
 #'   \code{"400px"}, \code{"auto"}) or a number, which will be coerced to a
 #'   string and have \code{"px"} appended.
+#' @param inline use an inline (\code{span()}) or block container 
+#' (\code{div()}) for the output
 #' @param expr An expression that generates a plotly
 #' @param env The environment in which to evaluate \code{expr}.
 #' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This 
@@ -17,8 +19,16 @@
 #' @name plotly-shiny
 #'
 #' @export
-plotlyOutput <- function(outputId, width = "100%", height = "400px") {
-  htmlwidgets::shinyWidgetOutput(outputId, "plotly", width, height, package = "plotly")
+plotlyOutput <- function(outputId, width = "100%", height = "400px", 
+                         inline = FALSE) {
+  htmlwidgets::shinyWidgetOutput(
+    outputId = outputId, 
+    name = "plotly", 
+    width = width, 
+    height = height, 
+    inline = inline, 
+    package = "plotly"
+  )
 }
 
 #' @rdname plotly-shiny

inst/examples/crosstalk.R

@@ -0,0 +1,34 @@
+# access renderPlotly() selections on a shiny server
+# https://github.com/cpsievert/shiny_apps/blob/master/plotlyCrosstalk/app.R
+
+# TODO: 
+# (1) pass selections from another htmlwidget (rcdimple?) to renderPlotly()
+# (2) crosstalk without shiny (see examples below)
+# (3) define custom event behavior in JS from R?
+
+library(plotly)
+library(htmltools)
+
+# click/show selects?
+mtcars$gear <- factor(mtcars$gear)
+mtcars$cyl <- factor(mtcars$cyl)
+p1 <- plot_ly(mtcars, x = wt, y = mpg, color = gear, mode = "markers", 
+              key = gear, set = "A", width = 400)
+p2 <- plot_ly(mtcars, x = wt, y = disp, color = gear, mode = "markers", 
+              key = gear, set = "A", width = 400)
+# TODO: inline-block?
+browsable(tagList(
+  as.widget(p1),
+  as.widget(p2)
+))
+
+library(dplyr)
+m <- count(mtcars, cyl)
+p1 <- plot_ly(m, x = cyl, y = n, type = "bar", 
+              key = cyl, set = "A", width = 400)
+p2 <- plot_ly(mtcars, x = mpg, y = disp, mode = "markers", 
+              key = cyl, set = "A", width = 400)
+browsable(tagList(
+  as.widget(p1),
+  as.widget(p2)
+))

inst/htmlwidgets/plotly.js

@@ -1,12 +1,14 @@
+
 HTMLWidgets.widget({
   name: "plotly",
   type: "output",
 
-  initialize: function(el, width, height){
+  initialize: function(el, width, height) {
     return {};
   },
 
   resize: function(el, width, height, instance) {
+    // TODO: impose fixed coordinates, if specified (see #342)
     Plotly.relayout(el.id, {width: width, height: height});
   },  
 
@@ -15,13 +17,57 @@ HTMLWidgets.widget({
     window.PLOTLYENV = window.PLOTLYENV || {};
     window.PLOTLYENV.BASE_URL = x.base_url;
 
+    var graphDiv = document.getElementById(el.id);
+
     // if no plot exists yet, create one with a particular configuration
     if (!instance.plotly) {
-      Plotly.plot(el.id, x.data, x.layout, x.config);
+      Plotly.plot(graphDiv, x.data, x.layout, x.config);
       instance.plotly = true;
     } else {
-      Plotly.newPlot(el.id, x.data, x.layout);
+      Plotly.newPlot(graphDiv, x.data, x.layout);
     }
+
+    var g = x.data[0].set;
+    var grp = crosstalk.group(g);
+
+    graphDiv.on('plotly_click', function(eventData) {
+      // extract only the data we may want to access in R
+      var d = eventData.points.map(function(pt) {
+        var obj = {
+            curveNumber: pt.curveNumber, 
+            pointNumber: pt.pointNumber, 
+            x: pt.x,
+            y: pt.y
+        };
+        if (pt.data.hasOwnProperty("key")) {
+          if (typeof pt.pointNumber === "number") {
+            obj.key = pt.data.key[pt.pointNumber];
+          } else {
+            obj.key = pt.data.key[pt.pointNumber[0]][pt.pointNumber[1]];
+          } // TODO: can pointNumber be 3D?
+        }
+        return obj;
+      });
+
+      // tell crosstalk about click data so we can access it in R (and JS)
+      grp.var("plotly_click").set(d);
+    });
+
+    graphDiv.on('plotly_selected', function(eventData) {
+      if (eventData !== undefined) {
+        // convert the array of objects to object of arrays so this converts
+        // to data frame in R as opposed to a vector
+        var pts = eventData.points;
+        var obj = {
+          curveNumber: pts.map(function(pt) {return pt.curveNumber; }),
+          pointNumber: pts.map(function(pt) {return pt.pointNumber; }), 
+          x: pts.map(function(pt) {return pt.x; }),
+          y: pts.map(function(pt) {return pt.y; })
+        };
+        grp.var("plotly_selected").set(obj);
+      }
+    });  
+
   }
 
 });