问题描述

我试图通过在 plotly 的交互式图例中取消选择它们来确定用户从散点图中隐藏了哪些跟踪.

我已阅读此

编辑

当双击图例项时，以前的解决方案存在问题.这是一个更好的解决方案:

图书馆(情节)图书馆(闪亮)图书馆(htmlwidgets)js <- c(函数(el，x){"，" var d3 = Plotly.d3;"," el.on('plotly_restyle', 函数(evtData) {"," 变量输出 = {};"," d3.select('g.legend').selectAll('.traces').each(function(){"," var trace = d3.select(this)[0][0].__data__[0].trace;"," out[trace.name] = trace.visible;"," });"," Shiny.setInputValue('traces', out);"," });","}")ui <-流体页面(情节输出(情节")，逐字文本输出(图例"))服务器 <- 功能(输入，输出，会话){输出$plot <- renderPlotly({p <- plot_ly()for(c 中的名称(drat"，wt"，qsec")){p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)}p %>% onRender(js)})output$legendItem <- renderPrint({输入$跟踪})}闪亮的应用程序(用户界面，服务器)

如果您有多个绘图，请在图例选择器中添加绘图 id，并使用函数生成 JavaScript 代码:

js <- function(i) {C(函数(el，x){"，" var id = el.getAttribute('id');"," var d3 = Plotly.d3;"," el.on('plotly_restyle', 函数(evtData) {"," 变量输出 = {};"," d3.select('#' + id + 'g.legend').selectAll('.traces').each(function(){"," var trace = d3.select(this)[0][0].__data__[0].trace;"," out[trace.name] = trace.visible;"," });",sprintf(" Shiny.setInputValue('traces%d', out);", i)," });","}")}

然后执行 p1 %>% onRender(js(1)), p2 %>% onRender(js(2)), ..., 和你在 input$traces1, input$traces2, ....

另一种方法是在 JavaScript 函数的第三个参数中传递所需的名称，借助 onRender 的 data 参数:

js <- c("函数(el, x, inputName){"," var id = el.getAttribute('id');"," var d3 = Plotly.d3;"," el.on('plotly_restyle', 函数(evtData) {"," 变量输出 = {};"," d3.select('#' + id + 'g.legend').selectAll('.traces').each(function(){"," var trace = d3.select(this)[0][0].__data__[0].trace;"," out[trace.name] = trace.visible;"," });"," Shiny.setInputValue(inputName, out);"," });","}")p1 %>% onRender(js, data = "tracesPlot1")p2 %>% onRender(js, data = "tracesPlot2")

I am trying to figure out which traces the user hides from a scatter plot by means of deselecting them in the interactive legend of plotly.

I have read this SO post, and the similar questions linked in the comments below and this brought me closer to the solution

The current solution is only doing partially what I need. Two things I am looking for to improve it is: - how to see which plot's legend is clicked (looking at source 'id' ?) - I can now see that a legend entry is clicked, but I need to be able to see whether it is clicked 'ON'(show trace) or 'OFF'

The output i'm looking for would look something like this: input$trace_plot1 : which is then a list of all traces that are off and which are on, or a single trace nr on every click but that tells whether that specific trace is now "ON" or "OFF"

The goal for me is to link the visual hiding and showing to an overview of all my groups in the data where the user can now give them new names, colors, and choose to keep or drop the group with a button that has a T/F state switch behind it. I would like to link that T/F state of the buttons to the 'show'/'hidden' of traces from a specific plot (since I have 5 copies of these plots in my app showing the data in different stages of the analysis process.

Here is my attempt that does not react to the legend somehow, only to zooom:

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

js <- c(
  "function(el, x){",
  "  el.on('plotly_legendclick', function(evtData) {",
  "    Shiny.setInputValue('trace', evtData.data[evtData.curveNumber].name);",
  "  });",
  "}")

iris$group <- c(rep(1,50), rep(2, 50), rep(3,50))

ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2"),
  verbatimTextOutput("legendItem")

)


server <- function(input, output){

  output$plot1 <- renderPlotly({
    p <- plot_ly(source = 'plotly1', data = iris, x = ~Sepal.Length, y = ~Petal.Length, color = ~as.factor(group), type = 'scatter', mode = 'markers') %>%
      layout(showlegend = TRUE)

    p %>% onRender(js)

    })

  output$plot2 <- renderPlotly({
    p <- plot_ly(source = 'plotly2', data = iris, x = ~Sepal.Length, y = ~Petal.Length, color = ~as.factor(group), type = 'scatter', mode = 'markers') %>%
      layout(showlegend = TRUE)

    p %>% onRender(js)

  })

  output$legendItem <- renderPrint({
    d <- input$trace
    if (is.null(d)) "Clicked item appear here" else d
  })

  }

shinyApp(ui = ui, server = server)

EDIT: WORKING SOLUTION THANKS TO THE EXTENSIVE ANSWER from S.L.

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

js <- c(
  "function(el, x, inputName){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue(inputName, out);",
  "  });",
  "}")


ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2"),
  verbatimTextOutput("tracesPlot1"),
  verbatimTextOutput("tracesPlot2")
)

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

output$plot1 <- renderPlotly({
    p1 <- plot_ly()
    p1 <-  add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
    p1 %>% onRender(js, data = "tracesPlot1")    
  })

  output$plot2 <- renderPlotly({
    p2 <- plot_ly()
    p2 <- add_trace(p2, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
    p2 %>% onRender(js, data = "tracesPlot2")  })


  output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1)  })

  output$tracesPlot2 <- renderPrint({unlist(input$tracesPlot2)
  })

}

