# [原] 解密 Uber 数据团队的大规模地理数据可视化神器：Deck.gl 与 H3

## 地理单元：H3

，而六边形的周围邻居到中心网格的距离却是相等的，从形状上来说更加接近于圆形。

H3 的前身其实是 DDGS(Discrete global grid systems) 中的 ISEA3H，其原理是把无限的不规则但体积相等的六棱柱从二十面体中心延伸，这样任何半径的球体都会穿过棱镜形成相等的面积cell，基于该标准使得每一个地理单元的面积大小就可以保证几乎相同。

``````#Include libraries
library(dggridR)
library(dplyr)

#Construct a global grid with cells approximately 1000 miles across
dggs <- dgconstruct(spacing=1000, metric=FALSE, resround='down')

#Load included test data set
data(dgquakes)

#Get the corresponding grid cells for each earthquake epicenter (lat-long pair)
dgquakes\$cell <- dgGEO_to_SEQNUM(dggs,dgquakes\$lon,dgquakes\$lat)\$seqnum

#Converting SEQNUM to GEO gives the center coordinates of the cells
cellcenters <- dgSEQNUM_to_GEO(dggs,dgquakes\$cell)

#Get the number of earthquakes in each cell
quakecounts <- dgquakes %>% group_by(cell) %>% summarise(count=n())

#Get the grid cell boundaries for cells which had quakes
grid <- dgcellstogrid(dggs,quakecounts\$cell,frame=TRUE,wrapcells=TRUE)

#Update the grid cells' properties to include the number of earthquakes
#in each cell
grid <- merge(grid,quakecounts,by.x="cell",by.y="cell")

#Make adjustments so the output is more visually interesting
grid\$count <- log(grid\$count)
cutoff <- quantile(grid\$count,0.9)
grid <- grid %>% mutate(count=ifelse(count>cutoff,cutoff,count))

#Get polygons for each country of the world
countries <- map_data("world")

#Plot everything on a flat map
p<- ggplot() +
geom_polygon(data=countries, aes(x=long, y=lat, group=group), fill=NA, color="black") +
geom_polygon(data=grid, aes(x=long, y=lat, group=group, fill=count), alpha=0.4) +
geom_path (data=grid, aes(x=long, y=lat, group=group), alpha=0.4, color="white") +
geom_point (aes(x=cellcenters\$lon_deg, y=cellcenters\$lat_deg)) +
p``````

``````#Replot on a spherical projection
p+coord_map("ortho", orientation = c(-38.49831, -179.9223, 0))+
xlab('')+ylab('')+
theme(axis.ticks.x=element_blank())+
theme(axis.ticks.y=element_blank())+
theme(axis.text.x=element_blank())+
theme(axis.text.y=element_blank())+
ggtitle('Your data could look like this')``````

``````# 以亮马桥地铁站为例
devtools::install_github("scottmmjackson/h3r")
library(h3r)

df <- h3r::getBoundingHexFromCoords(39.949958,116.46343,11) %>% # 单边长为24米
purrr::transpose() %>%
purrr::simplify_all() %>%
data.frame()

df %>% bind_rows(
) %>%
leaflet::leaflet() %>%
leafletCN::amap() %>%

H3 中还提供了类似 S2 的六边形压缩技术，使得数据的存储空间可以极大压缩，在处理大规模稀疏数据时将体现出优势：

## 地理数据可视化：Deck.gl

``````# 初始化
devtools::install_github("crazycapivara/deckgl")

library(deckgl)

# 设置 Mapbox token，过期需要免费在 Mapbox 官网申请
Sys.setenv(MAPBOX_API_TOKEN = "pk.eyJ1IjoidWJlcmRhdGEiLCJhIjoiY2poczJzeGt2MGl1bTNkcm1lcXVqMXRpMyJ9.9o2DrYg8C8UWmprj-tcVpQ")

# 数据集合
sample_data <- paste0(
"https://raw.githubusercontent.com/",
"uber-common/deck.gl-data/",
"master/website/sf-bike-parking.json"
)

properties <- list(
pickable = TRUE,
extruded = TRUE,
cellSize = 200,
elevationScale = 4,
getPosition = JS("data => data.COORDINATES"),
getTooltip = JS("object => object.count")
)

# 可视化
deckgl(zoom = 11, pitch = 45) %>%
add_hexagon_layer(data = sample_data, properties = properties) %>%
add_mapbox_basemap(style = "mapbox://styles/mapbox/light-v9") ``````

## 地理仪表盘：结合 Shiny

Deck.gl 结合 Shiny 后，可将可视化结果输出到仪表盘上：

``````library(mapdeck)
library(shiny)
library(shinydashboard)
library(jsonlite)
ui <- dashboardPage(
, dashboardSidebar()
, dashboardBody(
mapdeckOutput(
outputId = 'myMap'
),
sliderInput(
inputId = "longitudes"
, label = "Longitudes"
, min = -180
, max = 180
, value = c(-90, 90)
)
, verbatimTextOutput(
outputId = "observed_click"
)
)
)
server <- function(input, output) {

set_token('pk.eyJ1IjoidWJlcmRhdGEiLCJhIjoiY2poczJzeGt2MGl1bTNkcm1lcXVqMXRpMyJ9.9o2DrYg8C8UWmprj-tcVpQ') ## 如果token 过期了，需要去Mapbox官网免费申请一个

origin <- capitals[capitals\$country == "Australia", ]
destination <- capitals[capitals\$country != "Australia", ]
origin\$key <- 1L
destination\$key <- 1L

df <- merge(origin, destination, by = 'key', all = T)

output\$myMap <- renderMapdeck({
mapdeck(style = mapdeck_style('dark'))
})

## plot points & lines according to the selected longitudes
df_reactive <- reactive({
if(is.null(input\$longitudes)) return(NULL)
lons <- input\$longitudes
return(
df[df\$lon.y >= lons[1] & df\$lon.y <= lons[2], ]
)
})

observeEvent({input\$longitudes}, {
if(is.null(input\$longitudes)) return()

mapdeck_update(map_id = 'myMap') %>%
data = df_reactive()
, lon = "lon.y"
, lat = "lat.y"
, fill_colour = "country.y"
, radius = 100000
, layer_id = "myScatterLayer"
) %>%
data = df_reactive()
, origin = c("lon.x", "lat.x")
, destination = c("lon.y", "lat.y")
, layer_id = "myArcLayer"
, stroke_width = 4
)
})

## observe clicking on a line and return the text
observeEvent(input\$myMap_arc_click, {

event <- input\$myMap_arc_click
output\$observed_click <- renderText({
jsonlite::prettify( event )
})
})
}
shinyApp(ui, server)``````

2.2k 声望
2.2k 粉丝
0 条评论