Search code examples
ranimationplotlyflexdashboard

plotly - map and plot with shared animation

My flexdashboard has 2 animated outputs - a map and a scatter plot, linked via the animation slider, which goes through the date stamps in the data. To link the animation, I'm using subplot with a shared slider, as shown here.

When I use scatter plot instead of the map, everything works fine. But when I switch to a map, I have two problems - the map is no longer animated, and the second plot is plotted under the map and is not visible. A toy example is provided below, showing both the working and the non-working versions. Any help would be appreciated.

library(dplyr)         
library(plotly)       

# Make data
data <- expand.grid(Lat = c(46.5, 46.7, 46.8), Lon = seq(-110, -115, -0.5), Group = c("A", "B"),
                      Date = as.Date(c("24/02/2020", "25/02/2020", "26/02/2020", "27/02/2020", "28/02/2020", "29/02/2020"), 
                                     format = "%d/%m/%Y")) %>%
        mutate(Date = as.factor(Date),
                Lat = rnorm(n(), Lat, 1),
               Lon = rnorm(n(), Lon, 1))
data <- data[sample(1:nrow(data), 50), ]
df <- data %>% mutate(Y = rnorm(n(), 0, 1))

## the map does not work - no animation and the other plot is blocked from view
p1 <- data %>%
  plot_ly(lon = ~Lon, lat = ~Lat, frame = ~Date,
    type = "scattermapbox", mode = "markers") %>%
layout(mapbox= list(style = "white-bg", sourcetype = 'raster', zoom = 4,
      center = list(lon = -110 ,lat= 46.5),
      layers = list(list(below = 'traces', sourcetype = "raster",
        source = list("https://basemap.nationalmap.gov/arcgis/rest/services/USGSImageryOnly/MapServer/tile/{z}/{y}/{x}")))))

# scatterplot works just fine - comment this out to see the map issue
p1 <- data %>%
  plot_ly(x = ~Lon, y = ~Lat, frame = ~Date,
    type = "scatter", mode = "markers") %>%
 layout(xaxis = list(range = c(-120, -100), constrain="domain"),
     yaxis = list(range = c(46, 47), constrain="domain"))

p2 <- df %>%
  plot_ly(x = ~Group, y = ~Y, frame = ~Date, type = "scatter", mode = "markers") 

subplot(p1, p2, nrows = 2, heights = c(0.5, 0.5), titleX = TRUE) %>%
  animation_opts(1000, frame = 1100, redraw = FALSE) %>%
  animation_slider()
Solution

  • There are several things happening here that are a bit frustrating. Like many other occasions, I couldn't find the 'right' combination of Plotly parameters to make this work as expected.

    Here is a workaround that isn't very dynamic- that won't work in most other settings, particularly due to trace quantity.

    At the end of the answer, I'll provide all that code again, but altogether for easier copy + paste.

    In this answer, I used your data as is and no additional libraries.

    The only element of the first plot that I changed was to make the markers obnoxiously large -- this was just to ensure it was obviously working (or not).

    In the second plot, I didn't change anything from your question.

    The plots:

    ## the map does not work - no animation and the other plot is blocked from view
(p1 <- data %>%
  plot_ly(lon = ~Lon, lat = ~Lat, frame = ~Date, marker = list(size = 20), 
          type = "scattermapbox", mode = "markers") %>%
  layout(mapbox = list(style = "white-bg", sourcetype = 'raster', zoom = 4,
                      center = list(lon = -110 ,lat= 46.5),
                      layers = list(list(below = 'traces', sourcetype = "raster",
                                         source = list("https://basemap.nationalmap.gov/arcgis/rest/services/USGSImageryOnly/MapServer/tile/{z}/{y}/{x}"))))))

(p2 <- df %>%
  plot_ly(x = ~Group, y = ~Y, frame = ~Date, type = "scatter", mode = "markers"))

    Next, I've got a function that you'll use to fix the subplot. It has three arguments, the first is going to be fed forward (the subplot), the remaining arguments are the plots in you call in subplot() (p1 and p2).

    One of the issues addressed in this function is the axes assignments. Plotly doesn't recognize that a scattermapbox has axes, so when you created the subplot, it assigned the frames for the 2nd plot to xaxis and yaxis, but these really belong to the map. Because it faults out for the frames, likely due to this issue, it drops all frames from the subplot when it's created, so this function recreates the frames structure, using what's already been created in the plots that you call to subplot (the frames in p1 and p2).

    The function

    fixer <- function(plt, pl1, pl2) {
  pl1 <- plotly_build(pl1) # get all plot data to prepare for breakdown
  pl2 <- plotly_build(pl2); plt <- plotly_build(plt)
  comFr <- lapply(1:length(pl1$x$frames), function(k) { # combine anim frames
    fr <- pl1$x$frames[[k]]         # capture frame structure and frame name
    # combine data, currently 1 trace per frame in ea. plot
    fr$data <- list(pl1$x$frames[[k]]$data[[1]], pl2$x$frames[[k]]$data[[1]])
    fr$data[[2]]$xaxis <- "x2"     # fixed assigned axes for the second trace
    fr$data[[2]]$yaxis <- "y2"
    fr$traces <- c(0, 1)           # set traces for subplot
    fr                             # return frame
  })
  plt$x$frames <- comFr            # add frames to subplot
  plt                              # return modified subplot
}

    Lastly, the call to subplot.

    I've added a call to layout so that the two plots have a specified domain. Usually, just calling this in subplot is sufficient, but it isn't here. Of course, I call the fixer(). Other than that, this function is as you've made it in your question.

    subplot(p1, p2, nrows = 2, titleX = TRUE) %>%
  layout(grid = list(rows = 2, columns = 1)) %>% # create a grid to sep plots
  fixer(., p1, p2) %>%                           # manually consolidate frames
  animation_opts(1000, frame = 1100, redraw = FALSE) %>%
  animation_slider()

    enter image description here

    enter image description here

    By the way, the second plot will be orange before you animate. The animation frames will reflect blue markers.

    Here's all that code again, but altogether.

    library(dplyr)
library(plotly)       

# Make data
data <- expand.grid(Lat = c(46.5, 46.7, 46.8), Lon = seq(-110, -115, -0.5), Group = c("A", "B"),
                    Date = as.Date(c("24/02/2020", "25/02/2020", "26/02/2020", "27/02/2020", "28/02/2020", "29/02/2020"), 
                                   format = "%d/%m/%Y")) %>%
  mutate(Date = as.factor(Date),
         Lat = rnorm(n(), Lat, 1),
         Lon = rnorm(n(), Lon, 1))
data <- data[sample(1:nrow(data), 50), ]
df <- data %>% mutate(Y = rnorm(n(), 0, 1))

## the map does not work - no animation and the other plot is blocked from view
(p1 <- data %>%
  plot_ly(lon = ~Lon, lat = ~Lat, frame = ~Date, marker = list(size = 20), 
          type = "scattermapbox", mode = "markers") %>%
  layout(mapbox = list(style = "white-bg", sourcetype = 'raster', zoom = 4,
                      center = list(lon = -110 ,lat= 46.5),
                      layers = list(list(below = 'traces', sourcetype = "raster",
                                         source = list("https://basemap.nationalmap.gov/arcgis/rest/services/USGSImageryOnly/MapServer/tile/{z}/{y}/{x}"))))))

(p2 <- df %>%
  plot_ly(x = ~Group, y = ~Y, frame = ~Date, type = "scatter", mode = "markers"))

fixer <- function(plt, pl1, pl2) {
  pl1 <- plotly_build(pl1) # get all plot data to prepare for breakdown
  pl2 <- plotly_build(pl2); plt <- plotly_build(plt)
  comFr <- lapply(1:length(pl1$x$frames), function(k) { # combine anim frames
    fr <- pl1$x$frames[[k]]         # capture frame structure and frame name
    # combine data, currently 1 trace per frame in ea. plot
    fr$data <- list(pl1$x$frames[[k]]$data[[1]], pl2$x$frames[[k]]$data[[1]])
    fr$data[[2]]$xaxis <- "x2"     # fixed assigned axes for the second trace
    fr$data[[2]]$yaxis <- "y2"
    fr$traces <- c(0, 1)           # set traces for subplot
    fr                             # return frame
  })
  plt$x$frames <- comFr            # add frames to subplot
  plt                              # return modified subplot
}

subplot(p1, p2, nrows = 2, titleX = TRUE) %>%
  layout(grid = list(rows = 2, columns = 1)) %>% # create a grid to sep plots
  fixer(., p1, p2) %>%                           # manually consolidate frames
  animation_opts(1000, frame = 1100, redraw = FALSE) %>%
  animation_slider()