Simulating the Backlash Game.

The Backlash Game

Part I — Hidden \(r\) Version

1) Players, types, and timing

  • Leader’s competences: \(\theta_D, \theta_F \sim \text{Uniform}[0,1]\), independent.
  • Voters: each voter uses a relative weight \(r \geq 0\) on foreign competence.
    • \(r=1\) means neutral (equal weights).
    • \(0<r<1\) means domestic-oriented.
    • \(r>1\) means foreign-oriented.
  • Hidden \(r\): The leader does not know voters’ \(r\).
  • Sequence: Nature draws \((\theta_D,\theta_F)\) \(\to\) leader chooses which domain to showcase \(a \in \{D,F\}\) \(\to\) voters observe a noisy signal about the chosen domain and update \(\to\) voters decide retain (1) or remove (0).

2) Selection rule

Baseline assumption: the leader showcases her stronger side (the max):
- Choose \(F\) if \(\theta_F \geq \theta_D\), else choose \(D\).

3) Signals

  • If \(F\) is chosen: \(x_F = \theta_F + \varepsilon_F\), with \(\mathbb{E}[\varepsilon_F]=0\).
  • If \(D\) is chosen: \(x_D = \theta_D + \varepsilon_D\), with \(\mathbb{E}[\varepsilon_D]=0\).

4) Posterior beliefs

  • For the revealed domain, voters form a posterior mean \(\mu_F = \mathbb{E}[\theta_F \mid x_F]\) or \(\mu_D = \mathbb{E}[\theta_D \mid x_D]\).
  • For the hidden domain, voters infer it is about half the revealed value (due to selection from two uniforms):
    • If \(F\) chosen: \(\mu_D \approx \tfrac{1}{2}\mu_F\).
    • If \(D\) chosen: \(\mu_F \approx \tfrac{1}{2}\mu_D\).

5) Evaluation rule

Voters reelect iff \[ \frac{\mu_D + r\,\mu_F}{1+r} \;\geq\; 0.5. \]

  • After a foreign showcase (\(\mu_D = \mu_F/2\)): \[ \frac{\mu_F/2 + r\,\mu_F}{1+r} \geq 0.5 \;\;\Longleftrightarrow\;\; \mu_F \;\geq\; \frac{1+r}{1+2r}. \]

  • After a domestic showcase (\(\mu_F = \mu_D/2\)): \[ \frac{\mu_D + r\,\mu_D/2}{1+r} \geq 0.5 \;\;\Longleftrightarrow\;\; \mu_D \;\geq\; \frac{1+r}{1+r/2}. \]

Backlash interpretation:
- If \(r<1\) (domestic-oriented), the foreign threshold is very high, so even strong foreign signals may fail.
- If \(r>1\) (foreign-oriented), the domestic threshold is very high.

Part II — Public \(r\) Version

Now let \(r\) be common knowledge.

1) Thresholds

  • After foreign choice: \[ \mu_F \;\geq\; T_F(r) \equiv \frac{1+r}{1+2r}. \]

  • After domestic choice: \[ \mu_D \;\geq\; T_D(r) \equiv \frac{1+r}{1+r/2}. \]

2) Leader’s objective

  • Reelection payoff \(=1\) if retained, \(0\) if removed.
  • Add small policy taste \(\alpha \in (0,1)\): if both options give the same reelection outcome, choose the favorite (adds \(\alpha\)).

3) Leader’s best-response rule

Given \((\theta_D,\theta_F)\) and \(r\):

  1. If only foreign meets the threshold (\(\theta_F \geq T_F(r)\), \(\theta_D < T_D(r)\)), choose foreign.
  2. If only domestic meets the threshold (\(\theta_D \geq T_D(r)\), \(\theta_F < T_F(r)\)), choose domestic.
  3. If both meet thresholds, choose the favorite (or stronger if indifferent).
  4. If neither meets thresholds, choose the favorite (fails reelection).

4) Comparative statics

  • As \(r \uparrow\): \(T_F(r)\) falls, \(T_D(r)\) rises. Foreign-viable region expands, domestic shrinks.
  • As \(r \downarrow\): the opposite.

Numeric example

