R: efficient way to plot many plots in sequence with background image - r

Question

I am looking to plot a stop-motion animation of a sequence of plots in R. These will show dots moving around on a trajectory. I would like to show a map in the background so that the locations of the moving points correspond to the map coordinates. The way I have been doing this is through RgoogleMaps, where I created a map object and then stored it as a png file, then I set it as the background of the plot using the rasterImage function. Ultimately I am trying to have this be a shiny app (code below).
The problem is that the animation speed I have in shiny is too fast (I can slow it down but it doesn't look as good), so the plot goes opaque because it can't process it fast enough.
Basically I want to show one set of points per iteration with the same background. Is there a more efficient way to do this? Is there a way to, say, set the background image permanently without having to plot it each time. I save some time by using recordPlot() and then replaying it, but it still doesn't completely solve the problem. I have also tried seeing if I can make the raster lower resolution but the maxpixels and col arguments in as.raster don't seem to be doing anything for me.
I am not 100% sold on having to use GoogleMaps if there is a similar alternative that is much more efficient and will achieve roughly the same thing.
BC_googlemaps_point
library(shiny)
library(colorspace)
library(raster)
library(grDevices)
library(png)
#a png from Google Maps of the area above
bc_longlat_map_img <- png::readPNG("BC_googlemaps_point.png")
bc_longlat_map_img_ras <- grDevices::as.raster(bc_longlat_map_img, maxpixels=100)
bbox <- matrix(c(33.68208, -118.0554, 33.70493, -118.0279), byrow=TRUE, ncol=2)
rownames(bbox) <- c("lon","lat")
colnames(bbox) <- c("min","max")
#make some fake data
pt_data <- matrix(NA,nrow=1000, ncol=2)
colnames(pt_data) <- c("lon","lat")
#length of each side
plot_dims <- apply(bbox,1,diff)
pt_data[1:250,"lon"] <- bbox["lon","min"] + 0.2*plot_dims["lon"]
pt_data[1:250,"lat"] <- seq(bbox["lat","min"]+0.2*plot_dims["lat"], bbox["lat","max"]-0.2*plot_dims["lat"], length.out=250)
pt_data[251:500,"lon"] <- seq(bbox["lon","min"]+0.2*plot_dims["lon"], bbox["lon","max"]-0.2*plot_dims["lon"], length.out=250)
pt_data[251:500,"lat"] <- bbox["lat","max"] - 0.2*plot_dims["lat"]
pt_data[501:750,"lon"] <- bbox["lon","max"] - 0.2*plot_dims["lon"]
pt_data[501:750,"lat"] <- seq(bbox["lat","max"]-0.2*plot_dims["lat"], bbox["lat","min"]+0.2*plot_dims["lat"], length.out=250)
pt_data[751:1000,"lon"] <- seq(bbox["lon","max"]-0.2*plot_dims["lon"], bbox["lon","min"]+0.2*plot_dims["lon"], length.out=250)
pt_data[751:1000,"lat"] <- bbox["lat","min"] + 0.2*plot_dims["lat"]
#this is the slowest, have to replot the whole thing each time
for (ii in 1:1000) {
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
#plot first, then record, and only replay each time
#seems to be a bit faster
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
plot_back <- recordPlot()
for (ii in 1:1000) {
replayPlot(plot_back)
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
#example without the map background. very fast.
for (ii in 1:1000) {
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
points(x=pt_data[ii,"lon"], y=pt_data[ii,"lat"], pch=19, cex=3)
}
The shiny app I am trying to implement looks like this (code is repetitive):
shark_vis <- shinyApp(
ui= shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel("Inputs",
sliderInput("iter","Progress of simulation",value=1, min=1, max=1000, round=TRUE, step=1,
animate=animationOptions(interval=100, loop=FALSE))),
mainPanel(plotOutput("plot"))
)
)
),
server=shinyServer(
function(input, output) {
#current image dimensions
bbox <- matrix(c(33.68208, -118.0554, 33.70493, -118.0279), byrow=TRUE, ncol=2)
rownames(bbox) <- c("lon","lat")
colnames(bbox) <- c("min","max")
#make some fake data
pt_data <- matrix(NA,nrow=1000, ncol=2)
colnames(pt_data) <- c("lon","lat")
#length of each side
plot_dims <- apply(bbox,1,diff)
pt_data[1:250,"lon"] <- bbox["lon","min"] + 0.2*plot_dims["lon"]
pt_data[1:250,"lat"] <- seq(bbox["lat","min"]+0.2*plot_dims["lat"], bbox["lat","max"]-0.2*plot_dims["lat"], length.out=250)
pt_data[251:500,"lon"] <- seq(bbox["lon","min"]+0.2*plot_dims["lon"], bbox["lon","max"]-0.2*plot_dims["lon"], length.out=250)
pt_data[251:500,"lat"] <- bbox["lat","max"] - 0.2*plot_dims["lat"]
pt_data[501:750,"lon"] <- bbox["lon","max"] - 0.2*plot_dims["lon"]
pt_data[501:750,"lat"] <- seq(bbox["lat","max"]-0.2*plot_dims["lat"], bbox["lat","min"]+0.2*plot_dims["lat"], length.out=250)
pt_data[751:1000,"lon"] <- seq(bbox["lon","max"]-0.2*plot_dims["lon"], bbox["lon","min"]+0.2*plot_dims["lon"], length.out=250)
pt_data[751:1000,"lat"] <- bbox["lat","min"] + 0.2*plot_dims["lat"]
#plot and store
plot(bbox["lon",1]-1000, bbox["lat",1]-1000, xlim=bbox["lon",], ylim=bbox["lat",], xlab="Longitude", ylab="Latitude", las=1)
#read in current plots limits to fit Raster Image to
lims <- par()$usr
rasterImage(bc_longlat_map_img_ras, xleft=lims[1], ybottom=lims[3], xright=lims[2], ytop=lims[4])
plot_back <- recordPlot()
output$plot <- renderPlot({
replayPlot(plot_back)
points(x=pt_data[input$iter,"lon"], y=pt_data[input$iter,"lat"], pch=19, cex=3, col=1:2)
})
}
)
)
runApp(shark_vis)

