Relay customdata

R/layers2traces.R

@@ -637,6 +637,7 @@ geom2trace.GeomPath <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data[["hovertext"]]),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "scatter",
@@ -667,6 +668,7 @@ geom2trace.GeomPoint <- function(data, params, p) {
     y = data[["y"]],
     text = if (isDotPlot) data[["key"]] else uniq(data[["hovertext"]]),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "scatter",
@@ -720,6 +722,7 @@ geom2trace.GeomBar <- function(data, params, p) {
     y = y,
     text = uniq(data[["hovertext"]]),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "bar",
@@ -747,6 +750,7 @@ geom2trace.GeomPolygon <- function(data, params, p) {
     y = data[["y"]],
     text = uniq(data[["hovertext"]]),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "scatter",
@@ -778,6 +782,7 @@ geom2trace.GeomBoxplot <- function(data, params, p) {
     y = data[["y"]],
     hoverinfo = "y",
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "box",
@@ -812,6 +817,7 @@ geom2trace.GeomText <- function(data, params, p) {
     text = data[["label"]],
     hovertext = data[["hovertext"]],
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     textfont = list(
@@ -850,6 +856,7 @@ geom2trace.GeomTile <- function(data, params, p) {
     z = matrix(g$fill_plotlyDomain, nrow = length(y), ncol = length(x), byrow = TRUE),
     text = matrix(g$hovertext, nrow = length(y), ncol = length(x), byrow = TRUE),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     colorscale = setNames(colScale, NULL),
@@ -945,6 +952,7 @@ make_error <- function(data, params, xy = "x") {
     y = data[["y"]],
     text = uniq(data[["hovertext"]]),
     key = data[["key"]],
+    customdata = data[["customdata"]],
     frame = data[["frame"]],
     ids = data[["ids"]],
     type = "scatter",

R/plotly_build.R

@@ -190,6 +190,8 @@ plotly_build.plotly <- function(p, registerFrames = TRUE) {
     tr <- trace[names(trace) %in% allAttrs]
     # TODO: does it make sense to "train" matrices/2D-tables (e.g. z)?
     tr <- tr[vapply(tr, function(x) is.null(dim(x)) && is.atomic(x), logical(1))]
+    # white-list customdata as this can be a non-atomic vector
+    tr$customdata <- trace$customdata
     builtData <- tibble::as_tibble(tr)
     # avoid clobbering I() (i.e., variables that shouldn't be scaled)
     for (i in seq_along(tr)) {
@@ -266,7 +268,7 @@ plotly_build.plotly <- function(p, registerFrames = TRUE) {
 
   # insert NAs to differentiate groups
   traces <- lapply(traces, function(x) {
-    d <- data.frame(x[names(x) %in% x$.plotlyVariableMapping], stringsAsFactors = FALSE)
+    d <- tibble::as_tibble(x[names(x) %in% x$.plotlyVariableMapping])
     d <- group2NA(
       d, if (has_group(x)) ".plotlyGroupIndex",
       ordered = if (inherits(x, "plotly_line")) "x",

inst/examples/shiny/event_data/app.R

@@ -15,10 +15,10 @@ server <- function(input, output, session) {
 
   output$plot <- renderPlotly({
     if (identical(input$plotType, "ggplotly")) {
-      p <- ggplot(mtcars, aes(x = mpg, y = wt, key = nms)) + geom_point()
+      p <- ggplot(mtcars, aes(x = mpg, y = wt, customdata = nms)) + geom_point()
       ggplotly(p) %>% layout(dragmode = "select")
     } else {
-      plot_ly(mtcars, x = ~mpg, y = ~wt, key = nms) %>%
+      plot_ly(mtcars, x = ~mpg, y = ~wt, customdata = nms) %>%
         layout(dragmode = "select")
     }
   })

inst/htmlwidgets/plotly.js

@@ -236,6 +236,10 @@ HTMLWidgets.widget({
           obj.z = pt.z;
         }
 
+        if (pt.hasOwnProperty("customdata")) {
+          obj.customdata = pt.customdata;
+        }
+
         /* 
           TL;DR: (I think) we have to select the graph div (again) to attach keys...
 

tests/testthat/test-plotly-customdata.R

@@ -0,0 +1,32 @@
+context("customdata")
+
+# TODO: use shinytest to make sure we can access the right value in shiny
+test_that("ggplotly relays customdata", {
+  nms <- row.names(mtcars)
+  p <- ggplot(mtcars, aes(x = mpg, y = wt, customdata = nms)) + geom_point()
+  l <- plotly_build(p)
+  trace <- l$x$data[[1]]
+  expect_equivalent(trace$customdata, nms)
+})
+
+
+test_that("Can provide list-columns to customdata", {
+  l <- txhousing %>%
+    group_by(city) %>%
+    highlight_key(~city) %>%
+    plot_ly(x = ~date, y = ~median, hoverinfo = "name") %>%
+    add_lines(customdata = ~purrr::map2(date, median, ~list(.x, .y))) %>%
+    plotly_build()
+
+  trace <- l$x$data[[1]]
+  expect_true(length(trace$customdata) == length(trace$x))
+
+  # make sure customdata have been arranged properly
+  customx <- unlist(lapply(trace$customdata, function(x) x[1] %||% NA))
+  expect_equivalent(customx, trace$x)
+
+  # check there is no customdata where x values are null
+  nullcd <- trace$customdata[which(is.na(trace$x))]
+  expect_true(unique(lengths(nullcd)) == 0)
+})
+