2

我有一个闪亮的应用程序，其中用户可以使用 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 个点将变为红色，如下所示：

已选择红点

4

2 回答 2

0

这本来是执行上述操作的首选方法，但我提供的其他解决方案效果更好。这是因为 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)
于 2017-04-03T09:39:49.413 回答
0

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

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

我所做的主要更改：

  • 将我们正在使用的数据帧 ( m) 存储在 a 中reactiveValues，以便您可以从反应节点内部轻松访问它（无需使用 <<-）。
  • 添加了一个reactive(event_data(..来检索闪亮的选择数据。
  • 在我们的工作数据框中添加了一selected列，以跟踪应标记为红色的内容。
  • 添加了一个reactive节点（mvis）来处理所选数据，并将新事物标记为选中。将节点与 reactiveValue 事件隔离，isolate以避免无休止的反应链。
  • 摆脱了，el.on(plotly_selected因为我不知道它是如何工作的（尽管可能有办法）。
  • layout(dragmode="select")通过调用启用标记的选择
  • 添加了第二条迹线，一条用于黑色标记，一条用于选定的
  • 添加了一个关键变量，以便我们可以跟踪绘制的标记如何对应于我们的数据行。
  • 以及其他一些杂项的小变化（例如，在原始定义中xArr被颠倒了）yArrtraceBlock
  • 添加了一个引导切换按钮以突出显示选择器（如稍后要求的那样）。请注意，它需要双击才能切换。

所以这里是代码：

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 绑定中似乎有一个情节错误，当你这样做时，它会在选择后打乱键值。太糟糕了——它会更短更容易理解——也许它最终会得到修复。

于 2017-04-01T12:27:00.403 回答