R语言 基于运输时间的热图/等高线(反向等时等高线)

vhmi4jdf  于 2023-04-18  发布在  其他
关注(0)|答案(2)|浏览(124)

***注：***需要r或python中的解决方案。

我试图根据交通时间绘制等高线。为了更清楚，我想将具有相似旅行时间（假设10分钟间隔）的点聚集到特定点（目的地），并将其绘制为等高线或热图。
现在，我唯一的想法是使用R包***gmapsdistance来找到不同起点的旅行时间，然后将它们聚类并绘制在Map上。但是，正如你所看到的，这绝不是一个健壮的解决方案。
GIS-community上的thread和python上的this one***说明了一个类似的问题，但是对于在特定时间内到达的目的地的起点。我想找到我可以在特定时间内到达目的地的起点。
现在，下面的代码展示了我的基本想法（使用R）：

library(gmapsdistance)

set.api.key("YOUR.API.KEY") 

mdestination <- "40.7+-73"
morigin1 <- "40.6+-74.2"
morigin2 <- "40+-74"

gmapsdistance(origin = morigin1,
              destination = mdestination,
              mode = "transit")

gmapsdistance(origin = morigin2,
              destination = mdestination,
              mode = "transit")

这张Map也可以帮助理解这个问题：

使用这个***答案***我可以得到我可以从起点到达的点，但我需要反转它并找到旅行时间等于-小于-某个时间到达目的地的点;

library(httr)
library(googleway)
library(jsonlite)
appId <- "TravelTime_APP_ID"
apiKey <- "TravelTime_API_KEY"
mapKey <- "GOOGLE_MAPS_API_KEY"

location <- c(40, -73)
CommuteTime <- (5 / 6) * 60 * 60

url <- "http://api.traveltimeapp.com/v4/time-map"

requestBody <- paste0('{ 
                      "departure_searches" : [ 
                      {"id" : "test", 
                      "coords": {"lat":', location[1], ', "lng":', location[2],' }, 
                      "transportation" : {"type" : "driving"} ,
                      "travel_time" : ', CommuteTime, ',
                      "departure_time" : "2017-05-03T07:20:00z"
                      } 
                      ] 
                      }')

res <- httr::POST(url = url,
                  httr::add_headers('Content-Type' = 'application/json'),
                  httr::add_headers('Accept' = 'application/json'),
                  httr::add_headers('X-Application-Id' = appId),
                  httr::add_headers('X-Api-Key' = apiKey),
                  body = requestBody,
                  encode = "json")

res <- jsonlite::fromJSON(as.character(res))

pl <- lapply(res$results$shapes[[1]]$shell, function(x){
  googleway::encode_pl(lat = x[['lat']], lon = x[['lng']])
})
df <- data.frame(polyline = unlist(pl))

df_marker <- data.frame(lat = location[1], lon = location[2])

google_map(key = mapKey) %>%
  add_markers(data = df_marker) %>%
  add_polylines(data = df, polyline = "polyline")

此外，*旅行时间Map平台的文档*谈到多起点与到达时间这正是我想做的事情。但我需要为公共交通和驾驶（通勤时间不到一小时的地方）做这件事，我认为由于公共交通很棘手（基于您靠近的车站），也许热图是比轮廓更好的选择。

r

2条答案

按热度按时间
vzgqcmou

vzgqcmou1#

这个答案是基于获得一个（大致）等距点的网格之间的起点-目的地矩阵。这是一个计算机密集型操作，不仅因为它需要大量的API调用Map服务，而且因为服务器必须为每个调用计算一个矩阵。所需的调用数量沿着网格中的点的数量呈指数增长。
为了解决这个问题，我建议您考虑在本地机器或本地服务器上运行Map服务器。Project OSRM提供了一个相对简单，免费和开源的解决方案，使您能够在Linux Docker中运行OpenStreetMap服务器（https://github.com/Project-OSRM/osrm-backend）。拥有自己的本地Map服务器将允许您根据需要进行尽可能多的API调用。的osrm包允许您与OpenStreetMaps的API进行交互，包括放置在本地服务器上的API。

library(raster) # Optional
library(sp)
library(ggmap)
library(tidyverse)
library(osrm)
devtools::install_github("cmartin/ggConvexHull") # Needed to quickly draw the contours
library(ggConvexHull)

我创建了一个围绕布鲁塞尔（比利时）城市群的96个大致等距点的网格。这个网格没有考虑地球的曲率，在城市距离的水平上可以忽略不计。
为了方便起见，我使用光栅包下载比利时的ShapeFile并提取布鲁塞尔市的节点。