shinyApp(ui, server)

Does it help?

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

js <- c(
  "function(el, x){",
  "  el.on('plotly_legendclick', function(evtData) {",
  "    Shiny.setInputValue('trace', evtData.data[evtData.curveNumber].name);",
  "  });",
  "  el.on('plotly_restyle', function(evtData) {",
  "    Shiny.setInputValue('visibility', evtData[0].visible);",
  "  });",
  "}")

ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("legendItem")
)

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

  output$plot <- renderPlotly({
    p <- plot_ly()
    for(name in c("drat", "wt", "qsec"))
    {
      p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
    }
    p %>% onRender(js)
  })

  output$legendItem <- renderPrint({
    trace <- input$trace
    ifelse(is.null(trace), 
           "Clicked item will appear here",
           paste0("Clicked: ", trace, 
                  " --- Visibility: ", input$visibility)
    )
  })
}

shinyApp(ui, server)

EDIT

There's an issue with the previous solution when one double-clicks on a legend item. Here is a better solution:

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

js <- c(
  "function(el, x){",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue('traces', out);",
  "  });",
  "}")


ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("legendItem")
)

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

  output$plot <- renderPlotly({
    p <- plot_ly()
    for(name in c("drat", "wt", "qsec"))
    {
      p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
    }
    p %>% onRender(js)
  })

  output$legendItem <- renderPrint({
    input$traces
  })
}

shinyApp(ui, server)

If you have multiple plots, add the plot id in the legend selector, and use a function to generate the JavaScript code:

js <- function(i) { 
  c(
  "function(el, x){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  sprintf("    Shiny.setInputValue('traces%d', out);", i),
  "  });",
  "}")
}

Then do p1 %>% onRender(js(1)), p2 %>% onRender(js(2)), ..., and you get the info about the traces visibility in input$traces1, input$traces2, ....

Another way is to pass the desired name in the third argument of the JavaScript function, with the help of the data argument of onRender:

js <- c(
  "function(el, x, inputName){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue(inputName, out);",
  "  });",
  "}")


p1 %>% onRender(js, data = "tracesPlot1")
p2 %>% onRender(js, data = "tracesPlot2")

这篇关于R plotly:如何通过带有多个图的图例单击来观察跟踪是隐藏还是显示的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持跟版网！