Created
May 12, 2026 20:45
-
-
Save chrishanretty/5fc33d7fab81fcefebe508ca8861d872 to your computer and use it in GitHub Desktop.
Measuring disproportionality in mixed member systems
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| suppressPackageStartupMessages({ | |
| library(tidyverse) | |
| library(haven) | |
| library(tinytable) | |
| library(autumn) | |
| library(ggrepel) | |
| }) | |
| ### ####################################### | |
| ### Scotland | |
| ### ####################################### | |
| sp21 <- tribble(~Party, ~Seats, ~Voteshare, | |
| "SNP", 64, 40.34, | |
| "Cons", 31, 23.49, | |
| "Lab", 22, 17.91, | |
| "Green", 8, 8.12, | |
| "LDem", 4, 5.06, | |
| "Alba", 0, 1.66, | |
| "Unity", 0, .86, | |
| "SFP", 0, .59, | |
| "RUK", 0, .21, | |
| "UKIP", 0, .14) |> | |
| mutate(seat_share = Seats / 129, | |
| Voteshare = Voteshare / 100, | |
| A = seat_share / Voteshare, | |
| contrib = (A - 1)^2, | |
| wtd_contrib = contrib * Voteshare) | |
| sp21_tab <- sp21 |> | |
| dplyr::select(Party, | |
| `Vote share` = Voteshare, | |
| `Seat share` = seat_share, | |
| `A` = A, | |
| `(A - 1)²` = contrib, | |
| `v (A - 1)²` = wtd_contrib) | |
| sp21_sl <- sum(sp21$wtd_contrib) | |
| sp21_sl <- round(sp21_sl, 3) | |
| tt(sp21_tab, escape = FALSE) |> | |
| format_tt(j = 2:3, | |
| fn = scales::label_percent(accuracy = .01)) |> | |
| format_tt(j = 4:6, digits = 3) | |
| ses <- read_dta("SES_21_panel.dta", | |
| col_select = c(w2W8, | |
| w2vb12, | |
| w2vb12o, | |
| w2vb15, | |
| w2vb15o)) |> | |
| dplyr::select(weight = w2W8, | |
| consty_vote = w2vb12, | |
| consty_vote_other = w2vb12o, | |
| region_vote = w2vb15, | |
| region_vote_other = w2vb15o) |> | |
| filter(!is.na(weight)) | |
| ### Convert everything to a character | |
| ### round-trip as.character(as_factor(x)) because haven has labels | |
| ses <- ses |> | |
| mutate(across(contains("_vote"), ~ as.character(as_factor(.x)))) | |
| ### Just people who voted in both tiers | |
| non_vote <- c("[998]Skipped", "[999]Not Asked") | |
| ses <- ses |> | |
| filter(!is.element(consty_vote, non_vote)) |> | |
| filter(!is.element(region_vote, non_vote)) | |
| ### Copy across "others" | |
| ses <- ses |> | |
| mutate(consty_vote = case_when(consty_vote_other != "__NA__" ~ consty_vote_other, | |
| TRUE ~ consty_vote), | |
| region_vote = case_when(region_vote_other != "__NA__" ~ region_vote_other, | |
| TRUE ~ region_vote)) |> | |
| dplyr::select(-ends_with("_other")) | |
| ### Make names shorter | |
| shorten_names <- function(x) { | |
| x <- dplyr::recode(x, | |
| "Scottish National Party" = "SNP", | |
| "Scottish Labour" = "Lab", | |
| "Scottish Conservative and Unionist" = "Con", | |
| "Scottish Liberal Democrats" = "LDem", | |
| "Scottish Liberal Democrat" = "LDem", | |
| "All for Unity" = "Other", | |
| "Scottish Greens" = "Green", | |
| "Scottish Family Party" = "Other", | |
| "UK Independence Party (UKIP)" = "Other", | |
| "Reform UK" = "Other", | |
| "SNP"= "SNP", | |
| "Alba" = "Alba", | |
| "Alba Party" = "Alba", | |
| .default = "Other") | |
| x <- factor(x, | |
| levels = c("Alba", "Con", "Green", | |
| "Lab", "LDem", "Other", | |
| "SNP"), | |
| ordered = TRUE) | |
| } | |
| ses <- ses |> | |
| mutate(consty_vote = shorten_names(consty_vote), | |
| region_vote = shorten_names(region_vote)) | |
| ### There's one person who said they voted Alba in the constituency vote -- remove them | |
| ses <- ses |> | |
| filter(consty_vote != "Alba") | |
| ### Weight using anesrake | |
| ### This takes a named vector | |
| ### Make sure these are weighted accordingly | |
| consty_weights <- c("SNP" = .4770, | |
| "Con" = .2189, | |
| "Lab" = .2159, | |
| "LDem" = .0694, | |
| "Green" = 0.0129) | |
| region_weights <- c("SNP" = .4034, | |
| "Con" = .2349, | |
| "Lab" = .1791, | |
| "LDem" = .0506, | |
| "Green" = 0.0812, | |
| "Alba" = 0.0166) | |
| consty_weights <- c(consty_weights, | |
| "Other" = 1 - sum(consty_weights)) | |
| region_weights <- c(region_weights, | |
| "Other" = 1 - sum(region_weights)) | |
| tgts <- list("consty_vote" = consty_weights, | |
| "region_vote" = region_weights) | |
| ses$consty_vote <- as.character(ses$consty_vote) | |
| ses$region_vote <- as.character(ses$region_vote) | |
| ses <- autumn::harvest(ses, tgts, start_weights = ses$weight) | |
| ### Convert to "first" and "second" sorted by alphabetic order | |
| ses <- ses |> | |
| mutate(first = pmin(consty_vote, region_vote), | |
| second = pmax(consty_vote, region_vote)) | |
| ### Now we wish to see the distribution of types | |
| ### We sum up the weights by each combination, and pivot wider | |
| types <- ses |> | |
| group_by(first, second) |> | |
| summarize(weight = sum(weights, na.rm = TRUE), | |
| .groups = "drop") |> | |
| mutate(prop = weight / sum(weight)) | |
| ### Let's reset the factors | |
| common_levels <- sort(unique(c(types$first, | |
| types$second))) | |
| types$first <- factor(types$first, | |
| levels = common_levels, | |
| ordered = TRUE) | |
| types$second <- factor(types$second, | |
| levels = common_levels, | |
| ordered = TRUE) | |
| tab <- types |> | |
| dplyr::select(-weight) |> | |
| pivot_wider(names_from = second, | |
| values_from = prop, | |
| names_expand = TRUE) |> | |
| arrange(first) | |
| ### Now make this look pretty | |
| tt_out <- tt(tab) |> | |
| format_tt(j = 2:ncol(tab), | |
| fn = scales::label_percent(accuracy = .01)) |> | |
| format_tt(replace = ".") | |
| ### Greys on diagonal | |
| for (i in 1:nrow(tab)) { | |
| tt_out <- tt_out |> | |
| style_tt(i = i, | |
| j = i + 1, | |
| background = "#99999966") | |
| } | |
| ### greens column | |
| tt_out <- tt_out |> | |
| style_tt(i = 1:3, | |
| j = 4, | |
| line = "lr", | |
| line_width = 0.4, | |
| line_color = "#00B14066") |> | |
| style_tt(i = 3, | |
| j = 4:8, | |
| line = "tb", | |
| line_width = 0.4, | |
| line_color = "#00B14066") | |
| ### SNP column | |
| tt_out <- tt_out |> | |
| style_tt(i = 1:8, | |
| j = 8, | |
| background = "#FDF38E") | |
| tt_out | |
| shares <- lapply(unique(c(types$first, types$second)), | |
| function(p) { | |
| pos <- which(types$first == p | types$second == p) | |
| share <- sum(types$prop[pos]) | |
| data.frame(party = p, | |
| share = share) | |
| }) |> | |
| bind_rows() | |
| types <- left_join(types, | |
| shares, | |
| by = join_by(first == party)) | |
| types <- left_join(types, | |
| shares, | |
| by = join_by(second == party), | |
| suffix = c(".first", ".second")) | |
| add_seats <- function(x) { | |
| dplyr::recode(x, | |
| "Alba" = 0L, | |
| "Con" = 31L, | |
| "Green" = 8L, | |
| "Lab" = 22L, | |
| "LDem" = 4L, | |
| "Other" = 0L, | |
| "RUK" = 0L, | |
| "SFP" = 0L, | |
| "SNP" = 64L, | |
| "UKIP" = 0L, | |
| "Unity" = 0L) / | |
| 129 | |
| } | |
| types <- types |> | |
| mutate(first_seats = add_seats(first), | |
| second_seats = add_seats(second)) |> | |
| mutate(adv_first = first_seats / share.first, | |
| adv_second = second_seats / share.second, | |
| adv_combined = adv_first / 2 + adv_second / 2) | |
| types |> arrange(desc(adv_combined)) |> | |
| head() |> | |
| dplyr::select(`Party A` = first, | |
| `Party B` = second, | |
| `Proportion` = prop, | |
| `Advantage ratio, party A` = adv_first, | |
| `Advantage ratio, party B` = adv_second, | |
| Combined = adv_combined) |> | |
| tt() |> | |
| format_tt(j = 3, | |
| fn = scales::label_percent(accuracy = .01)) |> | |
| format_tt(j = 4:6, digits = 3) | |
| pop_wtd_avg <- weighted.mean(types$adv_combined, | |
| types$prop) | |
| types$adv_adjusted <- types$adv_combined / pop_wtd_avg | |
| sp21_slstar <- weighted.mean((types$adv_adjusted - 1)^2, | |
| types$prop) | |
| pop_wtd_avg <- round(pop_wtd_avg, 3) | |
| sp21_slstar <- round(sp21_slstar, 3) | |
| ### ####################################### | |
| ### Comparative | |
| ### ####################################### | |
| load("cses_imd.rdata") | |
| ### Just select those elections held under mixed systems (i.e., those | |
| ### with two tiers, where the systems are mixed) | |
| cses_imd <- cses_imd |> | |
| filter(IMD5041_1 == 2) |> | |
| filter(IMD5013 == 3) | |
| ### We just want weights and vote choice in the two tiers: | |
| ### nominal (IMD3002_LH_DC) | |
| ### proportional (IMD3002_LH_PL) | |
| ### and country, year (IMD1008_YEAR), and weight (political) (IMD1010_3) | |
| cses_imd <- cses_imd |> | |
| dplyr::select(IMD1006_UNALPHA3, | |
| IMD1008_YEAR, | |
| IMD1010_3, | |
| IMD3002_LH_DC, | |
| IMD3002_LH_PL) | |
| ### Just get those who voted across both tiers | |
| ### that is, | |
| cses_imd <- cses_imd |> | |
| filter(IMD3002_LH_DC < 9999993) |> | |
| filter(IMD3002_LH_PL < 9999993) | |
| ### But Albania is a bit borked | |
| cses_imd <- cses_imd |> | |
| filter(!(IMD1006_UNALPHA3 == "ALB")) | |
| ### This is the result of dputting the file I made | |
| mapping <- structure(list(IMD1006_UNALPHA3 = c("ALB", "ALB", "ALB", "ALB", | |
| "ALB", "ALB", "ALB", "ALB", "ALB", "ALB", "ALB", "ALB", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", "DEU", | |
| "DEU", "DEU", "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", | |
| "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", "HUN", | |
| "HUN", "HUN", "HUN", "HUN", "JPN", "JPN", "JPN", "JPN", "JPN", | |
| "JPN", "JPN", "JPN", "JPN", "JPN", "KOR", "KOR", "KOR", "KOR", | |
| "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", | |
| "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "KOR", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", | |
| "NZL", "NZL", "NZL", "NZL", "NZL", "NZL", "THA", "THA", "THA", | |
| "THA", "THA", "THA", "THA", "THA", "THA", "THA", "THA", "THA", | |
| "THA", "THA", "THA", "THA", "THA", "THA", "TWN", "TWN", "TWN", | |
| "TWN", "TWN", "TWN", "TWN", "TWN", "TWN", "TWN", "TWN", "TWN", | |
| "TWN", "TWN"), IMD1008_YEAR = c(2005L, 2005L, 2005L, 2005L, 2005L, | |
| 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 1998L, 1998L, | |
| 1998L, 1998L, 1998L, 1998L, 1998L, 1998L, 2002L, 2002L, 2002L, | |
| 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, | |
| 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, | |
| 2005L, 2005L, 2005L, 2005L, 2005L, 2005L, 2009L, 2009L, 2009L, | |
| 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, 2009L, | |
| 2009L, 2009L, 2009L, 2013L, 2013L, 2013L, 2013L, 2013L, 2013L, | |
| 2013L, 2013L, 2013L, 2013L, 2013L, 2013L, 2013L, 2013L, 2013L, | |
| 2013L, 1998L, 1998L, 1998L, 1998L, 1998L, 1998L, 1998L, 1998L, | |
| 1998L, 1998L, 1998L, 1998L, 2002L, 2002L, 2002L, 2002L, 2002L, | |
| 2002L, 2002L, 2002L, 1996L, 1996L, 1996L, 1996L, 1996L, 1996L, | |
| 1996L, 1996L, 1996L, 1996L, 2004L, 2004L, 2004L, 2004L, 2004L, | |
| 2004L, 2004L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, | |
| 2008L, 2012L, 2012L, 2012L, 2012L, 2012L, 2012L, 1996L, 1996L, | |
| 1996L, 1996L, 1996L, 1996L, 1996L, 1996L, 1996L, 1996L, 1996L, | |
| 1996L, 1996L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, | |
| 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2002L, 2008L, | |
| 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, | |
| 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, 2008L, | |
| 2011L, 2011L, 2011L, 2011L, 2011L, 2011L, 2011L, 2011L, 2011L, | |
| 2011L, 2011L, 2011L, 2014L, 2014L, 2014L, 2014L, 2014L, 2014L, | |
| 2014L, 2014L, 2014L, 2014L, 2014L, 2007L, 2007L, 2007L, 2007L, | |
| 2007L, 2007L, 2007L, 2011L, 2011L, 2011L, 2011L, 2011L, 2011L, | |
| 2011L, 2011L, 2011L, 2011L, 2011L, 2012L, 2012L, 2012L, 2012L, | |
| 2012L, 2012L, 2012L, 2012L, 2012L, 2012L, 2012L, 2012L, 2012L, | |
| 2012L), party = c(80005L, 80002L, 80001L, 80003L, 80004L, 80033L, | |
| 80031L, 80032L, 80010L, 80030L, 9999992L, 80011L, 2760004L, 2760007L, | |
| 2760001L, 2760005L, 9999992L, 2760006L, 2760008L, 2760017L, 2760004L, | |
| 2760007L, 2760005L, 2760001L, 2760006L, 9999992L, 2760019L, 2760024L, | |
| 2760017L, 2760009L, 2760008L, 2760020L, 2760001L, 2760004L, 2760006L, | |
| 2760007L, 2760005L, 2760009L, 2760028L, 2760008L, 9999992L, 2760026L, | |
| 2760019L, 2760034L, 2760032L, 2760021L, 2760031L, 2760001L, 2760018L, | |
| 2760006L, 2760005L, 2760004L, 2760007L, 2760009L, 2760008L, 9999992L, | |
| 2760020L, 2760014L, 2760026L, 2760025L, 2760023L, 2760028L, 2760007L, | |
| 2760004L, 2760001L, 2760014L, 2760005L, 2760010L, 9999992L, 2760006L, | |
| 2760009L, 2760025L, 2760020L, 2760021L, 2760026L, 2760008L, 2760022L, | |
| 2760030L, 3480007L, 3480002L, 3480013L, 3480008L, 3480001L, 3480006L, | |
| 3480032L, 9999992L, 9999989L, 3480004L, 3480014L, 3480009L, 3480012L, | |
| 3480001L, 3480006L, 3480008L, 3480004L, 3480033L, 9999992L, 3480013L, | |
| 3920012L, 9999989L, 3920002L, 3920004L, 3920001L, 3920006L, 3920019L, | |
| 3920013L, 3920014L, 3920018L, 4100010L, 4100021L, 4100001L, 4100015L, | |
| 9999992L, 4100011L, 4100020L, 9999992L, 4100001L, 4100007L, 4100004L, | |
| 4100002L, 4100003L, 4100015L, 4100017L, 4100004L, 4100001L, 4100005L, | |
| 9999989L, 9999992L, 4100002L, 5540003L, 5540001L, 5540009L, 5540004L, | |
| 5540002L, 5540037L, 5540015L, 9999992L, 5540021L, 5540034L, 5540038L, | |
| 5540023L, 5540016L, 5540002L, 5540001L, 9999992L, 5540009L, 5540023L, | |
| 5540003L, 5540004L, 5540012L, 5540005L, 5540014L, 5540006L, 9999989L, | |
| 5540025L, 5540036L, 5540038L, 5540008L, 5540002L, 5540012L, 5540001L, | |
| 5540003L, 5540004L, 5540005L, 9999992L, 5540006L, 5540033L, 5540032L, | |
| 5540026L, 5540019L, 5540009L, 5540018L, 5540029L, 5540022L, 5540038L, | |
| 5540039L, 5540001L, 5540002L, 5540006L, 5540005L, 5540007L, 5540003L, | |
| 9999992L, 5540035L, 5540004L, 5540011L, 5540008L, 5540009L, 5540005L, | |
| 5540002L, 5540001L, 5540007L, 5540003L, 5540004L, 9999989L, 9999992L, | |
| 5540006L, 5540008L, 5540010L, 7640021L, 7640014L, 7640002L, 7640008L, | |
| 7640024L, 7640060L, 7640018L, 7640001L, 7640002L, 7640004L, 7640007L, | |
| 7640006L, 9999992L, 7640005L, 7640003L, 7640017L, 7640008L, 7640009L, | |
| 1580002L, 1580001L, 9999989L, 1580003L, 1580025L, 1580005L, 1580007L, | |
| 1580015L, 1580026L, 1580024L, 9999992L, 1580027L, 1580004L, 1580006L | |
| ), seats = c(7L, 56L, 42L, 5L, 11L, 2L, 4L, 0L, 2L, 4L, NA, 3L, | |
| 298L, 36L, 245L, 47L, 0L, 43L, 0L, 0L, 251L, 2L, 55L, 248L, 47L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 0L, 226L, 222L, 61L, 54L, 51L, 0L, 0L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 239L, 0L, 93L, 68L, 146L, 76L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 64L, 193L, 311L, 0L, 63L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 17L, 148L, 48L, 24L, | |
| 134L, 0L, 0L, 0L, 1L, 14L, 0L, 0L, 188L, 178L, 0L, 19L, 0L, 0L, | |
| 1L, 0L, 156L, 9L, 52L, 26L, 239L, 15L, 0L, 2L, 1L, 0L, 9L, 152L, | |
| 121L, 10L, 2L, 4L, 1L, 25L, 153L, 14L, 81L, 18L, 0L, 5L, 0L, | |
| 127L, 152L, 13L, 3L, NA, 5L, 17L, 44L, 13L, 8L, 37L, 0L, 1L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 52L, 27L, 0L, 0L, 0L, 13L, 9L, 2L, 9L, | |
| 0L, 8L, 0L, 0L, 0L, 0L, 5L, 43L, 1L, 58L, 0L, 5L, 9L, 0L, 1L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 59L, 34L, 1L, 14L, 0L, | |
| 8L, 0L, 0L, 1L, 1L, 3L, 0L, 14L, 32L, 60L, 0L, 11L, 1L, 0L, 0L, | |
| 1L, 2L, 0L, 37L, 232L, 166L, 24L, 8L, 9L, 4L, 265L, 159L, 4L, | |
| 1L, 7L, 2L, 19L, 34L, 0L, 2L, 7L, 64L, 40L, 1L, 3L, 0L, 0L, 2L, | |
| 0L, 0L, 0L, 0L, 0L, 0L, 3L), seats_total = c(140L, 140L, 140L, | |
| 140L, 140L, 140L, 140L, 140L, 140L, 140L, 140L, 140L, 669L, 669L, | |
| 669L, 669L, 669L, 669L, 669L, 669L, 603L, 603L, 603L, 603L, 603L, | |
| 603L, 603L, 603L, 603L, 603L, 603L, 603L, 614L, 614L, 614L, 614L, | |
| 614L, 614L, 614L, 614L, 614L, 614L, 614L, 614L, 614L, 614L, 614L, | |
| 622L, 622L, 622L, 622L, 622L, 622L, 622L, 622L, 622L, 622L, 622L, | |
| 622L, 622L, 622L, 622L, 631L, 631L, 631L, 631L, 631L, 631L, 631L, | |
| 631L, 631L, 631L, 631L, 631L, 631L, 631L, 631L, 631L, 386L, 386L, | |
| 386L, 386L, 386L, 386L, 386L, 386L, 386L, 386L, 386L, 386L, 386L, | |
| 386L, 386L, 386L, 386L, 386L, 386L, 386L, 500L, 500L, 500L, 500L, | |
| 500L, 500L, 500L, 500L, 500L, 500L, 299L, 299L, 299L, 299L, 299L, | |
| 299L, 299L, 299L, 299L, 299L, 299L, 299L, 299L, 299L, 299L, 300L, | |
| 300L, 300L, 300L, 300L, 300L, 120L, 120L, 120L, 120L, 120L, 120L, | |
| 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, | |
| 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, 120L, | |
| 122L, 122L, 122L, 122L, 122L, 122L, 122L, 122L, 122L, 122L, 122L, | |
| 122L, 122L, 122L, 122L, 122L, 122L, 122L, 122L, 121L, 121L, 121L, | |
| 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, | |
| 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, 121L, 480L, 480L, | |
| 480L, 480L, 480L, 480L, 480L, 500L, 500L, 500L, 500L, 500L, 500L, | |
| 500L, 500L, 500L, 500L, 500L, 113L, 113L, 113L, 113L, 113L, 113L, | |
| 113L, 113L, 113L, 113L, 113L, 113L, 113L, 113L), nominal_share = c(NA, | |
| NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 43.8, 4.92, 39.58, | |
| 4.98, NA, 3.02, 2.27, 0, 41.93, 4.35, 5.63, 41.07, 5.75, NA, | |
| 0.16, 0.25, 0.22, 0.22, 0.12, 0.12, 40.85, 38.41, 4.68, 7.98, | |
| 5.38, 1.82, 0.16, 0.08, NA, 0.02, 0.01, 0.09, 1e-04, 0.12, 1e-04, | |
| 39.42, NA, 9.43, 9.2, 27.93, 11.08, 1.78, 0.07, NA, 0.24, 0.11, | |
| 0.04, 0, 0, 0.01, 8.22, 29.44, 45.33, 2.21, 7.29, 1.86, NA, 2.36, | |
| 1.46, 0.99, 0.29, 5e-04, 0.01, 0.06, 5e-04, 0.09, 7.68, 21.4, | |
| 13.3, 10.21, 29.82, 3.7, 2.9, NA, 1.7, 5.58, 0, 1.97, 39.43, | |
| 40.5, 1.93, 6.77, 4.58, 3.24, NA, 1.2, 27.97, 4.44, 10.62, 12.55, | |
| 38.63, 2.19, NA, 1.29, 0.26, NA, 7.96, 41.99, 37.9, 4.31, NA, | |
| 2.67, 0.3, NA, 43.45, 3.7, 28.92, 5.72, 1.33, 3.39, NA, 37.85, | |
| 43.28, 5.99, 9.35, NA, 2.2, 13.49, 33.91, 11.25, 3.75, 31.08, | |
| 1.55, 2.07, NA, 0.36, 0.59, 0.17, 0.23, 0.21, 44.69, 30.54, NA, | |
| 1.69, 0.41, 3.98, 3.55, 1.84, 5.35, 2.05, 4.63, 0.75, 0.03, 0, | |
| 0.17, 3.34, 35.22, 1.13, 46.6, 1.69, 2.99, 5.63, NA, 1.13, 0.01, | |
| 0.05, 0.68, 0.08, 0.08, 0.42, 0.4, 0.02, 0.17, 0, 47.31, 35.12, | |
| 0.87, 7.16, 2.38, 1.87, NA, 0.1, 1.43, 1.38, 1.81, 0.06, 7.06, | |
| 34.13, 46.08, 3.45, 3.13, 1.18, 0.16, NA, 0.63, 1.79, 1.58, 8.68, | |
| 36.09, 29.61, 8.89, 5.23, 4.66, 2.24, 43.02, 30.55, 0, 0.42, | |
| 3.79, NA, 4.62, 10.62, 0.35, 1.11, 0.74, 48.18, 43.8, 4.05, 1.33, | |
| 0.07, 0.61, 1.28, 0.15, 0.15, 0.04, NA, 0.12, 0.08, 0), list_share = c(NA, | |
| NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 40.93, 5.1, 35.14, | |
| 6.7, NA, 6.25, 1.84, 1.22, 38.52, 3.99, 8.56, 38.51, 7.37, NA, | |
| 0.24, 0.83, 0.45, 0.45, 0.58, 0.12, 35.17, 34.25, 9.83, 8.71, | |
| 8.12, 1.58, 0.41, 0.56, NA, 0.23, 0.42, 0.08, 0.05, 0.23, 0.06, | |
| 33.8, NA, 14.56, 10.71, 23.03, 11.89, 1.47, 0.45, NA, 0.3, 1.95, | |
| 0.53, 0.03, 0.13, 0.28, 8.59, 25.73, 41.55, 2.19, 8.45, 4.7, | |
| NA, 4.76, 1.28, 0.97, 0.29, 0.04, 0.32, 0.21, 0.06, 0.18, 2.8, | |
| 29.48, 13.15, 7.57, 32.92, 3.95, 2.31, NA, 0, 5.47, 0, 1.34, | |
| 41.07, 42.05, 2.16, 5.57, 4.37, 3.9, NA, 0.75, 28.04, 0, 16.1, | |
| 13.08, 32.76, 6.38, NA, 1.05, 0.03, NA, 7.09, 38.27, 35.77, 13.03, | |
| NA, 2.82, 0.56, NA, 37.48, 13.18, 25.18, 6.85, 2.94, 5.68, NA, | |
| 36.46, 42.8, 10.31, 0, NA, 3.24, 13.35, 33.84, 10.1, 6.1, 28.19, | |
| 4.33, 0.88, NA, 0.26, 0.29, 1.66, 0.2, 0.07, 41.26, 20.93, NA, | |
| 1.27, 0.25, 10.38, 7.14, 1.7, 7, 1.35, 5.04, 0, 0.29, 1.28, 0.64, | |
| 2.39, 33.99, 0.91, 44.93, 1.65, 3.65, 6.72, NA, 0.87, 0.01, 0.02, | |
| 0.54, 0.05, 0.08, 0.37, 0.35, 0.04, 0.41, 0.56, 47.31, 27.48, | |
| 0.6, 11.06, 2.65, 6.59, NA, 0.08, 1.07, 1.08, 1.43, 0.05, 10.7, | |
| 25.13, 47.04, 3.97, 8.66, 0.69, 0, NA, 0.22, 1.31, 1.42, 3.92, | |
| 39.84, 39.23, 5.16, 1.45, 2.39, 1.32, 47.03, 34.14, 2.98, 0.85, | |
| 1.48, NA, 2.71, 3.83, 0.34, 0.75, 0.53, 44.55, 34.62, 0, 5.49, | |
| 0.15, 1.74, 0, 1.24, 0.9, 0, NA, 0.23, 1.49, 8.96)), class = "data.frame", row.names = c(NA, | |
| -231L)) | |
| ### We need to write a function which takes individual data, and auxiliary data | |
| ### reweights to match known totals | |
| ### calculates the joint distribution | |
| ### calculates the advantage ratios | |
| sl <- function(aux) { | |
| v <- aux$list_share / 100 | |
| s <- aux$seats / aux$seats_total | |
| a <- s / v | |
| sum(v * (a - 1)^2, na.rm = TRUE) | |
| } | |
| sl_star <- function(ind, aux) { | |
| ### Just people for whom we have a record of both votes | |
| ind <- ind |> | |
| filter(IMD3002_LH_DC != 9999988) |> | |
| filter(IMD3002_LH_PL != 9999988) |> | |
| filter(IMD3002_LH_DC != 9999999) |> | |
| filter(IMD3002_LH_PL != 9999999) | |
| ### Convert these to characters | |
| ind <- ind |> | |
| mutate(IMD3002_LH_PL = as.character(IMD3002_LH_PL), | |
| IMD3002_LH_DC = as.character(IMD3002_LH_DC)) | |
| ### The auxiliary data frame has the proportions | |
| ### Remove any "others" | |
| aux <- aux |> | |
| filter(party != 9999992) | |
| dc_weights <- aux$nominal_share | |
| names(dc_weights) <- as.character(aux$party) | |
| pl_weights <- aux$list_share | |
| names(pl_weights) <- as.character(aux$party) | |
| ### Remove zero weights | |
| dc_weights <- dc_weights[which(dc_weights > 0)] | |
| pl_weights <- pl_weights[which(pl_weights > 0)] | |
| ### Add "other" back on | |
| dc_weights <- c(dc_weights, | |
| "9999992" = 100 - sum(dc_weights)) | |
| pl_weights <- c(pl_weights, | |
| "9999992" = 100 - sum(pl_weights)) | |
| dc_weights <- dc_weights / 100 | |
| pl_weights <- pl_weights / 100 | |
| if (any(dc_weights <= 0)) { | |
| stop("Negative/zero weights in district results") | |
| } | |
| if (any(pl_weights <= 0)) { | |
| stop("Negative/zero weights in list results") | |
| } | |
| ### Are there any constituency votes not found in the targets? | |
| tgts <- list("IMD3002_LH_DC" = dc_weights, | |
| "IMD3002_LH_PL" = pl_weights) | |
| err1 <- setdiff(unique(ind$IMD3002_LH_DC), | |
| names(tgts$IMD3002_LH_DC)) | |
| err2 <- setdiff(unique(ind$IMD3002_LH_PL), | |
| names(tgts$IMD3002_LH_PL)) | |
| if (length(err1) > 0) { | |
| nerrs <- length(which(ind$IMD3002_LH_DC %in% err1)) | |
| message(paste0(nerrs, | |
| " voters report voting for a party which received no votes in districts")) | |
| ind <- ind |> | |
| filter(!is.element(IMD3002_LH_DC, err1)) | |
| } | |
| if (length(err2) > 0) { | |
| nerrs <- length(which(ind$IMD3002_LH_PL %in% err2)) | |
| message(paste0(nerrs, | |
| " voters report voting for a party which received no votes in districts")) | |
| ind <- ind |> | |
| filter(!is.element(IMD3002_LH_PL, err2)) | |
| } | |
| ### What about cases where there is a target but no data? | |
| err1 <- setdiff(names(tgts$IMD3002_LH_DC), | |
| unique(ind$IMD3002_LH_DC)) | |
| err2 <- setdiff(names(tgts$IMD3002_LH_PL), | |
| unique(ind$IMD3002_LH_PL)) | |
| ### Add these on to the data frame | |
| while (length(err1) > 0) { | |
| addon <- ind[1,] | |
| addon$IMD3002_LH_DC <- err1[1] | |
| addon$IMD3002_LH_PL <- "9999992" | |
| ind <- do.call("rbind", list(ind, addon)) | |
| err1 <- setdiff(names(tgts$IMD3002_LH_DC), | |
| unique(ind$IMD3002_LH_DC)) | |
| } | |
| while (length(err2) > 0) { | |
| addon <- ind[1,] | |
| addon$IMD3002_LH_DC <- "9999992" | |
| addon$IMD3002_LH_PL <- err2[1] | |
| ind <- do.call("rbind", list(ind, addon)) | |
| err2 <- setdiff(names(tgts$IMD3002_LH_PL), | |
| unique(ind$IMD3002_LH_PL)) | |
| } | |
| ind$caseid <- 1:nrow(ind) | |
| ind <- as.data.frame(ind) | |
| ind <- autumn::harvest(ind, tgts) | |
| ### Get the joint distribution | |
| ### Convert to "first" and "second" sorted by alphabetic order | |
| ind <- ind |> | |
| mutate(first = pmin(IMD3002_LH_DC, IMD3002_LH_PL), | |
| second = pmax(IMD3002_LH_DC, IMD3002_LH_PL)) | |
| ### Now we wish to see the distribution of types | |
| ### We sum up the weights by each combination, and pivot wider | |
| types <- ind |> | |
| group_by(first, second) |> | |
| summarize(weight = sum(weights, na.rm = TRUE), | |
| .groups = "drop") |> | |
| mutate(prop = weight / sum(weight)) | |
| ### Get the shares corresponding to these parties | |
| shares <- lapply(unique(c(types$first, types$second)), | |
| function(p) { | |
| pos <- which(types$first == p | types$second == p) | |
| share <- sum(types$prop[pos]) | |
| data.frame(party = p, | |
| share = share) | |
| }) |> | |
| bind_rows() | |
| types <- left_join(types, | |
| shares, | |
| by = join_by(first == party)) | |
| types <- left_join(types, | |
| shares, | |
| by = join_by(second == party), | |
| suffix = c(".first", ".second")) | |
| ### Now add the seats on -- found in the aux frame | |
| types <- left_join(types, | |
| aux |> | |
| dplyr::select(party, seats) |> | |
| mutate(party = as.character(party)), | |
| by = join_by(first == party)) | |
| types <- left_join(types, | |
| aux |> | |
| dplyr::select(party, seats) |> | |
| mutate(party = as.character(party)), | |
| by = join_by(second == party), | |
| suffix = c(".first", ".second")) | |
| types <- types |> | |
| mutate(adv_first = seats.first / share.first, | |
| adv_second = seats.second / share.second, | |
| adv_combined = adv_first / 2 + adv_second / 2) | |
| ### Normalize | |
| pop_wtd_avg <- weighted.mean(types$adv_combined, | |
| types$prop, | |
| na.rm = TRUE) | |
| types$adv_adjusted <- types$adv_combined / pop_wtd_avg | |
| return(weighted.mean((types$adv_adjusted - 1)^2, | |
| types$prop, | |
| na.rm = TRUE)) | |
| } | |
| holder <- cses_imd |> | |
| distinct(IMD1006_UNALPHA3, IMD1008_YEAR) | |
| holder$sl_star <- holder$sl <- NA | |
| for (i in 1:nrow(holder)) { | |
| country <- holder$IMD1006_UNALPHA3[i] | |
| year <- holder$IMD1008_YEAR[i] | |
| ind <- cses_imd |> | |
| filter(IMD1006_UNALPHA3 == country) |> | |
| filter(IMD1008_YEAR == year) | |
| aux <- mapping |> | |
| filter(IMD1006_UNALPHA3 == country) |> | |
| filter(IMD1008_YEAR == year) | |
| holder$sl[i] <- sl(aux) | |
| holder$sl_star[i] <- sl_star(ind, aux) | |
| } | |
| ### Work out which cases are mixed member proportional which parallel | |
| holder <- holder |> | |
| mutate(type = case_when(IMD1006_UNALPHA3 %in% c("KOR", "HUN", "THA", | |
| "TWN", "JPN") ~ "Parallel", | |
| TRUE ~ "Proportional")) | |
| ### Colour should equal sl_star / sl - 1 | |
| holder <- holder |> | |
| mutate(col = sl_star / sl - 1) | |
| holder <- do.call("rbind", | |
| list(holder, | |
| data.frame(IMD1006_UNALPHA3 = "SCO", | |
| IMD1008_YEAR = 2021, | |
| sl = .069, | |
| sl_star = .053, | |
| col = 0.053 / 0.069 - 1, | |
| type = "Proportional"))) | |
| ggplot(holder, aes(x = sl, | |
| y = sl_star, | |
| fill = col)) + | |
| geom_abline(linetype = 2, colour = 'grey') + | |
| geom_point(aes(shape = type), size = 4, alpha = 3/4) + | |
| geom_text_repel(aes(label = paste0(IMD1006_UNALPHA3, | |
| IMD1008_YEAR)), | |
| vjust = 2) + | |
| annotate(geom = "text", | |
| x = 0.1 - .0025, | |
| y = 0.1 + .0025, | |
| angle = 45, | |
| label = "Looks more proportional under basic S-L", | |
| colour = scales::muted("blue")) + | |
| annotate(geom = "text", | |
| x = 0.1 + .0025, | |
| y = 0.1 - .0025, | |
| angle = 45, | |
| colour = scales::muted("red"), | |
| label = "Looks more proportional under extended S-L") + | |
| geom_smooth(method = "lm", | |
| se = FALSE, | |
| fullrange = TRUE, | |
| colour = "darkgrey", | |
| formula = y ~ x - 1) + | |
| scale_fill_gradient2(guide = "none") + | |
| scale_shape_manual("Mixed member... ", | |
| values = c(21, 25)) + | |
| scale_x_continuous("Basic Sainte-Laguë", | |
| labels = scales::percent, | |
| limits = c(0, NA), | |
| expand = expansion(mult = c(0, 0.05))) + | |
| scale_y_continuous("Extended Sainte-Laguë", | |
| labels = scales::percent, | |
| limits = c(0, NA), | |
| expand = expansion(mult = c(0, 0.05))) + | |
| theme_bw(base_size = 14) + | |
| coord_fixed(ratio = 1) + | |
| theme(legend.position = "bottom") |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment