如何在 R 中使用 cartogram_ncont() 创建多个具有相同基础比例的非连续制图?

How can I create multiple non-contiguous cartograms with the same underlying scale using cartogram_ncont() in R?

我的目标

我想在地图上可视化选举结果的空间变化。这将回答以下问题:每个选区如何投票?特别是,我想使用 non-contiguous cartograms 并根据每个政党的 投票数 来缩放每个选区的面积。

因此,我为每个政党制作了 一张地图,其中地区的大小反映了选票的数量cast 为那个地区的那个派对。为了更好的视觉识别,这些地区都涂上了党的颜色。为了实现这一切,我使用函数 cartogram_ncont() of the package cartogram in R.

我的问题

生成的比例在地图不一致。换句话说,这些地图 非常适合 露营,其中 一个政党 做得好或坏,但它们 不合适-适合比较哪一方做得更好或更差。换句话说,目前每张地图上都有一个“锚区”没有缩小。但是,我希望在所有地图中只有一个“锚区”,即最高选票 整个数据集。因此,所有个政党的全部票数范围应该设定比例,而不是每个人的票数范围派对。

我的例子

最多最少票的两个政党的结果为例Upper Austrian elections in 2015 :

OEVP - most votes overall

CPOE - least votes overall

我的解决方案?

我意识到 cartogram_ncont() 有一个可选参数 k,它决定了地图上有多少地区缩小了,有多少地区膨胀了。然而,我不明白是否或如何我可以使用这个参数来计算我所有的非连续制图到相同的基础比例。

非常欢迎任何提示和想法,因为我发现自己陷入了僵局!

这是一个有趣的问题。示例代码会对我的回答有所帮助。

玩转 k 值可能很棘手。所以我想建议一个更简单的解决方案:只需将所有变量组合成一个值向量并将其用于制图。

我修改了 cartogram_ncont() 手册页中的示例,以给您一个小演示。我确实使用了 sp-package,但您可以轻松采用 sf.

的代码
library(maptools)
library(cartogram)
library(rgdal)
library(rgeos)

data(wrld_simpl)

# Remove uninhabited regions
afr <- spTransform(wrld_simpl[wrld_simpl$REGION==2 & wrld_simpl$POP2005 > 0,],
                   CRS("+init=epsg:3395"))

# and keep only countries with larger area
afr <- afr[afr$AREA > 2568, ]

# Create fake data
set.seed(1234)
afr$V1 <- runif(nrow(afr), 0, 0.08) * 100
afr$V2 <- runif(nrow(afr), 0.3, 0.7) * 100
afr$V3 <- 100 - afr$V2 - afr$V1

# Keep the value for Egypt and Algeria constant
# this allows us to inspect the resulting map
afr$V1[afr$FIPS=="EG"] <- 40
afr$V2[afr$FIPS=="EG"] <- 40
afr$V3[afr$FIPS=="EG"] <- 40

afr$V1[afr$FIPS=="AG"] <- 13
afr$V2[afr$FIPS=="AG"] <- 13
afr$V3[afr$FIPS=="AG"] <- 13

# color vector for plotting
afr$col <- "gray"
afr$col[afr$FIPS=="EG"] <- "red"
afr$col[afr$FIPS=="AG"] <- "blue"

现在我们需要创建一个长格式的 SpatialDataFrame。所以我们使用 rbind 将多边形和变量值绑定在一起。制图基于这个新数据集。

# There is probably a more efficient way to do this...

# create temporary data
tmp <- afr
tmp$W <- tmp$V1      # assign V1 to new weight variable
tmp$variable <- "V1" # add information about variable

# do the same for all other variables and rbind the spatial data
for(v in c("V2", "V3")) {
  tt <- afr
  tt$W <- tt[[v]]
  tt$variable <- v
  tmp <- rbind(tmp, tt)
}

# cartogram calculation
afr_nc <- cartogram_ncont(tmp, "W", k = 8)

现在我们可以绘制扭曲的地图了。

# plot side-by-side
par(mfrow = c(1,3))
for(v in c("V1", "V2", "V3")) {
  plot(afr)
  plot(afr_nc[afr_nc$variable==v, ], add=T, col = afr_nc$col)
}

# overplot new polygons
par(mfrow = c(1,1))
plot(afr)
for(v in c("V1", "V2", "V3")) {
  plot(afr_nc[afr_nc$variable==v, ], add=T, col = "#00000022")
}

问题已解决 - 感谢 sjewo!

使用 sjewos 解决方案,我能够为上奥地利 制作地图 。在这里,仅供参考。

如果你想要运行源代码,请确保将脚本中的工作目录调整为适合你的所需的路径。选区地图应该会自动下载。

