我正在尝试制作一个交互式绘图,突出显示
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),]
})
}
您可以像这样更新数据:
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。