使用 plotlyProxy 按名称删除跟踪（或在反应上下文中访问输出模式）

Question

我正在尝试使用 plotlyProxy() 功能 (Documented here) 来允许 shiny 应用程序的用户以最小的延迟添加和删除跟踪。

事实证明添加跟踪相对简单，但我很难弄清楚如何按名称删除跟踪（我只看到按跟踪编号删除的记录示例）.

有没有办法使用 plotlyProxy() 按名称删除痕迹？

如果不是，有没有一种方法可以解析输出对象以得出哪些跟踪号与给定名称相关联？

我可以使用标准模式索引在交互式 R 会话中确定给定名称的关联跟踪号，但是当我尝试在闪亮的应用程序中应用相同的逻辑时，我收到错误消息： "Error in $.shinyoutput: Reading objects from shinyoutput object not allowed."

下面是一个最小的例子。观察 Remove 按钮的观察者都没有实际工作，但他们应该对我要实现的功能给出一个想法。

library(shiny)
library(plotly)

ui <- fluidPage(
  textInput("TraceName", "Trace Name"),
  actionButton("Add","Add Trace"),
  actionButton("Remove","Remove Trace"),
  plotlyOutput("MyPlot")
)

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

  ## Creaing the plot
  output$MyPlot <- renderPlotly({
    plot_ly() %>%
      layout(showlegend  = TRUE)
  })

  ## Adding traces is smooth sailing
  observeEvent(input$Add,{
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
                                          type = "scatter",mode = "markers",
                                          name = input$TraceName))
  })

  ## Ideal Solution (that does not work)
  observeEvent(input$Remove,{
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", input$TraceName)
  })

  ## Trying to extract tracenames throws an error:
  ## Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
  observeEvent(input$Remove,{
    TraceNames <- unlist(lapply(seq_along(names(output$MyPlot$x$attrs)),
                                function(x) output$MyPlot$x$attrs[[x]][["name"]]))
    ThisTrace <- which(TraceNames == input$TraceName)

    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", ThisTrace)
  })

}

shinyApp(ui, server)

Answer 1

我找不到痕迹的名称属性，我想 deleteTrace 功能不能按名称删除。根据参考，它只是删除 based on index.

我尝试为 Shiny 实现一些东西，它在数据框中记录添加的痕迹并为它们添加索引。对于删除，它将给定的名称与数据框进行匹配，并将这些索引提供给 plotlyProxyInvoke 的删除方法，但它无法正常工作。 也许有人可以补充一些关于为什么会发生这种情况的见解？

一个问题似乎是传说，它在删除后显示错误的标签，我不认为 plotly 和 R/shiny 保持相同的痕迹索引，这会导致奇怪的行为。所以这段代码肯定需要一些修复。

--
我包含了一个小的 JQuery 片段，它记录了情节的所有痕迹并将它们发送到 reactiveVal()。有趣的是，它与监听 AddTraces 事件的 data.frame 不同。情节中总会留下一丝痕迹。

library(shiny)
library(plotly)
library(shinyjs)

ui <- fluidPage(
  useShinyjs(),
  tags$head(tags$script(HTML(
    "$(document).on('shiny:value', function(event) {
    var a = $('.scatterlayer.mlayer').children();
    if (a.length > 0) {
    var text = [];
    for (var i = 0; i < a.length; i++){
    text += a[i].className.baseVal + '<br>';
    }
    Shiny.onInputChange('plotlystr', text);
    }
    });"
))),
textInput("TraceName", "Trace Name"),
actionButton("Add","Add Trace"),
actionButton("Remove","Remove Trace by Name"),
plotlyOutput("MyPlot"),
splitLayout(
  verbatimTextOutput("printplotly"),
  verbatimTextOutput("printreactive")
)
  )

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

  ## Reactive Plot
  plt <- reactive({
    plot_ly() %>%
      layout(showlegend  = T)
  })
  ## Reactive Value for Added Traces
  addedTrcs <- reactiveValues(tr = NULL, id = NULL, df = NULL)

  ## Creaing the plot
  output$MyPlot <- renderPlotly({
    plt()
  })

  ## Adding traces is smooth sailing
  observeEvent(input$Add,{
    req(input$TraceName)
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
                                          type = "scatter",mode = "markers", colors ="blue",
                                          name = input$TraceName))
  })
  ## Adding trace to reactive
  observeEvent(input$Add, {
    req(input$TraceName)
    x <- input$TraceName
    addedTrcs$id <- c(addedTrcs$id, length(addedTrcs$id))
    addedTrcs$tr <- c(addedTrcs$tr, x)
    addedTrcs$df <- data.frame(id=addedTrcs$id, tr=addedTrcs$tr, stringsAsFactors = F)
  })

  ## Remove Trace from Proxy by NAME
  observeEvent(input$Remove,{
    req(input$TraceName %in% addedTrcs$tr)
    ind = which(addedTrcs$df$tr == input$TraceName)
    ind = addedTrcs$df[ind,"id"]

    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", as.integer(ind))
  })  

  ## Remove Trace from Reactive
  observeEvent(input$Remove, {
    req(input$TraceName %in% addedTrcs$df$tr)  

    whichInd <- which(addedTrcs$tr == input$TraceName)
    addedTrcs$df <- addedTrcs$df[-whichInd,]
    addedTrcs$id <- addedTrcs$id[-whichInd]
    addedTrcs$tr <- addedTrcs$tr[-whichInd]

    req(nrow(addedTrcs$df)!=0)
    addedTrcs$df$id <- 0:(nrow(addedTrcs$df)-1)
  })


  tracesReact <- reactiveVal()
  observe({
    req(input$plotlystr)
    traces <- data.frame(traces=strsplit(input$plotlystr, split = "<br>")[[1]])
    tracesReact(traces)
  })
  output$printplotly <- renderPrint({
    req(tracesReact())
    tracesReact()
  })

  ## Print Reactive Value (added traces)
  output$printreactive <- renderPrint({
    req(addedTrcs$df)
    addedTrcs$df
  })
}