Suppose \(\mu_F = 0.74\) after a foreign showcase.

  • If \(r=0.3\): \(T_F(0.3)=1.3/1.6=0.8125\). Since \(0.74<0.8125\), voters remove (backlash).
  • If \(r=1\): \(T_F(1)=2/3=0.667\). Since \(0.74>0.667\), voters retain.
  • If \(r=1.2\): \(T_F(1.2)=2.2/3.4 \approx 0.647\). Since \(0.74>0.647\), voters retain.

Same performance, different electorates \(\Rightarrow\) backlash arises.

Simulations

ChatGPT assisted in the generation of the following code. All creative work and modeling decisions are the original and sole contribution of the author.

# ---- setup ----
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.2     ✔ tibble    3.2.1
## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
## ✔ purrr     1.0.4     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
set.seed(921) # I had this idea on the 21st night of september

# Prior belief for the showcased (max) competence under independent Uniform(0,1):
# mean = 2/3, var = 1/18 approx. 0.0555556
PRIOR_MEAN <- 2/3 # recall, the expectation of two uniform draws, taking the highest, is 2/3 (in a [0,1] distribution). 
PRIOR_VAR  <- 1/18

# Normal-Normal posterior mean update for continuous signals:
# prior: N(m0, s0^2); likelihood: x ~ N(theta, s^2)
# posterior mean for theta given x: (m0/s0^2 + x/s^2) / (1/s0^2 + 1/s^2)
post_mean_normal <- function(x, m0 = PRIOR_MEAN, s0 = sqrt(PRIOR_VAR), s = 0.20) {
  num <- m0/(s0^2) + x/(s^2)
  den <- 1/(s0^2) + 1/(s^2)
  num / den
}

# Given the selection "showcase the max", the *hidden* competence (the min) has E[min | max=θ] = θ/2.
infer_hidden_mean <- function(mu_revealed) mu_revealed / 2

# Voter evaluation rule: weighted average vs 0.5
# Eval = (mu_D + r * mu_F) / (1 + r). Retain if Eval >= 0.5
retain_decision <- function(muD, muF, r) {
  eval <- (muD + r * muF) / (1 + r)
  eval >= 0.5
}

# Analytical thresholds (useful for checks/plots)
TF <- function(r) (1 + r) / (1 + 2*r)          # required mu_F if Foreign is showcased
TD <- function(r) (1 + r) / (2 + r)        # required mu_D if Domestic is showcased

simulate_hidden_r <- function(
  N = 100000,
  noise_sd = 0.20,
  r_sampler = function(n) runif(n, 0.2, 2.0)  # customize electorate mix here
) {
  # Draw types
  thetaD <- runif(N)
  thetaF <- runif(N)

  # Leader chooses the stronger domain (unknown r baseline)
  choice <- ifelse(thetaF >= thetaD, "F", "D")

  # Draw r per voter (one representative voter per leader for sim purposes)
  r <- r_sampler(N)

  # Generate signals & posteriors
  # NOTE: Voters' prior for the revealed dimension already reflects "max" selection.
  # We model x = theta + eps, eps ~ N(0, noise_sd^2), then compute posterior mean.
  xF <- thetaF + rnorm(N, 0, noise_sd)
  xD <- thetaD + rnorm(N, 0, noise_sd)

  muF_revealed <- post_mean_normal(xF, s = noise_sd)
  muD_revealed <- post_mean_normal(xD, s = noise_sd)

  # Build muD, muF based on which side was revealed; infer hidden as half of revealed
  muF <- ifelse(choice == "F", muF_revealed, infer_hidden_mean(muD_revealed))
  muD <- ifelse(choice == "D", muD_revealed, infer_hidden_mean(muF_revealed))

  retained <- retain_decision(muD, muF, r)

  tibble(
    thetaD, thetaF, r, choice, xF, xD, muF_revealed, muD_revealed, muF, muD, retained
  )
}

# Example run + quick summaries
hidden_out <- simulate_hidden_r(N = 200000, noise_sd = 0.20)

hidden_out %>%
  summarize(
    share_foreign = mean(choice == "F"),
    overall_retention = mean(retained),
    retention_if_foreign = mean(retained[choice == "F"]),
    retention_if_domestic = mean(retained[choice == "D"])
  )