选举结果随机选择的,因为它们很难以编程方式下载和处理。

我制作颜色均匀的制图以及具有色阶的制图。

生成的地图

我持有三个选区的选举结果(WelsLinzMondsee)持续的。注意它们是如何突出的——尤其是在带有色标的地图上。以下是一些示例:

OEVP_Colour_Constant

OEVP_Colour_Scale

FPOE_Colour_Constant

FPOE_Colour_Scale

SPOE_Colour_Constant

SPOE_Colour_Scale

NEOS_Colour_Constant

NEOS_Colour_Scale

源代码

有很多内联评论 - 我希望它们足以解释发生的事情!


# Cartograms - how to scale multiple maps to the same benchmark?
# 
# Non-contiguous cartograms
#
# Dendron's question:
# 
#
# Implementing sjewo's answer:
# 

# load packages
library("sf")
library("dplyr")
library("rgdal")
library("maptools")
library("cartogram")
library("foreach")
library("doParallel")
library("graphics")
library("s2dv")
library("rgeos")

# Settings
ext    <- 'png'    # file type
a      <- 1        # alpha
gren   <- "grey"   # colour for border line
wd     <- '/path/to/your/working/directory'
setwd(wd)
file1  <- paste(wd,'GEMEINDEGRENZEN_GEN', 'GEMEINDEGRENZEN_GEN.shp', sep = '/')
par_1  <- 0.7                    # scaling factor for fonts
par_2  <- c(0.1,0.1,0.2,0.1)     # margins for multi-panel-plotting
par_3  <- c(0.05,0.85,0.05,0.95) # borders for panels
kk     <- 1                      # expansion factor

# Download & unzip .shp file
link  <- "https://e-gov.ooe.gv.at/at.gv.ooe.dorisdaten/DORIS_Basisdaten/GEMEINDEGRENZEN_GEN.zip"
file3 <- paste(wd,'GEMEINDEGRENZEN_GEN.zip',sep='/')
download.file(link,file3)
unzip(file3, exdir = 'GEMEINDEGRENZEN_GEN')

# Import Upper Austria's election districts
map   <- read_sf(dsn = file1)

# Choose some parties to participate in the election
part  <- c("oevp",  "fpoe",  "spoe", "gruene", "neos")

# Invent election results
set.seed(20210823)
map[['oevp']] <- runif(nrow(map),0,1)

foreach(g=2:length(part))%do%{
        
        # Make each party's results less than the previous'
        map[[part[g]]] <- map[[part[g-1]]]/2
        
        # Keep some values constant for comparison
        map[[part[g]]][map$GEM_NAME=="Wels"] = 1
        map[[part[g]]][map$GEM_NAME=="Mondsee"] = 0.5
        map[[part[g]]][map$GEM_NAME=="Linz"] = 0
}

# Summarise all election results into one variable
tmp       <- map
tmp$votes <- tmp[[part[1]]]
names(tmp$votes) <- 'votes'
tmp$part  <- part[1]

for(v in part[2:length(part)]) {
        tt       <- map
        tt$votes <- tt[[v]]
        tt$part  <- v
        tmp      <- rbind(tmp, tt)
}

# Hand-pick colours and colour scales which match the parties' branding
farb  <- c("#64c4d2","#044ee1","#ff0000","#00d600","#ff4ccf","#8C0307","#000000")

tuerk <-     c("#FFFFFF", "#F7FCFD", "#F0F9FB", "#E8F6F8", "#E0F3F6", "#D8F0F4",
               "#D1EDF2", "#C9EAEF", "#C1E7ED", "#B9E4EB", "#B2E2E9", "#AADFE6",
               "#A2DCE4", "#9AD9E2", "#93D6E0", "#8BD3DD", "#83D0DB", "#7BCDD9",
               "#74CAD7", "#6CC7D4", "#64C4D2")
blau  <-     c("#FFFFFF", "#F2F6FE", "#E6EDFC", "#D9E4FB", "#CDDCF9", "#C0D3F8",
               "#B4CAF6", "#A7C1F5", "#9BB8F3", "#8EAFF2", "#82A7F0", "#759EEF",
               "#6895ED", "#5C8CEC", "#4F83EA", "#437AE9", "#3671E7", "#2A69E6",
               "#1D60E4", "#1157E3", "#044EE1")
rot   <-     c("#FFFFFF", "#FFF2F2", "#FFE6E6", "#FFD9D9", "#FFCCCC", "#FFBFBF",
               "#FFB3B3", "#FFA6A6", "#FF9999", "#FF8C8C", "#FF8080", "#FF7373",
               "#FF6666", "#FF5959", "#FF4D4D", "#FF4040", "#FF3333", "#FF2626",
               "#FF1A1A", "#FF0D0D", "#FF0000")
