A Multilevel Analysis of Titelman & Lauderdale’s (2021) Voting Demographic Forecasting
200381985
2026-08-05
Replication Project
Rpubs link: https://rpubs.com/s200381985/1451238
GitHub Repository link: https://github.com/seforbes1/Replication_Materials_200381985.git
Replication Project Information
Replication project based on:
Titelman, N. and Lauderdale, B.E. (2021a) Can citizens guess how other
citizens vote based on demographic characteristics? Political
Science Research and Methods, 11(2), 254-274. Available at: https://doi.org/10.1017/psrm.2021.53
Replication method using replication materials made available by
authors:
Titelman, N. and Lauderdale, B.E. (2021b) Replication data for: Can
citizens guess how other citizens vote based on demographic
characteristics? [dataset]. Harvard Dataverse. Available at: https://doi.org/10.7910/DVN/3OWF6C
Workplace setup
YAML settings
output:
html_document:
code_download: true
toc: true
toc_depth: 2
toc_float:
collapsed: false
smooth_scroll: trueGlobal chunk settings
knitr::opts_chunk$set(
echo = TRUE,
cache = TRUE,
comment = NA,
warning = FALSE,
message = FALSE,
fig.align = "center"
)Versions of used packages
This project uses the renv package for reproducibility. Run
renv::restore().
This will install all packages with the correct versions as specified in
the renv.lock file.
renv::restore()Libraries
# libraries supplied by authors replication materials
library(matlib)
library(DescTools)
library(survey)
library(dplyr)
library(ggplot2)
library(ggthemes)
library(gridExtra)
library(plotrix)
library(plyr)
library(coefplot)
library(questionr)
library(psych)
library(snakecase)
library(stargazer)
library(texreg)
library(tidyr)
library(forcats)
library(stringr)
library(kableExtra)
library(naniar)
library(papaja)
# libraries for replication extension
library(tidyverse)
library(sjPlot)
library(lme4)
library(lmerTest)
library(patchwork)Environment
[1] "R version 4.5.2 (2025-10-31 ucrt)"For more details on project environment please see Appendix 1.
Introduction
The ability of citizens to infer political preferences and behaviours from social information is key to understanding how individuals navigate social and political environments. Research suggests that citizens with greater political knowledge, engagement, and cognitive resources are better able to process political information and make accurate judgements about others’ preferences (Lewis-Beck and Stegmaier, 2011). However, whether these resources translate into accurate prediction of others’ behaviour remains an open empirical question.
Titelman and Lauderdale (2021a) demonstrate that citizens can, to an extent, predict others’ voting behaviour using demographic information, while further linking individual demographics like political knowledge and attention to facilitate this forecasting ability, with politically engaged respondents found to achieve greater accuracy in their study. They use experimental profiles where respondents predict their voting behaviour based on given profile demographics.
This replication project will assess part of this paper relating to Table 1 of Titelman and Lauderdale’s analysis (2021a, p. 270), where they claimed to have found that accuracy of voting behaviour increased when certain respondent-level demographic characteristics were present, specifically political attention. Though they do not overstate any causal claim, their choice of regression analysis does not account for possible unobserved respondent-level heterogeneity.
Following the dimensions of replication outlined by Freese and Peterson (2017), this study primarily focuses on robustness, alongside an assessment of verifiability. This project begins by assessing whether the available replication package can reproduce the papers original results, finding partial verifiability due to inconsistencies in the data-cleaning and analysis pipeline. Although the authors provide replication materials, key stages of data processing and transformation are not fully documented, limiting complete reproduction from raw data. While this study evaluates verifiability using the provided replication materials, it does not constitute a full end-to-end reproduction from raw data sources, limiting the extent to which the complete data generation process can be independently verified.
Repeatability and generalisability are not tested within this project, relying exclusively on the original cleaned datasets provided rather than collecting new data or re-running their experimental design, and remains confined to the original experimental context of the 2017 UK political climate. The extent to which these findings apply to other political contexts, time periods or populations remain open to question, and this project does not evaluate whether these findings would reproduce under repeated data collection.
The primary aim of this project is to assess robustness by analysing the same data under alternative modelling assumptions. By changing the modelling strategy, this replication tests whether the authors’ findings are sensitive to different modelling assumptions. There is an argument for their chosen modelling strategy ignoring repeated observations per respondent. While Titelman and Lauderdale (2021a, p. 259) consider the implications of their experimental design for causal interpretation, they do not address a separate but important issue arising from the structure of their data: each respondent evaluates multiple profiles. This generates repeated observations nested within individual respondents, violating the assumption of independent observations underlying their chosen OLS models and potentially leading to underestimated standard errors (Finch, 2026; Maas & Hox, 2005). If the original results are partly driven by clustered observations, it is expected that multilevel models increase standard errors and reduce the statistical significance of some coefficients (Bickel, 2007; Raudenbush & Bryk, 2002; Snijders & Bosker, 2012). Based on prior research on clustered data structures and multilevel modelling (Gelman & Hill, 2007; Maas & Hox, 2005), it is expected that accounting for respondent-level clustering will increase standard errors and reduce the statistical significance of some predictors observed in the original OLS models. Substantively, while political attention and education are expected to remain positively associated with forecasting accuracy, their estimated effects are likely to be smaller and less precise once unobserved individual-level heterogeneity is accounted for. Therefore, this study extends the original analysis by examining whether its conclusions remain robust when accounting for the clustered structure of the experimental design through a multilevel modelling approach.
Data and Methods
Data
This analysis uses experimental replication datasets provided by
Titelman and Lauderdale (2021b), combining data from the 2017 British
Election Study (BES) face-to-face survey (Fieldhouse et al., 2019), and
an online YouGov experiment. The replication package contains layered
datafiles CleanBrexit.RData and
CleanParties.RData.
Retrospectively within these, contain imputed
Brexit.BES.Clean and Parties.BES.Clean data of
BES-sourced demographic profiles, and the final analysis datasets
Brexit.Experiment.Clean and
Parties.Experiment.Clean containing respondents’
demographic characteristics and their voting predictions combined with
the imputed BES.Clean data. These
.Experiment.Clean datasets contain repeated observations as
respondents evaluated multiple demographic profiles.
The supplied .RData files were loaded and chunks of the
authors’ original analysis script appendix.rmd were
executed to recreate the required outcome variables (see Appendix 2),
which were not included in the authors original cleaned datasets. Coding
was chunked and referenced to signal authorship of
appendix.rmd code (Titelman & Lauderdale, 2021c).
# load Brexit Datafile
load("Data/InputData/CleanBrexit.RData")
# load Party Datafile
load("Data/InputData/CleanParties.RData")Verification checks confirmed consistency with the original data and model specification, including treatment of political attention as numeric and demographic variables as categorical factors. Exact reproduction of reported statistical significance levels was not possible due to discrepancies between the supplied replication materials and published outputs; however, coefficient direction, model specification, and variable construction were successfully reproduced sufficiently to conduct the robustness extension (see Appendix 2, Table A1).
# run original models for verification
# brier - brexit
modelBrier_brex <- lm(BrierScore ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = Brexit.Experiment.Clean$respondent_weights,
data = Brexit.Experiment.Clean)
# brier - party
modelBrier_party <- lm(BrierScore ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = Parties.Experiment.Clean$respondent_weights,
data = Parties.Experiment.Clean)
# dichot - brexit
modelDicho_brex <- lm(Correct.Dich.Guess.Brex ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = fitted_BESCoef_BrexExp$respondent_weights, data = fitted_BESCoef_BrexExp)
# dichot - Party
modelDicho_party <- lm(Correct.Dich.Guess.Party ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = fitted_BESCoef_PartyExp$respondent_weights, data = fitted_BESCoef_PartyExp)Four analytical datasets were subsequently constructed
(brexit_brier, brexit_dicho,
parties_brier, and parties_dicho) containing
the variables required for the replicated and extended models.
# Create new dataframes relevant for replication project
# 1. BREXIT DATA: New dataframe extracting and renaming only the core analytical variables
brexit_brier <- Brexit.Experiment.Clean %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
brier_score = BrierScore,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 2. BREXIT & DICHOTOMOUS DATA: New dataframe for Dicho analysis
brexit_dicho <- fitted_BESCoef_BrexExp %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
dicho_score = Correct.Dich.Guess.Brex,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 3. PARTIES EXPERIMENT DATA: New dataframe extracting only the core analytical variables
parties_brier <- Parties.Experiment.Clean %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
brier_score = BrierScore,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 4. PARTIES & DICHOTOMOUS: New dataframe for dicho analysis
parties_dicho <- fitted_BESCoef_PartyExp %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
dicho_score = Correct.Dich.Guess.Party,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)Variables were renamed and subsetted while preserving the original
coding structure, factor levels, and reference categories. Both new
brexit_ and parties_ datasets contain
identical predictor variable information. Datasets are distinguished by
containing either brier or dicho dependent
variables.
# recode variables for modelling and interpretation
# ensure pol_attention is a numeric variable in all datasets
brexit_brier$pol_attention <- as.numeric(brexit_brier$pol_attention)
brexit_dicho$pol_attention <- as.numeric(brexit_dicho$pol_attention)
parties_brier$pol_attention <- as.numeric(parties_brier$pol_attention)
parties_dicho$pol_attention <- as.numeric(parties_dicho$pol_attention)
# Ensure respondent_id is set up as a factor variable in all datasets
brexit_brier$respondent_id <- as.factor(brexit_brier$respondent_id)
brexit_dicho$respondent_id <- as.factor(brexit_dicho$respondent_id)
parties_brier$respondent_id <- as.factor(parties_brier$respondent_id)
parties_dicho$respondent_id <- as.factor(parties_dicho$respondent_id)The replicated model examines predictors of respondent forecasting accuracy using two dependent variables: the continuous Brier Score, where lower values indicate greater prediction accuracy, and the Correct Dichotomised Guess measure, which captures directional accuracy on a 0–0.5–1 scale.
Figure 1 shows that Brier scores are distributed similarly across both experimental groups, with most responses concentrated toward lower values, indicating better accuracy among respondents. However, the spike present in both groups suggest that respondents may systematically overestimate the accuracy of their guesses.
Figure 2 demonstrates that correct predictions were the most common
outcome in both experiments, although a substantial proportion of
guesses were incorrect.
Independent variables include political attention, 2017 general election vote, EU referendum vote, age, education, gender, and region; their summary statistics are displayed below in Table 1 and Table 2.
|
|
Table 1 demonstrates variation in respondents’ previous voting behaviour and referendum choices, showing the connection between political voting patterns across the sample.
# Brexit sample distribution
edu_brex <- prop.table(table(brexit_brier$education)) * 100
# Parties sample distribution
edu_parties <- prop.table(table(parties_brier$education)) * 100
edu_brex_str <- paste(names(edu_brex), round(edu_brex, 1), "%", collapse = "; ")
edu_parties_str <- paste(names(edu_parties), round(edu_parties, 1), "%", collapse = "; ")
tibble(
`Sample` = c("Brexit", "Parties"),
`Education (%)` = c(edu_brex_str, edu_parties_str)
)# A tibble: 2 × 2
Sample `Education (%)`
<chr> <chr>
1 Brexit None 5.5 %; Level 1 3.9 %; Level 2 19.6 %; Level 3 18.3 %; Level 4 7.…
2 Parties None 4.9 %; Level 1 3.8 %; Level 2 18.8 %; Level 3 19 %; Level 4 8.8 …| Sample | Total (N) | Unique IDs | Mean Political Attention (0-10) | Mean Age (Years) | Gender (% Female) |
|---|---|---|---|---|---|
| Brexit | 5082 | 1694 | 6.07 | 49.11 | 55.61 |
| Parties | 5064 | 1688 | 6.09 | 49.36 | 55.69 |
Table 2 summaries the demographic characteristics used as predictors in the models.
Methods
Titelman and Lauderdale (2021a) employ Ordinary Least Squares (OLS) linear regressions to estimate whether respondent attributes predict forecasting accuracy. While this strategy assumes independent observations, because each respondent evaluated multiple demographic profiles, observations may be nested within individuals. Treating these evaluations as completely independent rows violates this assumption by failing to account for respondent-level characteristics that may influence guessing accuracy across experiments. Ignoring clustered data structures can lead to biased standard errors and overconfident inference (Raudenbush & Bryk, 2002; Snijders & Bosker, 2012). Multilevel models are widely recommended in such settings because they explicitly model within- and between-unit variation, producing more reliable estimates of uncertainty (Gelman & Hill, 2007).
To address this limitation, this replication extends the original analysis using Linear Mixed-Effects Models.
Before estimating the multilevel models, the replicated OLS specifications were re-estimated using the reconstructed datasets for verifiability with the original analytical framework (Freese & Peterson, 2007) (see Appendix 2, Table A2). After listwise deletion and application of supplied respondent weights, original analysis observations retain 3,308 for the Brexit experiment, and 3,394 for the Party experiment.
# run original models with new subsetted datasets for comparison
########## Brier Score ###########
# brier brexit
original_brier_brex <- lm(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = brexit_brier)
# brier party
original_brier_party <- lm(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = parties_brier)
######## Dichotomised ###########
# dicho brexit
original_dicho_brex <- lm(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = brexit_dicho)
# dicho party
original_dicho_party <- lm(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = parties_dicho)A random intercept was introduced for respondent ID (1 | respondent_id), modelling individual-level heterogeneity and separates between-respondent from within-respondent variation. Respondent identifiers were retained from the original data and converted into a factor variable to enable the multilevel specification. Investigation of respondent_id variables show 1,694 individual respondents in the Brexit experiment, and 1,688 in the party experiment. Four multilevel models were subsequently run.
# Run multilevel model with respondent ID's as nested variable
###### Brier #######
# mixed brier brexit model
mixed_brier_brex <- lmer(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = brexit_brier)
# mixed brier party model
mixed_brier_party <- lmer(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = parties_brier)
###### dicho ######
# dicho brexit
mixed_dicho_brex <- lmer(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = brexit_dicho)
# dicho party
mixed_dicho_party <- lmer(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = parties_dicho)Model fit was assessed using AIC differences and likelihood ratio tests comparing models with and without respondent-level random effects (Finch, 2026). Multilevel approaches were appropriate for clustered experimental data because they provide more accurate uncertainty estimates and reduce the risk of misleading inference arising from underestimated standard errors.
# comparing OLS model fit against Multilevel model fit
# Brier Score models
fit_test_brexit_brier <- anova(mixed_brier_brex, original_brier_brex)
fit_test_party_brier <- anova(mixed_brier_party, original_brier_party)
# Dicho models
fit_test_brexit_dicho <- anova(mixed_dicho_brex, original_dicho_brex)
fit_test_party_dicho <- anova(mixed_dicho_party, original_dicho_party)Data: brexit_brier
Models:
original_brier_brex: brier_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region
mixed_brier_brex: brier_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region + (1 | respondent_id)
npar AIC BIC logLik -2*log(L) Chisq Df Pr(>Chisq)
original_brier_brex 31 1646.5 1835.7 -792.24 1584.5
mixed_brier_brex 32 1597.3 1792.7 -766.66 1533.3 51.159 1 8.518e-13
original_brier_brex
mixed_brier_brex ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Data: parties_brier
Models:
original_brier_party: brier_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region
mixed_brier_party: brier_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region + (1 | respondent_id)
npar AIC BIC logLik -2*log(L) Chisq Df Pr(>Chisq)
original_brier_party 31 1480.8 1670.8 -709.40 1418.8
mixed_brier_party 32 1419.3 1615.5 -677.65 1355.3 63.498 1 1.605e-15
original_brier_party
mixed_brier_party ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Data: brexit_dicho
Models:
original_dicho_brex: dicho_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region
mixed_dicho_brex: dicho_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region + (1 | respondent_id)
npar AIC BIC logLik -2*log(L) Chisq Df Pr(>Chisq)
original_dicho_brex 31 4802.2 4991.4 -2370.1 4740.2
mixed_dicho_brex 32 4781.8 4977.2 -2358.9 4717.8 22.323 1 2.304e-06
original_dicho_brex
mixed_dicho_brex ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Data: parties_dicho
Models:
original_dicho_party: dicho_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region
mixed_dicho_party: dicho_score ~ pol_attention + past_vote_2017 + eu_ref_vote + age + education + gender + region + (1 | respondent_id)
npar AIC BIC logLik -2*log(L) Chisq Df Pr(>Chisq)
original_dicho_party 31 5049.8 5239.9 -2493.9 4987.8
mixed_dicho_party 32 5039.2 5235.3 -2487.6 4975.2 12.638 1 0.000378
original_dicho_party
mixed_dicho_party ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Results
The multilevel model reveals that forecasting accuracy is partly an individual-level trait. Incorporating a random intercept for individual respondents reveals that several demographic associations were less robust once respondent-level clustering was accounted for. When interpreting Table 4 results, it is important to note that a negative brier coefficient and a positive dichotomised coefficient represent improved respondent accuracy.
| Model Context & Comparison | OLS AIC | Multilevel AIC | Chi-Square | Significance (p-value) |
|---|---|---|---|---|
| Brexit Experiment: Brier Score | 1646.5 | 1597.3 | 51.159 | *** |
| Parties Experiment: Brier Score | 1480.8 | 1419.3 | 63.498 | *** |
| Brexit Experiment: Dichotomised Score | 4802.2 | 4781.8 | 22.323 | *** |
| Parties Experiment: Dichotomised Score | 5049.8 | 5039.2 | 12.638 | *** |
|
Brier Score
Brexit Exp. |
Brier Score
Party Exp. |
Correct Dichotomised Guess
Brexit Exp. |
Correct Dichotomised Guess
Party Exp. |
|||||
|---|---|---|---|---|---|---|---|---|
| Coefficient | Estimates | Standard Error | Estimates | Standard Error | Estimates | Standard Error | Estimates | Standard Error |
| Intercept | 0.404 *** | 0.050 | 0.341 *** | 0.053 | 0.459 *** | 0.079 | 0.525 *** | 0.086 |
| Political Attention | -0.007 * | 0.003 | -0.008 ** | 0.003 | 0.007 | 0.004 | 0.011 ** | 0.004 |
| Party Vote: Labour | 0.001 | 0.014 | -0.004 | 0.014 | 0.021 | 0.023 | 0.005 | 0.023 |
|
Party Vote: Liberal Democrat |
-0.029 | 0.024 | 0.020 | 0.023 | 0.049 | 0.038 | -0.011 | 0.037 |
| Party Vote: SNP | 0.046 | 0.042 | -0.030 | 0.039 | -0.077 | 0.066 | 0.068 | 0.064 |
| Party Vote: Plaid Cymru | -0.096 | 0.116 | 0.005 | 0.077 | 0.095 | 0.183 | -0.157 | 0.124 |
| Party Vote: UKIP | 0.070 | 0.042 | 0.048 | 0.045 | -0.032 | 0.067 | -0.052 | 0.073 |
| Party Vote: Green | -0.008 | 0.046 | -0.036 | 0.040 | 0.014 | 0.072 | 0.043 | 0.065 |
| Party Vote: Other | 0.072 | 0.076 | -0.007 | 0.071 | -0.151 | 0.121 | 0.000 | 0.114 |
| Party Vote: Don’t Know | -0.014 | 0.042 | -0.025 | 0.040 | 0.033 | 0.066 | 0.031 | 0.064 |
| EU Ref. Vote: Leave | 0.014 | 0.014 | 0.019 | 0.013 | -0.001 | 0.022 | -0.018 | 0.022 |
|
EU Ref. Vote: Did Not Vote |
0.037 | 0.032 | 0.037 | 0.028 | -0.010 | 0.051 | -0.022 | 0.045 |
| Age | -0.000 | 0.000 | -0.000 | 0.000 | 0.001 | 0.001 | -0.000 | 0.001 |
| Education Level: 1 | -0.099 * | 0.039 | -0.045 | 0.042 | 0.172 ** | 0.061 | 0.008 | 0.068 |
| Education Level: 2 | -0.033 | 0.028 | 0.006 | 0.030 | 0.044 | 0.044 | -0.030 | 0.049 |
| Education Level: 3 | -0.084 ** | 0.030 | -0.014 | 0.031 | 0.105 * | 0.046 | -0.002 | 0.050 |
| Education Level: 4 | -0.096 ** | 0.033 | 0.015 | 0.033 | 0.131 * | 0.052 | -0.065 | 0.054 |
|
Education Level: 5 and Above |
-0.080 ** | 0.028 | -0.003 | 0.030 | 0.104 * | 0.044 | -0.032 | 0.049 |
| Education Level: Other | -0.083 ** | 0.029 | -0.002 | 0.031 | 0.127 ** | 0.046 | -0.053 | 0.050 |
| Gender: Female | 0.001 | 0.012 | -0.012 | 0.012 | -0.006 | 0.019 | 0.002 | 0.019 |
| Region: North West | 0.042 | 0.034 | 0.023 | 0.034 | -0.107 * | 0.053 | 0.027 | 0.056 |
|
Region: Yorkshire and the Humber |
0.017 | 0.035 | 0.016 | 0.036 | -0.064 | 0.055 | 0.055 | 0.058 |
| Region: East Midlands | -0.014 | 0.036 | 0.018 | 0.036 | -0.024 | 0.057 | 0.009 | 0.058 |
| Region: West Midlands | 0.043 | 0.036 | 0.009 | 0.036 | -0.103 | 0.057 | 0.047 | 0.059 |
| Region: East of England | 0.002 | 0.035 | 0.025 | 0.036 | -0.055 | 0.054 | -0.036 | 0.057 |
| Region: London | 0.050 | 0.034 | 0.046 | 0.034 | -0.100 | 0.054 | -0.013 | 0.056 |
| Region: South East | 0.029 | 0.033 | 0.012 | 0.034 | -0.084 | 0.052 | 0.028 | 0.055 |
| Region: South West | 0.026 | 0.035 | 0.015 | 0.035 | -0.074 | 0.056 | 0.037 | 0.057 |
| Region: Wales | -0.005 | 0.041 | 0.003 | 0.040 | -0.103 | 0.064 | 0.044 | 0.066 |
| Region: Scotland | 0.013 | 0.039 | 0.042 | 0.038 | -0.008 | 0.061 | -0.029 | 0.061 |
| Random Effects | ||||||||
| σ2 | 0.08 | 0.07 | 0.21 | 0.21 | ||||
| τ00 | 0.01 respondent_id | 0.01 respondent_id | 0.02 respondent_id | 0.01 respondent_id | ||||
| ICC | 0.11 | 0.12 | 0.08 | 0.06 | ||||
| N | 1173 respondent_id | 1208 respondent_id | 1173 respondent_id | 1208 respondent_id | ||||
| Observations | 3308 | 3394 | 3308 | 3394 | ||||
| Marginal R2 / Conditional R2 | 0.021 / 0.128 | 0.009 / 0.127 | 0.014 / 0.089 | 0.009 / 0.069 | ||||
|
||||||||
The random effect estimates indicate clustering in the data, as reflected in the interclass correlation coefficient (ICC), showing that between 6% and 12% of total variance is attributed to respondent-level clustering (Table 4). This variance indicates that treating repeated respondent guesses as independent observations violates OLS assumptions. The correct dichotomised guess variance (6-8%) is, however, smaller than the random effects for respondents Brier scores (11-12%). This is substantively important when considering Titealman and Lauderdale’s (2021a, p. 271) claims on “wisdom of crowds” versus individual inaccuracy, where respondents on aggregate are more accurate that individual brier accuracy scores. The variance suggests that, even when accounting for unobserved individual differences, this crowd wisdom argument is less affected by random effects. When considering individual responses, forecasting ability can not be entirely explained by observable characteristics. Some respondents appear to have a general tendency to make more accurate predictions across voting scenarios, potentially reflecting unmeasured characteristics.
Table 3 also shows an improved fit, with AIC reductions ranging from 10.6 - 63.5 points and significant likelihood ratio tests (p < .001) across all four multilevel specifications.
Comparing to the original OLS framework (see Appendix, Table A2), political attention is shown to be a highly robust predictor of forecasting ability, achieving high significance across both experiments. Under the multilevel specification however, coefficients reduce across all for models, including a global reduction in significance (Table 4). Though strength and significance decreases, the general strength and trend remains, finding the parties experiment continuing to yield the most accurate and significant results. This suggests that, while politically attentive citizens do appear to have an advantage in guessing others’ voting behaviour, especially for infering partisan alignment, when accounting for nested data, this advantage may be smaller than Titelman & Lauderdale (2021a) initially estimated. While political engagement likely improves exposure to political information and awareness of electoral patterns, part of this apparent relationship may reflect broader individual differences among highly engaged respondents.
Concurrently, education coefficients remained directionally consistent but several categories showed reduced statistical certainty (Table 4). In the Brexit OLS baseline, higher tiers of education operate as highly significant predictors of accuracy, consistently achieving high significance (p < 0.001) (Appendix Table A2). Under the multilevel estimation (Table 4), however, education coefficients show a reduction in respondent accuracy, falling once high significance thresholds (p < 0.001). Similar to the comparative findings on political attention, the trend remains the same despite losing power and significance. While higher educational attainment may provide resources that facilitate understanding political behaviour, this suggest that education alone does not appear to fully explain why some citizens are better at predicting other voters.
Conversely to respondents level of political attention most improving in the parties experiment, higher education appears to improve the accuracy of respondents guesses for Brexit voting. This consistent trend substantiates Titelman and Lauderdale’s (2021a) findings that increased cognitive resources improve guessing ability, where greater attention to politics appears to aid more when inferring partisan alignment, and higher education links more to understanding the cleavages of the Brexit referendum. However, while these characteristics appear to still matter, their effects are smaller and less certain than originally stated.
Furthermore, some subgroup differences disappear, suggesting demographic characteristics were capturing individual differences rather than true group effects. For example, UKIP voters appeared less accurate in the original model (Appendix Table A1), but after accounting for respondent-level tendencies, this difference was no longer distinguishable from random variation (Table 4). These findings suggest that some apparent differences between groups may not represent genuine differences in citizens’ ability to understand political behaviour, but instead reflect differences between individuals who happened to be concentrated within those groups.
These findings qualify Titelman and Lauderdale’s (2021a) argument that political sophistication enhances prediction of political differences to an extent, while suggesting a more nuanced story that individual-level capacities beyond measured demographic resources also contribute to this accuracy. The difference between marginal and conditional R² in Table 4 (eg, Brexit - 0.021/0.128 and 0.014/0.089) indicates that unmeasured respondent-level characteristics explain considerably more variation than the measured demographic predictors alone. Therefore, while demographic factors contribute to forecasting accuracy, much of the variation appears to occur at the individual level rather than being explained by observable characteristics.
Conclusion
This study aimed to assess the robustness of Titelman and Lauderdale’s (2021a) findings by examining whether their conclusions regarding respondent characteristic predictors of forecasting accuracy remain consistent under alternative modelling assumptions. While the original analysis suggests that politically attentive and informed respondents are better able to predict others’ voting behaviour, this replication has demonstrated these findings to be somewhat sensitive to model specification.
First, the replication confirmed partial verifiability of the original results. Although exact statistical significance outputs could not be fully reported due to inconsistencies in replication materials, the coefficients retained consistency with the published findings. This supports the authors’ central claim that political attention is positively associated with forecasting accuracy for both probabilistic and directional accuracy.
However, the extension to a multilevel modelling framework highlights an important limitations in the original approach. By accounting for the clustered structure of the data, where multiple observations are nested within individual respondents, the analysis provides a more appropriate representation of the experimental data-generating process. Consistent with expectations from prior methodological literature (Gelman & Hill, 2007; Maas & Hox, 2005), the inclusions of respondent-level random effects resulted in increased standard errors and reduced statistical significance for all predictors. This suggests that the original OLS models may have overstated the precision of their estimates by failing to account for within-respondent correlation.
Several limitations of this replication should be acknowledged. First, the analysis relies entirely on the authors’ cleaned datasets, rather than raw data: either non-imputed BES data, or collecting new experimental data. This restricts the ability to fully assess the transparency and completeness of the data preparation process. Second, the study does not test generalisability, as it is confined to the original UK-based experimental context. Finally, while the multilevel approach improves model specification, it does not resolve other potential sources of bias, such as the use of Multiple Imputation by Chained Equations (MICE) in Titelman and Lauderdles’s (2021a, p. 258) original hidden data preparation process, which introduces additional modelling assumptions into the construction of the profile data.
Importantly, the extension does not overturn the substantive conclusions made by Titelman & Lauderdale (2021a). Instead, it refines their interpretation, where demographic and political resource variables remain some significant predictors of forecasting ability, but they explain less variance once unobserved individuals differences are taken into account.
Overall, this study highlights the value of modelling assumptions in shaping quantitative research. While Titelman and Lauderdale’s (2021a) core findings are broadly supported, they are less robust than initially presented when accounting for the hierarchical structure of the data. This suggests that citizens’ ability to infer people’s voting behaviour is shaped by both political resources and unobserved individual capabilities. This highlights the value of replication and robustness checks in empirical research indicated by Freese and Peterson (2017), particularly when working with layered experimental designs. Future research could extend this analysis by applying similar models to different datasets, or by incorporating additional respondent-level characteristics to better capture the mechanisms underlying political forcasting accuracy.
References
Reference List
Bickel, R. (2007) Multilevel analysis for applied research: It’s just regression! 1st edn. New York: Guilford Press.
Fieldhouse, E., Green, J., Evans, G., Schmitt, H., van der Eijk, C., Mellon, J., Prosser, C. (2019) British Election Study, 2017: Face-to-Face Post-Election Survey [data collection]. UK Data Service. Available at: https://doi.org/10.5255/UKDA-SN-8418-1.
Finch, H. (2026) ‘Using multilevel modeling to understand nested data’, Perspectives on Early Childhood Psychology and Education, 8(2), Article 4. Available at: https://doi.org/10.58948/2834-8257.1076.
Freese, J. and Peterson, D. (2017) ‘Replication in social science’, Annual Review of Sociology, 43, pp. 147–165. Available at: https://doi.org/10.1146/annurev-soc-060116-053450.
Gelman, A. and Hill, J. (2007) Data analysis using regression and multilevel/hierarchical models. Cambridge: Cambridge University Press.
Lewis-Beck, M. S. and Stegmaier, M. (2011) Citizen forecasting: can UK voters see the future?. Electoral Studies 30, pp. 264–268.
Maas, C.J.M. and Hox, J.J. (2005) ‘Sufficient sample sizes for multilevel modeling’, Methodology, 1(3), pp. 86–92. Available at: https://doi.org/10.1027/1614-1881.1.3.86.
Raudenbush, S.W. and Bryk, A.S. (2002) Hierarchical linear models: Applications and data analysis methods. 2nd edn. Thousand Oaks, CA: Sage Publications.
Snijders, T.A.B. and Bosker, R.J. (2012) Multilevel analysis: An introduction to basic and advanced multilevel modeling. 2nd edn. London: Sage Publications.
Titelman, N. and Lauderdale, B.E. (2021a) ‘Can citizens guess how other citizens vote based on demographic characteristics?’, Political Science Research and Methods, 11(2), pp. 254–274. Available at: https://doi.org/10.1017/PSRM.2021.53.
Titelman, N. and Lauderdale, B.E. (2021b) Replication data for: Can citizens guess how other citizens vote based on demographic characteristics? [Dataset]. Harvard Dataverse. Available at: https://doi.org/10.7910/DVN/3OWF6C.
Titelman, N. and Lauderdale, B.E. (2021c) Replication data for: Can citizens guess how other citizens voted based on demographic characteristics? [data set]. Harvard Dataverse, V1; appendix.rmd [fileName]. Available at: https://doi.org/10.7910/DVN/3OWF6C.
Appendix
Appendix 1. Environment (full information)
# Detailed information of environment
sessionInfo()R version 4.5.2 (2025-10-31 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 26200)
Matrix products: default
LAPACK version 3.12.1
locale:
[1] LC_COLLATE=English_United Kingdom.utf8
[2] LC_CTYPE=English_United Kingdom.utf8
[3] LC_MONETARY=English_United Kingdom.utf8
[4] LC_NUMERIC=C
[5] LC_TIME=English_United Kingdom.utf8
time zone: Europe/London
tzcode source: internal
attached base packages:
[1] grid stats graphics grDevices datasets utils methods
[8] base
other attached packages:
[1] patchwork_1.3.2 lmerTest_3.2-1 lme4_1.1-38 sjPlot_2.9.0
[5] lubridate_1.9.5 purrr_1.2.1 readr_2.1.6 tibble_3.3.1
[9] tidyverse_2.0.0 papaja_0.1.5 tinylabels_0.2.5 naniar_1.1.0
[13] kableExtra_1.4.1 stringr_1.6.0 forcats_1.0.1 tidyr_1.3.2
[17] texreg_1.39.5 stargazer_5.2.3 snakecase_0.11.1 psych_2.6.5
[21] questionr_0.8.2 coefplot_1.2.9 plyr_1.8.9 plotrix_3.8-14
[25] gridExtra_2.3.1 ggthemes_5.2.0 ggplot2_4.0.3 dplyr_1.2.1
[29] survey_4.5 survival_3.8-3 Matrix_1.7-4 DescTools_0.99.60
[33] matlib_1.0.1 knitr_1.51 rmarkdown_2.30
loaded via a namespace (and not attached):
[1] RColorBrewer_1.1-3 rstudioapi_0.18.0 jsonlite_2.0.0
[4] datawizard_1.3.0 magrittr_2.0.4 farver_2.1.2
[7] nloptr_2.2.1 fs_1.6.6 vctrs_0.7.1
[10] minqa_1.2.8 base64enc_0.1-6 effectsize_1.0.1
[13] htmltools_0.5.9 haven_2.5.5 cellranger_1.1.0
[16] sjmisc_2.8.11 Formula_1.2-6 sass_0.4.10
[19] bslib_0.10.0 htmlwidgets_1.6.4 rootSolve_1.8.2.4
[22] cachem_1.1.0 mime_0.13 lifecycle_1.0.5
[25] pkgconfig_2.0.3 sjlabelled_1.2.0 R6_2.6.1
[28] fastmap_1.2.0 rbibutils_2.4.1 shiny_1.14.0
[31] numDeriv_2016.8-1.1 digest_0.6.39 Exact_3.3
[34] useful_1.2.7 textshaping_1.0.4 labeling_0.4.3
[37] timechange_0.4.0 httr_1.4.7 abind_1.4-8
[40] compiler_4.5.2 proxy_0.4-29 withr_3.0.2
[43] S7_0.2.1 carData_3.0-6 DBI_1.2.3
[46] performance_0.16.0 highr_0.11 MASS_7.3-65
[49] gld_2.6.8 tools_4.5.2 otel_0.2.0
[52] httpuv_1.6.17 visdat_0.6.0 glue_1.8.0
[55] nlme_3.1-168 promises_1.5.0 reshape2_1.4.5
[58] generics_0.1.4 gtable_0.3.6 labelled_2.16.0
[61] tzdb_0.5.0 class_7.3-23 data.table_1.18.2.1
[64] lmom_3.2 hms_1.1.4 xml2_1.5.2
[67] car_3.1-5 pillar_1.11.1 later_1.4.8
[70] mitools_2.4 splines_4.5.2 lattice_0.22-9
[73] renv_1.2.3 tidyselect_1.2.1 miniUI_0.1.2
[76] reformulas_0.4.4 svglite_2.2.2 xfun_0.56
[79] expm_1.0-0 stringi_1.8.7 yaml_2.3.12
[82] boot_1.3-32 evaluate_1.0.5 codetools_0.2-20
[85] cli_3.6.5 xtable_1.8-8 parameters_0.28.3
[88] systemfonts_1.3.1 Rdpack_2.6.6 jquerylib_0.1.4
[91] Rcpp_1.1.2 readxl_1.4.5 parallel_4.5.2
[94] rgl_1.3.36 bayestestR_0.17.0 viridisLite_0.4.3
[97] mvtnorm_1.3-3 scales_1.4.0 e1071_1.7-17
[100] insight_1.4.6 rlang_1.3.0 mnormt_2.1.2 Appendix 2. Entire R code used in this project
# Key Libraries for replication
# rmarkdown
library(rmarkdown)
library(knitr)
knitr::opts_chunk$set(
echo = TRUE,
cache = TRUE,
comment = NA,
warning = FALSE,
message = FALSE,
fig.align = "center"
)
renv::restore()
# libraries supplied by authors replication materials
library(matlib)
library(DescTools)
library(survey)
library(dplyr)
library(ggplot2)
library(ggthemes)
library(gridExtra)
library(plotrix)
library(plyr)
library(coefplot)
library(questionr)
library(psych)
library(snakecase)
library(stargazer)
library(texreg)
library(tidyr)
library(forcats)
library(stringr)
library(kableExtra)
library(naniar)
library(papaja)
# libraries for replication extension
library(tidyverse)
library(sjPlot)
library(lme4)
library(lmerTest)
library(patchwork)
version[['version.string']]
# load Brexit Datafile
load("Data/InputData/CleanBrexit.RData")
# load Party Datafile
load("Data/InputData/CleanParties.RData")
# Run Titelman & Lauderdale's `appendix.rmd` code to create outcome variables neccesary for running models
###########################################################
########## [Titelman & Lauderdale (2021c) code] ###########
###################### Start: #############################
################## START CHUNK 3 ##########################
# The following chunk allows for comparisons of mean guess by profile attribute with the same mean in the BES
# Predicting the (weighted) mean guess by level of each attribute
MeansAge<-lm(profile_Leave~profile_AgeGroup, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
levels(Brexit.Experiment.Clean$profile_AgeGroup)
new.dat <- data.frame(profile_AgeGroup=c("18-29", "30-44", "45-59", "60-74", "75 +"))
MeansAge1<-data.frame(new.dat, predict(MeansAge, newdata = new.dat, interval = 'confidence'))
MeansAgeBES<-lm(profile_Leave~profile_AgeGroup, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansAgeBES2<-data.frame(new.dat, predict(MeansAgeBES, newdata = new.dat, interval = 'confidence'))
MeansAgeBES2$Probabilities<-"BES"
MeansAge1$Probabilities<-"Guess"
MeansAge.Bind<-bind_rows(MeansAge1, MeansAgeBES2)
MeansReligion<-lm(profile_Leave~profile_Religion, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Religion=c("Roman Catholic","Church of England/Anglican/Episcopal",
"Hindu","Islam",
"Methodist","Presbyterian/Church of Scotland",
"No religion","Unknown" ))
MeansReligion1<-data.frame(new.dat, predict(MeansReligion, newdata = new.dat, interval = 'confidence'))
MeansReligion1$profile_Religion<-factor(MeansReligion1$profile_Religion, levels=MeansReligion1$profile_Religion[order(MeansReligion1$fit)])
MeansReligionBES<-lm(profile_Leave~profile_Religion, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansReligionBES2<-data.frame(new.dat, predict(MeansReligionBES, newdata = new.dat, interval = 'confidence'))
MeansReligionBES2$Probabilities<-"BES"
MeansReligion1$Probabilities<-"Guess"
MeansReligion.Bind<-bind_rows(MeansReligion1, MeansReligionBES2)
MeansEthnicity<-lm(profile_Leave~profile_Ethnicity, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Ethnicity=c("Asian","Black",
"Mixed","White",
"Unknown"))
MeansEthnicity1<-data.frame(new.dat, predict(MeansEthnicity, newdata = new.dat, interval = 'confidence'))
MeansEthnicity1$profile_Ethnicity<-factor(MeansEthnicity1$profile_Ethnicity, levels=MeansEthnicity1$profile_Ethnicity[order(MeansEthnicity1$fit)])
MeansEthnicityBES<-lm(profile_Leave~profile_Ethnicity, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansEthnicityBES2<-data.frame(new.dat, predict(MeansEthnicityBES, newdata = new.dat, interval = 'confidence'))
MeansEthnicityBES2$Probabilities<-"BES"
MeansEthnicity1$Probabilities<-"Guess"
MeansEthnicity.Bind<-bind_rows(MeansEthnicity1, MeansEthnicityBES2)
MeansGender<-lm(profile_Leave~profile_Gender, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Gender=c("Male", "Female"))
MeansGender1<-data.frame(new.dat, predict(MeansGender, newdata = new.dat, interval = 'confidence'))
MeansGenderBES<-lm(profile_Leave~profile_Gender, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansGenderBES2<-data.frame(new.dat, predict(MeansGenderBES, newdata = new.dat, interval = 'confidence'))
MeansGenderBES2$Probabilities<-"BES"
MeansGender1$Probabilities<-"Guess"
MeansGender.Bind<-bind_rows(MeansGender1, MeansGenderBES2)
MeansEducation2<-lm(profile_Leave~profile_Education, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Education=c('Holds a university degree', 'Does not hold a university degree'))
MeansEducation3<-data.frame(new.dat, predict(MeansEducation2, newdata = new.dat, interval = 'confidence'))
MeansEducationBES<-lm(profile_Leave~profile_Education, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansEducationBES2<-data.frame(new.dat, predict(MeansEducationBES, newdata = new.dat, interval = 'confidence'))
MeansEducationBES2$Probabilities<-"BES"
MeansEducation3$Probabilities<-"Guess"
MeansEducation.Bind<-bind_rows(MeansEducation3, MeansEducationBES2)
MeansRegion<-lm(profile_Leave~profile_Region, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Region=factor(c("London", "North East",
"North West","Scotland",
"South East","South West",
"the East Midlands","the East of England",
"Wales","West Midlands",
"Yorkshire & Humber")))
MeansRegion1<-data.frame(new.dat, predict(MeansRegion, newdata = new.dat, interval = 'confidence'))
MeansRegion1$profile_Region<-factor(MeansRegion1$profile_Region, levels=MeansRegion1$profile_Region[order(MeansRegion1$fit)])
MeansRegionBES<-lm(profile_Leave~profile_Region, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansRegionBES2<-data.frame(new.dat, predict(MeansRegionBES, newdata = new.dat, interval = 'confidence'))
MeansRegionBES2$Probabilities<-"BES"
MeansRegion1$Probabilities<-"Guess"
MeansRegion.Bind<-bind_rows(MeansRegion1, MeansRegionBES2)
MeansRegion.Bind<-bind_rows(MeansRegion1, MeansRegionBES2)
Realvote<-Brexit.Experiment.Clean %>%
dplyr:: group_by(profile_Region) %>%
dplyr:: summarise(fit = mean(profile_regional_real_Leave, na.rm=T))
Realvote$Probabilities<-"Real"
MeansRegion.Bind2<-bind_rows(MeansRegion.Bind, Realvote)
MeansRegion.Bind2$Probabilities<-factor(MeansRegion.Bind2$Probabilities,
levels=c("BES"[order(1)],"Real"[order(2)],"Guess"[order(3)]))
MeansIncome<-lm(profile_Leave~profile_AnnualHouseholdIncome, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_AnnualHouseholdIncome=factor(c("Less than 5,199"[order(1)],
"Between 5,200 and 15,599"[order(2)],
"Between 15,600 and 25,999"[order(3)],
"Between 26,000 and 36,399"[order(4)],
"Between 36,400 and 44,999"[order(5)],
"Between 45,000 and 59,999"[order(6)],
"Between 60,000 and 99,999"[order(7)],
"Greater than 100,000"[order(8)] )))
MeansIncome2<-data.frame(new.dat, predict(MeansIncome, newdata = new.dat, interval = 'confidence'))
MeansIncomeBES<-lm(profile_Leave~profile_AnnualHouseholdIncome, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansIncomeBES2<-data.frame(new.dat, predict(MeansIncomeBES, newdata = new.dat, interval = 'confidence'))
MeansIncomeBES2$Probabilities<-"BES"
MeansIncome2$Probabilities<-"Guess"
MeansIncome.Bind<-bind_rows(MeansIncome2, MeansIncomeBES2)
MeansIncome.Bind$profile_AnnualHouseholdIncome<-factor(MeansIncome.Bind$profile_AnnualHouseholdIncome,
levels = c("Less than 5,199"[order(1)],
"Between 5,200 and 15,599"[order(2)],
"Between 15,600 and 25,999"[order(3)],
"Between 26,000 and 36,399"[order(4)],
"Between 36,400 and 44,999"[order(5)],
"Between 45,000 and 59,999"[order(6)],
"Between 60,000 and 99,999"[order(7)],
"Greater than 100,000"[order(8)] ))
MeansClass<-lm(profile_Leave~profile_SubClass, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubClass=c("Working class", "Middle class"))
MeansClass1<-data.frame(new.dat, predict(MeansClass, newdata = new.dat, interval = 'confidence'))
MeansClassBES<-lm(profile_Leave~profile_SubClass, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansClassBES2<-data.frame(new.dat, predict(MeansClassBES, newdata = new.dat, interval = 'confidence'))
MeansClassBES2$Probabilities<-"BES"
MeansClass1$Probabilities<-"Guess"
MeansClass.Bind<-bind_rows(MeansClass1, MeansClassBES2)
MeansFamClass<-lm(profile_Leave~profile_SubFamClass, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubFamClass=c("Family working class", "Family middle class"))
MeansFamClass1<-data.frame(new.dat, predict(MeansFamClass, newdata = new.dat, interval = 'confidence'))
MeansFamClassBES<-lm(profile_Leave~profile_SubFamClass, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansFamClassBES2<-data.frame(new.dat, predict(MeansFamClassBES, newdata = new.dat, interval = 'confidence'))
MeansFamClassBES2$Probabilities<-"BES"
MeansFamClass1$Probabilities<-"Guess"
MeansFamClass.Bind<-bind_rows(MeansFamClass1, MeansFamClassBES2)
MeansHomeStatus<-lm(profile_Leave~profile_HomeStatus, data=Brexit.Experiment.Clean, w=Brexit.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_HomeStatus=c("Rents home", "Owns home"))
MeansHomeStatus1<-data.frame(new.dat, predict(MeansHomeStatus, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusBES<-lm(profile_Leave~profile_HomeStatus, data=Brexit.BES.Clean, w=Brexit.BES.Clean$profile_weights)
MeansHomeStatusBES2<-data.frame(new.dat, predict(MeansHomeStatusBES, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusBES2$Probabilities<-"BES"
MeansHomeStatus1$Probabilities<-"Guess"
MeansHomeStatus.Bind<-bind_rows(MeansHomeStatus1, MeansHomeStatusBES2)
#Parties
MeansAge<-lm(profile_Con~profile_AgeGroup, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
levels(Parties.Experiment.Clean$profile_AgeGroup)
new.dat <- data.frame(profile_AgeGroup=c("18-29", "30-44", "45-59", "60-74", "75 +"))
MeansAge1<-data.frame(new.dat, predict(MeansAge, newdata = new.dat, interval = 'confidence'))
MeansAgeBES<-lm(profile_Con~profile_AgeGroup, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansAgeBES2<-data.frame(new.dat, predict(MeansAgeBES, newdata = new.dat, interval = 'confidence'))
MeansAgeBES2$Probabilities<-"BES"
MeansAge1$Probabilities<-"Guess"
MeansAgeP.Bind<-bind_rows(MeansAge1, MeansAgeBES2)
MeansEducationP<-lm(profile_Con~profile_Education, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Education=c('Holds a university degree', 'Does not hold a university degree'))
MeansEducationP2<-data.frame(new.dat, predict(MeansEducationP, newdata = new.dat, interval = 'confidence'))
MeansEducationPBES<-lm(profile_Con~profile_Education, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansEducationPBES2<-data.frame(new.dat, predict(MeansEducationPBES, newdata = new.dat, interval = 'confidence'))
MeansEducationPBES2$Probabilities<-"BES"
MeansEducationP2$Probabilities<-"Guess"
MeansEducationP.Bind<-bind_rows(MeansEducationP2, MeansEducationPBES2)
MeansIncomeP<-lm(profile_Con~profile_AnnualHouseholdIncome, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame((profile_AnnualHouseholdIncome=factor(c("Less than 5,199"[order(1)],
"Between 5,200 and 15,599"[order(2)],
"Between 15,600 and 25,999"[order(3)],
"Between 26,000 and 36,399"[order(4)],
"Between 36,400 and 44,999"[order(5)],
"Between 45,000 and 59,999"[order(6)],
"Between 60,000 and 99,999"[order(7)],
"Greater than 100,000"[order(8)]))))
MeansIncomeP2<-data.frame(new.dat, predict(MeansIncomeP, newdata = new.dat, interval = 'confidence'))
MeansIncomePBES<-lm(profile_Con~profile_AnnualHouseholdIncome, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansIncomePBES2<-data.frame(new.dat, predict(MeansIncomePBES, newdata = new.dat, interval = 'confidence'))
MeansIncomePBES2$Probabilities<-"BES"
MeansIncomeP2$Probabilities<-"Guess"
MeansIncomeP.Bind<-bind_rows(MeansIncomeP2, MeansIncomePBES2)
MeansIncomeP.Bind$profile_AnnualHouseholdIncome<-factor(MeansIncome.Bind$profile_AnnualHouseholdIncome,
levels = c("Less than 5,199"[order(1)],
"Between 5,200 and 15,599"[order(2)],
"Between 15,600 and 25,999"[order(3)],
"Between 26,000 and 36,399"[order(4)],
"Between 36,400 and 44,999"[order(5)],
"Between 45,000 and 59,999"[order(6)],
"Between 60,000 and 99,999"[order(7)],
"Greater than 100,000"[order(8)] ))
MeansRegionP<-lm(profile_Con~profile_Region, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Region=factor(c("London", "North East",
"North West","Scotland",
"South East","South West",
"the East Midlands","the East of England",
"Wales","West Midlands",
"Yorkshire & Humber")))
MeansRegionP1<-data.frame(new.dat, predict(MeansRegionP, newdata = new.dat, interval = 'confidence'))
MeansRegionP1$profile_Region<-factor(MeansRegionP1$profile_Region, levels=MeansRegionP1$profile_Region[order(MeansRegionP1$fit)])
MeansRegionPBES<-lm(profile_Con~profile_Region, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansRegionPBES2<-data.frame(new.dat, predict(MeansRegionPBES, newdata = new.dat, interval = 'confidence'))
MeansRegionPBES2$Probabilities<-"BES"
MeansRegionP1$Probabilities<-"Guess"
MeansRegionP.Bind<-bind_rows(MeansRegionP1, MeansRegionPBES2)
Realvote<-Parties.Experiment.Clean %>%
dplyr:: group_by(profile_Region) %>%
dplyr:: summarise(fit = mean(profile_regional_real_Con, na.rm=T))
Realvote$Probabilities<-"Real"
MeansRegionP2.Bind<-bind_rows(MeansRegionP.Bind, Realvote)
MeansRegionP2.Bind$Probabilities<-factor(MeansRegion.Bind2$Probabilities,
levels=c("BES"[order(1)],"Real"[order(2)],"Guess"[order(3)]))
MeansClassP<-lm(profile_Con~profile_SubClass, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubClass=c("Working class", "Middle class"))
MeansClassP1<-data.frame(new.dat, predict(MeansClassP, newdata = new.dat, interval = 'confidence'))
MeansClassPBES<-lm(profile_Con~profile_SubClass, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansClassPBES2<-data.frame(new.dat, predict(MeansClassPBES, newdata = new.dat, interval = 'confidence'))
MeansClassPBES2$Probabilities<-"BES"
MeansClassP1$Probabilities<-"Guess"
MeansClassP.Bind<-bind_rows(MeansClassP1, MeansClassPBES2)
MeansFamClassP<-lm(profile_Con~profile_SubFamClass, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_SubFamClass=c("Family working class", "Family middle class"))
MeansFamClassP1<-data.frame(new.dat, predict(MeansFamClassP, newdata = new.dat, interval = 'confidence'))
MeansFamClassPBES<-lm(profile_Con~profile_SubFamClass, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansFamClassPBES2<-data.frame(new.dat, predict(MeansFamClassPBES, newdata = new.dat, interval = 'confidence'))
MeansFamClassPBES2$Probabilities<-"BES"
MeansFamClassP1$Probabilities<-"Guess"
MeansFamClassP.Bind<-bind_rows(MeansFamClassP1, MeansFamClassPBES2)
MeansHomeStatusP<-lm(profile_Con~profile_HomeStatus, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_HomeStatus=c("Rents home", "Owns home"))
MeansHomeStatusP1<-data.frame(new.dat, predict(MeansHomeStatusP, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusPBES<-lm(profile_Con~profile_HomeStatus, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansHomeStatusPBES2<-data.frame(new.dat, predict(MeansHomeStatusPBES, newdata = new.dat, interval = 'confidence'))
MeansHomeStatusPBES2$Probabilities<-"BES"
MeansHomeStatusP1$Probabilities<-"Guess"
MeansHomeStatusP.Bind<-bind_rows(MeansHomeStatusP1, MeansHomeStatusPBES2)
MeansReligionP<-lm(profile_Con~profile_Religion, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Religion=c("Roman Catholic","Church of England/Anglican/Episcopal",
"Hindu","Islam",
"Methodist","Presbyterian/Church of Scotland",
"No religion","Unknown" ))
MeansReligionP1<-data.frame(new.dat, predict(MeansReligionP, newdata = new.dat, interval = 'confidence'))
MeansReligionP1$profile_Religion<-factor(MeansReligionP1$profile_Religion, levels=MeansReligionP1$profile_Religion[order(MeansReligionP1$fit)])
MeansReligionPBES<-lm(profile_Con~profile_Religion, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansReligionPBES2<-data.frame(new.dat, predict(MeansReligionPBES, newdata = new.dat, interval = 'confidence'))
MeansReligionPBES2$Probabilities<-"BES"
MeansReligionP1$Probabilities<-"Guess"
MeansReligionP.Bind<-bind_rows(MeansReligionP1, MeansReligionPBES2)
MeansEthnicityP<-lm(profile_Con~profile_Ethnicity, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat<-data.frame(profile_Ethnicity=factor(c("Asian","Black",
"Mixed","White",
"Unknown")))
MeansEthnicityP1<-data.frame(new.dat, predict(MeansEthnicityP, newdata = new.dat, interval = 'confidence'))
MeansEthnicityP1$profile_Ethnicity<-factor(MeansEthnicityP1$profile_Ethnicity, levels=MeansEthnicityP1$profile_Ethnicity[order(MeansEthnicityP1$fit)])
MeansEthnicityPBES<-lm(profile_Con~profile_Ethnicity, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansEthnicityPBES2<-data.frame(new.dat, predict(MeansEthnicityPBES, newdata = new.dat, interval = 'confidence'))
MeansEthnicityPBES2$Probabilities<-"BES"
MeansEthnicityP1$Probabilities<-"Guess"
MeansEthnicityP.Bind<-bind_rows(MeansEthnicityP1, MeansEthnicityPBES2)
MeansGenderP<-lm(profile_Con~profile_Gender, data=Parties.Experiment.Clean, w=Parties.Experiment.Clean$respondent_weights)
new.dat <- data.frame(profile_Gender=c("Male", "Female"))
MeansGenderP1<-data.frame(new.dat, predict(MeansGenderP, newdata = new.dat, interval = 'confidence'))
MeansGenderPBES<-lm(profile_Con~profile_Gender, data=Parties.BES.Clean, w=Parties.BES.Clean$profile_weights)
MeansGenderPBES2<-data.frame(new.dat, predict(MeansGenderPBES, newdata = new.dat, interval = 'confidence'))
MeansGenderPBES2$Probabilities<-"BES"
MeansGenderP1$Probabilities<-"Guess"
MeansGenderP.Bind<-bind_rows(MeansGenderP1, MeansGenderPBES2)
################ END CHUNK 3 ############################
############### START CHUNK 4 ###########################
#The following chunk allows for a comparison between BES and guesses, modelling all profile attributes together. Models are estaimted in logit and linear form. Linear model lead to invalid predictions for the binary vote choice for some profiles
# Brexit Linear model, predicting guessed probability of leave with porfiles attributes as predictors
GuessedLeave<- lm(profile_Leave ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean)
BESLeave<- lm(profile_Leave ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Brexit.BES.Clean$profile_weights, data = Brexit.BES.Clean)
# Brexit Logit model
Brexit.Experiment.Clean$LeaveProp <- Brexit.Experiment.Clean$profile_Leave/100
#Brexit.Sep is a dataset created to ease later combination
Brexit.Sep<- Brexit.Experiment.Clean %>%
select(LeaveProp, starts_with("profile"), respondent_weights)
colnames(Brexit.Sep)<-paste0(colnames(Brexit.Sep), "_")
GuessedLeaveLogit0 <- glm("LeaveProp_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Brexit.Sep$respondent_weights_, data = Brexit.Sep, family=quasibinomial(link="logit"))
# Same regression with Brexit.Experiment.Clean dataset (guesses model)
GuessedLeaveLogit<-glm(LeaveProp ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Brexit.Experiment.Clean$respondent_weights, data = Brexit.Experiment.Clean, family=quasibinomial(link="logit"))
# Same regression with Brexit.BES.Clean dataset (BES model)
Brexit.BES.Clean$Leave.BES.Prop <- Brexit.BES.Clean$profile_Leave/100
#Brexit.Sep.BES is a dataset created to ease later combination
Brexit.Sep.BES<- Brexit.BES.Clean %>%
select(Leave.BES.Prop, starts_with("profile"))
colnames(Brexit.Sep.BES)<-paste0(colnames(Brexit.Sep.BES), "_")
BESLeaveLogit0 <- glm("Leave.BES.Prop_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Brexit.Sep.BES$profile_weights_, data = Brexit.Sep.BES, family=quasibinomial(link="logit"))
# Same regression with Brexit.BES.Clean dataset (BES model)
BESLeaveLogit <- glm(Leave.BES.Prop ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Brexit.BES.Clean$profile_weights, data = Brexit.BES.Clean, family=quasibinomial(link="logit"))
# Parties Linear models
GuessedConservative <- lm(profile_Con ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome ,weights = Parties.Experiment.Clean$respondent_weights,data = Parties.Experiment.Clean)
RealConservative<- lm(profile_Con ~ profile_Gender+profile_AgeGroup+profile_Education+profile_Region+profile_SubClass+profile_SubFamClass+profile_HomeStatus+profile_Religion+profile_Ethnicity+profile_AnnualHouseholdIncome, weights=Parties.BES.Clean$profile_weights, data = Parties.BES.Clean)
# Parties Logstics models
Parties.Experiment.Clean$ConProp <- Parties.Experiment.Clean$profile_Con/100
# Party.Sep dataset created to to ease combination later
Party.Sep<- Parties.Experiment.Clean %>%
select(ConProp, starts_with("profile"), respondent_weights)
colnames(Party.Sep)<-paste0(colnames(Party.Sep), "_")
GuessedConservativeLogit0 <- glm("ConProp_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Party.Sep$respondent_weights_, data = Party.Sep, family=quasibinomial(link="logit"))
# Same regression with Parties.Experiment.Clean (guesses)
GuessedConservativeLogit <- glm(ConProp ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome , weights=Parties.Experiment.Clean$respondent_weights, data = Parties.Experiment.Clean, family=quasibinomial(link="logit"))
#Same regression with BES model
Parties.BES.Clean$profile_Con.Prop <- Parties.BES.Clean$profile_Con/100
Party.Sep.BES<- Parties.BES.Clean %>%
select(starts_with("profile"))
colnames(Party.Sep.BES)<-paste0(colnames(Party.Sep.BES), "_")
RealConservativeLogit0 <- glm("profile_Con.Prop_ ~ profile_Gender_ +profile_AgeGroup_ +profile_Education_ +profile_Region_ +profile_SubClass_ +profile_SubFamClass_ +profile_HomeStatus_ +profile_Religion_ +profile_Ethnicity_ +profile_AnnualHouseholdIncome_", weights=Party.Sep.BES$profile_weights_, data = Party.Sep.BES, family=quasibinomial(link="logit"))
RealConservativeLogit <- glm(profile_Con.Prop ~ profile_Gender +profile_AgeGroup +profile_Education +profile_Region +profile_SubClass +profile_SubFamClass +profile_HomeStatus +profile_Religion +profile_Ethnicity +profile_AnnualHouseholdIncome, weights=Parties.BES.Clean$profile_weights_, data = Parties.BES.Clean, family=quasibinomial(link="logit"))
############## END CHUNK 4 #############################
############## START CHUNK 5 ###########################
#This chunk allows for comparisons between the predicted probabilities of profiles voting in a certain way, implied by the BES model and the Guesses model.
#Brexit experiment
fitted_BES_Brex<-predict(BESLeaveLogit, newdata=Brexit.BES.Clean, type="response")
predicted_Experiment_Brex <- predict(GuessedLeaveLogit , newdata=Brexit.BES.Clean,type="response")
fitted_BES_Brexit<-data.frame("profile"= c(1:1695), fitted_BES_Brex)
predicted_Experiment_Brexit<-data.frame("profile"= c(1:1695), predicted_Experiment_Brex)
Relation.Models.Brexit<-merge(fitted_BES_Brexit, predicted_Experiment_Brexit, by="profile")
#Parties experiment
fitted_BES_Con<- predict(RealConservativeLogit, newdata=Parties.BES.Clean,type="response")
predicted_Experiment_Con <- predict(GuessedConservativeLogit, newdata=Parties.BES.Clean,type="response")
fitted_BES_Conservative<-data.frame("profile"= c(1:1362), fitted_BES_Con)
predicted_Experiment_Conservative<-data.frame("profile"= c(1:1362), predicted_Experiment_Con)
Relation.Models.Con<-merge(fitted_BES_Conservative, predicted_Experiment_Conservative, by="profile")
################# END CHUNK 5 ########################
################ START CHUNK 6 #######################
#Individual Brier Score Brexit
Brexit.Experiment.Clean$BrierScore<- ((Brexit.Experiment.Clean$profile_Leave/100)-Brexit.Experiment.Clean$profile_Leave.Real)^2
BrierScoreTotal<-weighted.mean(Brexit.Experiment.Clean$BrierScore, w=Brexit.Experiment.Clean$respondent_weights, na.rm = T)
#Individual Brier Score Parties
Parties.Experiment.Clean$BrierScore<- (Parties.Experiment.Clean$profile_Conservative.Real-(Parties.Experiment.Clean$profile_Con/100))^2
Parties.Experiment.Clean$BrierScoreBinary <- ((0.5+0.5*sign((Parties.Experiment.Clean$profile_Con - 50)))-Parties.Experiment.Clean$profile_Conservative.Real)^2
BrierScoreTotalParties<-mean(Parties.Experiment.Clean$BrierScore, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)
################# END CHUNK 6 ##########################
################ START CHUNK 7 #########################
#Average Brier score
#Predicted probabilities for every profile, using BES model
fitted_BESCoef_BrexExp<-predict(BESLeaveLogit, newdata=Brexit.Experiment.Clean,type="response")
fitted_BESCoef_BrexExp<-data.frame(Brexit.Experiment.Clean, fitted_BESCoef_BrexExp)
fitted_BESCoef_PartyExp<-predict(RealConservativeLogit, newdata=Parties.Experiment.Clean,type="response")
fitted_BESCoef_PartyExp<-data.frame(Parties.Experiment.Clean, fitted_BESCoef_PartyExp)
fitted_BESCoef_BrexExp<-fitted_BESCoef_BrexExp %>%
dplyr::rename(fittedBrexExp = fitted_BESCoef_BrexExp)
fitted_BESCoef_PartyExp<-fitted_BESCoef_PartyExp %>%
dplyr::rename(fittedPartyExp = fitted_BESCoef_PartyExp)
#Brier score Parties
fitted_BESCoef_PartyExp$BrierScore.fitted<- (fitted_BESCoef_PartyExp$fittedPartyExp-(fitted_BESCoef_PartyExp$profile_Con/100))^2
BrierScoreTotalParty.fitted<-mean(fitted_BESCoef_PartyExp$BrierScore.fitted, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)
#Brier Score Brexit
fitted_BESCoef_BrexExp$BrierScore.fitted<- (fitted_BESCoef_BrexExp$fittedBrexExp-(fitted_BESCoef_BrexExp$profile_Leave/100))^2
BrierScoreTotalBrex.fitted<-mean(fitted_BESCoef_BrexExp$BrierScore.fitted, w=Parties.Experiment.Clean$respondent_weights, na.rm = T)
####### ~ [section removed from Chunk 7 due to separate analysis] ~ ##############
#Preparing data for dichotomous analysis in Parties experiment
fitted_BESCoef_BrexExp<- fitted_BESCoef_BrexExp %>%
mutate(profile_Leave.Dich = case_when( profile_Leave<50 ~ "Remain",
profile_Leave>50 ~ "Leave",
profile_Leave==50 ~ "50-50"))
fitted_BESCoef_PartyExp<- fitted_BESCoef_PartyExp %>%
mutate(profile_Con.Dich = case_when( profile_Con<50 ~ "Labour",
profile_Con>50 ~ "Conservative",
profile_Con==50 ~ "50-50"))
fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
mutate(profile_Leave.RealN = case_when(profile_Leave.Real == 1 ~ "Leave" ,
profile_Leave.Real == 0 ~ "Remain"))
#Creating variable that equals 1 for correct dichotomous guess (and 0.5 for "50-50"). Brexit
fitted_BESCoef_BrexExp <- fitted_BESCoef_BrexExp %>%
mutate(Correct.Dich.Guess.Brex = case_when(profile_Leave.Dich=="50-50" ~ 0.5,
profile_Leave.Dich==profile_Leave.RealN ~ 1,
profile_Leave.Dich!=profile_Leave.RealN ~ 0))
dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_BrexExp$respondent_weights, data=fitted_BESCoef_BrexExp)
meanleave<-svymean(~Correct.Dich.Guess.Brex, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanleave)
CI.Correct.Brex.Dich<-data.frame("Correct"="Brexit", "fit"=meanleave[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)
#Creating variable that equals 1 for correct dichotomous guess (and 0.5 for "50-50"). Parties
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
mutate(profile_Conservative.RealN = case_when(profile_Conservative.Real == 1 ~ "Conservative" ,
profile_Conservative.Real == 0 ~ "Labour"))
fitted_BESCoef_PartyExp <- fitted_BESCoef_PartyExp %>%
mutate(Correct.Dich.Guess.Party = case_when(profile_Con.Dich=="50-50" ~ 0.5,
profile_Con.Dich==profile_Conservative.RealN ~ 1,
profile_Con.Dich!=profile_Conservative.RealN ~ 0))
dclus1<-svydesign(ids=~0, weights=fitted_BESCoef_PartyExp$respondent_weights, data=fitted_BESCoef_PartyExp)
meanCon<-svymean(~Correct.Dich.Guess.Party, dclus1 ,deff=F, na.rm =T)
CI<-confint(meanCon)
CI.Correct.Party.Dich<-data.frame("Correct"="Party", "fit"=meanCon[1]*100, "lwr"=CI[1,1]*100,"upr"=CI[1,2]*100)
##### ~ [End of Chunk 7 removed due to separate analysis] ~ ####
# set political attention to factor
Parties.Experiment.Clean$respondent_PoliticalAttention<-as.numeric(as.character(Parties.Experiment.Clean$respondent_PoliticalAttention))
Brexit.Experiment.Clean$respondent_PoliticalAttention<-as.numeric(as.character(Brexit.Experiment.Clean$respondent_PoliticalAttention))
fitted_BESCoef_BrexExp$respondent_PoliticalAttention<-as.numeric(as.character(fitted_BESCoef_BrexExp$respondent_PoliticalAttention))
fitted_BESCoef_PartyExp$respondent_PoliticalAttention<-as.numeric(as.character(fitted_BESCoef_PartyExp$respondent_PoliticalAttention))
################# END CHUNK 7 ##################################
###################### End: ###############################
########## [Titelman & Lauderdale (2021c) code] ###########
###########################################################
#check levels of variables being used
levels(Brexit.Experiment.Clean$respondent_pastvote_2017)
levels(fitted_BESCoef_BrexExp$respondent_pastvote_2017)
levels(Brexit.Experiment.Clean$respondent_pastvote_EURef)
levels(fitted_BESCoef_BrexExp$respondent_pastvote_EURef)
levels(Brexit.Experiment.Clean$respondent_Gender)
levels(fitted_BESCoef_BrexExp$respondent_Gender)
levels(Brexit.Experiment.Clean$respondent_Education)
levels(fitted_BESCoef_BrexExp$respondent_Education)
levels(Brexit.Experiment.Clean$respondent_Region)
levels(fitted_BESCoef_BrexExp$respondent_Region)
# run original models for verification
# brier - brexit
modelBrier_brex <- lm(BrierScore ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = Brexit.Experiment.Clean$respondent_weights,
data = Brexit.Experiment.Clean)
# brier - party
modelBrier_party <- lm(BrierScore ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = Parties.Experiment.Clean$respondent_weights,
data = Parties.Experiment.Clean)
# dichot - brexit
modelDicho_brex <- lm(Correct.Dich.Guess.Brex ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = fitted_BESCoef_BrexExp$respondent_weights, data = fitted_BESCoef_BrexExp)
# dichot - Party
modelDicho_party <- lm(Correct.Dich.Guess.Party ~ respondent_PoliticalAttention + respondent_pastvote_2017 + respondent_pastvote_EURef
+ respondent_Age + respondent_Education + respondent_Gender + respondent_Region,
weights = fitted_BESCoef_PartyExp$respondent_weights, data = fitted_BESCoef_PartyExp)
sjPlot::tab_model(
modelBrier_brex, modelBrier_party, modelDicho_brex, modelDicho_party,
file = "Outputs/DataAppendixOutputs/tab_A1.html",
digits = 3,
title = "Table A1. Verification of Original Models Predicting Guess Accuracy Across Brexit and Party Experiments.",
pred.labels = c(
"(Intercept)" = "Intercept",
"respondent_PoliticalAttention" = "Political Attention",
"respondent_pastvote_2017Labour" = "Party Vote: Labour",
"respondent_pastvote_2017Liberal Democrat" = "Party Vote: Liberal Democrat",
"respondent_pastvote_2017Scottish National Party (SNP)" = "Party Vote: SNP",
"respondent_pastvote_2017Plaid Cymru" = "Party Vote: Plaid Cymru",
"respondent_pastvote_2017UK Independence Party (UKIP)" = "Party Vote: UKIP",
"respondent_pastvote_2017Green" = "Party Vote: Green",
"respondent_pastvote_2017Other" = "Party Vote: Other",
"respondent_pastvote_2017Don’t know" = "Party Vote: Don't Know",
"respondent_pastvote_EURefLeave" = "EU Ref. Vote: Leave",
"respondent_pastvote_EURefDid not vote" = "EU Ref. Vote: Did Not Vote",
"respondent_Age" = "Age",
"respondent_EducationLevel 1" = "Education Level: 1",
"respondent_EducationLevel 2" = "Education Level: 2",
"respondent_EducationLevel 3" = "Education Level: 3",
"respondent_EducationLevel 4" = "Education Level: 4",
"respondent_EducationLevel 5 and above" = "Education Level: 5 and Above",
"respondent_EducationOther" = "Education Level: Other",
"respondent_GenderFemale" = "Gender: Female",
"respondent_RegionNorth West" = "Region: North West",
"respondent_RegionYorkshire and the Humber" = "Region: Yorkshire and the Humber",
"respondent_RegionEast Midlands" = "Region: East Midlands",
"respondent_RegionWest Midlands" = "Region: West Midlands",
"respondent_RegionEast of England" = "Region: East of England",
"respondent_RegionLondon" = "Region: London",
"respondent_RegionSouth East" = "Region: South East",
"respondent_RegionSouth West" = "Region: South West",
"respondent_RegionWales" = "Region: Wales",
"respondent_RegionScotland" = "Region: Scotland"
),
dv.labels = c(
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>"
),
string.pred = "Coefficient",
show.ci = FALSE,
show.se = TRUE,
string.se = "Standard Error",
p.style = "stars",
CSS = list(
css.colheaders = "text-align: center; vertical-align: bottom;"
)
)
# Create new dataframes relevant for replication project
# 1. BREXIT DATA: New dataframe extracting and renaming only the core analytical variables
brexit_brier <- Brexit.Experiment.Clean %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
brier_score = BrierScore,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 2. BREXIT & DICHOTOMOUS DATA: New dataframe for Dicho analysis
brexit_dicho <- fitted_BESCoef_BrexExp %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
dicho_score = Correct.Dich.Guess.Brex,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 3. PARTIES EXPERIMENT DATA: New dataframe extracting only the core analytical variables
parties_brier <- Parties.Experiment.Clean %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
brier_score = BrierScore,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# 4. PARTIES & DICHOTOMOUS: New dataframe for dicho analysis
parties_dicho <- fitted_BESCoef_PartyExp %>%
select(
respondent_id = respondent_ID,
weights = respondent_weights,
dicho_score = Correct.Dich.Guess.Party,
pol_attention = respondent_PoliticalAttention,
past_vote_2017 = respondent_pastvote_2017,
eu_ref_vote = respondent_pastvote_EURef,
age = respondent_Age,
education = respondent_Education,
gender = respondent_Gender,
region = respondent_Region
)
# class check before modelling
class(brexit_brier$respondent_id) # make a factor
class(brexit_brier$brier_score)
class(brexit_brier$pol_attention) # make numeric
class(brexit_brier$past_vote_2017)
class(brexit_brier$eu_ref_vote)
class(brexit_brier$age)
class(brexit_brier$education)
class(brexit_brier$gender)
class(brexit_brier$region)
class(brexit_dicho$dicho_score)
# check rows
nrow(brexit_brier)
nrow(parties_brier)
# recode variables for modelling and interpretation
# ensure pol_attention is a numeric variable in all datasets
brexit_brier$pol_attention <- as.numeric(brexit_brier$pol_attention)
brexit_dicho$pol_attention <- as.numeric(brexit_dicho$pol_attention)
parties_brier$pol_attention <- as.numeric(parties_brier$pol_attention)
parties_dicho$pol_attention <- as.numeric(parties_dicho$pol_attention)
# Ensure respondent_id is set up as a factor variable in all datasets
brexit_brier$respondent_id <- as.factor(brexit_brier$respondent_id)
brexit_dicho$respondent_id <- as.factor(brexit_dicho$respondent_id)
parties_brier$respondent_id <- as.factor(parties_brier$respondent_id)
parties_dicho$respondent_id <- as.factor(parties_dicho$respondent_id)
# check levels of all factor vs (set baseline categories to same as original models for ease of comparison)
levels(brexit_brier$past_vote_2017)
levels(brexit_dicho$past_vote_2017)
levels(parties_brier$past_vote_2017)
levels(parties_dicho$past_vote_2017)
levels(brexit_brier$eu_ref_vote)
levels(brexit_brier$education)
levels(brexit_brier$gender)
levels(brexit_brier$region)
# graphs made for each experiment (brexit/party) then combined using patchwork package
# Brexit Experiment
brex_brier_plot <- ggplot(data = brexit_brier, aes(x = brier_score)) +
geom_histogram(
binwidth = 0.05,
fill = "#2c3e50",
color = "white",
alpha = 0.8
) +
theme_minimal(base_size = 13) +
theme(
plot.title = element_text(face = "bold", hjust= 0.5),
panel.grid.minor = element_blank(),
axis.title.x = element_text(size = 11),
axis.title.y = element_text(size = 11),
) +
labs(
title = "Brexit Experiment",
x = "Brier Score (0 - 1)",
y = "Count"
)
# Parties Experiment
party_brier_plot <- ggplot(data = parties_brier, aes(x = brier_score)) +
geom_histogram(
binwidth = 0.05,
fill = "#2c3e50",
color = "white",
alpha = 0.8
) +
theme_minimal(base_size = 13) +
theme(
plot.title = element_text(face = "bold", hjust = 0.5),
panel.grid.minor = element_blank(),
axis.title.x = element_text(size = 11),
axis.title.y = element_text(size = 11),
) +
labs(
title = "Parties Experiment",
x = "Brier Score (0 - 1)",
y = "Count"
)
# align the y-axis
brex_brier_plot_aligned <- brex_brier_plot + coord_cartesian(ylim = c(0, 600))
party_brier_plot_aligned <- party_brier_plot + coord_cartesian(ylim = c(0, 600))
# Combine both histograms using patchwork package # - dv1 plot
dv1 <- (brex_brier_plot_aligned + party_brier_plot_aligned) +
plot_annotation(
title = "Figure 1: Overall Distribution of Brier Scores",
subtitle = "Comparing prediction accuracy across both experimental groups",
caption = "Note: A lower Brier Score indicates better prediction accuracy.",
theme = theme(
plot.title = element_text(size = 18, face = "bold", hjust = 0.5),
plot.subtitle = element_text(size = 13, face = "italic", hjust = 0.5),
plot.caption = element_text(size = 11, face = "italic", hjust = 0.5, margin = margin(t = 15))
)
)
ggsave(filename = "Outputs/Results/fig_1.png", dv1)
dv1
# Make Distribution plots for Dicho variables for both brexit and party
# combine plots
# bar chart
brex_dicho_plot <- ggplot(
brexit_dicho %>%
dplyr::filter(!is.na(dicho_score)),
aes(x = factor(dicho_score))
) +
geom_bar(fill = "#4C78A8", aes(y = after_stat(prop), group = 1)) +
scale_x_discrete(
labels = c(
"0" = "Incorrect",
"0.5" = "50–50 (Unsure)",
"1" = "Correct"
)
) +
scale_y_continuous(
labels = scales::percent,
limits = c(0, 1),
breaks = seq(0, 1, 0.25)
) +
labs(
x = "Directional Accuracy",
y = "Proportion",
title = "Brexit Experiment"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", hjust= 0.5),
axis.title.x = element_text(size = 11),
axis.title.y = element_text(size = 11),
legend.position = "none"
)
# Parties Experiment
#bar chart
party_dicho_plot <- ggplot(
parties_dicho %>%
dplyr::filter(!is.na(dicho_score)),
aes(x = factor(dicho_score))
) +
geom_bar(fill = "#4C78A8", aes(y = after_stat(prop), group = 1)) +
scale_x_discrete(
labels = c(
"0" = "Incorrect",
"0.5" = "50–50 (Unsure)",
"1" = "Correct"
)
) +
scale_y_continuous(
labels = scales::percent,
limits = c(0, 1),
breaks = seq(0, 1, 0.25)
) +
labs(
x = "Directional Accuracy",
y = "Proportion",
title = "Party Experiment"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", hjust= 0.5),
axis.title.x = element_text(size = 11),
axis.title.y = element_text(size = 11),
legend.position = "none"
)
# patchwork two plots together - dv2 plot
dv2 <- brex_dicho_plot + party_dicho_plot +
plot_layout(axes = "collect") +
plot_annotation(
title = "Figure 2: Directional Accuracy of Respondent Guesses",
subtitle = "Distribution of Correct Dichotomised Guess scores across both Experiments",
theme = theme(
plot.title = element_text(size = 18, face = "bold", hjust = 0.5),
plot.subtitle = element_text(size = 13, face = "italic", hjust = 0.5)
))
ggsave(filename = "Outputs/Results/fig_2.png", dv2)
dv2
# Generate the cross-tabulations
# clean the NAs
clean_brex_tab_df <- brexit_brier %>%
mutate(past_vote_2017 = str_replace_all(as.character(past_vote_2017), "Don’t know", "Dont know")) %>%
filter(!past_vote_2017 %in% c("N/A", "N/A_duplicated_9"))
clean_party_tab_df <- parties_brier %>%
mutate(past_vote_2017 = str_replace_all(as.character(past_vote_2017), "Don’t know", "Dont know")) %>%
filter(!past_vote_2017 %in% c("N/A", "N/A_duplicated_9"))
brexit_tab <- table(clean_brex_tab_df$past_vote_2017, clean_brex_tab_df$eu_ref_vote)
parties_tab <- table(clean_party_tab_df$past_vote_2017, clean_party_tab_df$eu_ref_vote)
# Combine them
# format = "html" ensures the HTML page aligns them horizontally
tab1 <- knitr::kable(
list(brexit_tab, parties_tab),
format = "html",
caption = "**Table 1: Cross-Tab of Respondent Voter History for Brexit (Left) and Parties (Right) Samples**",
col.names = colnames(brexit_tab)
)
save_kable(tab1, "Outputs/Results/tab_1.html")
tab1
# Brexit sample distribution
edu_brex <- prop.table(table(brexit_brier$education)) * 100
# Parties sample distribution
edu_parties <- prop.table(table(parties_brier$education)) * 100
edu_brex_str <- paste(names(edu_brex), round(edu_brex, 1), "%", collapse = "; ")
edu_parties_str <- paste(names(edu_parties), round(edu_parties, 1), "%", collapse = "; ")
tibble(
`Sample` = c("Brexit", "Parties"),
`Education (%)` = c(edu_brex_str, edu_parties_str)
)
# key background predictors
iv_stats <- tibble(
`Sample` = c("Brexit", "Parties"),
`Total (N)` = c(nrow(brexit_brier), nrow(parties_brier)),
`Unique IDs` = c(
length(unique(brexit_brier$respondent_id)),
length(unique(parties_brier$respondent_id))
),
`Mean Political Attention (0-10)` = c(
mean(brexit_brier$pol_attention, na.rm = TRUE),
mean(parties_brier$pol_attention, na.rm = TRUE)
),
`Mean Age (Years)` = c(
mean(brexit_brier$age, na.rm = TRUE),
mean(parties_brier$age, na.rm = TRUE)
),
`Gender (% Female)` = c(
mean(brexit_brier$gender == "Female", na.rm = TRUE) * 100,
mean(parties_brier$gender == "Female", na.rm = TRUE) * 100
)
)
tab2 <- knitr::kable(iv_stats, digits = 2,
caption = "**Table 2: Additional Respondent Demographics Summary Stats**")
save_kable(tab2, "Outputs/Results/tab_2.html")
tab2
# run original models with new subsetted datasets for comparison
########## Brier Score ###########
# brier brexit
original_brier_brex <- lm(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = brexit_brier)
# brier party
original_brier_party <- lm(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = parties_brier)
######## Dichotomised ###########
# dicho brexit
original_dicho_brex <- lm(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = brexit_dicho)
# dicho party
original_dicho_party <- lm(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region,
weights = weights,
data = parties_dicho)
# original table results
tab_model(
original_brier_brex, original_brier_party, original_dicho_brex, original_dicho_party,
file = "Outputs/DataAppendixOutputs/tab_A2.html",
digits = 3,
title = "Table A2. Verification of Original Models with New Dataframes of Respondent Characteristics Predicting Guess Accuracy Across Brexit and Party Experiments.",
pred.labels = c(
"(Intercept)" = "Intercept",
"pol_attention" = "Political Attention",
"past_vote_2017Labour" = "Party Vote: Labour",
"past_vote_2017Scottish National Party (SNP)" = "Party Vote: SNP",
"past_vote_2017Liberal Democrat" = "Party Vote: Liberal Democrat",
"past_vote_2017Green" = "Party Vote: Green",
"past_vote_2017Plaid Cymru" = "Party Vote: Plaid Cymru",
"past_vote_2017UK Independence Party (UKIP)" = "Party Vote: UKIP",
"past_vote_2017Other" = "Party Vote: Other",
"past_vote_2017Don’t know" = "Party Vote: Don't Know",
"eu_ref_voteLeave" = "EU Ref. Vote: Leave",
"eu_ref_voteDid not vote" = "EU Ref. Vote: Did Not Vote",
"age" = "Age",
"educationLevel 1" = "Education Level: 1",
"educationLevel 2" = "Education Level: 2",
"educationLevel 3" = "Education Level: 3",
"educationLevel 4" = "Education Level: 4",
"educationLevel 5 and above" = "Education Level: 5 and Above",
"educationOther" = "Education Level: Other",
"genderFemale" = "Gender: Female",
"regionNorth West" = "Region: North West",
"regionYorkshire and the Humber" = "Region: Yorkshire and the Humber",
"regionEast Midlands" = "Region: East Midlands",
"regionWest Midlands" = "Region: West Midlands",
"regionEast of England" = "Region: East of England",
"regionLondon" = "Region: London",
"regionSouth East" = "Region: South East",
"regionSouth West" = "Region: South West",
"regionWales" = "Region: Wales",
"regionScotland" = "Region: Scotland"
),
dv.labels = c(
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>"
),
string.pred = "Coefficient",
show.ci = FALSE,
show.se = TRUE,
string.se = "Standard Error",
p.style = "stars",
CSS = list(
css.colheaders = "text-align: center; vertical-align: bottom;"
)
)
# check length of unique respondent_id
length(unique(brexit_brier$respondent_id))
length(unique(brexit_dicho$respondent_id))
length(unique(parties_dicho$respondent_id))
length(unique(parties_brier$respondent_id))
# Run multilevel model with respondent ID's as nested variable
###### Brier #######
# mixed brier brexit model
mixed_brier_brex <- lmer(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = brexit_brier)
# mixed brier party model
mixed_brier_party <- lmer(brier_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = parties_brier)
###### dicho ######
# dicho brexit
mixed_dicho_brex <- lmer(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = brexit_dicho)
# dicho party
mixed_dicho_party <- lmer(dicho_score ~ pol_attention +
past_vote_2017 + eu_ref_vote
+ age + education + gender + region +
(1 | respondent_id),
weights = weights,
data = parties_dicho)
# summary coomparison of original and new multilevel specs
# brier brexit
summary(original_brier_brex)
summary(mixed_brier_brex)
# brier party
summary(original_brier_party)
summary(mixed_brier_party)
# dicho brexit
summary(original_dicho_brex)
summary(mixed_dicho_brex)
# dicho party
summary(original_dicho_party)
summary(mixed_dicho_party)
# comparing OLS model fit against Multilevel model fit
# Brier Score models
fit_test_brexit_brier <- anova(mixed_brier_brex, original_brier_brex)
fit_test_party_brier <- anova(mixed_brier_party, original_brier_party)
# Dicho models
fit_test_brexit_dicho <- anova(mixed_dicho_brex, original_dicho_brex)
fit_test_party_dicho <- anova(mixed_dicho_party, original_dicho_party)
# Display results
print(fit_test_brexit_brier)
print(fit_test_party_brier)
print(fit_test_brexit_dicho)
print(fit_test_party_dicho)
# summary of model fit tests with plugged in values from print output above
test_summary_table <- tibble(
`Model Context & Comparison` = c(
"Brexit Experiment: Brier Score",
"Parties Experiment: Brier Score",
"Brexit Experiment: Dichotomised Score",
"Parties Experiment: Dichotomised Score"
),
`OLS AIC` = c(1646.5, 1480.8, 4802.2, 5049.8),
`Multilevel AIC` = c(1597.3, 1419.3, 4781.8, 5039.2),
`Chi-Square` = c(51.159, 63.498, 22.323, 12.638),
`Significance (p-value)` = c("***", "***", "***", "***")
)
# Print consolidated table
tab3 <- knitr::kable(test_summary_table, digits = 3,
caption = "**Table 3: Test Fit Comparisons across Modeling Structures**")
save_kable(tab3, "Outputs/Results/tab_3.html")
tab3
# summary table of new multi level models
tab_model(
mixed_brier_brex, mixed_brier_party, mixed_dicho_brex, mixed_dicho_party,
file = "Outputs/Results/tab_4.html",
digits = 3,
title = "Table 4. Multi-level Predictors of Respondent Characteristics Predicting Guess Accuracy (Brier Score and Correct Dichotomised Guess) Across Brexit and Party Experiments.",
pred.labels = c(
"(Intercept)" = "Intercept",
"pol_attention" = "Political Attention",
"past_vote_2017Labour" = "Party Vote: Labour",
"past_vote_2017Scottish National Party (SNP)" = "Party Vote: SNP",
"past_vote_2017Liberal Democrat" = "Party Vote: Liberal Democrat",
"past_vote_2017Green" = "Party Vote: Green",
"past_vote_2017Plaid Cymru" = "Party Vote: Plaid Cymru",
"past_vote_2017UK Independence Party (UKIP)" = "Party Vote: UKIP",
"past_vote_2017Other" = "Party Vote: Other",
"past_vote_2017Don’t know" = "Party Vote: Don't Know",
"eu_ref_voteLeave" = "EU Ref. Vote: Leave",
"eu_ref_voteDid not vote" = "EU Ref. Vote: Did Not Vote",
"age" = "Age",
"educationLevel 1" = "Education Level: 1",
"educationLevel 2" = "Education Level: 2",
"educationLevel 3" = "Education Level: 3",
"educationLevel 4" = "Education Level: 4",
"educationLevel 5 and above" = "Education Level: 5 and Above",
"educationOther" = "Education Level: Other",
"genderFemale" = "Gender: Female",
"regionNorth West" = "Region: North West",
"regionYorkshire and the Humber" = "Region: Yorkshire and the Humber",
"regionEast Midlands" = "Region: East Midlands",
"regionWest Midlands" = "Region: West Midlands",
"regionEast of England" = "Region: East of England",
"regionLondon" = "Region: London",
"regionSouth East" = "Region: South East",
"regionSouth West" = "Region: South West",
"regionWales" = "Region: Wales",
"regionScotland" = "Region: Scotland"
),
dv.labels = c(
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Brier Score</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Brexit Exp.</div>",
"<div style='text-align: center;'><b>Correct Dichotomised Guess</b><hr style='border: none; border-top: 1px solid black; margin: 4px 0;'>Party Exp.</div>"
),
string.pred = "Coefficient",
show.ci = FALSE,
show.se = TRUE,
string.se = "Standard Error",
p.style = "stars",
show.icc = TRUE,
CSS = list(
css.colheaders = "text-align: center; vertical-align: bottom;",
css.randomparts = "font-style: normal; font-weight: bold; color: #2c3e50;"
)
)
# Detailed information of environment
sessionInfo()