可以将文章内容翻译成中文,广告屏蔽插件可能会导致该功能失效(如失效，请关闭广告屏蔽插件后再试):

问题:

I have a Shiny application in which a user can select black points in a Plotly scatterplot using the Plotly "box select" icon. The points the user selects will be highlighted in red. I have a MWE of this application below:

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

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot")
))

server <- shinyServer(function(input, output) {
  p <- ggplot(mtcars, aes(x = wt, y = mpg))  + xlim(10,40) +ylim(0,10)
  ggPS <- ggplotly(p)

  output$myPlot <- renderPlotly(ggPS %>%
    onRender("
       function(el, x, data) {

       var xArr = [];
       var yArr = [];
       for (a=0; a<data.wt.length; a++){
       xArr.push(data.wt[a])
       yArr.push(data.mpg[a])
       }

       Traces=[]
       var tracePoints = {
         x: yArr,
         y: xArr,
         hoverinfo: 'none',
         mode: 'markers',
         marker: {
           color: 'black',
           size: 4
         }
       };
       Traces.push(tracePoints);
       Plotly.addTraces(el.id, Traces);

       el.on('plotly_selected', function(e) {
       var numSel = e.points.length
       var xSel = [];
       var ySel = [];

       for (a=0; a<numSel; a++){
         xSel.push(e.points[a].x)
         ySel.push(e.points[a].y)
       }

       var trace = {
         x: xSel,
         y: ySel,
         mode: 'markers',
         marker: {
           color: 'red',
           size: 4
         },
         hoverinfo: 'none'
       };

       Traces.push(trace);
       Plotly.addTraces(el.id, Traces);
       })

       }
       ", data = list(dat= mtcars, wt=mtcars$wt, mpg=mtcars$mpg)))})

shinyApp(ui, server)

I am now trying to update this Shiny application so that the selected black points do not automatically become red. Instead, after the user selects the black points, they can click on an action button with a label "Highlight selected points". If the user clicks that action button, then the selected points become red. Below is my attempt at getting this to work. Unfortunately, this application is not working, and actually loses its functionality of drawing the original black points and providing a box select icon in the first place .

library(plotly)
library(Shiny)
library(htmlwidgets)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  actionButton("highlight", "Highlight selected points")
))

server <- shinyServer(function(input, output) {

  highlight <- reactive(input$highlight)

  p <- ggplot(mtcars, aes(x = wt, y = mpg))  + xlim(10,40) +ylim(0,10)
  ggPS <- ggplotly(p)

  output$myPlot <- renderPlotly(ggPS %>%
onRender("
   function(el, x, data) {

   var xArr = [];
   var yArr = [];
   for (a=0; a<data.wt.length; a++){
   xArr.push(data.wt[a])
   yArr.push(data.mpg[a])
   }

   Traces=[]
   var tracePoints = {
   x: yArr,
   y: xArr,
   hoverinfo: 'none',
   mode: 'markers',
   marker: {
   color: 'black',
   size: 4
   }
   };
   Traces.push(tracePoints);
   Plotly.addTraces(el.id, Traces);

   el.on('plotly_selected', function(e) {

observeEvent(data.highlightS, {
   var numSel = e.points.length
   var xSel = [];
   var ySel = [];
   for (a=0; a<numSel; a++){
   xSel.push(e.points[a].x)
   ySel.push(e.points[a].y)
   }

   var trace = {
   x: xSel,
   y: ySel,
   mode: 'markers',
   marker: {
   color: 'red',
   size: 4
   },
   hoverinfo: 'none'
   };
   Traces.push(trace);
   Plotly.addTraces(el.id, Traces);
})
   })

   }
   ", data = list(dat= mtcars, wt=mtcars$wt, mpg=mtcars$mpg, highlightS=highlight())))})

shinyApp(ui, server)

EDIT:

I wanted to include a picture to demonstrate what I am aiming for. Basically, if the user selects the 15 dots shown below, they remain black:

However, if the user selects the "Highlight the selected points" Shiny button, then the 15 dots will become red as shown below:

回答1:

Ok, this does what you want I think.

I had to take a different approach since I don't think you can add a plotly el.on event like that, but plotly has actually a Shiny event_data("plotly_selected") construct intended just for this kind of thing - so I used that instead.

The major changes I made:

stored the dataframe we are working with (m) in a reactiveValues so you could access it easily (without using <<-) from inside a reactive node.
added a reactive(event_data(.. to retreive the shiny selection data.
added a selected column to our working dataframe to keep track of what should be marked red.
added a reactive node (mvis) to process the selected data as it comes in and mark the new things as selected. Isolated the node from the reactiveValue event as well with isolate to avoid an endless reaction chain.
got rid of the el.on(plotly_selected because I don't see how that could work (although there is probably a way).
enabled the selection of the markers with a layout(dragmode="select") call
added a second trace one for black markers, one for selected ones
added a key variable so we could keep track of how the plotted markers correspond to our data rows.
and a few other miscellaneous small changes (xArr and yArr were reversed in the original traceBlock definition for example)
added a bootstrap toggle button to highlight the selectionr (as later requested). Note that it requires a double-click to toggle.

So here is the code:

library(plotly)
library(htmlwidgets)
library(shiny)
library(shinyBS)
library(ggplot2)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  bsButton("high","Highlight Selected Points",type="toggle")
))

server <- shinyServer(function(input, output) {

  m <- mtcars
  m$selected <- 0

  rv <- reactiveValues(m=m,high=FALSE)

  observeEvent(input$high,{req(input$high);rv$high <- !rv$high } )

  ggPS <- reactive(ggplotly(ggplot(m, aes(x = wt, y = mpg))))

  sel <- reactive(event_data("plotly_selected"))

  mvis <- reactive({
    rv$high
    sdatf <- sel()
    print(rv$high)
    isolate({
      rv$m$selected <- 0 
      rv$m$selected[ sdatf$key ] <- 1  # now select the ones in sdatf
    })
    #  print(sdatf)  # debugging
    return(rv$m)
  })

  jscode <- 
 "function(el, x, data) {
    Traces=[]
    var xArrNrm = [];
    var yArrNrm = [];
    var idxNrm = [];
    var xArrSel = [];
    var yArrSel = [];
    var idxSel = [];
    for (a=0; a<data.mvis.length; a++){
      if(data.mvis[a]['selected']===0){
        xArrNrm.push(data.mvis[a]['wt'])
        yArrNrm.push(data.mvis[a]['mpg'])
        idxNrm.push(a+1)
      } else {
        xArrSel.push(data.mvis[a]['wt'])
        yArrSel.push(data.mvis[a]['mpg'])
        idxSel.push(a+1)
      }
    }
    console.log(data.mvis.length)
    console.log(data)
    var tracePointsNrm = {
      x: xArrNrm,
      y: yArrNrm,
      key: idxNrm,
      hoverinfo: 'none',
      mode: 'markers',
      marker: {
        color: 'black',
        size: 4
      }
    };
    var tracePointsSel = {
      x: xArrSel,
      y: yArrSel,
      key: idxSel,
      hoverinfo: 'none',
      mode: 'markers',
      marker: {
        color: 'red',
        size: 6
      }
    };
    if (!data.high){
       tracePointsSel.marker.color = 'black'
    }
    //   console.log(tracePointsNrm) // debuging 
    //   console.log(tracePointsSel)
    Traces.push(tracePointsNrm);
    Traces.push(tracePointsSel);
    Plotly.addTraces(el.id, Traces);
 }"
  output$myPlot <- renderPlotly({
                    ggPS() %>%  onRender(jscode,data=list(mvis=mvis(),high=rv$high)) %>%
                                layout(dragmode = "select")
                    })
})
shinyApp(ui, server)

And here is a screen shot:

Note:

This seems overly complex, and it is. In theory this could be done without using onRender and any javascript, by adding traces with add_marker and setting the key attribute. Unfortunately there seems to be a plotly bug in the R binding that scrambles the key values after selection when you do it that way. Too bad - it would be much shorter and easier to understand - maybe it will eventually get fixed.

回答2:

This would have been a preferred way to do the above, but the other solution I provided works better. This is because of a plotly bug in the R-binding that scatters the key values on selection, so it only works for one iteration. Once a selection has happened, the key values will no longer work. If you try it out you will see what I mean.

Also I couldn't get the sizes to work as above, that could also be another bug, or just a weird design issue.

However I am providing it anyway because it will probably work some day, and it is a better solution requiring far less code - or maybe someone will suggest a nice workaround for it.

library(plotly)
library(htmlwidgets)
library(shiny)
library(shinyBS)
library(ggplot2)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  bsButton("high","Highlight Selected Points",type="toggle")
))

server <- shinyServer(function(input, output) {

  m <- mtcars
  m$selected <- 0
  m$key <- 1:nrow(m)

  rv <- reactiveValues(m=m,high=FALSE)

  observeEvent(input$high,{req(input$high);rv$high <- !rv$high } )

  ggPS <- reactive(ggplotly(ggplot(m, aes(x = wt, y = mpg))))

  sel <- reactive(event_data("plotly_selected"))

  mvis <- reactive({
    rv$high
    sdatf <- sel()
    isolate({
      rv$m$selected <- 0L 
      rv$m$selected[ sdatf$key ] <- 1L  # now select the ones in sdatf
    })
    print(sdatf)  # debugging
    return(rv$m)
  })

  output$myPlot <- renderPlotly({
    mvf <- mvis()
    mvf$selfac <- factor(mvf$selected,levels=c(0L, 1L))
    print(mvf)
    highcol <- ifelse(rv$high,"red","black")
    clrs <-  c("black",highcol)
    ggPS() %>%  add_markers(data=mvf,x=~wt,y=~mpg,key=~key, 
                            color=~selfac,colors=clrs) %>%
                layout(dragmode = "select")
    })
})

shinyApp(ui, server)