輸送時間に基づくヒートマップ/等高線（逆等高線）
注：python のソリューション、 r 、 Java 、または必要に応じて c ++ または c＃ が必要です。
輸送時間に基づいて等高線を描くようにしています。より明確にするために、特定のポイント（目的地）と同様の移動時間（たとえば10分間隔）を持つポイントをクラスター化し、等高線またはヒートマップとしてマップしたいと思います。
今のところ、私が持っている唯一のアイデアはgmapsdistanceさまざまな原点の移動時間を見つけて、それらをクラスター化し、地図上に描画します。しかし、お分かりのように、これは決して堅牢なソリューションではありません。
これスレッドGISコミュニティおよびこれfor pythonは同様の問題を示していますが、特定の時間内に到達可能な目的地への出発地。特定の時間内に目的地に移動できる出発地を見つけたい。
今のところ、以下のコードは私の基本的な考えを示しています。
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")
このマップは、質問を理解するのにも役立つ場合があります。
更新I：
これを使ってanswer私は行くことができるポイントを得ることができます原点からですが、それを逆にして、目的地までの特定の時間よりも短い移動時間のポイントを見つける必要があります。
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")
アップデートII：
さらに、旅行時間マッププラットフォームのドキュメントは到着時間のあるマルチオリジンこれはまさに私がやりたいことです。しかし、私は公共交通機関と運転の両方（通勤時間が1時間未満の場所）でそれを行う必要があります。公共交通機関は（近くの駅に基づいて）注意が必要なため、輪郭よりもヒートマップの方が適していると思います。
多数のAPI呼び出しを行う場合と比較して適用できるアプローチを考え出しました。
アイデアは、特定の時間に到達できる場所を見つけることです（これを見てください スレッド ）。朝から夕方に時間を変更することで、交通をシミュレートできます。両方の場所から到達できる重複領域になります。
次に、 Nicolas answer を使用して、その重複領域内のいくつかのポイントをマップし、目的地のヒートマップを描画できます。このようにすると、カバーする領域（ポイント）が少なくなるため、API呼び出しがはるかに少なくなります（そのことについては適切な時間を使用することを忘れないでください）。
以下では、これらが何を意味するのかを示し、他の回答で言及されているグリッドを作成して、見積もりをより堅牢にすることができるようにしようとしました。
これは、交差する領域をマッピングする方法を示しています。
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データフレームから座標を取得し、それらのポイントの周りにグリッドを構築して、最終的にヒートマップを作成できます。そのアイデア/答えを思いついた他のユーザーを尊重するために、私はそれを私のものに含めず、単にそれを参照しています。
この答えは、（ほぼ）等距離の点のグリッド間の起点-終点行列を取得することに基づいています。これは、マッピングサービスへの多数のAPI呼び出しを必要とするだけでなく、サーバーが各呼び出しのマトリックスを計算する必要があるため、コンピューターを集中的に使用する操作です。必要な呼び出しの数は、グリッド内のポイントの数に沿って指数関数的に増加します。
この問題に取り組むには、ローカルマシンまたはローカルサーバーでのマッピングサーバーでの実行を検討することをお勧めします。 Project OSRMは、比較的シンプルで無料のオープンソースソリューションを提供し、OpenStreetMapサーバーをLinux Dockerで実行できるようにします（ https://github.com/Project-OSRM/osrm-backend ）。独自のローカルマッピングサーバーを使用すると、必要な数のAPI呼び出しを行うことができます。 Rのosrmパッケージを使用すると、OpenStreetMapsの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() %>%
as.data.frame() %>% ## I convert the SpatialPoints object into a simple data.frame
rownames_to_column() %>% ## create a unique id for each point in the data.frame
rename(id = rowname, lat = x2, lon = x1) # rename variables of the data.frame with more explanatory names.
options(osrm.server = "http://127.0.0.1:5000/") ## 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.
Distance_Tables <- osrmTable(loc = df_grid) ## I obtain a list with distances (Origin Destination Matrix in minutes, origins and destinations)
OD_Matrix <- Distance_Tables$durations %>% ## Subset the previous list and
as_data_frame() %>% ## ...convert the Origin Destination Matrix into a tibble
rownames_to_column() %>%
rename(Origin_id = rowname) %>% ## make sure we have an id column for the OD tibble
gather(key = destination_id, value = distance_time, -Origin_id) %>% # transform the tibble into long/tidy format
left_join(df_grid, by = c("Origin_id" = "id")) %>%
rename(Origin_lon = lon, Origin_lat = lat) %>% ## set Origin coordinates
left_join(df_grid, by = c("destination_id" = "id")) %>%
rename(destination_lat = lat, destination_lon = lon) ## set destination coordinates
## 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 %>%
filter(destination_id == 42), ## Here I selected point_id 42 as the desired target, just because it is not far from the City Center.
size = 0.5) +
geom_point(aes(x = Origin_lon, y = Origin_lat),
data = OD_Matrix %>%
filter(destination_id == 42, Origin_id == 42),
shape = 5, size = 3) + ## Draw a diamond around point_id 42
geom_convexhull(alpha = 0.2,
fill = "blue",
colour = "blue",
data = OD_Matrix %>%
filter(destination_id == 42,
distance_time <= 8), ## Countour marking a distance of up to 8 minutes
aes(x = Origin_lon, y = Origin_lat)) +
geom_convexhull(alpha = 0.2,
fill = "red",
colour = "red",
data = OD_Matrix %>%
filter(destination_id == 42,
distance_time <= 15), ## Countour marking a distance of up to 16 minutes
aes(x = Origin_lon, y = Origin_lat))
結果
青い輪郭は、市内中心部までの最大8分の距離を表しています。赤い輪郭は、最大15分の距離を表します。
これが逆アイソクロンの取得に役立つことを願っています。