Parallel coordinates plot not triggering events with Shiny

[RCura]

Hi,

There is a bug regarding the events sent by parallel coordinates plot in shiny.
As far as I understand it, parallel coordinates are really different from usual plotly plots, as their axis, labels etc. do not work the same way as the others.
The events are also affected, as they aren't emmited the same way as in other plots.

Here's an adapted version of the example given in Shiny Gallery.

suppressPackageStartupMessages(library(plotly))
library(shiny)

ui <- fluidPage(
  plotlyOutput("parcoords"),
  verbatimTextOutput("hover"),
  verbatimTextOutput("click"),
  verbatimTextOutput("brush"),
  verbatimTextOutput("zoom")
)

server <- function(input, output, session) {
  
  output$parcoords <- renderPlotly({
    p <- plot_ly(data = iris, 
                type = 'parcoords',
                dimensions = list(
                list(range = c(min(iris$Sepal.Width), max(iris$Sepal.Width)),
                     label = 'Sepal Width', values = ~Sepal.Width),
                list(range = c(min(iris$Sepal.Length), max(iris$Sepal.Length)),
                     label = 'Sepal Length', values = ~Sepal.Length),
                list(range = c(min(iris$Petal.Width), max(iris$Petal.Width)),
                     label = 'Petal Width', values = ~Petal.Width),
                list(range = c(min(iris$Petal.Length), max(iris$Petal.Length)),
                     label = 'Petal Length', values = ~Petal.Length)
              )
      )
    p
  })
  
  output$hover <- renderPrint({
    d <- event_data("plotly_hover")
    if (is.null(d)) "Hover events appear here (unhover to clear)" else d
  })
  
  output$click <- renderPrint({
    d <- event_data("plotly_click")
    if (is.null(d)) "Click events appear here (double-click to clear)" else d
  })
  
  output$brush <- renderPrint({
    d <- event_data("plotly_selected")
    if (is.null(d)) "Click and drag events (i.e., select/lasso) appear here (double-click to clear)" else d
  })
  
  output$zoom <- renderPrint({
    d <- event_data("plotly_relayout")
    if (is.null(d)) "Relayout (i.e., zoom) events appear here" else d
  })
  
}

shinyApp(ui, server)

Created on 2018-08-10 by the reprex package (v0.2.0).

As you can see when running this, whatever you do, no event is ever triggered (the 4 verbatim outputs remain with their default text).
This is because in parallel coordinates plots, none of plotly_hover, plotly_click, plotly_selected or plotly_relayout are ever called.

What's called, when brushing a selection, is the js plotly_restyle event.

But this event contains not many significant thing, that is, only the last brushed selection, thus, not enabling to have a clear vision of what's selected.
Here's a demo app, using a custom binding with htmlwidgets::onRender(), showing the content of the event :

suppressPackageStartupMessages(library(plotly))
library(htmlwidgets)
library(shiny)

ui <- fluidPage(
  plotlyOutput("parcoords"),
  verbatimTextOutput("restyle")
)

server <- function(input, output, session) {
  
  output$parcoords <- renderPlotly({
    p <- plot_ly(data = iris, 
                 type = 'parcoords',
                 dimensions = list(
                   list(range = c(min(iris$Sepal.Width), max(iris$Sepal.Width)),
                        label = 'Sepal Width', values = ~Sepal.Width),
                   list(range = c(min(iris$Sepal.Length), max(iris$Sepal.Length)),
                        label = 'Sepal Length', values = ~Sepal.Length),
                   list(range = c(min(iris$Petal.Width), max(iris$Petal.Width)),
                        label = 'Petal Width', values = ~Petal.Width),
                   list(range = c(min(iris$Petal.Length), max(iris$Petal.Length)),
                        label = 'Petal Length', values = ~Petal.Length)
                 )
    )
    onRender(p, "function(el, x) {
    el.on('plotly_restyle', function(d) {
      console.log(d);
      Shiny.setInputValue('plotly_restyle', JSON.stringify(d));
    });
  }"
             )
  })

  output$restyle <- renderPrint({
    d <- input$plotly_restyle
    if (is.null(d)) "Restyle events appear here" else d
  })
}

shinyApp(ui, server)

Created on 2018-08-10 by the reprex package (v0.2.0).

As you can see, only the last selected dimension is shown, resulting in this json object:

[
  {
    "dimensions[2].constraintrange": [
      [
        0.08125,
        0.6906249999999999
      ]
    ]
  },
  [
    0
  ]
]

Stringified, this results in this R string : ``` r
"[{"dimensions[2].constraintrange":[[0.08125,0.6906249999999999]]},[0]]"

So, using the content of `plotly_restyle` is not enough, as it only gives informations on the lastly selected dimension.

For my part, as a workaround, I'm using a custom js function, so that all the filters are returned :

``` js
function(el, x) {
   el.on('plotly_restyle', function(d) {
     var dimensionsBrushed = el.data[0].dimensions.map(function(x){return({label: x.label, constraintrange: x.constraintrange})});
     Shiny.setInputValue('plotly_brushed', JSON.stringify(dimensionsBrushed));
   });
 }

I should note that I stringify this content instead of returning the js object directly because jsonlite conversions loose many informations about the object here. So, I have to do a custom R handling of this string, resulting in this demo app :

suppressPackageStartupMessages(library(plotly))
library(htmlwidgets)
library(shiny)
library(tibble)
library(purrr)

ui <- fluidPage(
  plotlyOutput("parcoords"),
  verbatimTextOutput("restyle"),
  tableOutput("brushed")
)