Answer 1

You can use my googleway package to 'simulate' an animation onto an actual Google Map.
I've simplified your example so I could get it to work, but the idea should translate to your example too.
Here I'm animating the route between Melbourne and Sydney
To do the animation you load a series of circles onto the map, then set the opacity to either 0 or 1 depending on which ones you want shown.
In this instance the ones you want shown are dependant on the value of the input slider.
The trick to avoid re-drawing the map and shapes each time is to load all the circles at the start, then use the update_circles() function to change the attributes (i.e., opacity) of the circles.
Notes:
You need a valid Google Maps Javascript API key
The input data must be a data.frame, not a matrix
I haven't found the 'break' point yet - i.e., the point at which there are too many circles that they can't update quick enough
library(shiny)
library(googleway)
ui <- fluidPage(
sliderInput(inputId = "mySlider", label = "slider", min = 0, max = 222, value = 0, step = 1,
animate = animationOptions(interval=100, loop=FALSE)),
google_mapOutput("myMap", height = 800)
)
server <- function(input, output){
polyline <- "rqxeF_cxsZgr#xmCekBhMunGnWc_Ank#vBpyCqjAfbAqmBjXydAe{AoF{oEgTqjGur#ch#qfAhUuiCww#}kEtOepAtdD{dDf~BsgIuj#}tHi{C{bGg{#{rGsmG_bDbW{wCuTyiBajBytF_oAyaI}K}bEkqA{jDg^epJmbB{gC}v#i~D`#gkGmJ_kEojD_O{`FqvCetE}bGgbDm_BqpD}pEqdGiaBo{FglEg_Su~CegHw`Cm`Hv[mxFwaAisAklCuUgzAqmCalJajLqfDedHgyC_yHibCizK~Xo_DuqAojDshAeaEpg#g`Dy|DgtNswBcgDiaAgEqgBozB{jEejQ}p#ckIc~HmvFkgAsfGmjCcaJwwD}~AycCrx#skCwUqwN{yKygH}nF_qAgyOep#slIehDcmDieDkoEiuCg|LrKo~Eb}Bw{Ef^klG_AgdFqvAaxBgoDeqBwoDypEeiFkjBa|Ks}#gr#c}IkE_qEqo#syCgG{iEazAmeBmeCqvA}rCq_AixEemHszB_SisB}mEgeEenCqeDab#iwAmZg^guB}cCk_F_iAmkGsu#abDsoBylBk`Bm_CsfD{jFgrAerB{gDkw#{|EacB_jDmmAsjC{yBsyFaqFqfEi_Ei~C{yAmwFt{B{fBwKql#onBmtCq`IomFmdGueD_kDssAwsCyqDkx#e\\kwEyUstC}uAe|Ac|BakGpGkfGuc#qnDguBatBot#}kD_pBmmCkdAgkB}jBaIyoC}xAexHka#cz#ahCcfCayBqvBgtBsuDxb#yiDe{Ikt#c{DwhBydEynDojCapAq}AuAksBxPk{EgPgkJ{gA}tGsJezKbcAcdK__#uuBn_AcuGsjDwvC_|AwbE}~#wnErZ{nGr_#stEjbDakFf_#clDmKkwBbpAi_DlgA{lArLukCBukJol#w~DfCcpBwnAghCweA}{EmyAgaEbNybGeV}kCtjAq{EveBwuHlb#gyIg\\gmEhBw{G{dAmpHp_#a|MsnCcuGy~#agIe#e`KkoA}lBspBs^}sAmgIdpAumE{Y_|Oe|CioKouFwuIqnCmlDoHamBiuAgnDqp#yqIkmEqaIozAohAykDymA{uEgiE}fFehBgnCgrGmwCkiLurBkhL{jHcrGs}GkhFwpDezGgjEe_EsoBmm#g}KimLizEgbA{~DwfCwvFmhBuvBy~DsqCicBatC{z#mlCkkDoaDw_BagA}|Bii#kgCpj#}{E}b#cuJxQwkK}j#exF`UanFzM{fFumB}fCirHoTml#CoAh`A"
df <- decode_pl(polyline)
df$opacity <- 1
df$id <- 1:nrow(df)
rv <- reactiveValues()
rv$df <- df
map_key <- "your_api_key"
output$myMap <- renderGoogle_map({
google_map(key = map_key, data = df) %>%
add_circles(radius = 1000, id = "id", lat = "lat", lon = "lon",
fill_opacity = "opacity", stroke_opacity = "opacity")
})
observeEvent({
input$mySlider
},{
r <- input$mySlider
rv$df[r, "opacity"] <- 1
rv$df[-r, "opacity"] <- 0
google_map_update(map_id = "myMap") %>%
update_circles(data = rv$df, radius = 1000, id = "id",
fill_opacity = "opacity", stroke_opacity = "opacity")
})
}
shinyApp(ui, server)
Screenshots
Starting state: showing everything
step 34 on the slider
step 44 on the slider
step 82 on the slider