shinyApp(ui, server)

Answer 2

编辑使用 plotlyProxy:

更新 @SeGa，感谢添加对删除重名痕迹的支持！

最后，我找到了一个解决方案，通过调整这个来实现预期的行为。单击删除按钮后，我通过使用来自 library(htmlwidgets) 的 onRender 接收 trace.name / trace.index 映射：

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

js <- "function(el, x, inputName){
  var id = el.getAttribute('id');
  var d3 = Plotly.d3;
  $(document).on('shiny:inputchanged', function(event) {
    if (event.name === 'Remove') {
      var out = [];
      d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
        var trace = d3.select(this)[0][0].__data__[0].trace;
        out.push([name=trace.name, index=trace.index]);
      });
      Shiny.setInputValue(inputName, out);
    }
  });
}"

ui <- fluidPage(
  textInput("TraceName", "Trace Name"),
  verbatimTextOutput("PrintTraceMapping"),
  actionButton("Add", "Add Trace"),
  actionButton("Remove", "Remove Trace"),
  plotlyOutput("MyPlot")
)

server <- function(input, output, session) {
  
  output$MyPlot <- renderPlotly({
    plot_ly(type = "scatter", mode = "markers") %>%
      layout(showlegend  = TRUE) %>% onRender(js, data = "TraceMapping") 
  })
  
  output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
  
  observeEvent(input$Add, {
    req(input$TraceName)
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
                                          type = "scatter",mode = "markers",
                                          name = input$TraceName))
  })
  
  observeEvent(input$Remove, {
    req(input$TraceName, input$TraceMapping)
    traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
    indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", indices)
  })
  
}

shinyApp(ui, server)

结果：

这方面的有用文章：

shiny js-events

plotly addTraces

plotly deleteTraces

闪亮模块的解决方案 使用 plotlyProxy:

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

js <- "function(el, x, data){
  var id = el.getAttribute('id');
  var d3 = Plotly.d3;
  $(document).on('shiny:inputchanged', function(event) {
    if (event.name.indexOf('Remove') > -1) {
      var out = [];
      d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){
        var trace = d3.select(this)[0][0].__data__[0].trace;
        out.push([name=trace.name, index=trace.index]);
      });
      Shiny.setInputValue(data.ns + data.x, out);
    }
  });
}"

plotly_ui_mod <- function(id) {
  ns <- NS(id)
  tagList(
    textInput(ns("TraceName"), "Trace Name"),
    verbatimTextOutput(ns("PrintTraceMapping")),
    actionButton(ns("Add"), "Add Trace"),
    actionButton(ns("Remove"), "Remove Trace"),
    plotlyOutput(ns("MyPlot"))
  )
}

plotly_server_mod <- function(input, output, session) {
  sessionval <- session$ns("")
  
  output$MyPlot <- renderPlotly({
    plot_ly(type = "scatter", mode = "markers") %>%
      layout(showlegend  = TRUE) %>% onRender(js, data = list(x = "TraceMapping", 
                                                              ns = sessionval))
  })
  output$PrintTraceMapping <- renderPrint({unlist(input$TraceMapping)})
  observeEvent(input$Add, {
    req(input$TraceName)
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("addTraces", list(x = rnorm(10),y = rnorm(10),
                                          type = "scatter",mode = "markers",
                                          name = input$TraceName))
  })
  observeEvent(input$Remove, {
    req(input$TraceName, input$TraceMapping)
    traces <- matrix(input$TraceMapping, ncol = 2, byrow = TRUE)
    indices <- as.integer(traces[traces[, 1] == input$TraceName, 2])
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", indices)
  })
}


ui <- fluidPage(
  plotly_ui_mod("plotly_mod")
)

server <- function(input, output, session) {
  callModule(plotly_server_mod, "plotly_mod")
}

shinyApp(ui, server)

以前的解决方案 避免 plotlyProxy:

我是通过这个来到这里的。

您明确要求 plotlyProxy()，所以我不确定这是否对您有帮助，但这里有一个解决方法，可以通过更新提供给 plot_ly() 的数据来实现预期的行为使用 plotlyProxy():

library(shiny)
library(plotly)

ui <- fluidPage(
  selectizeInput(inputId="myTraces", label="Trace names", choices = NULL, multiple = TRUE, options = list('plugins' = list('remove_button'), 'create' = TRUE, 'persist' = TRUE, placeholder = "...add or remove traces")),
  plotlyOutput("MyPlot")
)

server <- function(input, output, session){
  
  myData <- reactiveVal()
  
  observeEvent(input$myTraces, {
    tmpList <- list()
    
    for(myTrace in input$myTraces){
      tmpList[[myTrace]] <- data.frame(name = myTrace, x = rnorm(10),y = rnorm(10))
    }
    
    myData(do.call("rbind", tmpList))
    
    return(NULL)
  }, ignoreNULL = FALSE)
  
  output$MyPlot <- renderPlotly({
    if(is.null(myData())){
      plot_ly(type = "scatter", mode = "markers")
    } else {
      plot_ly(myData(), x = ~x, y = ~y, color = ~name, type = "scatter", mode = "markers") %>%
        layout(showlegend  = TRUE)
    }
  })
}

shinyApp(ui, server)

使用 plotlyProxy 按名称删除跟踪（或在反应上下文中访问输出模式）

Removing traces by name using plotlyProxy (or accessing output schema in reactive context)

r

shiny

plotly

r-plotly