## # A tibble: 1 × 4
##   share_foreign overall_retention retention_if_foreign retention_if_domestic
##           <dbl>             <dbl>                <dbl>                 <dbl>
## 1         0.501             0.509                0.500                 0.518
# Retention as a function of r, stratified by showcased domain
hidden_out %>%
  mutate(choice = factor(choice, levels = c("D","F"))) %>%
  group_by(choice, rbin = cut(r, breaks = seq(0.2, 2.0, by = 0.1), include.lowest = TRUE)) %>%
  summarize(retain = mean(retained), r_mid = mean((as.numeric(rbin)-0.5)*0.1 + 0.2), .groups = "drop") %>%
  ggplot(aes(r_mid, retain, color = choice)) +
  geom_line(size = 1) +
  labs(x = "r (relative weight on foreign)", y = "Retention rate",
       color = "Showcased", title = "Hidden-r: Retention vs r by showcased domain") +
  theme_minimal(base_size = 12)
## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

# Compare observed posterior mu_revealed to analytical thresholds TF/TD (hidden-r):
# (Even though leader doesn't know r, voters do; we visualize where signals pass/fail for different r)
grid_r <- tibble(r = seq(0.2, 2, by = 0.01), TF = TF(r), TD = TD(r)) %>%
  pivot_longer(c(TF, TD), names_to = "which", values_to = "thr")

ggplot(grid_r, aes(r, thr, color = which)) +
  geom_line(size = 1) +
  labs(x = "r", y = "Threshold", color = "Threshold",
       title = "Analytical thresholds TF(r), TD(r)") +
  theme_minimal(base_size = 12)

simulate_public_r <- function(
  N = 10000,
  noise_sd = 0.20,
  r_sampler = function(n) runif(n, 0.2, 2.0),
  alpha = 0.05  # small policy taste to break ties (only matters when both/none pass)
) {
  thetaD <- runif(N)
  thetaF <- runif(N)
  r      <- r_sampler(N)

  # Leader evaluates viability using the analytical thresholds with mu ≈ theta
  viableF <- thetaF >= TF(r)
  viableD <- thetaD >= TD(r)

  # Choice rule:
  choice <- ifelse(
    viableF & !viableD, "F",
    ifelse(!viableF & viableD, "D",
           ifelse(viableF & viableD,
                  # both viable: pick favorite; if no favorite given, pick stronger
                  ifelse(thetaF >= thetaD, "F", "D"),
                  # neither viable: pick favorite; if none, pick stronger (for display)
                  ifelse(thetaF >= thetaD, "F", "D")
           ))
  )

  # Generate signals and posteriors as in hidden-r, given realized choice
  xF <- thetaF + rnorm(N, 0, noise_sd)
  xD <- thetaD + rnorm(N, 0, noise_sd)

  muF_revealed <- post_mean_normal(xF, s = noise_sd)
  muD_revealed <- post_mean_normal(xD, s = noise_sd)

  muF <- ifelse(choice == "F", muF_revealed, infer_hidden_mean(muD_revealed))
  muD <- ifelse(choice == "D", muD_revealed, infer_hidden_mean(muF_revealed))

  retained <- retain_decision(muD, muF, r)

  tibble(thetaD, thetaF, r, choice, xF, xD, muF_revealed, muD_revealed, muF, muD, retained,
         viableF, viableD)
}

public_out <- simulate_public_r(N = 200000, noise_sd = 0.20)

public_out %>%
  summarize(
    share_foreign = mean(choice == "F"),
    overall_retention = mean(retained),
    retention_if_foreign = mean(retained[choice == "F"]),
    retention_if_domestic = mean(retained[choice == "D"])
  )
