闪亮的传单添加大量分离的折线

Question

我有一个 20 万行数据集，其中包含出发地和目的地的坐标。我有一个 R 闪亮应用程序，带有传单地图，可以在这些坐标上显示圆圈，尽管坐标数量很大，但效果很好。

这是数据的简化示例。每行包含行程id、出发地经纬度、目的地经纬度。

  id lat_begin lat_end lng_begin lng_end
1  1     46.49   46.27      2.65    7.66
2  2     45.94   49.24      7.94    0.76
3  3     48.07   49.50      2.05    2.61
4  4     46.98   48.94      0.80    5.76
5  5     46.94   48.82      7.36    6.40
6  6     47.37   48.52      5.83    7.00

现在我的目标是在每个出发地和目的地之间添加线路，所以 20 万条线路。

我在 1000 行样本上尝试了几种想法，但它总是花费太多时间，并且显示 200k 行需要几个小时。

第一种方法：

addPolylines 函数的 for 循环

library(dplyr)
library(shiny)
library(leaflet)


n = 1000 # small number of lines 
data_dots = data.frame(id = 1:n,
                       lat_begin = round(runif(n,45,50),2),
                       lat_end = round(runif(n,45,50),2),
                       lng_begin = round(runif(n,0,8),2),
                       lng_end = round(runif(n,0,8),2))

ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output) {
  # Initiate the map
  output$map <- renderLeaflet({
    myMap = leaflet() %>% 
      addTiles(options = providerTileOptions(noWrap = TRUE)) %>%
      setView(lng=3.07381,lat=45.7829,zoom=5) %>%
      
      # add dots
      addCircles(data = data_dots, ~c(lng_begin,lng_end) , ~c(lat_begin,lat_end), 
                 stroke=FALSE, fillOpacity = 0.7)
    
    # add lines
    for(i in 1:n){
          myMap = myMap %>%
            addPolylines(data = data_dots[i,],
                         lng= ~ c(lng_begin, lng_end),
                         lat= ~ c(lat_begin, lat_end),
                         color = 'blue',
                         weight = 1)
    }
    myMap

    # also tried with apply
    # lapply(data_dots$id,
    #        function(x) {
    #          addPolylines(myMap,
    #                       data = data_dots[data_dots$id == x, ],
    #                       lng = ~c(lng_begin, lng_end),
    #                       lat = ~c(lat_begin, lat_end),
    #                       color = 'blue',
    #                       weight = 1)
    #        })
    # myMap
    
  })
}
shinyApp(ui = ui, server = server)

第二种方法：

创建空间线对象

library(dplyr)
library(shiny)
library(leaflet)
library(maptools)
library(sp)

n = 1000
data_dots = data.frame(id = 1:n,
                       lat_begin = round(runif(n,45,50),2),
                       lat_end = round(runif(n,45,50),2),
                       lng_begin = round(runif(n,0,8),2),
                       lng_end = round(runif(n,0,8),2))

begin <- data_dots %>% 
  select(id, lat_begin, lng_begin) %>%
  rename(latitude = lat_begin, longitude = lng_begin)

end <- data_dots %>%
  select(id, lat_end, lng_end) %>%
  rename(latitude = lat_end, longitude =lng_end)


data_lines = bind_rows(begin, end)

# make data_lines a spatialdataframe
coordinates(data_lines) <- c('longitude', 'latitude')

# create a list per id
id_list <- sp::split(data_lines, data_lines[['id']])

id <- 1
#for each id, create a line that connects all points with that id
for ( i in id_list ) {
  event.lines <- SpatialLines( list( Lines( Line( i[1]@coords ), ID = id ) ),
                               proj4string = CRS( "+init=epsg:4326" ) )
  if ( id == 1 ) {
    sp_lines  <- event.lines
  } else {
    sp_lines  <- spRbind( sp_lines, event.lines )
  }
  id <- id + 1
}



ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output) {
  # Initiate the map
  output$map <- renderLeaflet({
    myMap = leaflet() %>% 
      addTiles(options = providerTileOptions(noWrap = TRUE)) %>%
      setView(lng=3.07381,lat=45.7829,zoom=5) %>%
      
      # add dots
      addCircles(data = data_dots, ~c(lng_begin,lng_end) , ~c(lat_begin,lat_end), 
                 stroke=FALSE, fillOpacity = 0.7) %>%
      # add lines
      addPolylines(data = sp_lines)
    
  })

shinyApp(ui = ui, server = server)

1000 行，每个案例都需要几秒钟。我可以用 200k 条线快速添加圆圈，但最大的问题是添加线。

Answer 1

为什么使用 for 循环来循环每一行而不是一次性绘制整个数据框？这已经快得多了，但是对于 200k 行，渲染仍然会“慢”。

  output$map <- renderLeaflet({
    myMap = leaflet() %>% 
      addTiles(options = providerTileOptions(noWrap = TRUE)) %>%
      setView(lng=3.07381,lat=45.7829,zoom=5) %>%

      # add dots
      addCircles(data = data_dots, ~c(lng_begin,lng_end) , ~c(lat_begin,lat_end), 
                 stroke=FALSE, fillOpacity = 0.7) %>% 

        addPolylines(data = data_dots,
                     lng= ~ c(lng_begin, lng_end),
                     lat= ~ c(lat_begin, lat_end),
                     color = 'blue',
                     weight = 1)

    myMap
  })

---

也许

mapview

可能对此有所帮助，因为它曾经有一个处理大型数据集的函数（

addLargeFeatures

）并在内部使用了相当多的C++。

我认为该功能消失了，希望现在可以实现到

addFeatures

中。这应该比纯传单要快一些。

library(dplyr)
library(shiny)
library(leaflet)
library(mapview)
library(sf)


n = 10000 # small number of lines 
data_dots = data.frame(id = 1:n,
                       lat_begin = round(runif(n,45,50),2),
                       lat_end = round(runif(n,45,50),2),
                       lng_begin = round(runif(n,0,8),2),
                       lng_end = round(runif(n,0,8),2))

ui <- fluidPage(
  leafletOutput("map")
)

server <- function(input, output) {
  # Initiate the map
  output$map <- renderLeaflet({
    data_dots_sf_begin <- data_dots %>% 
      st_as_sf(coords=c("lng_begin", "lat_begin"))

    data_dots_sf_end <- data_dots %>% 
      st_as_sf(coords=c("lng_end", "lat_end"))

    data_dots_sf <- st_combine(cbind(data_dots_sf_begin, data_dots_sf_end)) %>% 
      st_cast("LINESTRING")

    st_crs(data_dots_sf) <- 4326

    leaflet() %>% 
      addTiles(options = providerTileOptions(noWrap = TRUE)) %>%
      addFeatures(data = data_dots_sf,
                  color = 'blue',
                  weight = 1)
  })
}
shinyApp(ui = ui, server = server)