使用闪亮(R)中的 sliderInput 对输入数据进行子集化时保留一些绘图痕迹

问题描述 投票:0回答:1

我正在尝试制作一个交互式绘图,突出显示

plotly
shiny
绘图上的点击,并让用户使用
sliderInput
更改绘图上显示的数据范围。如果用户已经添加点击后范围发生更改,我会尝试保留已添加的跟踪。目前,它会删除所有现有的痕迹,因为它每次都会完全渲染新的绘图。

我使用

addTraces
而不是
restyle
单击的标记,因为我还希望能够删除痕迹,这比重新设计单个标记更容易。我正在对用于渲染绘图的数据进行子集化,而不是仅仅更改 x 轴限制,因为我使用具有数万个数据点的很长时间序列,并且子集化似乎可以极大地提高性能,否则性能会非常慢。

我尝试调整这个问题接受的答案,但由于用例有点不同并且数据结构更复杂,所以实际上无法做到。我对闪亮还是个新手,这可能是问题的一部分。

我尝试将每个添加的跟踪的相应值保存到反应数据框中,并将跟踪添加到

observeEvent
上,但这似乎也不起作用。

#Sample Data
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))
library(shiny)
library(plotly)

# UI

ui <-fluidPage(
  fluidRow(style = "padding: 15px;",
             actionButton("remove", "Delete last click", 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

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) 
  })
  
  # highlight clicked point
  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')))
    })
  
  # remove last click
  observeEvent(input$remove, {
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("deleteTraces", list(-1))
  })
}
shinyApp(ui,server)

尝试使用

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)
  })
  
  #did my slider range change and I already have highlighted points?
  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'))))
    }
  })
  
  # highlight clicked point
  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)
  })
  
  # remove last click
  observeEvent(input$remove, {
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("deleteTraces", list(-1))
    
    vals$d_click <- vals$d_click[-nrow(vals$d_click),]
  })
}
r shiny plotly
1个回答
0
投票

您可以像这样更新数据:

  output$plot <- renderPlotly({
    df %>%
      plot_ly(x= ~t, y = ~V1, type='scatter', mode='line')%>%
      layout(showlegend=F) 
  })

  Dat <- eventReactive(input$range, {
    df[df$t >= input$range[1] & df$t <= input$range[2], ]
  })
  
  observeEvent(input$range, {
    plotlyProxy("plot", session) %>%
      plotlyProxyInvoke("restyle", list(x = list(Dat()$t), y = list(Dat()$V1)), 0)
  })

0
中的
plotlyProxyInvoke
表示重新设计必须仅应用于迹线0。

© www.soinside.com 2019 - 2024. All rights reserved.