server <- function(input, output, session) {
  
  output$parcoords <- renderPlotly({
    p <- plot_ly(data = iris, 
                 type = 'parcoords',
                 dimensions = list(
                   list(range = c(min(iris$Sepal.Width), max(iris$Sepal.Width)),
                        label = 'Sepal Width', values = ~Sepal.Width),
                   list(range = c(min(iris$Sepal.Length), max(iris$Sepal.Length)),
                        label = 'Sepal Length', values = ~Sepal.Length),
                   list(range = c(min(iris$Petal.Width), max(iris$Petal.Width)),
                        label = 'Petal Width', values = ~Petal.Width),
                   list(range = c(min(iris$Petal.Length), max(iris$Petal.Length)),
                        label = 'Petal Length', values = ~Petal.Length)
                 )
    )
    onRender(p, "function(el, x) {
    el.on('plotly_restyle', function(d) {
      var dimensionsBrushed = el.data[0].dimensions.map(function(x){return({label: x.label, constraintrange: x.constraintrange})});
      Shiny.setInputValue('plotly_brushed', JSON.stringify(dimensionsBrushed));
    });
  }")
  })

  output$restyle <- renderPrint({
    d <- input$plotly_brushed
    if (is.null(d)) "Brushed events appear here" else d
  })
  
  output$brushed <- renderTable({
    if (is.null( input$plotly_brushed)){
      "Dataframed-brushed events appear here"
    } else {
      inputJSON <- input$plotly_brushed
      filterDF <- jsonlite::fromJSON(txt = inputJSON,
                                     simplifyMatrix = FALSE,
                                     simplifyDataFrame = FALSE) %>%
        purrr::compact(.x = ., "constraintrange") %>%
        tibble(listcol = .) %>%
        mutate(var = map_chr(listcol, "label")) %>%
        mutate(range = map(listcol, "constraintrange")) %>%
        select(-listcol) %>%
        mutate(min = map_dbl(range, 1),
               max = map_dbl(range, 2)) %>%
        select(-range)
      filterDF
    }
  })
}

shinyApp(ui, server)

Created on 2018-08-10 by the reprex package (v0.2.0).

Of course, this solution isn't optimal, because :

• With current R transformation of the json, it doens't handle multi-selections, ie. multiple brush on a single dimension
• The plotly_restyle seems to be meaning different things among plotly plots, and thus, using such a code wouldn't be generic among plots for this R package.

Yet, eventhough I currently don't have time to work on a PR (I just discovered plotly, and can't spend many time trying to understand the bindings with R right now), it would be fantastic if you could take this issue into consideration, and maybe use my "findings" (related to how events work with parallel coordinates) to fix this troublesome issue.

[cpsievert]

Wow, nice investigation, and thanks for the thorough report!

You're right about plotly_restyle -- I believe it's fired anytime Plotly.restyle() is called -- I'm surprised no one has requested access to it via event_data() before. I wouldn't necessarily be opposed to firing the raw event JSON from plotly_restyle, as in #1282, and just having the "back transformation" be a user responsibility, here is how to could do that:

library(plotly)
library(shiny)

ui <- fluidPage(
  plotlyOutput("parcoords"),
  tableOutput("data")
)

server <- function(input, output, session) {
  
  iris_numeric <- dplyr::select_if(iris, is.numeric)
  
  output$parcoords <- renderPlotly({
    dims <- Map(function(x, y) {
      list(values = x, range = range(x), label = y)
    }, iris_numeric, names(iris_numeric), USE.NAMES = FALSE)
    plot_ly(type = 'parcoords', dimensions = dims, source = "pcoords")
  })
  
  # maintain a collection of selection ranges
  # since each parcoord dimension is allowed to have multiple 
  # selected ranges, this reactive values data structure is 
  # allowed 
  # list(
  #  var1 = list(c(min1, max1), c(min2, max2), ...),
  #  var2 = list(c(min1, max1)),
  #  ...
  # )
  ranges <- reactiveValues()
  observeEvent(event_data("plotly_restyle", source = "pcoords"), {
    d <- event_data("plotly_restyle", source = "pcoords")
    # what is the relevant dimension (i.e. variable)?
    dimension <- as.numeric(stringr::str_extract(names(d[[1]]), "[0-9]+"))
    # careful of the indexing in JS (0) versus R (1)!
    dimension_name <- names(iris_numeric)[[dimension + 1]]
    # a given dimension can have multiple selected ranges
    # these will come in as 3D arrays, but a list of vectors 
    # is nicer to work with
    info <- d[[1]][[1]]
    ranges[[dimension_name]] <- if (length(dim(info)) == 3) {
      lapply(seq_len(dim(info)[2]), function(i) info[,i,])
    } else {
      list(as.numeric(info))
    }
  })
  
  # filter the dataset down to the rows that match the selection ranges
  iris_selected <- reactive({
    keep <- TRUE
    for (i in names(ranges)) {
      range_ <- ranges[[i]]
      keep_var <- FALSE
      for (j in seq_along(range_)) {
        rng <- range_[[j]]
        keep_var <- keep_var | dplyr::between(iris[[i]], min(rng), max(rng))
      }
      keep <- keep & keep_var
    }
    iris[keep, ]
  })
  
  output$data <- renderTable({
    iris_selected()
  })
}

shinyApp(ui, server)

It would be nice to try and emit essentially the result of iris_selected() for this class of event automatically, but I'm not sure that's gonna be possible by working directly with the parcoords JSON spec. Perhaps if we implement a add_parcoords() and requiring a data frame we could do that...

[ismirsehregal]

The above example is no longer working using plotly 4.10.0

Edit: I found a working version here.