在htmlWidgets的onRender()函数中使用闪亮的actionButton()函数

Question

我有一个闪亮的应用程序，其中用户可以选择黑点在一个Plotly散点图使用Plotly“框选择”图标。用户选择的点将以红色突出显示。下面是此应用程序的MWE：

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)

我现在正在尝试更新这个闪亮的应用程序，以便选定的黑点不会自动变成红色。取而代之的是，在用户选择黑点之后，他们可以点击带有标签“高亮显示所选点”的动作按钮。如果用户单击该操作按钮，则选定的点将变为红色。下面是我让它工作的尝试。不幸的是，这个应用程序无法工作，实际上失去了绘制原始黑点和提供框选择图标的功能。

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)

编辑：

我想包括一张图片来展示我的目标。基本上，如果用户选择下面所示的15个点，它们将保持黑色：

​

​

但是，如果用户选择“高亮显示所选点”闪亮按钮，则15个点将变为红色，如下所示：

​

​

Answer 1

好的，我想这就是你想要的。

我不得不采取一种不同的方法，因为我不认为你可以添加一个像那样的plotly el.on事件，但plotly实际上有一个闪亮的event_data("plotly_selected")构造，专门用于这种事情-所以我使用了它。

我所做的主要更改如下：

• 将我们正在使用的数据帧(m)存储在reactiveValues中，以便您可以从反应节点内部轻松地访问它(而无需使用<<-)。
• 添加了一个reactive(event_data(..来检索闪亮的选择数据。
• 向我们的工作数据帧添加了selected列，以跟踪应该标记为红色的内容。
• 添加了一个reactive节点(mvis)，用于在所选数据传入时对其进行处理，并将新数据标记为已选。为了避免无休止的反应链，
• 去掉了el.on(plotly_selected，因为我不知道这是如何工作的(虽然可能有一个way).
• enabled，但通过调用
• 来选择标记，为黑色标记添加了第二个跟踪，
• 增加了一个关键变量，这样我们就可以跟踪绘制的标记如何与我们的数据行相对应。
• 和其他一些杂项的小更改(xArr和yArr在example)
• added的原始traceBlock定义中颠倒了一个引导切换按钮，以突出显示selectionr (根据后来的要求)。请注意，它需要双击才能切换。

下面是代码：

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)

这是一个屏幕截图：

​

​

注意：

这看起来过于复杂，事实也的确如此。从理论上讲，这可以在不使用onRender和任何javascript的情况下完成，只需使用add_marker添加跟踪并设置key属性即可。不幸的是，在R绑定中似乎有一个密谋的bug，当你这样做的时候，它会在选择之后扰乱键值。太糟糕了--它会更短，更容易理解--也许它最终会被修复。

Answer 2

这个将一直是做以上工作的首选方法，但我提供的另一个解决方案工作得更好。这是因为R绑定中的一个小错误，它在选择时分散了键值，所以它只在一次迭代中起作用。

此外，我无法获得上述大小的工作，这也可能是另一个错误，或只是一个奇怪的设计问题。

无论如何，我还是提供了它，因为它可能有一天会工作，而且它是一个需要更少代码的更好的解决方案-或者也许有人会为它提供一个很好的解决方案。

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)