## # A tibble: 1 × 4
##   share_foreign overall_retention retention_if_foreign retention_if_domestic
##           <dbl>             <dbl>                <dbl>                 <dbl>
## 1         0.498             0.512                0.507                 0.517
# Share choosing Foreign vs r & retention vs r
public_out %>%
  group_by(rbin = cut(r, breaks = seq(0.2, 2.0, by = 0.1), include.lowest = TRUE)) %>%
  summarize(
    r_mid = mean((as.numeric(rbin)-0.5)*0.1 + 0.2),
    share_foreign = mean(choice == "F"),
    retain = mean(retained),
    .groups = "drop"
  ) %>%
  pivot_longer(c(share_foreign, retain), names_to = "metric", values_to = "value") %>%
  ggplot(aes(r_mid, value, color = metric)) +
  geom_line(size = 1) +
  labs(x = "r", y = "Rate", color = "Metric",
       title = "Public-r: share choosing Foreign & retention vs r") +
  theme_minimal(base_size = 12)

# Hidden-r: condition on foreign showcase and test the pass/fail boundary
# For each r bin, compute the fraction of cases with muF >= TF(r), and compare to retention
chk_hidden <- hidden_out %>%
  filter(choice == "F") %>%
  mutate(passF = muF >= TF(r)) %>%
  group_by(rbin = cut(r, breaks = seq(0.2, 2.0, by = 0.1), include.lowest = TRUE)) %>%
  summarize(
    r_mid = mean((as.numeric(rbin)-0.5)*0.1 + 0.2),
    frac_pass = mean(passF),
    frac_ret  = mean(retained),
    .groups = "drop"
  )

ggplot(chk_hidden, aes(r_mid)) +
  geom_line(aes(y = frac_pass, color = "Above TF(r)")) +
  geom_line(aes(y = frac_ret,  color = "Retained")) +
  labs(x = "r", y = "Fraction (foreign-showcase cases only)",
       color = "", title = "Hidden-r: passing TF(r) aligns with retention") +
  theme_minimal(base_size = 12)

# Public-r: the choice rule uses thresholds; realized retention should align closely
chk_public <- public_out %>%
  mutate(
    passF = (choice == "F") & (muF >= TF(r)),
    passD = (choice == "D") & (muD >= TD(r))
  ) %>%
  group_by(rbin = cut(r, breaks = seq(0.2, 2.0, by = 0.1), include.lowest = TRUE)) %>%
  summarize(
    r_mid = mean((as.numeric(rbin)-0.5)*0.1 + 0.2),
    frac_ret  = mean(retained),
    frac_pass = mean(passF | passD),
    share_F   = mean(choice == "F"),
    .groups = "drop"
  )

ggplot(chk_public, aes(r_mid)) +
  geom_line(aes(y = frac_pass, color = "Pass threshold")) +
  geom_line(aes(y = frac_ret,  color = "Retained")) +
  geom_line(aes(y = share_F,   color = "Share choosing F"), linetype = 2) +
  labs(x = "r", y = "Rate", color = "",
       title = "Public-r: thresholds, retention, and foreign choice vs r") +
  theme_minimal(base_size = 12)

library(tidyverse)

# binary indicators
df <- public_out %>%
  transmute(r,
            retained_i = as.integer(retained),
            showF_i    = as.integer(choice == "F"))

# correlation by r-bin + CIs (Fisher z)
bw <- 0.10
corr_by_r <- df %>%
  mutate(rbin = cut(r, breaks = seq(0.2, 2.0, by = bw), include.lowest = TRUE)) %>%
  group_by(rbin) %>%
  summarize(
    r_mid = mean((as.numeric(rbin)-0.5)*bw + 0.2),
    n     = n(),
    cor_rf = cor(retained_i, showF_i),          # Pearson = point-biserial
    .groups = "drop"
  ) %>%
  mutate(
    z  = atanh(cor_rf),
    se = 1 / sqrt(pmax(n - 3, 1)),
    zlo = z - 1.96*se, zhi = z + 1.96*se,
    lo = tanh(zlo), hi = tanh(zhi)
  )

ggplot(corr_by_r, aes(r_mid, cor_rf)) +
  geom_hline(yintercept = 0, linetype = 3) +
  geom_ribbon(aes(ymin = lo, ymax = hi), alpha = 0.15) +
  geom_line(size = 1) +
  labs(x = "r", y = "Corr(retained, show Foreign)",
       title = "Public-r: correlation between retention and choosing Foreign by r") +
  theme_minimal(12)