Удаление следов по имени с помощью plotlyProxy (или доступ к выходной схеме в реактивном контексте)

Question

Я пытаюсь использовать функциональность plotlyProxy() ( Документировано здесь ), чтобы пользователи блестящего приложения могли добавлять и удалять следы с минимальной задержкой.

Добавление следов оказывается относительно простым, но мне трудно понять, как удалить следы по имени (я вижу только документированные примеры, которые удаляются по номеру следа) .

Есть ли способ удалить следы по имени, используя plotlyProxy()?

Если нет, могу ли я проанализировать выходной объект, чтобы определить, какие номера трасс связаны с данным именем?

Я могу определить связанный номер трассировки данного имени в интерактивном сеансе R, используя стандартные индексы схемы, но когда я пытаюсь применить ту же логику в блестящем приложении, я получаю ошибку: "Ошибка в $ .shinyoutput: чтение объектов из объекта светового выхода не допускается. "

Ниже приведен минимальный пример. Ни один наблюдатель, наблюдающий за кнопкой 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

Редактировать с использованием plotlyProxy:

Наконец, я нашел решение для реализации ожидаемого поведения, адаптировав этот ответ . Я получаю сопоставление trace.name / trace.index, используя onRender из library(htmlwidgets) после нажатия кнопки удаления:

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[trace.name] = 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)
    plotlyProxy("MyPlot", session) %>%
      plotlyProxyInvoke("deleteTraces", input$TraceMapping[[input$TraceName]])
  })

}

shinyApp(ui, server)

Результат:

Полезная статья в этом контексте: https://shiny.rstudio.com/articles/js-events.html

---

Предыдущее решение Избегать 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)

Answer 2

Я не смог найти атрибуты имен трасс, и я думаю, что функция deleteTrace не может удалить по имени. На основании ссылки он просто удаляет на основе index .

Я попытался реализовать что-то для Shiny, которое записывает добавленные трассы в информационный фрейм и добавляет к ним индекс. Для удаления он сопоставляет данные имена с фреймом данных и присваивает эти значения методу удаления plotlyProxyInvoke, но он работает неправильно. Может быть, кто-нибудь мог бы немного объяснить, почему это происходит?

Одна проблема , кажется, легенда, которая показывает неправильные метки после удаления, и я не думаю, что график и R / блестящий сохраняют одинаковые индексы трасс, что приводит к странному поведению. Так что этот код определенно нуждается в исправлении.

-
Я включил небольшой фрагмент JQuery, который записывает все следы сюжета и отправляет их на reactiveVal(). Интересно, что он отличается от data.frame, который слушает событие AddTraces. На сюжете всегда будет один оставшийся след.

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)