UK 2019 MRP predictions: party preference by age and likely turnout

MRP_predictions_age.R

# Data from https://yg-infographics-data.s3-eu-west-1.amazonaws.com/ZAfbtHgj42wx4reHnaMtbBamoKdMxkFMpz4gnWMjiZCUAxDX66MsCB38K/2019_data/MRP_Tables_2019_Election_Public_Release.pdf

library(tidyverse)
theme_set(theme_minimal()) # no mouldy waffle

age <- "Age Con Lab LD Brexit Green SNP PC Other Turnout Fraction
18-25 22 53 13 2 5 4 0 1 52 8
25-30 26 48 13 2 5 4 0 1 52 6
30-35 30 43 15 2 4 4 0 1 57 7
35-40 36 38 15 2 4 3 0 1 63 7
40-45 39 34 16 3 4 3 0 1 66 7
45-50 42 31 15 3 3 4 0 1 70 9
50-55 44 30 14 3 3 4 1 1 74 10
55-60 45 29 13 4 3 4 1 1 79 9
60-65 48 28 13 4 2 4 1 2 83 8
65-70 53 23 12 4 2 3 1 2 85 8
70-75 59 18 13 3 2 3 0 1 85 7
75-80 60 18 13 3 2 3 0 1 85 5
80-85 62 17 12 3 2 3 0 2 87 4
85+ 63 15 12 4 2 2 0 2 90 2"

byage <- read_delim(age, delim = " ") %>%
  select(Age, Con, Lab, LD, Turnout, Fraction) %>%
  mutate(Other = 100 - (Con + Lab + LD)) %>%
  mutate_at(c("Con", "Lab", "LD", "Other"), # turnout model: p(turnout | age, pref) = p(turnout | age)
            list(out = ~ . * Turnout / 100,
                 home = ~ . * (1 - Turnout / 100))) %>%
  pivot_longer(contains("_"), names_to = "Party", values_to = "Support") %>%
  separate(Party, into = c("Party", "turnout")) %>%
  select(Age, Fraction, turnout, Party, Support)

# https://en.wikipedia.org/wiki/Wikipedia:Index_of_United_Kingdom_political_parties_meta_attributes
party_colors <- c(Con = "#0087DC", LD = "#FAA61A", Lab = "#DC241f", Other = "black")
party_names <-  c(Con = "Conservatives", LD = "Liberal Democrats", Lab = "Labour", Other = "Other")

ggplot(byage, aes(x = Age, y = Support, fill = Party,
                  alpha = turnout, width = Fraction / 10)) +
  geom_col() +
  scale_fill_manual(values = party_colors, labels = party_names) +
  scale_alpha_manual(values = c(out = 1, home = 0.6),
                     labels = c(out = "Turns out", home = "Stays home")) +
  labs(x = "Age band", y = "Support", fill = "Party", alpha = "Shading",
       title = "Predicted UK party Vote Shares") +
  theme(panel.grid.major.x = element_blank(),
        panel.grid.minor.x = element_blank())

ggsave("predvoteshares.png", width = 8.5, height = 5)

Note that this graph implements an unrealistic turnout model that assumes that age does, but preference over parties does not, alter the probability a potential voter actually turns out to vote. In the absence of a three way table of party preference x age x turnout, or the individual MRP predictions themselves, this is about as much as we can do.