Change limits in a plot without redrawing, on a click in another plot

shiny
rstudio
r
plotly

#1

I need to have two plots displayed. The first plot is the main scatter plot. And the second plot must be changed each time one clicks a point in the first plot. So I need the behavior similar to the picture at https://davidgohel.github.io/ggiraph/index.html

To be more precise, each point of the first plot must be associated with the x-limits of the second plot.

I have found an example https://stackoverflow.com/questions/38616790/how-to-display-many-points-from-plotly-click-in-r-shiny and modified it accordingly:

library(ggplot2)
library(plotly)
library(shiny)

ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2")
)

range2=1000000
p1x=runif(10)
p1y=runif(10)
p1t=runif(10)*range2

times=seq(1,range2)
#ys=cumsum(rnorm(range2)/sqrt(range2))
ys=runif(range2)


plot2xlim=c(1000,2000)
p2 <- plot_ly()
p2 <- add_trace(p2, x = times, y = ys, type = "scattergl", mode = "lines",
                line = list(width = 1, color = "blue"))

server <- function(input, output, session) {
  # make plotly plot
  output$plot1 <- renderPlotly({
    g <- ggplot()+geom_point(aes(x=p1x,y=p1y))
    ggplotly(g)
  })
  output$plot2 <- renderPlotly({
    selpoint <- event_data("plotly_click")$pointNumber[1]+1
    plot2xlim <- c(p1t[selpoint]-500,p1t[selpoint]+500)
    p2 <<- layout(p2, xaxis = list(range = plot2xlim), 
                  yaxis = list(range = c(0, 1)))
    p2
  })
}
shinyApp(ui, server)

However the code works very-very slowly, since plot2 is built for a huge data. So it takes much time to rebuild it.

Is there a way not to redraw the second plot on each click, but just to change its x-limits?


#2

There are two main bottlenecks here. First is the initial rendering of the line with 1 million points and the second is the 'update' to zoom in on a time series. It's not entirely clear how best to address the initial draw (it depends on the context of your problem), but you could certainly speed up of the update via plotlyProxy(). Similar to leaflet::leafletProxy(), this function allows you to a partially update a plotly graph in shiny (instead of doing a full redraw). Currently the best place to read about plotlyProxy() is here, but I'll be adding a section to the plotly book fairly soon.

Here is how I would implement the 'partial update' you need, which is actually somewhat similar to this example -- https://github.com/ropensci/plotly/blob/master/inst/examples/shiny/proxy_relayout/app.R

library(ggplot2)
library(plotly)
library(shiny)

ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2")
)

range2 <- 1000000
p1x <- runif(10)
p1y <- runif(10)
p1t <- runif(10)*range2

times <- seq(1, range2)
ys <- runif(range2)


plot2xlim <- c(1000,2000)

server <- function(input, output, session) {
  # make plotly plot
  output$plot1 <- renderPlotly({
    g <- ggplot()+geom_point(aes(x=p1x,y=p1y))
    ggplotly(g)
  })
  
  output$plot2 <- renderPlotly({
    plot_ly() %>%
      add_lines(x = times, y = ys, size = I(1), color = I("blue")) %>%
      toWebGL()
  })
  
  observeEvent(event_data("plotly_click"), {
    selpoint <- event_data("plotly_click")$pointNumber[1] + 1
    plot2xlim <- c(p1t[selpoint]-500,p1t[selpoint]+500)
    plotlyProxy("plot2", session) %>%
      plotlyProxyInvoke("relayout", list(xaxis = list(range = plot2xlim)))
  })
  
}
shinyApp(ui, server)

If you really need to draw everything by default, plotlyProxy() will help you update the range quickly, but rendering a 1M time series probably isn't the best way to go about it. One option is to select one of these points by default (and provide a visual clue that the series is selection in the scatterplot)

library(ggplot2)
library(plotly)
library(shiny)

ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2")
)

range2 <- 1000000
pts <- data.frame(
  x = runif(10),
  y = runif(10),
  t = runif(10) * range2,
  id = seq_len(10)
)

lines <- data.frame(
  x = seq_len(range2),
  y = runif(range2)
)


plot2xlim <- c(1000, 2000)

server <- function(input, output, session) {
  
  # keep track of selection id/key
  selection <- reactiveVal(1)
  
  observeEvent(event_data("plotly_click"), {
    d <- event_data("plotly_click")
    if (!is.null(d$key)) selection(d$key)
  })
  
  output$plot1 <- renderPlotly({
    plot_ly(showlegend = FALSE) %>%
      add_markers(data = pts, x = ~x, y = ~y, key = ~id, color = I("black")) %>%
      add_markers(data = pts[pts$id %in% selection(), ], x = ~x, y = ~y, color = I("blue"))
  })
  
  output$plot2 <- renderPlotly({
    rng <- pts[pts$id %in% selection(), ]$t
    idx <- rng + 500 >= lines$x & lines$x >= rng - 500
    
    plot_ly() %>%
      add_lines(data = lines[idx, ], x = ~x, y = ~y, size = I(1), color = I("blue")) %>%
      toWebGL()
  })
  
}
shinyApp(ui, server)