R: эффективный способ последовательного построения множества графиков с фоновым изображением.

Я хочу построить покадровую анимацию последовательности сюжетов в R. Они покажут точки, движущиеся по траектории. Я хотел бы показать карту на заднем плане, чтобы расположение движущихся точек соответствовало координатам карты. Я делал это с помощью RgoogleMaps, где я создал объект карты, а затем сохранил его в виде файла png, а затем установил его в качестве фона графика с помощью функции rasterImage. В конечном счете, я пытаюсь сделать это блестящим приложением (код ниже). Проблема в том, что скорость анимации, которую я использую в Shiny, слишком высока (я могу замедлить ее, но она выглядит не так хорошо), поэтому сюжет становится непрозрачным, потому что он не может обработать его достаточно быстро.

В основном я хочу показать один набор точек за итерацию с одним и тем же фоном. Есть ли более эффективный способ сделать это? Есть ли способ, скажем, установить фоновое изображение на постоянной основе, не создавая его каждый раз. Я экономлю время, используя записьPlot(), а затем воспроизводя ее, но это все еще не решает проблему полностью. Я также пытался посмотреть, могу ли я уменьшить разрешение растра, но аргументы maxpixels и col в as.raster, похоже, ничего для меня не делают.

Я не на 100% уверен, что мне нужно использовать GoogleMaps, если есть аналогичная альтернатива, которая гораздо более эффективна и дает примерно те же результаты.

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)
   }

Блестящее приложение, которое я пытаюсь реализовать, выглядит так (код повторяется):

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)

r shiny r-raster rgooglemaps

Sam A. 31.01.2017 источник

comment

Это может быть полезно: gganimate и/или tweenr - JasonAizkalns 31.01.2017

comment

Я хотел бы придерживаться блестящего для части анимации, потому что я пытаюсь разработать интерактивный инструмент для визуализации, в котором параметры можно легко изменить, а не использовать код напрямую. Тем не менее, я попробовал ggmap, и он примерно в два раза быстрее, чем график, который я использовал. - Sam A. 03.02.2017

Ответы (1)

arrow_upward
1
arrow_downward

Вы можете использовать мой пакет googleway для "симуляции" анимации на реальной карте Google.

Я упростил ваш пример, чтобы заставить его работать, но идея должна быть применима и к вашему примеру.

Здесь я анимирую маршрут между Мельбурном и Сиднеем.

Чтобы сделать анимацию, вы загружаете серию кругов на карту, затем устанавливаете непрозрачность на 0 или 1 в зависимости от того, какие из них вы хотите показать.

В этом случае те, которые вы хотите показать, зависят от значения ползунка ввода.

Хитрость, позволяющая избежать перерисовки карты и фигур каждый раз, состоит в том, чтобы сначала загрузить все круги, а затем использовать функцию update_circles() для изменения атрибутов (т. е. непрозрачности) кругов.

Примечания:

Вам необходим действительный ключ API Javascript Карт Google.
Входные данные должны быть data.frame, а не матрицей
Я еще не нашел точку «разрыва», то есть точку, в которой слишком много кругов, которые они не могут обновить достаточно быстро.

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)

Скриншоты

Исходное состояние: показывает все