BE <- raster::getData("GADM", country = "BEL", level = 1)
  Bruxelles <- BE[BE$NAME_1 == "Bruxelles", ]

  df_grid <- makegrid(Bruxelles, cellsize = 0.02) %>% 
        SpatialPoints() %>%
        ## I convert the SpatialPoints object into a simple data.frame 
        as.data.frame() %>% 
        ## create a unique id for each point in the data.frame
        rownames_to_column() %>% 
        ## rename variables of the data.frame with more explanatory names.
        rename(id = rowname, lat = x2, lon = x1) 

 ## I point osrm.server to the OpenStreet docker running in my Linux machine. ... 
 ### ... Do not run this if you are getting your data from OpenStreet public servers.
 options(osrm.server = "http://127.0.0.1:5000/") 

 ## I obtain a list with distances (Origin Destination Matrix in ...
 ### ... minutes, origins and destinations)
 Distance_Tables <- osrmTable(loc = df_grid) 

 OD_Matrix <- Distance_Tables$durations %>% ## subset the previous list
                ## convert the Origin Destination Matrix into a tibble
                as_data_frame() %>%  
                rownames_to_column() %>% 
                ## make sure we have an id column for the OD tibble
                rename(origin_id = rowname) %>% 
                ## transform the tibble into long/tidy format
                gather(key = destination_id, value = distance_time, -origin_id) %>% 
                left_join(df_grid, by = c("origin_id" = "id")) %>% 
                ## set origin coordinates
                rename(origin_lon = lon, origin_lat = lat) %>% 
                left_join(df_grid, by = c("destination_id" = "id")) %>% 
                ## set destination coordinates
                rename(destination_lat = lat, destination_lon = lon)
## Obtain a nice looking road map of Brussels
 Brux_map <- get_map(location = "bruxelles, belgique", 
                     zoom = 11, 
                     source = "google", 
                     maptype = "roadmap")

 ggmap(Brux_map) + 
   geom_point(aes(x = origin_lon, y = origin_lat), 
              data = OD_Matrix %>% 
                ## Here I selected point_id 42 as the desired target, ...
                ## ... just because it is not far from the City Center.
                filter(destination_id == 42), 
                size = 0.5) + 
   ## Draw a diamond around point_id 42                                      
   geom_point(aes(x = origin_lon, y = origin_lat), 
              data = OD_Matrix %>% 
                filter(destination_id == 42, origin_id == 42),
              shape = 5, size = 3) +  
   ## Countour marking a distance of up to 8 minutes
   geom_convexhull(alpha = 0.2, 
                   fill = "blue", 
                   colour = "blue",
                   data = OD_Matrix %>% 
                            filter(destination_id == 42, 
                            distance_time <= 8), 
                   aes(x = origin_lon, y = origin_lat)) + 
   ## Countour marking a distance of up to 16 minutes
   geom_convexhull(alpha = 0.2, 
                   fill = "red",
                   colour = "red",
                   data = OD_Matrix %>% 
                            filter(destination_id == 42, 
                                   distance_time <= 15), 
                   aes(x = origin_lon, y = origin_lat))

结果

蓝色的等值线代表到市中心最多8分钟的距离，红色的等值线代表最多15分钟的距离。

