为地图中的多边形着色，以便相邻多边形具有不同的颜色

Question

我制作了以下地图：

library(sf)  
library(leaflet)
library(leafgl)
library(colourvalues)
library(leaflet.extras)


nc <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE) %>% 
  st_transform(st_crs(4326)) %>% 
  st_cast('POLYGON')

leaflet(data = nc) %>% addPolygons( stroke = FALSE) %>% addTiles(group = "OSM") %>%  addProviderTiles(provider = providers$OpenStreetMap) %>% addPolygons(data = nc, weight=1, popup = ~NAME,
                label = ~NAME, group = "name", col = 'blue') %>% 
    addSearchFeatures(targetGroups  = 'name', options = searchFeaturesOptions(zoom=10, openPopup=TRUE))

我想给多边形涂上不同的颜色，以便它们更容易看到 - 我通过随机为多边形分配颜色来做到这一点：

nc$color <- sample(c("red", "blue", "green", "yellow", "purple"), nrow(nc), replace = TRUE)

leaflet(data = nc) %>% 
    addTiles(group = "OSM") %>% 
    addProviderTiles(provider = providers$OpenStreetMap) %>% 
    addPolygons(data = nc, weight=1, popup = ~NAME,
                label = ~NAME, group = "name", fillColor = ~color, fillOpacity = 0.5) %>% 
    addSearchFeatures(targetGroups  = 'name', options = searchFeaturesOptions(zoom=10, openPopup=TRUE))

我的问题：从这个著名的计算机科学问题https://en.wikipedia.org/wiki/Four_color_theorem中汲取灵感，我想以不相邻多边形具有相同颜色的方式随机为多边形着色。

我认为我首先需要将 shapefile/map 转换为网络图：

library(igraph)
adj <- st_touches(nc, sparse = TRUE)
g <- graph_from_adjacency_matrix(as.matrix(adj))
plot(g)

我不知道如何继续这个问题 - 目前，我想到了一种间接方法，我只需选择许多不同的随机颜色来减少两个多边形具有相同颜色的几率，但我有兴趣了解新的和创造性的方法解决我原来的问题。

有人可以告诉我该怎么做吗？

谢谢！

Answer 1

您可以使用MapColoring包。该包使用 DSatur 算法，在这种情况下能够找到问题的最小（四色）解决方案，而基于贪婪算法的解决方案则不能。一般来说，DSatur已被证明可以比贪婪算法获得明显更好的顶点着色。

devtools::install_github("hunzikp/MapColoring")
library(sp)
library(MapColoring)

my.palette = RColorBrewer::brewer.pal(4, 'Set1')
nc$color = my.palette[getColoring(as(nc, 'Spatial'))]

要查看地图，您只需使用问题中的相同代码即可：

leaflet(data = nc) %>% 
    addTiles(group = "OSM") %>% 
    addProviderTiles(provider = providers$OpenStreetMap) %>% 
    addPolygons(data = nc, weight=1, popup = ~NAME,
                label = ~NAME, group = "name", fillColor = ~color, fillOpacity = 0.5) %>% 
    addSearchFeatures(targetGroups  = 'name', options = searchFeaturesOptions(zoom=10, openPopup=TRUE))