Shiny中用sliderInput筛选数据时保留Plotly已添加轨迹

我在R语言的Shiny框架中制作交互式Plotly图表，需求如下：

• 点击图表可高亮对应点
• 支持用sliderInput调整显示的数据范围
• 希望调整范围后，之前点击添加的高亮轨迹能够保留，但当前每次调整范围都会重绘图表，导致已添加的轨迹全部丢失

技术方案选择原因 #

• 使用addTraces而非restyle处理点击标记：因为需要实现删除轨迹的功能，这种方式比单独修改标记更简便
• 选择子集数据而非仅修改X轴范围：处理的是包含数万条数据的长时序，子集化能大幅提升性能，避免卡顿

尝试过的无效方案 #

• 参考相关问题解决方案，但因场景和数据结构不同未能成功
• 将点击数据保存到reactiveValues的响应式数据框中，在范围变化时重新添加轨迹，但未生效

示例代码 #

示例数据 #

# 示例数据
df <- data.frame(
  t = seq(as.POSIXct("2024-01-01 00:00:00", tz='UTC'),
          as.POSIXct("2024-01-02 00:00:00", tz='UTC'), by="1 hour"),
  V1 = sample(1:20, 25, replace=T)
)

UI 代码 #

library(shiny)
library(plotly)

# UI 部分
ui <- fluidPage(
  fluidRow(style = "padding: 15px;",
           actionButton("remove", "删除最后一次点击标记", width='150px') 
  ),
  fluidRow(style = "padding: 0px;",
           plotlyOutput("plot"),
           div(style = "margin: auto; width: 90%",
               sliderInput("range", label = NULL, width="100%",
                           min = as.POSIXct(min(df$t), tz='UTC'), 
                           max = as.POSIXct(max(df$t), tz='UTC'), 
                           value = c(as.POSIXct(min(df$t), tz='UTC'), 
                                     as.POSIXct(max(df$t), tz='UTC')),
                           timeFormat="%F %T", timezone="+0000")
           ))
)

初始服务器代码（调整范围后丢失高亮轨迹） #

# 初始服务器代码（调整范围后丢失高亮轨迹）
server <- function(input, output, session) {
  
  output$plot <- renderPlotly({
    df[df$t >= input$range[1] & df$t <= input$range[2],] %>%
      plot_ly(x= ~t, y = ~V1, type='scatter', mode='line') %>%
      layout(showlegend=F) 
  })
  
  # 高亮点击的点
  observeEvent(event_data("plotly_click"),{
    d <- req(event_data("plotly_click"))
    
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("addTraces", list(
        x = c(d$x, d$x), 
        y = c(d$y, d$y), 
        type = 'scatter',
        marker = list(symbol='x', size=10, color='red')
      ))
  })
  
  # 删除最后一次点击标记
  observeEvent(input$remove, {
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("deleteTraces", list(-1))
  })
}

启动应用 #

shinyApp(ui, server)

效果演示 #

尝试的无效版本（使用observeEvent(input$range,{})） #

尝试使用observeEvent(input$range,{})的版本（未生效，无法重新添加轨迹）：

server <- function(input, output, session) {
  
  vals <- reactiveValues(
    d_click = data.frame()
  )
  
  output$plot <- renderPlotly({
    df[df$t >= input$range[1] & df$t <= input$range[2],] %>%
      plot_ly(x= ~t, y = ~V1, type='scatter', mode='line') %>%
      layout(showlegend=F)
  })
  
  # 范围变化且已有高亮点时重新添加轨迹
  observeEvent(input$range,{
    if(dim(vals$d_click)[1] > 0){
      plotlyProxy("plot", session) %>%
        plotlyProxyInvoke("addTraces", list(
          list(
            x = c(vals$d_click$x, vals$d_click$x), 
            y = c(vals$d_click$y, vals$d_click$y), 
            type = 'scatter',
            marker = list(symbol='x', size=10, color='red')
          )
        ))
    }
  })
  
  # 高亮点击的点
  observeEvent(event_data("plotly_click"),{
    d <- req(event_data("plotly_click"))
    
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("addTraces", list(
        x = c(d$x, d$x), 
        y = c(d$y, d$y), 
        type = 'scatter',
        marker = list(symbol='x', size=10, color='red')
      ))
    
    vals$d_click <- rbind(vals$d_click, d)
  })
  
  # 删除最后一次点击标记
  observeEvent(input$remove, {
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("deleteTraces", list(-1))
    
    vals$d_click <- vals$d_click[-nrow(vals$d_click),]
  })
}

内容的提问来源于stack exchange，提问作者Anke