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

Question

我的目标

我想在地图上可视化选举结果的空间变化。这将回答这个问题：每个选区是如何投票的？特别是，我想使用不连续的地图，并根据每个党派的票数来缩放每个地区的面积。

因此，我为每个政党制作了一张地图，其中地区的大小反映了该党在该地区的投票数。为了更好的视觉识别，这些地区以党的颜色着色。为了实现这一切，我使用cartogram_ncont()了.cartogramR

我的问题

生成的比例在地图上不一致。换句话说，这些地图非常适合单方表现更好或更差的营地，但它们不适合比较哪一方做得更好或更差。换一种说法，目前每张地图上都有一个“锚区”并没有缩小。但是，我希望所有地图中只有一个“锚区”，即整个数据集中投票数最高的地区。因此，所有投票的范围对所有政党应设定规模，而不是每个政党的计票范围。

我的例子

以 2015 年上奥地利州选举中总体得票最多和最少的两个政党的结果为例：

OEVP - 总票数最多

CPOE - 总票数最少

我的解决方案？

我意识到这cartogram_ncont()需要一个可选参数k，该参数确定地图上缩小了多少区域以及膨胀了多少。然而，我不明白我是否或如何使用这个论点来计算我所有的非连续制图到相同的基础规模。

任何提示和想法都会非常受欢迎，因为我发现自己陷入了僵局！

score 0 · Accepted Answer

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

玩弄 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")
}

score 0 · Accepted Answer

问题已解决 - 感谢 sjewo！

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

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

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

我制作了统一颜色的制图以及具有色标的制图。

生成的地图

我保持三个区（韦尔斯、林茨和蒙德塞）的选举结果不变。注意它们是如何突出的——尤其是在具有色标的地图上。这里有些例子：

源代码

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


# Cartograms - how to scale multiple maps to the same benchmark?
# 
# Non-contiguous cartograms
#
# Dendron's question:
# https://stackoverflow.com/questions/68685129
#
# Implementing sjewo's answer:
# https://stackoverflow.com/a/68716489

# 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>