voter_rep/optimisation.R at master · robertkck/voter_rep · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
# Optimisation exercise
# author: Robert Kalcik

# This script calculates the Cambridge Compromise allocation of seats for
# Parliament sizes between 600 and 800 seats. The allocation is subsequently
# evaluated using a number of measures of inequality. The results are plotted.

library(ggplot2)
library(countrycode)
library(SciencesPo)
library(tidyverse)
library(IC2)
source('funk/voting_gini.R')
source('funk/camcom.R')
source('funk/malapportionment.R')

theil <- function(pop, rep){
  pop_prop <- pop / sum(pop)
  rep_prop <- rep / pop
  mu <- sum(rep_prop*pop_prop)
  temp <- (pop_prop*rep_prop / mu) * log(rep_prop / mu)
  return(sum(temp))
}

# Load population data and set treaty limits
eu <- read.csv("data/eu.csv")
eu <- eu[eu$GEO != "United Kingdom", ]
m <- 6
M <- 96

# Calculate CamCom allocation for every Parliament size between 600 and 800
rep_opt <- purrr::map(600:800, ~ alloc.camcom(eu$pop, m, M, .x)$rep)
rep_opt_df <- data.frame(matrix(unlist(rep_opt), nrow = 27), row.names = eu$GEO)
colnames(rep_opt_df) <- paste0('H', 600:800)
# write.csv(rep_opt_df, 'output/CamCom_allocations.csv')

# Compute Gini, Malapportionment and other inequality metrics from the Science Po package
ginis <- map_dbl(rep_opt, ~ voting_gini(eu$pop, .x))
mals <- map_dbl(rep_opt, ~ mal(eu$pop, .x))
spo1 <- map_dbl(rep_opt, ~ SciencesPo::Proportionality(eu$pop, .x, index = "Loosemore-Hanby"))
spo2 <- map_dbl(rep_opt, ~ 10 * Proportionality(eu$pop, .x, index = "Rae"))
spo3 <- map_dbl(rep_opt, ~ 1 - Proportionality(eu$pop, .x, index = "Cox-Shugart"))
spo4 <- map_dbl(rep_opt, ~ Proportionality(eu$pop, .x, index = "Farina"))
spo5 <- map_dbl(rep_opt, ~ Proportionality(eu$pop, .x, index = "Gallagher"))
spo6 <- map_dbl(rep_opt, ~ 10 * Proportionality(eu$pop, .x, index = "Grofman"))
spo7 <- map_dbl(rep_opt, ~ Proportionality(eu$pop, .x, index = "Lijphart"))
spo8 <- map_dbl(rep_opt, ~ 1 - Proportionality(eu$pop, .x, index = "Rose"))
spo9 <- map_dbl(rep_opt, ~ Proportionality(eu$pop, .x, index = "DHondt"))
# theils <- map_dbl(rep_opt, ~ theil(eu$pop, .x))
theils <- map_dbl(rep_opt, ~ calcGEI(.x / eu$pop, w = eu$pop, alpha = 1)$ineq$index)
entropies <- map_dbl(rep_opt, ~ calcGEI(.x / eu$pop, w = eu$pop, alpha = 0)$ineq$index)

# Collect and demean results
results <- data.frame(Gini = ginis, "LoosemoreHanby" = mals, Rae = spo2, Cox = spo3, Farina = spo4, Gallagher = spo5, Grofman = spo6, Rose = spo8, Theil = theils, Entropy = entropies)
results <-  sweep(results, 2, apply(results, 2, mean))
minima <- apply(results, 2, which.min)
results$H <- 600:800

# Export the long format
results_long <- results %>%
  gather("methods", "t", -H) %>%
  transform(methods = factor(methods,levels = c("Gini", "Cox", "Farina", "Gallagher", "LoosemoreHanby", "Grofman", "Rae", "Rose", "Theil", "Entropy")))
# write.csv(results_long, 'optimisation.csv')

# Prepare facet plot
min_labels <- data.frame(x = 650, y = 0.04, min_text = paste0("Min: ", 600 + minima), methods = names(minima))
p <- ggplot(results_long, aes(x = H, y = t, color = methods)) +
      geom_point() +
      facet_wrap( ~ methods, ncol = 4) +
      scale_x_continuous(breaks = c(600, 700, 800)) +
      geom_text(data = min_labels, aes(x,y,label = min_text, color = methods),  color = "black", inherit.aes = FALSE) +
      xlab("Parliament size") +
      ylab("Demeaned inequality coefficients") +
      theme(legend.position = "none")
p