diff --git a/R/layers2traces.R b/R/layers2traces.R index b57a444e1f..563b8174cf 100644 --- a/R/layers2traces.R +++ b/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", diff --git a/R/plotly_build.R b/R/plotly_build.R index 4c001472be..57f42e070f 100644 --- a/R/plotly_build.R +++ b/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", diff --git a/inst/examples/shiny/event_data/app.R b/inst/examples/shiny/event_data/app.R index 5127f02484..0ffdb32114 100644 --- a/inst/examples/shiny/event_data/app.R +++ b/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") } }) diff --git a/inst/htmlwidgets/plotly.js b/inst/htmlwidgets/plotly.js index e693246f78..1afe75f566 100644 --- a/inst/htmlwidgets/plotly.js +++ b/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... diff --git a/tests/testthat/test-plotly-customdata.R b/tests/testthat/test-plotly-customdata.R new file mode 100644 index 0000000000..e0a406eec0 --- /dev/null +++ b/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) +}) +