赞(0）分享  回复(0）举报  2023-04-18
hsvhsicv

hsvhsicv2#

我提出了一种方法，与进行大量的API调用相比，它是适用的。
我们的想法是找到你可以在一定的时间到达的地方（看看这个线程）。交通可以通过改变时间从早上到晚上来模拟。你最终会得到一个重叠的区域，你可以从两个地方到达。
然后你可以使用Nicolas answer，在重叠区域内绘制一些点，并为你的目的地绘制热图。这样，你将有更少的区域（点）覆盖，因此你将少得多的API调用（记住使用适当的时间）。
下面，我试着演示一下我的意思，并让你明白，你可以制作另一个答案中提到的网格，使你的估计更可靠。
这显示了如何Map相交区域。

library(httr)
library(googleway)
library(jsonlite)
appId <- "Travel.Time.ID"
apiKey <- "Travel.Time.API"
mapKey <- "Google.Map.ID"

locationK <- c(40, -73) #K
locationM <- c(40, -74) #M

CommuteTimeK <- (3 / 4) * 60 * 60
CommuteTimeM <- (0.55) * 60 * 60
url <- "http://api.traveltimeapp.com/v4/time-map"

requestBodyK <- paste0('{ 
                      "departure_searches" : [ 
                      {"id" : "test", 
                      "coords": {"lat":', locationK[1], ', "lng":', locationK[2],' }, 
                      "transportation" : {"type" : "public_transport"} ,
                      "travel_time" : ', CommuteTimeK, ',
                      "departure_time" : "2018-06-27T13:00:00z"
                      } 
                      ] 
                      }')

requestBodyM <- paste0('{ 
                      "departure_searches" : [ 
                      {"id" : "test", 
                      "coords": {"lat":', locationM[1], ', "lng":', locationM[2],' }, 
                      "transportation" : {"type" : "driving"} ,
                      "travel_time" : ', CommuteTimeM, ',
                      "departure_time" : "2018-06-27T13:00:00z"
                      } 
                      ] 
                      }')
resKi <- httr::POST(url = url,
                  httr::add_headers('Content-Type' = 'application/json'),
                  httr::add_headers('Accept' = 'application/json'),
                  httr::add_headers('X-Application-Id' = appId),
                  httr::add_headers('X-Api-Key' = apiKey),
                  body = requestBodyK,
                  encode = "json")

resMi <- httr::POST(url = url,
                   httr::add_headers('Content-Type' = 'application/json'),
                   httr::add_headers('Accept' = 'application/json'),
                   httr::add_headers('X-Application-Id' = appId),
                   httr::add_headers('X-Api-Key' = apiKey),
                   body = requestBodyM,
                   encode = "json")
resK <- jsonlite::fromJSON(as.character(resKi))
resM <- jsonlite::fromJSON(as.character(resMi))

plK <- lapply(resK$results$shapes[[1]]$shell, function(x){
  googleway::encode_pl(lat = x[['lat']], lon = x[['lng']])
})

plM <- lapply(resM$results$shapes[[1]]$shell, function(x){
  googleway::encode_pl(lat = x[['lat']], lon = x[['lng']])
})
dfK <- data.frame(polyline = unlist(plK))
dfM <- data.frame(polyline = unlist(plM))

df_markerK <- data.frame(lat = locationK[1], lon = locationK[2], colour = "#green")
df_markerM <- data.frame(lat = locationM[1], lon = locationM[2], colour = "#lavender")

iconK <- "red"
df_markerK$icon <- iconK

iconM <- "blue"
df_markerM$icon <- iconM

google_map(key = mapKey) %>%
  add_markers(data = df_markerK,
              lat = "lat", lon = "lon",colour = "icon",
              mouse_over = "K_K") %>%
  add_markers(data = df_markerM, 
              lat = "lat", lon = "lon", colour = "icon",
              mouse_over = "M_M") %>%
  add_polygons(data = dfM, polyline = "polyline", stroke_colour = '#461B7E',
               fill_colour = '#461B7E', fill_opacity = 0.6) %>% 
  add_polygons(data = dfK, polyline = "polyline", 
               stroke_colour = '#F70D1A',
               fill_colour = '#FF2400', fill_opacity = 0.4)

可以像这样提取相交区域：

# install.packages(c("rgdal", "sp", "raster","rgeos","maptools"))
library(rgdal)
library(sp)
library(raster)
library(rgeos)
library(maptools)
Kdata <- resK$results$shapes[[1]]$shell
Mdata <- resM$results$shapes[[1]]$shell

xyfunc <- function(mydf) {
  xy <- mydf[,c(2,1)]
  return(xy)
}

spdf <- function(xy, mydf){
            sp::SpatialPointsDataFrame(
                coords = xy, data = mydf,
                proj4string = CRS("+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"))}

for (i in (1:length(Kdata))) {Kdata[[i]] <- xyfunc(Kdata[[i]])}
for (i in (1:length(Mdata))) {Mdata[[i]] <- xyfunc(Mdata[[i]])}

Kshp <- list(); for (i in (1:length(Kdata))) {Kshp[i] <- spdf(Kdata[[i]],Kdata[[i]])}

Mshp <- list(); for (i in (1:length(Mdata))) {Mshp[i] <- spdf(Mdata[[i]],Mdata[[i]])}

Kbind <- do.call(bind, Kshp) 
Mbind <- do.call(bind, Mshp) 
#plot(Kbind);plot(Mbind)

x <- intersect(Kbind,Mbind)
#plot(x)

xdf <- data.frame(x)
xdf$icon <- "https://i.stack.imgur.com/z7NnE.png"

google_map(key = mapKey, 
           location = c(mean(latmax,latmin), mean(lngmax,lngmin)), zoom = 8) %>% 
     add_markers(data = xdf, lat = "lat", lon = "lng", marker_icon = "icon")

这只是相交区域的图示。

现在，你可以从xdf dataframe中获取坐标，并围绕这些点构建网格，最终得出一个热图.为了尊重提出这个想法/答案的其他用户，我没有将其包含在我的中，只是引用它.
Nicolás Velásquez -在（大致）等距点的网格之间获得起点-终点矩阵

赞(0）分享  回复(0）举报  2023-04-18
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备2022004421号-2 NULL123 https://www.null123.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com