gruen <-     c("#FFFFFF", "#F2FDF2", "#E6FBE6", "#D9F9D9", "#CCF7CC", "#BFF5BF",
               "#B3F3B3", "#A6F1A6", "#99EF99", "#8CED8C", "#80EB80", "#73E873",
               "#66E666", "#59E459", "#4DE24D", "#40E040", "#33DE33", "#26DC26",
               "#1ADA1A", "#0DD80D", "#00D600")
pink  <-     c("#FFFFFF", "#FFF6FD", "#FFEDFA", "#FFE4F8", "#FFDBF5", "#FFD2F3",
               "#FFC9F1", "#FFC0EE", "#FFB7EC", "#FFAEE9", "#FFA6E7", "#FF9DE5",
               "#FF94E2", "#FF8BE0", "#FF82DD", "#FF79DB", "#FF70D9", "#FF67D6",
               "#FF5ED4", "#FF55D1", "#FF4CCF")
purp  <-     c("#FFFFFF", "#F9F2F3", "#F4E6E6", "#EED9DA", "#E8CDCD", "#E2C0C1",
               "#DDB3B5", "#D7A7A8", "#D19A9C", "#CB8E8F", "#C68183", "#C07477",
               "#BA686A", "#B45B5E", "#AF4F51", "#A94245", "#A33539", "#9D292C",
               "#981C20", "#921013", "#8C0307")
schw  <-     c("#FFFFFF", "#F2F2F2", "#E6E6E6", "#D9D9D9", "#CCCCCC", "#BFBFBF",
               "#B3B3B3", "#A6A6A6", "#999999", "#8C8C8C", "#808080", "#737373",
               "#666666", "#595959", "#4D4D4D", "#404040", "#333333", "#262626",
               "#1A1A1A", "#0D0D0D", "#000000")

# Combine colour maps
pally <- cbind(tuerk, blau, rot, gruen, pink, purp, schw)

# Choose breaks for colour scale
brks  <- seq(0, 1, length.out = length(rot)+1)

# Choose sensible ticks for colour bar
ll    <- seq(min(brks),max(brks), length.out = 3)

# Create base map
base     <- st_geometry(map)

# Calculate Cartogram
ooe_scal <- cartogram_ncont(tmp, 'votes', k=kk, inplace = TRUE)

# Setup parallel cluster
cores=detectCores()

# Do not overload your computer
cl <- makeCluster(cores[1]-1)
registerDoParallel(cl)

# Loop over parties
foreach(i=1:length(part),
        .packages = c("cartogram","sf","foreach","s2dv","graphics","rgdal","rgeos"))%dopar%{
                
                # ----- WITH COLOUR SCALE ----- #
                
                # Pick title/filename
                tt <- paste(part[i], 'scale', sep = '_')
                
                # start recording plot
                png(file=paste(tt, ext, sep = '.'))
                
                # Reset plotting device
                layout(1)
                par(cex=par_1, mai=par_2)
                par(fig=par_3)
                
                # Background map
                plot(base, axes = FALSE, border = gren)
                
                # Generate colour palette
                pp <- colorRampPalette(pally[,i], space = "rgb", interpolate = "linear")
                
                # Visualise
                cc <- which(colnames(ooe_scal)==part[i], arr.ind = TRUE)
                plot(ooe_scal[cc][ooe_scal$part==part[i],], pal = pp,
                     axes = FALSE, border = gren, add = TRUE, alpha = a, breaks = brks)
                
                # Add description
                title(tt)
                
                # Visualise colour scale on bar
                par(fig=c(0.9,1,0.2,0.8), new=TRUE)
                ColorBar(brks = brks, cols = pally[,i], plot = TRUE,
                         vertical = TRUE, label_digits = 2, extra_labels = ll)
                
                # Save output
                dev.off()
                
                # ----- WITH CONSTANT COLOURS ----- #
                
                # Pick title/filename
                tt <- paste(part[i], 'const', sep = '_')
                
                # start recording plot
                png(file=paste(tt, ext, sep = '.'))
                
                # Reset plotting device
                layout(1)
                
                # Background map
                plot(base, axes = FALSE, border = gren)
                
                # Visualise
                cc <- which(colnames(ooe_scal)==part[i], arr.ind = TRUE)
                plot(ooe_scal[cc][ooe_scal$part==part[i],], col = c(farb[i]),
                     axes = FALSE, border = gren, add = TRUE, alpha = a, breaks = brks)
                
                # Add description
                title(tt)
                
                # Save output
                dev.off()
        }

# stop cluster
stopCluster(cl)

# <EOF>