R绘图:通过多图例图例点击观察如何观察迹线是隐藏还是显示 [英] R plotly: how to observe whether a trace is hidden or shown through legend clicks with multiple plots

问题描述

我正在尝试通过在plotly的交互式图例中取消选择来隐藏散点图中用户隐藏的迹线.

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.

我已阅读 SO 帖子，并且类似的问题链接在下面的评论中，这使我更接近解决方案

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

当前的解决方案仅能部分满足我的需求.我正在寻求改进的两件事是: -如何查看单击了哪个图例的图例(查看源"id"?) -现在可以看到单击了图例条目，但是我需要能够看到它是单击了打开"(显示跟踪)还是关闭"

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'

我正在寻找的输出看起来像这样: input$trace_plot1:然后是所有已关闭且已打开的迹线的列表，或者每次单击时显示单个迹线nr，但它告诉您该特定迹线现在是"ON"还是"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"

对我来说，目标是将可视化的隐藏和显示链接到数据中我所有组的概述，用户现在可以为他们提供新的名称，颜色，并选择保留或删除该组.按钮后面有一个T/F状态开关.我想将按钮的T/F状态链接到特定图的显示"/隐藏"迹线(因为我的应用程序中有5个这些图的副本，显示了分析过程中不同阶段的数据

这是我的尝试，对传奇没有任何反应，只是对人兽共鸣:

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)

感谢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)

推荐答案

有帮助吗?

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)

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

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)

如果有多个图，请在图例选择器中添加图ID，然后使用函数来生成JavaScript代码:

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),
  "  });",
  "}")
}

然后执行p1 %>% onRender(js(1))，p2 %>% onRender(js(2))，...，您会在input$traces1，input$traces2，...中获得有关迹线可见性的信息.

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

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

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绘图:通过多图例图例点击观察如何观察迹线是隐藏还是显示的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！