Question

我有一个Shiny应用程序，用户可以使用Plotly＆＃34;框选择＆＃34;在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)

我现在正在尝试更新此Shiny应用程序，以便所选的黑点不会自动变为红色。相反，在用户选择黑点之后，他们可以点击带有标签＆＃34;突出显示所选点＆＃34;的操作按钮。如果用户单击该操作按钮，则所选点变为红色。以下是我试图让它发挥作用。不幸的是，这个应用程序无法正常工作，并且实际上失去了绘制原始黑点并首先提供框选择图标的功能。

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个点，它们将保持黑色：

但是，如果用户选择＆＃34;突出显示所选点＆＃34;闪亮的按钮，然后15点将变为红色，如下所示：

Answer 1

好的，这就是你想要的。

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

我做出的重大改变：

将我们正在使用的数据框（m）存储在reactiveValues中，以便您可以轻松访问它（不在反应节点内使用＆lt;＆lt ;-)。
添加reactive(event_data(..来检索闪亮的选择数据。
在我们的工作数据框中添加了selected列，以跟踪应标记为红色的内容。
添加了一个reactive节点（mvis）来处理所选数据，并将新内容标记为已选中。从reactiveValue事件中隔离节点以及isolate以避免无限的反应链。
摆脱了el.on(plotly_selected，因为我不知道它是如何起作用的（虽然可能有办法）。
启用了layout(dragmode="select")调用
为黑色标记添加了第二个跟踪，一个用于选定的跟踪
添加了一个关键变量，以便我们可以跟踪绘制的标记与数据行的对应关系。
以及其他一些其他小的更改（xArr和yArr在原始的traceBlock定义中被撤消了例如）
添加了一个bootstrap切换按钮以突出显示选择器（如后所述）。请注意，它需要双击才能切换。

所以这是代码：

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绑定中似乎存在一个错误的错误，当你这样做时，它会在选择后对键值进行加扰。太糟糕了 - 它会更短更容易理解 - 也许最终会得到修复。

Answer 2

这一直是上述方法的首选方式，但我提供的其他解决方案效果更好。这是因为R-binding中的一个错误的错误会在选择时散布键值，所以它只适用于一次迭代。选择发生后，键值将不再起作用。如果你尝试一下，你会看到我的意思。

此外，我无法使尺寸如上所述，也可能是另一个错误，或者只是一个奇怪的设计问题。

然而，无论如何我都提供它，因为它可能会在某一天工作，并且它是一个更好的解决方案，需要更少的代码 - 或者可能有人会建议一个很好的解决方法。

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)

在htmlWidgets的onRender（）函数中使用Shiny actionButton（）函数

2 个答案:

注意：