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

Question

My Goal

I would like to visualise the spatial variation in election results on a map. This would answer the question: how did each electoral district vote? In particular, I would like to use non-contiguous cartograms and scale each district's area according to the count of votes cast for each party.

Hence, I produce one map per party, where the size of the district reflects the number of votes cast for that party in that district. For better visual recognition, the districts are coloured in the party's colour. To achieve all this, I use the function cartogram_ncont() of the package cartogram in R.

My Problem

The resulting scale is not consistent across maps. In other words, the maps are well-suited to campare where a single party did better or worse, but they are ill-suited to compare which party did better or worse. Put differently still, there currently is one "anchor district" on each map which isn't shrunk. However, I would like there to be only one "anchor district" across all maps, namely the district with the highest ballot count in the entire data set. Hence, the range of all vote counts for all parties should set the scale, not the range of vote counts for each individual party.

My Examples

See as an example the results of the two parties with the most and the least votes overall in the Upper Austrian elections in 2015:

OEVP - most votes overall

CPOE - least votes overall

My Solution?

I realise that cartogram_ncont() takes an optional argument k which determines how many districts on the map are shrunk and how many are inflated. Yet, I don't understand whether or how I can use this argument to compute all my non-contiguous cartograms to the same underlying scale.

Any hints and ideas would be very welcome for I find myself at an impasse!

Answer 1

That is an interesting question. A sample code would have been helpful for my answer.

Playing around with the k values could be tricky. So I would like to suggest a simpler solution: just combine all variables into one value vector and use that for the cartogram.

I have modified the example from the cartogram_ncont() man page to give you a small demonstration. I did used the sp-package, but you can easily adopt the code for 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"

Now we need to create a SpatialDataFrame in long format. So we use rbind to bind polygons and variable values together. The cartogram is based on this new dataset.

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

Now we can plot the distorted map.

# 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")
}

Answer 2

Problem Solved - Thanks to sjewo!

Using sjewos solution I was able to produce the cartograms for Upper Austria. Here they are, FYI.

If you want to run the source code, make sure to adapt the working directory within the script to your desired path. The map of election districts should download automatically.

The election results are chosen randomly because they are hard to download and handle programmatically.

I produce both uniformly coloured cartograms as well as cartograms with a colour scale.

The resulting maps

I hold the election results of three districts (Wels, Linz and Mondsee) constant. Notice how they stick out - especially on maps with a colour scale. Here are some examples:

OEVP_Colour_Constant

OEVP_Colour_Scale

FPOE_Colour_Constant

FPOE_Colour_Scale

SPOE_Colour_Constant

SPOE_Colour_Scale

NEOS_Colour_Constant

NEOS_Colour_Scale

The source code

There are numerous inline comments - I hope they are sufficient explanation of what happens!

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