编辑

Question

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

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

当前的解决方案仅能部分满足我的需求。我正在寻求改进的两件事是： -如何查看单击了哪个地块的图例（查看源“ id”？） -现在，我看到单击了图例条目，但是我需要能够看到单击的是“ ON”（显示跟踪）还是“ OFF”

我正在寻找的输出看起来像这样： input$trace_plot1：然后是所有已关闭且已打开的迹线的列表，或者是每次单击都显示一个迹线nr，但它告诉您该特定迹线现在是“ ON”还是“ OFF”

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

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

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)

Answer 1

有帮助吗？

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)

编辑

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

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代码：

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，...中获得有关迹线可见性的信息。

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

onRender

R绘图：通过多图例点击图例如何观察痕迹是隐藏还是显示

1 个答案:

编辑