Replication Codes for ‘From Olympic Gold to Government Approval?: Limited Evidence of Attribution Error from the 2024 Paris Games’

Replication Materials

This repository provides the data and code required to reproduce the analyses and figures reported in “From Olympic Gold to Government Approval? Limited Evidence of Attribution Error from the 2024 Paris Games.” All scripts are written in R and are organized to mirror the structure of the paper and Supplementary Information.

Required R Packages

We conducted the analyses in R (Version 4.4.2). The packages listed below are needed to reproduce the results. You can install any missing packages with the code snippet provided. We recommend using renv to snapshot and restore the exact package versions.

library(cobalt) # Ver.4.5.5
library(ebal) #Ver.0.1-8
library(equivalence) #Ver.0.8.2
library(fracdiff) #Ver.1.5-3
library(ggsignif) #Ver.0.6.4
library(ggthemes) ##Ver.5.1.0
library(grid) #Ver.2.3
library(gridExtra) #Ver.2.3
library(grf) #Ver.2.4.0
library(lmtest) #Ver.0.9-40
library(lubridate) #Ver.1.9.4
library(psych) #Ver.2.4.12
library(rddensity) #Ver.2.6
library(rdrobust) #Ver.2.0.0
library(readr) #Ver.2.1.5
library(sandwich) #Ver.3.1-1
library(scales) #Ver.1.3.0
library(stargazer) #Ver.5.2.3
library(tidyverse) #Ver.2.0.0
library(tseries) #Ver.0.10-58
library(vtable) #Ver.1.4.8
library(WeightIt) #Ver.1.4.0

Setting Variables

Setting variables for the first gold medal

set.seed(1234)
cutoff_time <- as.POSIXct("2024-07-28 01:01:00", tz = "Asia/Tokyo")

judo48p <- read_csv("judo48pure.csv", show_col_types = FALSE) |>
  mutate(
    StartDate = force_tz(
      as.POSIXct(StartDate, format = "%Y/%m/%d %H:%M", tz = "America/Denver"),
      tzone = "America/Denver"
    ) |> with_tz("Asia/Tokyo"),
    
    
    cutoff_time = .env$cutoff_time,
    
    cabap   = case_when(Q1 == 1 ~ 1,
                        Q1 == 2 ~ 0,
                        Q1 == 3 ~ NA_real_,
                        TRUE    ~ NA_real_),
    exposure = case_when(Q6 == 1 ~ 1,
                         Q6 %in% c(6,7,8) ~ 0,
                         TRUE ~ NA_real_),
    
    ftj  = Q3_11,
    ftl  = Q3_1,
    ftki = Q3_6,
    
    busi = case_when(Q8_1 == 1 ~ 5,
                     Q8_1 == 2 ~ 4,
                     Q8_1 == 4 ~ 2,
                     Q8_1 == 5 ~ 1,
                     TRUE      ~ 3),
    liv  = case_when(Q7_2 == 1 ~ 5,
                     Q7_2 == 2 ~ 4,
                     Q7_2 == 4 ~ 2,
                     Q7_2 == 5 ~ 1,
                     TRUE      ~ 3),
    
    psu_rul = case_when(Q2 %in% c(14,15) ~ NA_real_,
                        Q2 %in% c(1,4)    ~ 1,
                        TRUE              ~ 0),
    
    age       = Q11,
    female    = case_when(Q10 == 2 ~ 1,
                          Q10 == 1 ~ 0,
                          Q10 == 3 ~ NA_real_,
                          TRUE      ~ NA_real_),
    education = na_if(Q12, 5),
    income    = if_else(Q13 %in% c(15,16), NA, Q13),
    
    set.seed(1234),
    
    cutoff      = as.integer(StartDate >= cutoff_time),
    running_var = as.numeric(difftime(StartDate, cutoff_time, units = "mins")),
    running_var2 = running_var + rnorm(length(running_var), mean = 0, sd = 0.01)
  )


fa_result <- judo48p |>
  dplyr::select(Q7_1, Q7_2, Q7_3, Q7_4, Q7_5, Q7_6) |>
  psych::fa(nfactors = 2, rotate = "varimax", scores = "regression")

judo48p <- judo48p |>
  mutate(patriotism = as.numeric(fa_result$scores[, 1]))

judo48p_patriot_hi <- judo48p |>
  filter(patriotism >= median(patriotism, na.rm = TRUE))


df_rdd48 <- judo48p |>
  dplyr::select(
    StartDate, cabap, ftj, busi, liv, ftki, ftl,
    cutoff, age, female, education, income, psu_rul,
    exposure, cutoff_time,
    X1 = Q7_1, X2 = Q7_2, X3 = Q7_3, X4 = Q7_4, X5 = Q7_5, X6 = Q7_6,
    patriotism, running_var, running_var2
  ) |>
  tidyr::drop_na() 

dim(df_rdd48)

## [1] 740  24

Setting variables for the second gold medal

set.seed(1234)

cutoff_time <- as.POSIXct("2024-07-29 00:56:18",
                          format = "%Y-%m-%d %H:%M:%S", tz = "Asia/Tokyo")


judo66p <- read_csv("judo52pure.csv", show_col_types = FALSE) |>
  mutate(
    # StartDate: America/Denver → Asia/Tokyo
    StartDate = force_tz(
      as.POSIXct(StartDate, format = "%Y/%m/%d %H:%M", tz = "America/Denver"),
      tzone = "America/Denver"
    ) |> with_tz("Asia/Tokyo"),
    
    cutoff_time = .env$cutoff_time,
    
    StartTime = StartDate,
    
    cabap = case_when(Q1 == 1 ~ 1,
                      Q1 == 2 ~ 0,
                      Q1 == 3 ~ NA_real_,
                      TRUE    ~ NA_real_),
    
    exposure = case_when(Q5_4 == 1 ~ 1,
                         TRUE       ~ 0),
    
    ftj  = Q3_11,
    ftl  = Q3_1,
    ftki = Q3_6,
    
    busi = case_when(Q7_1...42 == 1 ~ 5,
                     Q7_1...42 == 2 ~ 4,
                     Q7_1...42 == 4 ~ 2,
                     Q7_1...42 == 5 ~ 1,
                     TRUE      ~ 3),
    liv  = case_when(Q7_2...43 == 1 ~ 5,
                     Q7_2...43 == 2 ~ 4,
                     Q7_2...43 == 4 ~ 2,
                     Q7_2...43 == 5 ~ 1,
                     TRUE      ~ 3),
    
    psu_rul = case_when(Q2 %in% c(14,15) ~ NA_real_,
                        Q2 %in% c(1,4)    ~ 1,
                        TRUE              ~ 0),
    
    age       = Q10,
    female    = case_when(Q9 == 2 ~ 1,
                          Q9 == 1 ~ 0,
                          Q9 == 3 ~ NA_real_,
                          TRUE     ~ NA_real_),
    education = na_if(Q11, 5),
    income    = if_else(Q12 %in% c(15,16), NA, Q12),
    
    cutoff      = as.integer(StartTime >= cutoff_time),
    running_var = as.numeric(difftime(StartDate, cutoff_time, units = "mins")),
    running_var2 = running_var + rnorm(length(running_var), mean = 0, sd = 0.01)
  )

df_rdd66 <- judo66p |>
  dplyr::select(
    StartDate, StartTime,
    Q1, cabap, ftj, busi, liv, ftki, ftl, exposure,
    cutoff, age, female, education, income, psu_rul,
    X1 = Q7_1...42, X2 = Q7_2...43, X3 = Q7_3, X4 = Q7_4, X5 = Q7_5, X6 = Q7_6, cutoff_time,
    running_var, running_var2
  ) |>
  tidyr::drop_na()

fa_result <- df_rdd66 |>
  dplyr::select(X1, X2, X3, X4, X5,X6) |>
  psych::fa(nfactors = 2, rotate = "varimax", scores = "regression")

df_rdd66 <- df_rdd66 |>
  mutate(patriotism = as.numeric(fa_result$scores[, 1]))



cutoff_range  <- range(df_rdd66$running_var,  na.rm = TRUE)
cutoff_range2 <- range(df_rdd66$running_var2, na.rm = TRUE)

dim(df_rdd66)

## [1] 712  26

Code for the Main-Text Analyses

Basic regression discontinuity design analysis

Table 1: Even the first gold medal (Women’s Judo 48kg) does not increase cabinet approval and thermometer to government

covariates <- cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul)

results_judo48p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]

  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo48p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo48p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo48p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo48p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo48p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo48p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo48p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}



source("process_results_rdd.R")

#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res4c", "res5c"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48p) <- c("", "(1)", "(2)", "(3)", "(4)")



#feeling thermometer
final_results_list <- lapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48pft) <- c("", "(1)", "(2)", "(3)", "(4)")

RDD Results (Cabinet approval)

Treatment	0.068	0.067	0.089	0.074
Robust 95% CI	[-0.162, 0.298]	[-0.166, 0.299]	[-0.137, 0.315]	[-0.170, 0.317]
Robust \(p\)-value	0.560	0.575	0.441	0.555
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	85.718	92.958	39.878	66.808
BW bias (\(b\))	107.51	107.507	90.044	107.507
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	12.188	12.311	-0.871	15.172
Robust 95% CI	[-11.909, 36.285]	[-12.017, 36.639]	[-14.755, 13.013]	[-15.409, 45.753]
Robust \(p\)-value	0.322	0.321	0.902	0.331
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	26.079	25.912	47.499	18.743
BW bias (\(b\))	48.829	48.829	106.379	48.829
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table 2: No significant gaps occurred near the cutoff, the the second gold medal of men’s Judo 66kg

covariates <- cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul)

results_judo66p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
  # Helper function to safely run rdrobust and return results or NULL if error occurs
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo66p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo66p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo66p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo66p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo66p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo66p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo66p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}


#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res4c", "res5c"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66p) <- c("", "(1)", "(2)", "(3)", "(4)")




#feeling thermometer
final_results_list <- lapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66pft) <- c("", "(1)", "(2)", "(3)", "(4)")

RDD Results (Cabinet approval)

Treatment	0.305	0.288	-3.887	0.261
Robust 95% CI	[0.044, 0.565]	[0.032, 0.543]	[-11.767, 3.993]	[-0.002, 0.523]
Robust \(p\)-value	0.022	0.027	0.334	0.051
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	2.38	2.658	1.338	1.714
BW bias (\(b\))	4.017	4.176	3.275	4.017
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	-4.296	-4.290	290.282	-4.890
Robust 95% CI	[-17.248, 8.656]	[-17.168, 8.589]	[-434.616, 1015.181]	[-19.811, 10.030]
Robust \(p\)-value	0.516	0.514	0.433	0.521
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	4.127	4.202	1.656	2.972
BW bias (\(b\))	5.91	5.922	3.335	5.91
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Ordinary least squares estimations

Table 3: The OLS estimation results indicate that almost all treatment effects are null (Table D.3 in Supplementary Information)

m_cabap <- lm(cabap ~ cutoff + age + female + income + education + psu_rul, data = df_rdd48)
m_ftj   <- lm(ftj   ~ cutoff + age + female + income + education + psu_rul, data = df_rdd48)

rmse <- function(m) sqrt(mean(residuals(m)^2))

bp_cabap    <- bptest(m_cabap)                 
bp_ftj      <- bptest(m_ftj)

reset_cabap <- resettest(m_cabap, power = 2:3)  
reset_ftj   <- resettest(m_ftj,   power = 2:3)

sw_cabap    <- shapiro.test(residuals(m_cabap)) 
sw_ftj      <- shapiro.test(residuals(m_ftj))

fmt <- function(x, d=3) sprintf(paste0("%.", d, "f"), x)

add_lines <- list(
  c("Covariates", "YES", "YES"),
  c("Constant",   "YES", "YES"),
  c("AIC",        fmt(AIC(m_cabap)), fmt(AIC(m_ftj))),
  c("RMSE",       fmt(rmse(m_cabap)), fmt(rmse(m_ftj))),
  c("Breusch–Pagan p-value", fmt(bp_cabap$p.value), fmt(bp_ftj$p.value)),
  c("RESET (ovtest) p-value", fmt(reset_cabap$p.value), fmt(reset_ftj$p.value)),
  c("Shapiro–Wilk p-value",   fmt(sw_cabap$p.value),    fmt(sw_ftj$p.value))
)

OLS with Treatment (cutoff) and Covariates

	Dependent variable (1st gold medal)
Variable	Cabinet approval	Feeling thermometer
Treatment	0.024	1.874
	(0.037)	(2.331)
Age	-0.002	0.114†
	(0.001)	(0.060)
Female	0.022	-2.342
	(0.030)	(1.908)
Income	0.001	-0.023
	(0.004)	(0.278)
Education	0.012	0.338
	(0.016)	(0.981)
In-partisans	0.462***	25.761***
	(0.030)	(1.863)
Constant	0.118	26.455***
	(0.077)	(4.829)
Observations	740	740
\(R\)²	0.256	0.216
Adjusted \(R\)²	0.249	0.210
AIC	631.002	6764.565
RMSE	0.367	23.125
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

m_cabap <- lm(cabap ~ cutoff + age + female + income + education + psu_rul, data = df_rdd66)
m_ftj   <- lm(ftj   ~ cutoff + age + female + income + education + psu_rul, data = df_rdd66)

rmse <- function(m) sqrt(mean(residuals(m)^2))

bp_cabap    <- bptest(m_cabap)                 
bp_ftj      <- bptest(m_ftj)

reset_cabap <- resettest(m_cabap, power = 2:3)  
reset_ftj   <- resettest(m_ftj,   power = 2:3)

sw_cabap    <- shapiro.test(residuals(m_cabap)) 
sw_ftj      <- shapiro.test(residuals(m_ftj))

fmt <- function(x, d=3) sprintf(paste0("%.", d, "f"), x)

add_lines <- list(
  c("Covariates", "YES", "YES"),
  c("Constant",   "YES", "YES"),
  c("AIC",        fmt(AIC(m_cabap)), fmt(AIC(m_ftj))),
  c("RMSE",       fmt(rmse(m_cabap)), fmt(rmse(m_ftj))),
  c("Breusch–Pagan p-value", fmt(bp_cabap$p.value), fmt(bp_ftj$p.value)),
  c("RESET (ovtest) p-value", fmt(reset_cabap$p.value), fmt(reset_ftj$p.value)),
  c("Shapiro–Wilk p-value",   fmt(sw_cabap$p.value),    fmt(sw_ftj$p.value))
)

OLS with Treatment (cutoff) and Covariates

	Dependent variable (2nd gold medal)
Variable	Cabinet approval	Feeling thermometer
Treatment	0.071*	0.401
	(0.029)	(1.835)
Age	-0.000	0.085
	(0.001)	(0.054)
Female	-0.022	-0.154
	(0.027)	(1.738)
Income	-0.004	-0.133
	(0.004)	(0.267)
Education	-0.000	0.072
	(0.002)	(0.117)
In-partisans	0.477***	24.967***
	(0.028)	(1.800)
Constant	0.067	26.699***
	(0.063)	(3.977)
Observations	712	712
\(R\)²	0.289	0.215
Adjusted \(R\)²	0.283	0.209
AIC	555.531	6461.196
RMSE	0.353	22.358
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Equivalence test

Figure 3: Equivalence test shows that the first gold medal’s effect size is negligibly small

df <- df_rdd48
df$outcome     <- df$cabap
df$treatment   <- df$cutoff
df$running_var <- df$running_var

compute_xrange_and_labels <- function(effect, ci, eps, mult_range = 1.25, offset_frac = 0.06) {
  xmax <- max(abs(c(ci, effect, -eps, eps)), na.rm = TRUE) * mult_range
  lab_off <- offset_frac * xmax
  list(xlim = c(-xmax, xmax),
       x_left  = -eps + lab_off,
       x_right =  eps - lab_off)
}


compute_xrange_and_labels <- function(effect, ci, eps, mult_range = 1.25, offset_frac = 0.08) {
  xmax <- max(abs(c(ci, effect, -eps, eps)), na.rm = TRUE) * mult_range
  lab_off <- offset_frac * xmax
  list(
    xlim    = c(-xmax, xmax),    
    x_left  = -eps + lab_off,    
    x_right =  eps - lab_off    
  )
}

eps_cabap <- round(0.2 * sd(df$cabap, na.rm = TRUE), 3)
x <- df$cabap[df$treatment == 1]
y <- df$cabap[df$treatment == 0]

equiv_test_result1 <- tost(x = x, y = y, epsilon = eps_cabap)
effect_size1 <- mean(x, na.rm = TRUE) - mean(y, na.rm = TRUE)
ci1 <- equiv_test_result1$tost.interval

ax1 <- compute_xrange_and_labels(effect = effect_size1, ci = ci1, eps = eps_cabap,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect  <- 0.50
y_bounds  <- 0.50

p0 <-
  ggplot(NULL, aes(x = effect_size1, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci1[1], xmax = ci1[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[1], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[2], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_cabap, linetype = "dashed") +
  geom_vline(xintercept =  eps_cabap, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Cabinet approval (1st gold medal)",
       x = "Effect size (difference in proportions, shown as pp)", y = "") +
  scale_x_continuous(labels = scales::label_percent(accuracy = 1, scale = 100)) +
  coord_cartesian(xlim = ax1$xlim, clip = "off") +                   
  theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +                      
  annotate("text", x = effect_size1, y = y_effect,
           label = paste0("Effect size: ", round(effect_size1*100, 1), " pp\n[",
                          round(ci1[1]*100, 1), ", ", round(ci1[2]*100, 1), "] pp"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax1$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", round(eps_cabap*100, 1), " pp)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax1$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", round(eps_cabap*100, 1), " pp)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")



df <- df_rdd48
df$outcome     <- df$ftj
df$treatment   <- df$cutoff
df$running_var <- df$running_var

eps_ftj <- round(0.2 * sd(df$ftj, na.rm = TRUE), 2)
x2 <- df$ftj[df$treatment == 1]
y2 <- df$ftj[df$treatment == 0]

equiv_test_result2 <- tost(x = x2, y = y2, epsilon = eps_ftj)
effect_size2 <- mean(x2, na.rm = TRUE) - mean(y2, na.rm = TRUE)
ci2 <- equiv_test_result2$tost.interval

ax2 <- compute_xrange_and_labels(effect = effect_size2, ci = ci2, eps = eps_ftj,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect <- 0.50
y_bounds <- 0.50

p1 <-
  ggplot(NULL, aes(x = effect_size2, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci2[1], xmax = ci2[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[1], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[2], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_ftj, linetype = "dashed") +
  geom_vline(xintercept =  eps_ftj, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Feeling thermometer to Japanese government (1st gold medal)",
       x = "Effect size (difference in points)", y = "") +
  coord_cartesian(xlim = ax2$xlim, clip = "off") +
  theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +
  annotate("text", x = effect_size2, y = y_effect,
           label = paste0("Effect size: ", round(effect_size2, 2), " points\n[",
                          round(ci2[1], 2), ", ", round(ci2[2], 2), "]"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax2$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", eps_ftj, " points)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax2$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", eps_ftj, " points)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")

 grid.arrange(p0, p1, ncol = 1)

Specification curve

Figure 4: Specification curve shows the statistical insignificance of the cutoff (the first gold medal) in all covariates combinations

variables <- c("age", "female", "income", "education", "psu_rul", " patriotism")

specifications <- lapply(1:length(variables), function(n) combn(variables, n, simplify = FALSE))
specifications <- unlist(specifications, recursive = FALSE)

results <- data.frame(
  Specification = integer(),
  Coefficient = numeric(),
  ConfLow = numeric(),
  ConfHigh = numeric()
)

for (i in seq_along(specifications)) {
  formula <- as.formula(paste("cabap ~ cutoff +", paste(specifications[[i]], collapse = " + ")))
  model <- lm(formula, data = df_rdd48)
  
  cutoff_coef <- summary(model)$coefficients["cutoff", "Estimate"]
  conf_int <- confint(model)["cutoff", ]
  
  results <- rbind(results, data.frame(
    Specification = i,
    Coefficient = cutoff_coef,
    ConfLow = conf_int[1],
    ConfHigh = conf_int[2]
  ))
}

results <- results |> arrange(Coefficient)
results$Specification <- seq_along(results$Specification)


variables_included <- lapply(specifications, function(spec) {
  sapply(variables, function(var) var %in% spec)
})
variables_long <- do.call(rbind, lapply(seq_along(variables_included), function(i) {
  data.frame(Specification = i, Variable = variables, Included = variables_included[[i]])
}))
variables_long$Included <- as.factor(variables_long$Included)

upper_panel <- ggplot(results, aes(x = Specification, y = Coefficient)) +
  geom_point() +
  geom_errorbar(aes(ymin = ConfLow, ymax = ConfHigh), width = 0.2) +
  geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
  labs(
    title = "Sensitivity Analysis of Coefficient Estimates (Cutoff: 1st gold medal)",
    x = NULL,
    y = "Coefficient Estimate for 'cutoff'"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())

lower_panel <- ggplot(variables_long, aes(x = Specification, y = Variable, fill = Included)) +
  geom_tile() +
  scale_fill_manual(values = c("FALSE" = "white", "TRUE" = "gray"), guide = "none") +
  scale_y_discrete(labels = c("age" = "Age", "female" = "Female",
                              "income" = "Income", "education" = "Education",
                              "psu_rul" = "Ruling party support",
                              " patriotism" = "Patriotism")) +
  labs(
    x = "Specification Number",
    y = "Variables"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))



grid.arrange(upper_panel, lower_panel, ncol = 1, heights = c(2, 1))

Rolling RDD

Figure 5 and 6: Gradually shifting the cutoff (Before and After the first gold medal) does not alter the null results for cabinet approval

#cabinet approval

cutoff_time <- as.POSIXct("2024-07-28 01:01:00")

df_rdd48 <- df_rdd48 |>
  mutate(running_var = as.numeric(difftime(StartDate, cutoff_time, units = "mins")))

cutoff_diffs <- c(-20, -15, -5, -3, -1, 0, 1, 3, 5, 15, 20)
titles <- c("20 mins before", "15 mins before", "5 mins before", "3 mins before", "1 min before",
            "At cutoff", "1 min after", "3 mins after", "5 mins after", "15 mins after", "20 mins after")

plots <- vector("list", length(cutoff_diffs))

for (i in seq_along(cutoff_diffs)) {
  cutoff_range <- range(df_rdd48$running_var, na.rm = TRUE)

  invisible(capture.output({
    suppressMessages({
      rd <- rdrobust::rdplot(
        y     = df_rdd48$cabap,
        x     = df_rdd48$running_var,
        covs  = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
        x.lim = cutoff_range,
        x.lab = "Time difference from cutoff (mins)",
        y.lab = "Cabinet approval",
        title = titles[i],
        c     = cutoff_diffs[i]
      )
    })
  }, type = "message"))  

  plots[[i]] <- rd$rdplot + theme_igray()
}

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

ordered_plots1 <- list(
  plots[[1]], plots[[2]], 
  plots[[3]], plots[[4]], 
  plots[[5]], plots[[6]]
)

ordered_plots2 <- list(
  plots[[6]], plots[[7]],  
  plots[[8]], plots[[9]],
  plots[[10]], plots[[11]]  
)


grid.arrange(grobs = ordered_plots1, ncol = 3)

grid.arrange(grobs = ordered_plots2, ncol = 3)

#feeling thermometer

plots <- vector("list", length(cutoff_diffs))

for (i in seq_along(cutoff_diffs)) {
  cutoff_range <- range(df_rdd48$running_var, na.rm = TRUE)

  invisible(capture.output({
    suppressMessages({
      rd <- rdrobust::rdplot(
        y     = df_rdd48$cabap,
        x     = df_rdd48$running_var,
        covs  = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
        x.lim = cutoff_range,
        x.lab = "Time difference from cutoff (mins)",
        y.lab = "Cabinet approval",
        title = titles[i],
        c     = cutoff_diffs[i]
      )
    })
  }, type = "message"))  

  plots[[i]] <- rd$rdplot + theme_igray()
}

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

ordered_plots1 <- list(
  plots[[1]], plots[[2]],  
  plots[[3]], plots[[4]],  
  plots[[5]], plots[[6]]
)

ordered_plots2 <- list(
  plots[[6]], plots[[7]], 
  plots[[8]], plots[[9]], 
  plots[[10]], plots[[11]]  
)


grid.arrange(grobs = ordered_plots1, ncol = 3)

grid.arrange(grobs = ordered_plots2, ncol = 3)

Code for the Supplementary Information

C. Data collection

Figure C.2: Cumulative data collection (Around the first gold medal)

data_cum <- judo48p |>
  arrange(StartDate) |>
  mutate(CumulativeCount = row_number())

vline_time <- as.POSIXct("2024/07/28 01:01", format = "%Y/%m/%d %H:%M", tz = "Asia/Tokyo")

ggplot(data_cum, aes(x = StartDate, y = CumulativeCount)) +
  geom_line() +
  geom_point() +
  geom_vline(xintercept = as.numeric(vline_time), linetype = "dashed", color = "red") +
  annotate("text",
           x = vline_time,
           y = max(data_cum$CumulativeCount),
           label = "1st gold medal confirmed",
           angle = 90, vjust = -0.5, hjust = 1.1, size = 3) +
  labs(title = "Cumulative data collection over time (Women's judo 48kg), \n July 28th, 10:01 JST",
       x = "Recorded Date", y = "Cumulative Count") +
  scale_x_datetime(date_breaks = "1 hour", date_labels = "%H:%M") +
  theme_igray()

Summary statistics of survey start times (Women’s judo 48kg)

Minimum time	Maximum time	Median time
2024-07-28 00:31:00	2024-07-28 08:31:00	2024-07-28 00:41:00

Figure C.3: Cumulative data collection (Around the second gold medal)

data_cum <- judo66p |>
  arrange(StartDate) |>
  mutate(CumulativeCount = row_number())


vline_time <- as.POSIXct("2024/07/29 00:56:18", format = "%Y/%m/%d %H:%M", tz = "Asia/Tokyo")

ggplot(data_cum, aes(x = StartDate, y = CumulativeCount)) +
  geom_line() +
  geom_point() +
  geom_vline(xintercept = as.numeric(vline_time), linetype = "dashed", color = "red") +
  annotate("text",
           x = vline_time,
           y = max(data_cum$CumulativeCount),
           label = "2nd gold medal confirmed",
           angle = 90, vjust = -0.5, hjust = 1.1, size = 3) +
  labs(title = "Cumulative data collection over time (Men's judo 66kg),\n July 29th, 00:56 JST",
       x = "Recorded Date", y = "Cumulative Count") +
  scale_x_datetime(date_breaks = "1 hour", date_labels = "%H:%M") +
  theme_igray()

Summary statistics of survey start times (Men’s judo 66kg)

Minimum time	Maximum time	Median time
2024-07-29 00:48:00	2024-07-29 08:25:00	2024-07-29 01:01:00

D. Additional Analysis of Main Results

D.1 Additional analysis using regression discontinuity design

Figure D.1: No significant effect differences occurred near the cutoff, the first gold medal of women’s Judo 48kg (without confidence intervals

covariates <- cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul)

results_judo48p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
 
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo48p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo48p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo48p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo48p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo48p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo48p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo48p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}

p1 <- rdplot(df_rdd48$cabap, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0) 

p2 <- rdplot(df_rdd48$ftj, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Figure D.2: No significant effect differences occurred near the cutoff, the first gold medal (WITH confidence intervals)

p1 <- rdplot(df_rdd48$cabap, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0,
             ci = 95) 

p2 <- rdplot(df_rdd48$ftj, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0,
             ci = 95) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Figure D.3: No significant effect differences occurred near the cutoff, the second gold medal (WITH confidence intervals)

covariates <- cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul)

results_judo66p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")


for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo66p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo66p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo66p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo66p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo66p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo66p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo66p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}


p1 <- rdplot(df_rdd66$cabap, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 66kg",
             c = 0) 

p2 <- rdplot(df_rdd66$ftj, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 66kg",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Figure D.4: No significant effect differences occurred near the cutoff, the second gold medal (WITHOUT confidence intervals like in the text)

p1 <- rdplot(df_rdd66$cabap, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 66kg",
             c = 0,
             ci = 95) 

p2 <- rdplot(df_rdd66$ftj, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 66kg",
             c = 0,
             ci = 95) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Table D.1: Even the first gold medal (Women’s Judo 48kg) does not increase cabinet approval and thermometer to government

covariates <- cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul)

results_judo48p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]

  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo48p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo48p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo48p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo48p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo48p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo48p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo48p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd48[[outcome_var]], df_rdd48$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}



source("process_results_rdd.R")

#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res4c", "res5c"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res2c","res3c", "res4c", "res5c"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48p) <- c("", "(1)", "(2)", "(3)", "(4)")



#feeling thermometer
final_results_list <- lapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48pft) <- c("", "(1)", "(2)", "(3)", "(4)")

RDD Results (Cabinet approval)

Treatment	0.068	0.067	0.089	0.074
Robust 95% CI	[-0.162, 0.298]	[-0.166, 0.299]	[-0.137, 0.315]	[-0.170, 0.317]
Robust \(p\)-value	0.560	0.575	0.441	0.555
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	85.718	92.958	39.878	66.808
BW bias (\(b\))	107.51	107.507	90.044	107.507
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	12.188	12.311	-0.871	15.172
Robust 95% CI	[-11.909, 36.285]	[-12.017, 36.639]	[-14.755, 13.013]	[-15.409, 45.753]
Robust \(p\)-value	0.322	0.321	0.902	0.331
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	26.079	25.912	47.499	18.743
BW bias (\(b\))	48.829	48.829	106.379	48.829
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table D.2: No significant gaps occurred near the cutoff, the the second gold medal of men’s Judo 66kg

covariates <- cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul)

results_judo66p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo66p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo66p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo66p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo66p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo66p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo66p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo66p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd66[[outcome_var]], df_rdd66$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}


#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res4c", "res5c"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1c","res2c", "res4c", "res5c"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66p) <- c("", "(1)", "(2)", "(3)", "(4)")




#feeling thermometer
final_results_list <- lapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1f",  "res2f", "res4f", "res5f"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66pft) <- c("", "(1)", "(2)", "(3)")

RDD Results (Cabinet approval)

Treatment	0.305	0.288	-3.887	0.261
Robust 95% CI	[0.044, 0.565]	[0.032, 0.543]	[-11.767, 3.993]	[-0.002, 0.523]
Robust \(p\)-value	0.022	0.027	0.334	0.051
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	2.38	2.658	1.338	1.714
BW bias (\(b\))	4.017	4.176	3.275	4.017
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

				NA
Treatment	-4.296	-4.290	290.282	-4.890
Robust 95% CI	[-17.248, 8.656]	[-17.168, 8.589]	[-434.616, 1015.181]	[-19.811, 10.030]
Robust \(p\)-value	0.516	0.514	0.433	0.521
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	mserd	msesum	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	4.127	4.202	1.656	2.972
BW bias (\(b\))	5.91	5.922	3.335	5.91
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

D.2 Mean comparisons and all results of ordinary least square regressions

Figure D.5: No significant mean difference is found, the first gold medal of women’s Judo 48kg

if (!"cutoff_f" %in% names(df_rdd48)) {
  df_rdd48 <- df_rdd48 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("before","after")))
}

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else "n.s."
}

summ_ci <- function(df, var){
  df |>
    group_by(cutoff_f) |>
    summarise(
      n     = sum(!is.na(.data[[var]])),
      mean  = mean(.data[[var]], na.rm = TRUE),
      sd    = sd(.data[[var]],   na.rm = TRUE),
      se    = sd / sqrt(n),
      tcrit = qt(0.975, df = pmax(n - 1, 1)),
      lo95  = mean - tcrit * se,
      up95  = mean + tcrit * se,
      .groups = "drop"
    )
}

make_mean_plot_cont <- function(df, var, main_title, ylab = "Mean") {
  
  s <- summ_ci(df, var)
  t_out <- t.test(df[[var]] ~ df$cutoff_f)
  pval  <- t_out$p.value
  stars <- p_to_stars(pval)
  
  ymax  <- max(s$up95, na.rm = TRUE)
  y_sig <- ymax + 0.05 * max(1, ymax)
  y_txt <- ymax + 0.10 * max(1, ymax)
  
  ggplot(s, aes(x = cutoff_f, y = mean)) +
    geom_bar(stat = "identity", width = 0.6, fill = "grey70", color = "grey20") +
    geom_errorbar(aes(ymin = lo95, ymax = up95), width = 0.15) +
    geom_text(aes(label = sprintf("%.2f\n[%.2f, %.2f]", mean, lo95, up95)),
              vjust = -1.1, size = 3) +
    ggsignif::geom_signif(
      comparisons = list(c("before","after")),
      annotations = stars,
      y_position  = y_sig,
      tip_length  = 0,
      textsize    = 4.2
    ) +
    annotate("text", x = 1.5, y = y_txt,
             label = paste0("Welch's t-test p = ", signif(pval, 3)),
             size = 4.2) +
    ggthemes::theme_igray() +
    labs(title = main_title, x = "Control/Treatment", y = ylab) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.18))) +
    theme(plot.title = element_text(size = 10),
          axis.title.x = element_text(margin = margin(t = 6)))
}

p_cabap <- make_mean_plot_cont(df_rdd48, "cabap",
                               "Cabinet approval (mean; 95% CI)",
                               ylab = "Mean Cabinet Approval")
p_ftj   <- make_mean_plot_cont(df_rdd48, "ftj",
                               "Feeling thermometer (mean; 95% CI)",
                               ylab = "Mean Feeling Thermometer")

grid.arrange(p_cabap, p_ftj, ncol = 2)

Figure D.6: No significant mean difference is found, the first gold medal of men’s Judo 66kg

if (!"cutoff_f" %in% names(df_rdd66)) {
  df_rdd66 <- df_rdd66 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("before","after")))
}

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else if (p < 0.10)  "†"   # ← 追加（10%有意）
  else "n.s."
}

summ_ci <- function(df, var){
  df |>
    group_by(cutoff_f) |>
    summarise(
      n     = sum(!is.na(.data[[var]])),
      mean  = mean(.data[[var]], na.rm = TRUE),
      sd    = sd(.data[[var]],   na.rm = TRUE),
      se    = sd / sqrt(n),
      tcrit = qt(0.975, df = pmax(n - 1, 1)),
      lo95  = mean - tcrit * se,
      up95  = mean + tcrit * se,
      .groups = "drop"
    )
}

make_mean_plot_cont <- function(df, var, main_title, ylab = "Mean") {
  
  s <- summ_ci(df, var)
  t_out <- t.test(df[[var]] ~ df$cutoff_f)
  pval  <- t_out$p.value
  stars <- p_to_stars(pval)
  
  ymax  <- max(s$up95, na.rm = TRUE)
  y_sig <- ymax + 0.05 * max(1, ymax)
  y_txt <- ymax + 0.10 * max(1, ymax)
  
  ggplot(s, aes(x = cutoff_f, y = mean)) +
    geom_bar(stat = "identity", width = 0.6, fill = "grey70", color = "grey20") +
    geom_errorbar(aes(ymin = lo95, ymax = up95), width = 0.15) +
    geom_text(aes(label = sprintf("%.2f\n[%.2f, %.2f]", mean, lo95, up95)),
              vjust = -1.1, size = 3) +
    ggsignif::geom_signif(
      comparisons = list(c("before","after")),
      annotations = stars,
      y_position  = y_sig,
      tip_length  = 0,
      textsize    = 4.2
    ) +
    annotate("text", x = 1.5, y = y_txt,
             label = paste0("Welch's t-test p = ", signif(pval, 3)),
             size = 4.2) +
    ggthemes::theme_igray() +
    labs(title = main_title, x = "Control/Treatment", y = ylab) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.18))) +
    theme(plot.title = element_text(size = 10),
          axis.title.x = element_text(margin = margin(t = 6)))
}

p_cabap <- make_mean_plot_cont(df_rdd66, "cabap",
                               "Cabinet approval (mean; 95% CI)",
                               ylab = "Mean Cabinet Approval")
p_ftj   <- make_mean_plot_cont(df_rdd66, "ftj",
                               "Feeling thermometer (mean; 95% CI)",
                               ylab = "Mean Feeling Thermometer")

grid.arrange(p_cabap, p_ftj, ncol = 2)

D.3 Subsample analysis: Ruling parties supporters and higher patriotism groups

Table D.4: In the in-partisan subsample, the treatment effect by the OLS remains null (The 1st gold medal)

df_rdd48_ruling <- df_rdd48 |> filter(psu_rul == 1)

m_cabap <- lm(cabap ~ cutoff + age + female + income + education + psu_rul, data = df_rdd48)
m_ftj   <- lm(ftj   ~ cutoff + age + female + income + education + psu_rul, data = df_rdd48)

rmse <- function(m) sqrt(mean(residuals(m)^2))

bp_cabap    <- bptest(m_cabap)                 
bp_ftj      <- bptest(m_ftj)

reset_cabap <- resettest(m_cabap, power = 2:3)  
reset_ftj   <- resettest(m_ftj,   power = 2:3)

sw_cabap    <- shapiro.test(residuals(m_cabap)) 
sw_ftj      <- shapiro.test(residuals(m_ftj))

fmt <- function(x, d=3) sprintf(paste0("%.", d, "f"), x)

add_lines <- list(
  c("Covariates", "YES", "YES"),
  c("Constant",   "YES", "YES"),
  c("AIC",        fmt(AIC(m_cabap)), fmt(AIC(m_ftj))),
  c("RMSE",       fmt(rmse(m_cabap)), fmt(rmse(m_ftj))),
  c("Breusch–Pagan p-value", fmt(bp_cabap$p.value), fmt(bp_ftj$p.value)),
  c("RESET (ovtest) p-value", fmt(reset_cabap$p.value), fmt(reset_ftj$p.value)),
  c("Shapiro–Wilk p-value",   fmt(sw_cabap$p.value),    fmt(sw_ftj$p.value))
)

OLS with Treatment (cutoff) and Covariates

	Dependent variable (1st gold medal)
Variable	Cabinet approval	Feeling thermometer
Treatment	0.073	2.060
	(0.086)	(3.801)
Age	-0.001	0.121
	(0.002)	(0.095)
Female	0.141*	-3.543
	(0.075)	(3.324)
Income	0.012	0.357
	(0.010)	(0.457)
Education	0.006	0.408
	(0.039)	(1.723)
Constant	0.419**	49.262***
	(0.188)	(8.327)
Observations	226	226
\(R\)²	0.032	0.021
Adjusted \(R\)²	0.010	-0.002
AIC	331.603	2045.250
RMSE	0.489	21.649
Breusch–Pagan p-value	0.378	0.146
RESET (ovtest) p-value	0.026	0.280
Shapiro–Wilk p-value	0.000	0.000
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table D.5: In the in-partisan subsample, the treatment effect by the OLS remains null (The 2nd gold medal)

df_rdd66_ruling <- df_rdd66 |> filter(psu_rul == 1)

m_cabap <- lm(cabap ~ cutoff + age + female + income + education , data = df_rdd66_ruling)
m_ftj   <- lm(ftj   ~ cutoff + age + female + income + education, data = df_rdd66_ruling)

rmse <- function(m) sqrt(mean(residuals(m)^2))

bp_cabap    <- bptest(m_cabap)                  
bp_ftj      <- bptest(m_ftj)

reset_cabap <- resettest(m_cabap, power = 2:3)  
reset_ftj   <- resettest(m_ftj,   power = 2:3)

sw_cabap    <- shapiro.test(residuals(m_cabap)) 
sw_ftj      <- shapiro.test(residuals(m_ftj))

fmt <- function(x, d=3) sprintf(paste0("%.", d, "f"), x)

add_lines <- list(
  c("Covariates", "YES", "YES"),
  c("Constant",   "YES", "YES"),
  c("AIC",        fmt(AIC(m_cabap)), fmt(AIC(m_ftj))),
  c("RMSE",       fmt(rmse(m_cabap)), fmt(rmse(m_ftj))),
  c("Breusch–Pagan p-value", fmt(bp_cabap$p.value), fmt(bp_ftj$p.value)),
  c("RESET (ovtest) p-value", fmt(reset_cabap$p.value), fmt(reset_ftj$p.value)),
  c("Shapiro–Wilk p-value",   fmt(sw_cabap$p.value),    fmt(sw_ftj$p.value))
)

OLS with Treatment (cutoff) and Covariates

	Dependent variable (2nd gold medal)
Variable	Cabinet approval	Feeling thermometer
Treatment	0.151**	-0.056
	(0.070)	(3.088)
Age	0.001	0.076
	(0.002)	(0.089)
Female	0.013	-4.012
	(0.068)	(2.988)
Income	-0.014	-0.127
	(0.010)	(0.435)
Education	-0.001	0.028
	(0.004)	(0.164)
Constant	0.479***	54.171***
	(0.147)	(6.492)
Observations	235	235
\(R\)²	0.033	0.012
Adjusted \(R\)²	0.011	-0.010
AIC	345.450	2126.203
RMSE	0.490	21.652
Breusch–Pagan p-value	0.998	0.262
RESET (ovtest) p-value	0.598	0.251
Shapiro–Wilk p-value	0.000	0.006
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure D.7: Ruling parties supporters are more likely to react the first gold medal, using mean difference

if (!"cutoff_f" %in% names(df_rdd48)) {
  df_rdd48 <- df_rdd48 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("Control","Treatment")))
}

summ_ci2 <- function(df, value, group_lab){  
  nm_val <- value; nm_grp <- group_lab
  df |>
    group_by(cutoff_f, .data[[nm_grp]]) |>
    summarise(
      n    = sum(!is.na(.data[[nm_val]])),
      mean = mean(.data[[nm_val]], na.rm = TRUE),
      sd   = sd(.data[[nm_val]],   na.rm = TRUE),
      se   = sd / sqrt(n),
      tcrt = qt(0.975, pmax(n - 1, 1)),
      lo95 = mean - tcrt * se,
      up95 = mean + tcrt * se,
      .groups = "drop"
    )
}

make_cross_bar <- function(df_sum, title, ylab){
  pd <- position_dodge(width = 0.65)
  
  ggplot(df_sum, aes(x = cutoff_f, y = mean, fill = group)) +
    geom_bar(stat = "identity", position = pd, width = 0.6,
             color = "grey20") +
    geom_errorbar(aes(ymin = lo95, ymax = up95),
                  position = pd, width = 0.18, color = "grey20") +
    geom_text(aes(label = sprintf("%.2f\n[%.2f, %.2f]", mean, lo95, up95)),
              position = position_dodge(width = 0.65),
              vjust = -0.9, size = 3.2, color = "grey20") +
    scale_fill_manual(values = c("Low Patriotism" = "#cfcfcf",
                                 "High Patriotism" = "#6f6f6f",
                                 "Not in-partisan" = "#cfcfcf",
                                 "In-partisan"     = "#6f6f6f")) +
    ggthemes::theme_igray() +
    labs(title = title,
         subtitle = "With 95% Confidence Intervals",
         x = "Control/Treatment", y = ylab, fill = NULL) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.20))) +
    theme(plot.title   = element_text(size = 10, face = "bold"),
          legend.position = c(0.82, 0.18),  
          legend.background = element_rect(fill = scales::alpha("white", 0.6),
                                           color = NA),
          legend.key.height = unit(10, "pt"),
          legend.key.width  = unit(14, "pt"),
          legend.margin = margin(t = 2, r = 2, b = 2, l = 2))
}


df_rdd48 <- df_rdd48 |>
  mutate(rul_grp = factor(psu_rul, levels = c(0,1),
                          labels = c("Not in-partisan", "In-partisan")))

sum_cabap_rul <- summ_ci2(df_rdd48 |> rename(group = rul_grp),
                          value = "cabap", group_lab = "group")
sum_ftj_rul   <- summ_ci2(df_rdd48 |> rename(group = rul_grp),
                          value = "ftj",   group_lab = "group")

p_cabap_rul <- make_cross_bar(sum_cabap_rul,
                              "Cabinet approval by ruling partisanship", "Mean Cabinet approval")
p_ftj_rul   <- make_cross_bar(sum_ftj_rul,
                              "Feeling thermometer by ruling partisanship", "Mean Feeling Thermometer")


pat_med <- median(df_rdd48$patriotism, na.rm = TRUE)
df_rdd48 <- df_rdd48 |>
  mutate(pat_grp = factor(ifelse(patriotism >= pat_med, 1, 0),
                          levels = c(0,1),
                          labels = c("Low Patriotism", "High Patriotism")))

sum_cabap_pat <- summ_ci2(df_rdd48 |> rename(group = pat_grp),
                          value = "cabap", group_lab = "group")
sum_ftj_pat   <- summ_ci2(df_rdd48 |> rename(group = pat_grp),
                          value = "ftj",   group_lab = "group")

p_cabap_pat <- make_cross_bar(sum_cabap_pat,
                              "Cabinet approval by patriotism", "Mean Cabinet approval")
p_ftj_pat   <- make_cross_bar(sum_ftj_pat,
                              "Feeling thermometer by patriotism", "Mean Feeling Thermometer")

gridExtra::grid.arrange(
  p_cabap_rul, p_ftj_rul,
  p_cabap_pat, p_ftj_pat,
  ncol = 2
)

Figure D.8: Ruling parties supporters are more likely to react the second gold medal, using mean difference

if (!"cutoff_f" %in% names(df_rdd66)) {
  df_rdd66 <- df_rdd66 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("Control","Treatment")))
}

df_rdd66 <- df_rdd66 |>
  mutate(rul_grp = factor(psu_rul, levels = c(0,1),
                          labels = c("Not in-partisan", "In-partisan")))

sum_cabap_rul <- summ_ci2(df_rdd66 |> rename(group = rul_grp),
                          value = "cabap", group_lab = "group")
sum_ftj_rul   <- summ_ci2(df_rdd66 |> rename(group = rul_grp),
                          value = "ftj",   group_lab = "group")

p_cabap_rul <- make_cross_bar(sum_cabap_rul,
                              "Cabinet approval by ruling partisanship", "Mean Cabinet approval")
p_ftj_rul   <- make_cross_bar(sum_ftj_rul,
                              "Feeling thermometer by ruling partisanship", "Mean Feeling Thermometer")


pat_med <- median(df_rdd66$patriotism, na.rm = TRUE)
df_rdd66 <- df_rdd66 |>
  mutate(pat_grp = factor(ifelse(patriotism >= pat_med, 1, 0),
                          levels = c(0,1),
                          labels = c("Low Patriotism", "High Patriotism")))

sum_cabap_pat <- summ_ci2(df_rdd66 |> rename(group = pat_grp),
                          value = "cabap", group_lab = "group")
sum_ftj_pat   <- summ_ci2(df_rdd66 |> rename(group = pat_grp),
                          value = "ftj",   group_lab = "group")

p_cabap_pat <- make_cross_bar(sum_cabap_pat,
                              "Cabinet approval by patriotism", "Mean Cabinet approval")
p_ftj_pat   <- make_cross_bar(sum_ftj_pat,
                              "Feeling thermometer by patriotism", "Mean Feeling Thermometer")

 gridExtra::grid.arrange(
  p_cabap_rul, p_ftj_rul,
  p_cabap_pat, p_ftj_pat,
  ncol = 2
)

Table D.6: In-partisans (the LDP and Komeito supporters) are more likely to respond the first gold medal

covariates <- cbind(df_rdd48_ruling$age, df_rdd48_ruling$female, df_rdd48_ruling$income, df_rdd48_ruling$education)

results_judo48p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo48p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo48p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo48p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo48p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo48p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo48p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo48p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd48_ruling[[outcome_var]], df_rdd48_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))

}


#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res5c"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1c", "res2c", "res5c"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel,
                               check.names = FALSE, stringsAsFactors = FALSE)

colnames(df_rdd48_judo48p) <- c("","(1)", "(2)", "(3)")


#feeling thermometer
final_results_list <- lapply(c("res1f", "res2f", "res5f"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1f", "res2f", "res5f"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48pft) <- c("", "(1)", "(2)", "(3)")

RDD Results (Cabinet approval)

Treatment	2.026	1.943	1.803
Robust 95% CI	[1.464, 2.588]	[1.380, 2.506]	[1.222, 2.383]
Robust \(p\)-value	0.000	0.000	0.000
Observations	226	226	226
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	76.781	75.359	58.553
BW bias (\(b\))	23.865	23.944	23.865
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	107.380	107.806	99.925
Robust 95% CI	[84.254, 130.506]	[84.681, 130.932]	[76.540, 123.311]
Robust \(p\)-value	0.000	0.000	0.000
Observations	226	226	226
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	53.734	53.745	40.977
BW bias (\(b\))	19.372	19.361	19.372
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure D.9: Ruling parties supporters are more likely to react the first gold medal

p1 <- rdplot(df_rdd48_ruling$cabap, df_rdd48_ruling$running_var2,
             covs = cbind(df_rdd48_ruling$age, df_rdd48_ruling$female, df_rdd48_ruling$income, df_rdd48_ruling$education, df_rdd48_ruling$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: 1st gold medal; Subsample: Ruling party support",
             c = 0) 

p2 <- rdplot(df_rdd48_ruling$ftj, df_rdd48_ruling$running_var2,
             covs = cbind(df_rdd48_ruling$age, df_rdd48_ruling$female, df_rdd48_ruling$income, df_rdd48_ruling$education, df_rdd48_ruling$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: 1st gold medal; Subsample: Ruling party support",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Table D.7: In-partisans (the LDP and Komeito supporters) are also more likely to respond the second gold medal

covariates <- cbind(df_rdd66_ruling$age, df_rdd66_ruling$female, df_rdd66_ruling$income, df_rdd66_ruling$education)

results_judo66p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo66p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo66p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo66p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo66p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo66p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo66p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo66p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd66_ruling[[outcome_var]], df_rdd66_ruling$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))

}


#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res5c"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1c", "res2c", "res5c"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel,
                               check.names = FALSE, stringsAsFactors = FALSE)

colnames(df_rdd66_judo66p) <- c("","(1)", "(2)", "(3)")


#feeling thermometer
final_results_list <- lapply(c("res1f", "res2f", "res5f"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1f", "res2f", "res5f"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66pft) <- c("", "(1)", "(2)", "(3)")

RDD Results (Cabinet approval)

Treatment	1.082	0.933	9.156
Robust 95% CI	[0.490, 1.675]	[0.353, 1.514]	[-24.505, 42.817]
Robust \(p\)-value	0.000	0.002	0.594
Observations	235	235	235
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	1.941	2.605	1.477
BW bias (\(b\))	3.569	3.891	3.569
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	10.113	9.400	9.516
Robust 95% CI	[-14.367, 34.593]	[-14.309, 33.109]	[-17.785, 36.816]
Robust \(p\)-value	0.418	0.437	0.495
Observations	235	235	235
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	3.767	4.075	2.867
BW bias (\(b\))	5.126	5.419	5.126
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure D.10: Ruling parties supporters are also more likely to react the second gold medal

p1 <- rdplot(df_rdd66_ruling$cabap, df_rdd66_ruling$running_var2,
             covs = cbind(df_rdd66_ruling$age, df_rdd66_ruling$female, df_rdd66_ruling$income, df_rdd66_ruling$education, df_rdd66_ruling$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: 1st gold medal; Subsample: Ruling party support",
             c = 0) 

p2 <- rdplot(df_rdd66_ruling$ftj, df_rdd66_ruling$running_var2,
             covs = cbind(df_rdd66_ruling$age, df_rdd66_ruling$female, df_rdd66_ruling$income, df_rdd66_ruling$education, df_rdd66_ruling$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: 1st gold medal; Subsample: Ruling party support",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Table D.8: Higher patriotic group does not especially respond to the first gold medal

pat_median <- median(df_rdd48$patriotism, na.rm = TRUE)

df_rdd48_patriotism <- df_rdd48 |>
  mutate(
    patriotism_split = if_else(patriotism >= pat_median, 1L, 0L)
  )


covariates <- cbind(df_rdd48_patriotism$age, df_rdd48_patriotism$female, df_rdd48_patriotism$income, df_rdd48_patriotism$education)

results_judo48p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  

  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo48p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo48p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo48p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo48p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo48p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo48p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo48p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd48_patriotism[[outcome_var]], df_rdd48_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}



#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res5c"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1c", "res2c", "res5c"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48p) <- c("", "(1)", "(2)", "(3)")


#feeling thermometer
final_results_list <- lapply(c("res1f", "res2f", "res5f"), function(res) {
  process_results(results_judo48p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$kernel)
bwselect_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$bwselect)
bwp_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo48p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo48p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$p)
q_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo48p[[res]]$q)
n_results <- sapply(c("res1f", "res2f", "res5f"), function(res) sum(results_judo48p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd48_judo48pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd48_judo48pft) <- c("", "(1)", "(2)", "(3)")

RDD Results (Cabinet approval)

Treatment	0.166	0.166	0.182
Robust 95% CI	[-0.097, 0.430]	[-0.097, 0.430]	[-0.128, 0.491]
Robust \(p\)-value	0.216	0.215	0.251
Observations	740	740	740
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	47.012	47.131	33.787
BW bias (\(b\))	104.324	104.33	104.324
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	20.200	20.199	20.732
Robust 95% CI	[-8.316, 48.716]	[-8.320, 48.717]	[-8.835, 50.299]
Robust \(p\)-value	0.165	0.165	0.169
Observations	740	740	740
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	19.758	19.75	14.2
BW bias (\(b\))	48.431	48.432	48.431
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure D.11: Higher patriotism group does not react to the first gold medal

p1 <- rdplot(df_rdd48_patriotism$cabap, df_rdd48_patriotism$running_var2,
             covs = cbind(df_rdd48_patriotism$age, df_rdd48_patriotism$female, df_rdd48_patriotism$income, df_rdd48_patriotism$education, df_rdd48_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: 1st gold medal; Subsample: Higher patriotism",
             c = 0) 

p2 <- rdplot(df_rdd48_patriotism$ftj, df_rdd48_patriotism$running_var2,
             covs = cbind(df_rdd48_patriotism$age, df_rdd48_patriotism$female, df_rdd48_patriotism$income, df_rdd48_patriotism$education, df_rdd48_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: 1st gold medal; Subsample: Higher Patriotism",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Table D.9: Higher patriotic group does not also respond to the second gold medal

pat_median <- median(df_rdd66$patriotism, na.rm = TRUE)

df_rdd66_patriotism <- df_rdd66 |>
  mutate(
    patriotism_split = if_else(patriotism >= pat_median, 1L, 0L)
  )


covariates <- cbind(df_rdd66_patriotism$age, df_rdd66_patriotism$female, df_rdd66_patriotism$income, df_rdd66_patriotism$education)

results_judo66p <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  

  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judo66p[[paste0("res1", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judo66p[[paste0("res2", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judo66p[[paste0("res3", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judo66p[[paste0("res4", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judo66p[[paste0("res5", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judo66p[[paste0("res6", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judo66p[[paste0("res7", prefix)]] <- safe_rdrobust(df_rdd66_patriotism[[outcome_var]], df_rdd66_patriotism$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}



#cabinet approval

final_results_list <- lapply(c("res1c", "res2c", "res5c"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1c", "res2c", "res5c"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1c", "res2c", "res5c"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1c", "res2c", "res5c"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66p <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                 "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                 "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66p) <- c("", "(1)", "(2)", "(3)")


#feeling thermometer
final_results_list <- lapply(c("res1f", "res2f", "res5f"), function(res) {
  process_results(results_judo66p[[res]])
})

final_combined_results <- do.call(cbind, lapply(final_results_list, function(x) x[, 2]))

kernel_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$kernel)
bwselect_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$bwselect)
bwp_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo66p[[res]]$bws[1,1], 3))
bwb_results <- sapply(c("res1f", "res2f", "res5f"), function(res) round(results_judo66p[[res]]$bws[2,1], 3))
pol_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$p)
q_results <- sapply(c("res1f", "res2f", "res5f"), function(res) results_judo66p[[res]]$q)
n_results <- sapply(c("res1f", "res2f", "res5f"), function(res) sum(results_judo66p[[res]]$N))

final_combined_results_with_kernel <- rbind(
  final_combined_results,
  n_results,
  kernel_results,
  bwselect_results,
  pol_results,
  q_results,
  bwp_results,
  bwb_results
)

df_rdd66_judo66pft <- data.frame(c("Treatment", "Robust 95% CI","Robust $p$-value", "Observations" , "Kernel type",
                                   "BW type", "Order loc. poly.($p$)", "Order bias ($q$)", "BW loc. poly.($h$)",
                                   "BW bias ($b$)"), final_combined_results_with_kernel)

colnames(df_rdd66_judo66pft) <- c("", "(1)", "(2)", "(3)")

RDD Results (Cabinet approval)

Treatment	0.156	0.157	0.215
Robust 95% CI	[-0.068, 0.380]	[-0.069, 0.382]	[-0.072, 0.503]
Robust \(p\)-value	0.172	0.174	0.142
Observations	712	712	712
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	3.245	3.123	2.337
BW bias (\(b\))	4.871	4.785	4.871
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

RDD Results (Feeling thermometer)

Treatment	-10.871	-12.019	-11.598
Robust 95% CI	[-31.521, 9.780]	[-32.378, 8.340]	[-33.320, 10.124]
Robust \(p\)-value	0.302	0.247	0.295
Observations	712	712	712
Kernel type	Triangular	Triangular	Triangular
BW type	mserd	msesum	cerrd
Order loc. poly.(\(p\))	1	1	1
Order bias (\(q\))	2	2	2
BW loc. poly.(\(h\))	2.39	2.624	1.721
BW bias (\(b\))	3.768	3.861	3.768
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure D.12: Higher patriotism group does not react to the second gold medal

p1 <- rdplot(df_rdd66_patriotism$cabap, df_rdd66_patriotism$running_var2,
             covs = cbind(df_rdd66_patriotism$age, df_rdd66_patriotism$female, df_rdd66_patriotism$income, df_rdd66_patriotism$education, df_rdd66_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: 1st gold medal; Subsample: Higher patriotism",
             c = 0) 

p2 <- rdplot(df_rdd66_patriotism$ftj, df_rdd66_patriotism$running_var2,
             covs = cbind(df_rdd66_patriotism$age, df_rdd66_patriotism$female, df_rdd66_patriotism$income, df_rdd66_patriotism$education, df_rdd66_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: 1st gold medal; Subsample: Higher Patriotism",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Figure D.12: Higher patriotism group does not react to the second gold medal

p1 <- rdplot(df_rdd66_patriotism$cabap, df_rdd66_patriotism$running_var2,
             covs = cbind(df_rdd66_patriotism$age, df_rdd66_patriotism$female, df_rdd66_patriotism$income, df_rdd66_patriotism$education, df_rdd66_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: 1st gold medal; Subsample: Higher patriotism",
             c = 0) 

p2 <- rdplot(df_rdd66_patriotism$ftj, df_rdd66_patriotism$running_var2,
             covs = cbind(df_rdd66_patriotism$age, df_rdd66_patriotism$female, df_rdd66_patriotism$income, df_rdd66_patriotism$education, df_rdd66_patriotism$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: 1st gold medal; Subsample: Higher Patriotism",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

D.4 Equivalance analysis using the Welch two one-sided tests

Figure D.13: Equivalence test shows that the second gold medal’s effect size is negligibly small

# Cabinet approval

df <- df_rdd48
df$outcome     <- df$cabap
df$treatment   <- df$cutoff
df$running_var <- df$running_var


compute_xrange_and_labels <- function(effect, ci, eps, mult_range = 1.25, offset_frac = 0.08) {
  xmax <- max(abs(c(ci, effect, -eps, eps)), na.rm = TRUE) * mult_range
  lab_off <- offset_frac * xmax
  list(
    xlim    = c(-xmax, xmax),    
    x_left  = -eps + lab_off,     
    x_right =  eps - lab_off     
  )
}

eps_cabap <- round(0.2 * sd(df$cabap, na.rm = TRUE), 3)
x <- df$cabap[df$treatment == 1]
y <- df$cabap[df$treatment == 0]

equiv_test_result1 <- tost(x = x, y = y, epsilon = eps_cabap)
effect_size1 <- mean(x, na.rm = TRUE) - mean(y, na.rm = TRUE)
ci1 <- equiv_test_result1$tost.interval

ax1 <- compute_xrange_and_labels(effect = effect_size1, ci = ci1, eps = eps_cabap,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect  <- 0.50
y_bounds  <- 0.50

p0 <-
  ggplot(NULL, aes(x = effect_size1, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci1[1], xmax = ci1[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[1], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[2], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_cabap, linetype = "dashed") +
  geom_vline(xintercept =  eps_cabap, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Cabinet approval (1st gold medal)",
       x = "Effect size (difference in proportions, shown as pp)", y = "") +
  scale_x_continuous(labels = scales::label_percent(accuracy = 1, scale = 100)) +
  coord_cartesian(xlim = ax1$xlim, clip = "off") +                     theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +                         annotate("text", x = effect_size1, y = y_effect,
           label = paste0("Effect size: ", round(effect_size1*100, 1), " pp\n[",
                          round(ci1[1]*100, 1), ", ", round(ci1[2]*100, 1), "] pp"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax1$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", round(eps_cabap*100, 1), " pp)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax1$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", round(eps_cabap*100, 1), " pp)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")


#Feeling thermometer

df <- df_rdd48
df$outcome     <- df$ftj
df$treatment   <- df$cutoff
df$running_var <- df$running_var

eps_ftj <- round(0.2 * sd(df$ftj, na.rm = TRUE), 2)
x2 <- df$ftj[df$treatment == 1]
y2 <- df$ftj[df$treatment == 0]

equiv_test_result2 <- tost(x = x2, y = y2, epsilon = eps_ftj)
effect_size2 <- mean(x2, na.rm = TRUE) - mean(y2, na.rm = TRUE)
ci2 <- equiv_test_result2$tost.interval

ax2 <- compute_xrange_and_labels(effect = effect_size2, ci = ci2, eps = eps_ftj,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect <- 0.50
y_bounds <- 0.50

p1 <-
  ggplot(NULL, aes(x = effect_size2, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci2[1], xmax = ci2[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[1], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[2], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_ftj, linetype = "dashed") +
  geom_vline(xintercept =  eps_ftj, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Feeling thermometer to Japanese government (1st gold medal)",
       x = "Effect size (difference in points)", y = "") +
  coord_cartesian(xlim = ax2$xlim, clip = "off") +
  theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +
  annotate("text", x = effect_size2, y = y_effect,
           label = paste0("Effect size: ", round(effect_size2, 2), " points\n[",
                          round(ci2[1], 2), ", ", round(ci2[2], 2), "]"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax2$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", eps_ftj, " points)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax2$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", eps_ftj, " points)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")

grid.arrange(p0, p1, ncol = 1)

Figure D.14: Equivalence test shows that the second gold medal’s effect size is negligibly small

#Cabinet approval

df <- df_rdd66
df$outcome     <- df$cabap
df$treatment   <- df$cutoff
df$running_var <- df$running_var


eps_cabap <- round(0.2 * sd(df$cabap, na.rm = TRUE), 3)
x <- df$cabap[df$treatment == 1]
y <- df$cabap[df$treatment == 0]

equiv_test_result1 <- tost(x = x, y = y, epsilon = eps_cabap)
effect_size1 <- mean(x, na.rm = TRUE) - mean(y, na.rm = TRUE)
ci1 <- equiv_test_result1$tost.interval

ax1 <- compute_xrange_and_labels(effect = effect_size1, ci = ci1, eps = eps_cabap,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect  <- 0.50
y_bounds  <- 0.50

p0 <-
  ggplot(NULL, aes(x = effect_size1, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci1[1], xmax = ci1[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[1], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci1[2], xend = effect_size1, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_cabap, linetype = "dashed") +
  geom_vline(xintercept =  eps_cabap, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Cabinet approval (2nd gold medal)",
       x = "Effect size (difference in proportions, shown as pp)", y = "") +
  scale_x_continuous(labels = scales::label_percent(accuracy = 1, scale = 100)) +
  coord_cartesian(xlim = ax1$xlim, clip = "off") +                    
  theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +                      
  annotate("text", x = effect_size1, y = y_effect,
           label = paste0("Effect size: ", round(effect_size1*100, 1), " pp\n[",
                          round(ci1[1]*100, 1), ", ", round(ci1[2]*100, 1), "] pp"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax1$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", round(eps_cabap*100, 1), " pp)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax1$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", round(eps_cabap*100, 1), " pp)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")

# Feeling thermometer

df <- df_rdd66
df$outcome     <- df$ftj
df$treatment   <- df$cutoff
df$running_var <- df$running_var

eps_ftj <- round(0.2 * sd(df$ftj, na.rm = TRUE), 2)
x2 <- df$ftj[df$treatment == 1]
y2 <- df$ftj[df$treatment == 0]

equiv_test_result2 <- tost(x = x2, y = y2, epsilon = eps_ftj)
effect_size2 <- mean(x2, na.rm = TRUE) - mean(y2, na.rm = TRUE)
ci2 <- equiv_test_result2$tost.interval

ax2 <- compute_xrange_and_labels(effect = effect_size2, ci = ci2, eps = eps_ftj,
                                 mult_range = 1.25, offset_frac = 0.08)

y_effect <- 0.50
y_bounds <- 0.50

p1 <-
  ggplot(NULL, aes(x = effect_size2, y = 0.5)) +
  geom_point(size = 3) +
  geom_linerange(aes(xmin = ci2[1], xmax = ci2[2], y = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[1], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_segment(aes(x = ci2[2], xend = effect_size2, y = 0.5, yend = 0.5), size = 0.5) +
  geom_vline(xintercept = -eps_ftj, linetype = "dashed") +
  geom_vline(xintercept =  eps_ftj, linetype = "dashed") +
  geom_vline(xintercept = 0, color = "red") +
  labs(title = "Equivalence Test: Feeling thermometer to Japanese government (2nd gold medal)",
       x = "Effect size (difference in points)", y = "") +
  coord_cartesian(xlim = ax2$xlim, clip = "off") +
  theme_igray() +
  theme(axis.text.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(hjust = 0.5),
        axis.text.x = element_text(size = 10),
        axis.title.x = element_text(size = 12),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.y = element_blank(),
        plot.margin = margin(10, 30, 10, 30)) +
  annotate("text", x = effect_size2, y = y_effect,
           label = paste0("Effect size: ", round(effect_size2, 2), " points\n[",
                          round(ci2[1], 2), ", ", round(ci2[2], 2), "]"),
           hjust = 0.5, vjust = 0, size = 3.5, color = "black") +
  annotate("text", x = ax2$x_left,  y = y_bounds,
           label = paste0("Lower equivalence bound\n(-", eps_ftj, " points)"),
           hjust = 1, vjust = 1, size = 3.5, color = "blue") +
  annotate("text", x = ax2$x_right, y = y_bounds,
           label = paste0("Upper equivalence bound\n(+", eps_ftj, " points)"),
           hjust = 0, vjust = 1, size = 3.5, color = "blue")

grid.arrange(p0, p1, ncol = 1)

E. Robustness checks with unexpected events during survey design approach

E.1 Balance Checks and Results to Address Imbalances

Table E.1: Balance check results represent a clear imbalance between the treatment and control groups (The first gold medal case)

tb_bc1 <- df_rdd48 |>
  dplyr::select(cutoff, age, female, education, income, psu_rul) |>
  tidyr::drop_na() |>
  vtable::sumtable(group = "cutoff", group.test = TRUE, title = "")

cutoff	0			1
Variable	N	Mean	SD	N	Mean	SD	Test
age	558	50	14	182	63	17	F=118.785***
female	558	0.32	0.47	182	0.69	0.46	F=88.224***
education	558	3.3	0.91	182	3	0.92	F=15.873***
income	558	7.2	3.3	182	6	2.8	F=18.208***
psu_rul	558	0.3	0.46	182	0.32	0.47	F=0.2
Statistical significance markers: * p<0.1; ** p<0.05; *** p<0.01

Table E.2: Balance check results also represent a clear imbalance between the treatment and control groups (The second gold medal case)

tb_bc2 <- df_rdd66 |>
  dplyr::select(cutoff, age, female, education, income, psu_rul) |>
  tidyr::drop_na() |>
  vtable::sumtable(group = "cutoff", group.test = TRUE, title = "")

cutoff	0			1
Variable	N	Mean	SD	N	Mean	SD	Test
age	226	51	14	486	54	17	F=5.528**
female	226	0.3	0.46	486	0.45	0.5	F=14.238***
education	226	3.7	6.4	486	3.8	7.6	F=0.045
income	226	7	3.4	486	6.8	3.1	F=0.253
psu_rul	226	0.35	0.48	486	0.32	0.47	F=0.568
Statistical significance markers: * p<0.1; ** p<0.05; *** p<0.01

Table E.3: Covariate distribution BEFORE entropy balancing (The first gold medal case))

pre_balance_stats_df <- df_rdd48 |>
  summarise(
    Age_Mean_Control = mean(age[cutoff == 0], na.rm = TRUE),
    Age_Mean_Treatment = mean(age[cutoff == 1], na.rm = TRUE),
    Age_Variance_Control = var(age[cutoff == 0], na.rm = TRUE),
    Age_Variance_Treatment = var(age[cutoff == 1], na.rm = TRUE),
    Age_Skewness_Control = e1071::skewness(age[cutoff == 0], na.rm = TRUE),
    Age_Skewness_Treatment = e1071::skewness(age[cutoff == 1], na.rm = TRUE),
    
    Education_Mean_Control = mean(education[cutoff == 0], na.rm = TRUE),
    Education_Mean_Treatment = mean(education[cutoff == 1], na.rm = TRUE),
    Education_Variance_Control = var(education[cutoff == 0], na.rm = TRUE),
    Education_Variance_Treatment = var(education[cutoff == 1], na.rm = TRUE),
    Education_Skewness_Control = e1071::skewness(education[cutoff == 0], na.rm = TRUE),
    Education_Skewness_Treatment = e1071::skewness(education[cutoff == 1], na.rm = TRUE),
    
    Income_Mean_Control = mean(income[cutoff == 0], na.rm = TRUE),
    Income_Mean_Treatment = mean(income[cutoff == 1], na.rm = TRUE),
    Income_Variance_Control = var(income[cutoff == 0], na.rm = TRUE),
    Income_Variance_Treatment = var(income[cutoff == 1], na.rm = TRUE),
    Income_Skewness_Control = e1071::skewness(income[cutoff == 0], na.rm = TRUE),
    Income_Skewness_Treatment = e1071::skewness(income[cutoff == 1], na.rm = TRUE),
    
    psu_rul_Mean_Control = mean(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Mean_Treatment = mean(psu_rul[cutoff == 1], na.rm = TRUE),
    psu_rul_Variance_Control = var(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Variance_Treatment = var(psu_rul[cutoff == 1], na.rm = TRUE),
    psu_rul_Skewness_Control = e1071::skewness(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Skewness_Treatment = e1071::skewness(psu_rul[cutoff == 1], na.rm = TRUE),
    
    patriotism_Mean_Control = mean(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Mean_Treatment = mean(patriotism[cutoff == 1], na.rm = TRUE),
    patriotism_Variance_Control = var(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Variance_Treatment = var(patriotism[cutoff == 1], na.rm = TRUE),
    patriotism_Skewness_Control = e1071::skewness(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Skewness_Treatment = e1071::skewness(patriotism[cutoff == 1], na.rm = TRUE)
  )

pre_balance_stats_df_cleaned <- data.frame(
  Variable = c("Age", "Education", "Income", "psu_rul", "patriotism"),
  Mean_Control = c(pre_balance_stats_df$Age_Mean_Control, pre_balance_stats_df$Education_Mean_Control, pre_balance_stats_df$Income_Mean_Control, pre_balance_stats_df$psu_rul_Mean_Control, pre_balance_stats_df$patriotism_Mean_Control),
  Variance_Control = c(pre_balance_stats_df$Age_Variance_Control, pre_balance_stats_df$Education_Variance_Control, pre_balance_stats_df$Income_Variance_Control, pre_balance_stats_df$psu_rul_Variance_Control, pre_balance_stats_df$patriotism_Variance_Control),
  Skewness_Control = c(pre_balance_stats_df$Age_Skewness_Control, pre_balance_stats_df$Education_Skewness_Control, pre_balance_stats_df$Income_Skewness_Control, pre_balance_stats_df$psu_rul_Skewness_Control, pre_balance_stats_df$patriotism_Skewness_Control),
  Mean_Treatment = c(pre_balance_stats_df$Age_Mean_Treatment, pre_balance_stats_df$Education_Mean_Treatment, pre_balance_stats_df$Income_Mean_Treatment, pre_balance_stats_df$psu_rul_Mean_Treatment, pre_balance_stats_df$patriotism_Mean_Treatment),
  Variance_Treatment = c(pre_balance_stats_df$Age_Variance_Treatment, pre_balance_stats_df$Education_Variance_Treatment, pre_balance_stats_df$Income_Variance_Treatment, pre_balance_stats_df$psu_rul_Variance_Treatment, pre_balance_stats_df$patriotism_Variance_Treatment),
  Skewness_Treatment = c(pre_balance_stats_df$Age_Skewness_Treatment, pre_balance_stats_df$Education_Skewness_Treatment, pre_balance_stats_df$Income_Skewness_Treatment, pre_balance_stats_df$psu_rul_Skewness_Treatment, pre_balance_stats_df$patriotism_Skewness_Treatment)
)

colnames(pre_balance_stats_df_cleaned) <- c("Variable", 
                                            "Mean (Control)", 
                                            "Variance (Control)", 
                                            "Skewness (Control)",
                                            "Mean (Treatment)",
                                            "Variance (Treatment)",
                                            "Skewness (Treatment)")

rownames(pre_balance_stats_df_cleaned) <- NULL

pre_balance_stats_df_cleaned |>
  kable(format = "html",
        caption = "Covariate Distribution Before Entropy Balancing",
        digits = 3, 
        booktabs = TRUE) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
                full_width = FALSE,
                position = "center")|> 
  kable_classic(full_width = FALSE, html_font = "Times")

Covariate Distribution Before Entropy Balancing

Variable	Mean (Control)	Variance (Control)	Skewness (Control)	Mean (Treatment)	Variance (Treatment)	Skewness (Treatment)
Age	49.846	186.680	-0.073	63.401	291.092	-1.696
Education	3.294	0.829	-0.810	2.984	0.845	-0.095
Income	7.183	10.861	0.269	6.022	7.988	0.825
psu_rul	0.301	0.211	0.865	0.319	0.218	0.772
patriotism	0.004	0.888	-0.888	0.184	0.622	-0.907

Table E.4: Covariate distribution AFTER entropy balancing (The first gold medal case)

covariates <- df_rdd48[, c("age", "female", "education", "income", "psu_rul", "patriotism")]

treatment <- df_rdd48$cutoff

eb_result <- weightit(
  cutoff ~ age + female + education + income + psu_rul + patriotism,
  data = df_rdd48,
  method = "ebal"
)


weights <- eb_result$w


weights <- eb_result$w
summary(eb_result$w)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  0.1360  0.6409  0.8987  1.0000  1.2225 12.0208

weighted_df_rdd48 <- na.omit(df_rdd48)
weighted_df_rdd48$weights <- weights

final_stats_df <- weighted_df_rdd48 |>
  summarise(
    Age_Mean_Control = weighted.mean(age[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Age_Mean_Treatment = weighted.mean(age[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Age_Variance_Control = Hmisc::wtd.var(age[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Age_Variance_Treatment = Hmisc::wtd.var(age[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Age_Skewness_Control = e1071::skewness(age[cutoff == 0], na.rm = TRUE),
    Age_Skewness_Treatment = e1071::skewness(age[cutoff == 1], na.rm = TRUE),
    
    Education_Mean_Control = weighted.mean(education[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Education_Mean_Treatment = weighted.mean(education[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Education_Variance_Control = Hmisc::wtd.var(education[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Education_Variance_Treatment = Hmisc::wtd.var(education[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Education_Skewness_Control = e1071::skewness(education[cutoff == 0], na.rm = TRUE),
    Education_Skewness_Treatment = e1071::skewness(education[cutoff == 1], na.rm = TRUE),
    
    Income_Mean_Control = weighted.mean(income[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Income_Mean_Treatment = weighted.mean(income[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Income_Variance_Control = Hmisc::wtd.var(income[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Income_Variance_Treatment = Hmisc::wtd.var(income[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Income_Skewness_Control = e1071::skewness(income[cutoff == 0], na.rm = TRUE),
    Income_Skewness_Treatment = e1071::skewness(income[cutoff == 1], na.rm = TRUE),
    
    psu_rul_Mean_Control = weighted.mean(psu_rul[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    psu_rul_Mean_Treatment = weighted.mean(psu_rul[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    psu_rul_Variance_Control = Hmisc::wtd.var(psu_rul[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    psu_rul_Variance_Treatment = Hmisc::wtd.var(psu_rul[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    psu_rul_Skewness_Control = e1071::skewness(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Skewness_Treatment = e1071::skewness(psu_rul[cutoff == 1], na.rm = TRUE),
    
    patriotism_Mean_Control = weighted.mean(patriotism[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    patriotism_Mean_Treatment = weighted.mean(patriotism[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    patriotism_Variance_Control = Hmisc::wtd.var(patriotism[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    patriotism_Variance_Treatment = Hmisc::wtd.var(patriotism[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    patriotism_Skewness_Control = e1071::skewness(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Skewness_Treatment = e1071::skewness(patriotism[cutoff == 1], na.rm = TRUE)
  )

final_stats_df_cleaned <- data.frame(
  Variable = c("Age", "Education", "Income", "In-partisans", "patriotism"),
  Mean_Control = c(final_stats_df$Age_Mean_Control, final_stats_df$Education_Mean_Control, final_stats_df$Income_Mean_Control, final_stats_df$psu_rul_Mean_Control, final_stats_df$patriotism_Mean_Control),
  Variance_Control = c(final_stats_df$Age_Variance_Control, final_stats_df$Education_Variance_Control, final_stats_df$Income_Variance_Control, final_stats_df$psu_rul_Variance_Control, final_stats_df$patriotism_Variance_Control),
  Skewness_Control = c(final_stats_df$Age_Skewness_Control, final_stats_df$Education_Skewness_Control, final_stats_df$Income_Skewness_Control, final_stats_df$psu_rul_Skewness_Control, final_stats_df$patriotism_Skewness_Control),
  Mean_Treatment = c(final_stats_df$Age_Mean_Treatment, final_stats_df$Education_Mean_Treatment, final_stats_df$Income_Mean_Treatment, final_stats_df$psu_rul_Mean_Treatment, final_stats_df$patriotism_Mean_Treatment),
  Variance_Treatment = c(final_stats_df$Age_Variance_Treatment, final_stats_df$Education_Variance_Treatment, final_stats_df$Income_Variance_Treatment, final_stats_df$psu_rul_Variance_Treatment, final_stats_df$patriotism_Variance_Treatment),
  Skewness_Treatment = c(final_stats_df$Age_Skewness_Treatment, final_stats_df$Education_Skewness_Treatment, final_stats_df$Income_Skewness_Treatment, final_stats_df$psu_rul_Skewness_Treatment, final_stats_df$patriotism_Skewness_Treatment)
)

colnames(final_stats_df_cleaned) <- c("Variable", 
                                      "Mean ", 
                                      "Variance", 
                                      "Skewness ",
                                      "Mean ",
                                      "Variance ",
                                      "Skewness ")

rownames(final_stats_df_cleaned) <- NULL

final_stats_df_cleaned |>
  kable(format = "html",
        caption = "Covariate Distribution After Entropy Balancing",
        digits = 3,
        booktabs = TRUE) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
                full_width = FALSE,
                position = "center")|> 
  kable_classic(full_width = FALSE, html_font = "Times")

Covariate Distribution After Entropy Balancing

Variable	Mean	Variance	Skewness	Mean	Variance	Skewness
Age	53.180	184.663	-0.073	53.180	482.544	-1.696
Education	3.218	0.839	-0.810	3.218	0.867	-0.095
Income	6.897	10.408	0.269	6.897	11.597	0.825
In-partisans	0.305	0.213	0.865	0.305	0.213	0.772
patriotism	0.049	0.838	-0.888	0.049	0.745	-0.907

Table E.5: Covariate distribution BEFORE entropy balancing (The second gold medal case)

#before balancing
pre_balance_stats_df <- df_rdd66 |>
  summarise(
    Age_Mean_Control = mean(age[cutoff == 0], na.rm = TRUE),
    Age_Mean_Treatment = mean(age[cutoff == 1], na.rm = TRUE),
    Age_Variance_Control = var(age[cutoff == 0], na.rm = TRUE),
    Age_Variance_Treatment = var(age[cutoff == 1], na.rm = TRUE),
    Age_Skewness_Control = e1071::skewness(age[cutoff == 0], na.rm = TRUE),
    Age_Skewness_Treatment = e1071::skewness(age[cutoff == 1], na.rm = TRUE),
    
    Education_Mean_Control = mean(education[cutoff == 0], na.rm = TRUE),
    Education_Mean_Treatment = mean(education[cutoff == 1], na.rm = TRUE),
    Education_Variance_Control = var(education[cutoff == 0], na.rm = TRUE),
    Education_Variance_Treatment = var(education[cutoff == 1], na.rm = TRUE),
    Education_Skewness_Control = e1071::skewness(education[cutoff == 0], na.rm = TRUE),
    Education_Skewness_Treatment = e1071::skewness(education[cutoff == 1], na.rm = TRUE),
    
    Income_Mean_Control = mean(income[cutoff == 0], na.rm = TRUE),
    Income_Mean_Treatment = mean(income[cutoff == 1], na.rm = TRUE),
    Income_Variance_Control = var(income[cutoff == 0], na.rm = TRUE),
    Income_Variance_Treatment = var(income[cutoff == 1], na.rm = TRUE),
    Income_Skewness_Control = e1071::skewness(income[cutoff == 0], na.rm = TRUE),
    Income_Skewness_Treatment = e1071::skewness(income[cutoff == 1], na.rm = TRUE),
    
    psu_rul_Mean_Control = mean(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Mean_Treatment = mean(psu_rul[cutoff == 1], na.rm = TRUE),
    psu_rul_Variance_Control = var(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Variance_Treatment = var(psu_rul[cutoff == 1], na.rm = TRUE),
    psu_rul_Skewness_Control = e1071::skewness(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Skewness_Treatment = e1071::skewness(psu_rul[cutoff == 1], na.rm = TRUE),
    
    patriotism_Mean_Control = mean(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Mean_Treatment = mean(patriotism[cutoff == 1], na.rm = TRUE),
    patriotism_Variance_Control = var(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Variance_Treatment = var(patriotism[cutoff == 1], na.rm = TRUE),
    patriotism_Skewness_Control = e1071::skewness(patriotism[cutoff == 0], na.rm = TRUE),
    patriotism_Skewness_Treatment = e1071::skewness(patriotism[cutoff == 1], na.rm = TRUE)
  )

pre_balance_stats_df_cleaned <- data.frame(
  Variable = c("Age", "Education", "Income", "psu_rul", "patriotism"),
  Mean_Control = c(pre_balance_stats_df$Age_Mean_Control, pre_balance_stats_df$Education_Mean_Control, pre_balance_stats_df$Income_Mean_Control, pre_balance_stats_df$psu_rul_Mean_Control, pre_balance_stats_df$patriotism_Mean_Control),
  Variance_Control = c(pre_balance_stats_df$Age_Variance_Control, pre_balance_stats_df$Education_Variance_Control, pre_balance_stats_df$Income_Variance_Control, pre_balance_stats_df$psu_rul_Variance_Control, pre_balance_stats_df$patriotism_Variance_Control),
  Skewness_Control = c(pre_balance_stats_df$Age_Skewness_Control, pre_balance_stats_df$Education_Skewness_Control, pre_balance_stats_df$Income_Skewness_Control, pre_balance_stats_df$psu_rul_Skewness_Control, pre_balance_stats_df$patriotism_Skewness_Control),
  Mean_Treatment = c(pre_balance_stats_df$Age_Mean_Treatment, pre_balance_stats_df$Education_Mean_Treatment, pre_balance_stats_df$Income_Mean_Treatment, pre_balance_stats_df$psu_rul_Mean_Treatment, pre_balance_stats_df$patriotism_Mean_Treatment),
  Variance_Treatment = c(pre_balance_stats_df$Age_Variance_Treatment, pre_balance_stats_df$Education_Variance_Treatment, pre_balance_stats_df$Income_Variance_Treatment, pre_balance_stats_df$psu_rul_Variance_Treatment, pre_balance_stats_df$patriotism_Variance_Treatment),
  Skewness_Treatment = c(pre_balance_stats_df$Age_Skewness_Treatment, pre_balance_stats_df$Education_Skewness_Treatment, pre_balance_stats_df$Income_Skewness_Treatment, pre_balance_stats_df$psu_rul_Skewness_Treatment, pre_balance_stats_df$patriotism_Skewness_Treatment)
)

colnames(pre_balance_stats_df_cleaned) <- c("Variable", 
                                            "Mean (Control)", 
                                            "Variance (Control)", 
                                            "Skewness (Control)",
                                            "Mean (Treatment)",
                                            "Variance (Treatment)",
                                            "Skewness (Treatment)")

rownames(pre_balance_stats_df_cleaned) <- NULL

pre_balance_stats_df_cleaned |>
  kable(format = "html",
        caption = "Covariate Distribution Before Entropy Balancing",
        digits = 3,  # 小数点以下3桁
        booktabs = TRUE) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
                full_width = FALSE,
                position = "center")|> 
  kable_classic(full_width = FALSE, html_font = "Times")

Covariate Distribution Before Entropy Balancing

Variable	Mean (Control)	Variance (Control)	Skewness (Control)	Mean (Treatment)	Variance (Treatment)	Skewness (Treatment)
Age	50.770	183.902	-0.161	53.747	276.758	-0.356
Education	3.650	41.411	14.388	3.774	57.301	12.284
Income	6.969	11.532	0.365	6.840	9.653	0.435
psu_rul	0.350	0.228	0.627	0.321	0.218	0.765
patriotism	0.038	0.792	-0.862	-0.018	0.787	-0.801

Table E.6: Covariate distribution AFTER entropy balancing (The second gold medal case)

covariates <- df_rdd66[, c("age", "female", "education", "income", "psu_rul", "patriotism")]

treatment <- df_rdd66$cutoff

eb_result <- weightit(
  cutoff ~ age + female + education + income + psu_rul + patriotism,
  data = df_rdd66,
  method = "ebal"
)


weights <- eb_result$w


weighted_df_rdd66 <- na.omit(df_rdd66)
weighted_df_rdd66$weights <- weights



final_stats_df <- weighted_df_rdd66 |>
  summarise(
    Age_Mean_Control = weighted.mean(age[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Age_Mean_Treatment = weighted.mean(age[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Age_Variance_Control = Hmisc::wtd.var(age[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Age_Variance_Treatment = Hmisc::wtd.var(age[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Age_Skewness_Control = e1071::skewness(age[cutoff == 0], na.rm = TRUE),
    Age_Skewness_Treatment = e1071::skewness(age[cutoff == 1], na.rm = TRUE),
    
    Education_Mean_Control = weighted.mean(education[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Education_Mean_Treatment = weighted.mean(education[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Education_Variance_Control = Hmisc::wtd.var(education[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Education_Variance_Treatment = Hmisc::wtd.var(education[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Education_Skewness_Control = e1071::skewness(education[cutoff == 0], na.rm = TRUE),
    Education_Skewness_Treatment = e1071::skewness(education[cutoff == 1], na.rm = TRUE),
    
    Income_Mean_Control = weighted.mean(income[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Income_Mean_Treatment = weighted.mean(income[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Income_Variance_Control = Hmisc::wtd.var(income[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Income_Variance_Treatment = Hmisc::wtd.var(income[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Income_Skewness_Control = e1071::skewness(income[cutoff == 0], na.rm = TRUE),
    Income_Skewness_Treatment = e1071::skewness(income[cutoff == 1], na.rm = TRUE),
    
    psu_rul_Mean_Control = weighted.mean(psu_rul[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    psu_rul_Mean_Treatment = weighted.mean(psu_rul[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    psu_rul_Variance_Control = Hmisc::wtd.var(psu_rul[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    psu_rul_Variance_Treatment = Hmisc::wtd.var(psu_rul[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    psu_rul_Skewness_Control = e1071::skewness(psu_rul[cutoff == 0], na.rm = TRUE),
    psu_rul_Skewness_Treatment = e1071::skewness(psu_rul[cutoff == 1], na.rm = TRUE),
    
    Partriotism_Mean_Control = weighted.mean(patriotism[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Partriotism_Mean_Treatment = weighted.mean(patriotism[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Partriotism_Variance_Control = Hmisc::wtd.var(patriotism[cutoff == 0], weights[cutoff == 0], na.rm = TRUE),
    Partriotism_Variance_Treatment = Hmisc::wtd.var(patriotism[cutoff == 1], weights[cutoff == 1], na.rm = TRUE),
    Partriotism_Skewness_Control = e1071::skewness(patriotism[cutoff == 0], na.rm = TRUE),
    Partriotism_Skewness_Treatment = e1071::skewness(patriotism[cutoff == 1], na.rm = TRUE)
  )

final_stats_df_cleaned <- data.frame(
  Variable = c("Age", "Education", "Income", "psu_rul", "Partriotism"),
  Mean_Control = c(final_stats_df$Age_Mean_Control, final_stats_df$Education_Mean_Control, final_stats_df$Income_Mean_Control, final_stats_df$psu_rul_Mean_Control, final_stats_df$Partriotism_Mean_Control),
  Variance_Control = c(final_stats_df$Age_Variance_Control, final_stats_df$Education_Variance_Control, final_stats_df$Income_Variance_Control, final_stats_df$psu_rul_Variance_Control, final_stats_df$Partriotism_Variance_Control),
  Skewness_Control = c(final_stats_df$Age_Skewness_Control, final_stats_df$Education_Skewness_Control, final_stats_df$Income_Skewness_Control, final_stats_df$psu_rul_Skewness_Control, final_stats_df$Partriotism_Skewness_Control),
  Mean_Treatment = c(final_stats_df$Age_Mean_Treatment, final_stats_df$Education_Mean_Treatment, final_stats_df$Income_Mean_Treatment, final_stats_df$psu_rul_Mean_Treatment, final_stats_df$Partriotism_Mean_Treatment),
  Variance_Treatment = c(final_stats_df$Age_Variance_Treatment, final_stats_df$Education_Variance_Treatment, final_stats_df$Income_Variance_Treatment, final_stats_df$psu_rul_Variance_Treatment, final_stats_df$Partriotism_Variance_Treatment),
  Skewness_Treatment = c(final_stats_df$Age_Skewness_Treatment, final_stats_df$Education_Skewness_Treatment, final_stats_df$Income_Skewness_Treatment, final_stats_df$psu_rul_Skewness_Treatment, final_stats_df$Partriotism_Skewness_Treatment)
)

colnames(final_stats_df_cleaned) <- c("Variable", 
                                      "Mean ", 
                                      "Variance", 
                                      "Skewness ",
                                      "Mean ",
                                      "Variance ",
                                      "Skewness ")

rownames(final_stats_df_cleaned) <- NULL

final_stats_df_cleaned |>
  kable(format = "html",
        caption = "Covariate Distribution After Entropy Balancing",
        digits = 3,
        booktabs = TRUE) |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"),
                full_width = FALSE,
                position = "center")|> 
  kable_classic(full_width = FALSE, html_font = "Times") 

Covariate Distribution After Entropy Balancing

Variable	Mean	Variance	Skewness	Mean	Variance	Skewness
Age	52.802	175.684	-0.161	52.802	275.314	-0.356
Education	3.735	55.116	14.388	3.735	52.753	12.284
Income	6.881	11.358	0.365	6.881	9.786	0.435
psu_rul	0.330	0.222	0.627	0.330	0.222	0.765
Partriotism	0.000	0.825	-0.862	0.000	0.773	-0.801

Table E.7: Regression Results with and without Weights (The first gold meda case)

model1 <- lm(cabap ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = df_rdd48)

model2<- lm(ftj ~ cutoff + age + female + education + income + psu_rul + patriotism,
            data = df_rdd48)

# regression iwth weight
model3 <- lm(cabap ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = weighted_df_rdd48, weights = weights)

model4 <- lm(ftj ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = weighted_df_rdd48, weights = weights)

Regression Results with and without Weights

	Cabinet approval<br>No Weight	Feeling thermometer<br>No Weight	Cabinet approval<br>Weighted	Feeling thermometer<br>Weighted
	dep_header
	Cabinet approval No Weight	Feeling thermometer No Weight	Cabinet approval Weighted	Feeling thermometer Weighted
Treatment (Before=0; After=1)	0.021 (0.037)	1.240 (2.281)	0.031 (0.031)	1.020 (1.967)
Age	-0.002 (0.001)	0.084 (0.059)	-0.002 (0.001)	0.075 (0.055)
Female (Female=1; Male=0)	0.024 (0.030)	-1.921 (1.866)	0.012 (0.029)	-2.687 (1.802)
Education (4-scales)	0.013 (0.016)	0.654 (0.961)	0.009 (0.016)	0.453 (0.981)
Income (20-scales)	0.001 (0.004)	-0.023 (0.271)	0.002 (0.004)	-0.050 (0.273)
In-partisans (In-partisan=1; Otherwise=0)	0.454*** (0.030)	24.078*** (1.843)	0.478*** (0.030)	26.079*** (1.870)
Patriotism (Factor scores)	0.025 (0.015)	5.557*** (0.939)	0.026 (0.015)	4.937*** (0.951)
Constant	0.121 (0.076)	27.227*** (4.722)	0.125 (0.076)	28.289*** (4.796)
Weighted	NO	NO	YES	YES
Observations	740	740	740	740
\(R^2\)	0.258	0.252	0.282	0.256
Adjusted \(R^2\)	0.251	0.245	0.275	0.249
Residual Std. Error	0.368	22.714	0.365	23.040
	(df = 732)	(df = 732)	(df = 732)	(df = 732)
\(F\) Statistic	36.425	35.178	41.104	35.962
	(df = 7; 732)	(df = 7; 732)	(df = 7; 732)	(df = 7; 732)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.8: Regression Results with and without Weights (The second gold medal case)

model1 <- lm(cabap ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = df_rdd66)

model2<- lm(ftj ~ cutoff + age + female + education + income + psu_rul + patriotism,
            data = df_rdd66)

model3 <- lm(cabap ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = weighted_df_rdd66, weights = weights)

model4 <- lm(ftj ~ cutoff + age + female + education + income + psu_rul + patriotism,
             data = weighted_df_rdd66, weights = weights)

Regression Results with and without Weights

	Cabinet approval<br>No Weight	Feeling thermometer<br>No Weight	Cabinet approval<br>Weighted	Feeling thermometer<br>Weighted
	dep_header
	Cabinet approval No Weight	Feeling thermometer No Weight	Cabinet approval Weighted	Feeling thermometer Weighted
Treatment (Before=0; After=1)	0.073* (0.029)	0.749 (1.800)	0.067* (0.029)	0.647 (1.790)
Age	-0.000 (0.001)	0.065 (0.053)	-0.000 (0.001)	0.058 (0.054)
Female (Female=1; Male=0)	-0.023 (0.027)	-0.559 (1.707)	-0.029 (0.027)	-0.554 (1.705)
Education (4-scales)	-0.000 (0.002)	0.092 (0.115)	-0.000 (0.002)	0.144 (0.114)
Income (20-scales)	-0.004 (0.004)	-0.130 (0.261)	-0.006 (0.004)	-0.083 (0.263)
In-partisans (In-partisan=1; Otherwise=0)	0.469*** (0.029)	22.959*** (1.805)	0.473*** (0.029)	22.877*** (1.826)
Patriotism (Factor scores)	0.020 (0.015)	5.129*** (0.955)	0.015 (0.015)	5.011*** (0.965)
Constant	0.073 (0.063)	28.276*** (3.912)	0.087 (0.065)	28.252*** (4.068)
Weighted	NO	NO	YES	YES
Observations	712	712	712	712
\(R^2\)	0.291	0.246	0.292	0.242
Adjusted \(R^2\)	0.284	0.239	0.285	0.235
Residual Std. Error	0.355	22.038	0.356	22.231
	(df = 704)	(df = 704)	(df = 704)	(df = 704)
\(F\) Statistic	41.278	32.838	41.469	32.143
	(df = 7; 704)	(df = 7; 704)	(df = 7; 704)	(df = 7; 704)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.9: Counterfactual analysis with causal forest shows the null effect from event (The first gold medal)

#cabinet approval
cf <- causal_forest(
  X = df_rdd48[, c("age","female","education","income","psu_rul")],
  Y = df_rdd48$cabap,
  W = df_rdd48$cutoff,
  seed = 2025
)


treatment_effects_cabap <- predict(cf)$predictions

mean_effect_cabap <- c(mean(treatment_effects_cabap), 
                       quantile(treatment_effects_cabap, 0.025), 
                       quantile(treatment_effects_cabap, 0.975))

#feeling thermometer


cf_ftj <- causal_forest(
  X = df_rdd48[, c("age","female","education","income","psu_rul")],
  Y = df_rdd48$ftj,
  W = df_rdd48$cutoff,
  seed = 2025)


treatment_effects_ftj <- predict(cf_ftj)$predictions

mean_effect_ftj <- c(mean(treatment_effects_ftj), 
                     quantile(treatment_effects_ftj, 0.025), 
                     quantile(treatment_effects_ftj, 0.975))


df_cf <- t(cbind(mean_effect_cabap, mean_effect_ftj))
colnames(df_cf) <- c("mean", "up", "low")

df_cf <- data.frame(outcome = c("mean_effect_cabap", "mean_effect_ftj"),df_cf)

df_cf$mean <- round(df_cf$mean, 3)
df_cf$up <- round(df_cf$up, 3)
df_cf$low <- round(df_cf$low, 3)

format_ci <- function(mean, low, up) {
  sprintf("%.3f\n[%.3f, %.3f]", mean, low, up)
}

formatted_results <- mapply(format_ci, df_cf$mean, df_cf$low, df_cf$up)

df_formatted <- data.frame(
  Outcome = df_cf$outcome,
  Results = formatted_results
)

Causal forest mean effects with 95% CI

Outcome variables	Results
Cabinet approval	0.017 [0.106, -0.077]
Feeling thermometer	-1.417 [6.330, -5.728]

Table E.10: Counterfactual analysis with causal forest also shows the null effect from event (The second gold medal)

#cabinet approval
cf <- causal_forest(
  X = df_rdd66[, c("age","female","education","income","psu_rul")],
  Y = df_rdd66$cabap,
  W = df_rdd66$cutoff,
  seed = 2025
)

treatment_effects_cabap <- predict(cf)$predictions

mean_effect_cabap <- c(mean(treatment_effects_cabap), 
                       quantile(treatment_effects_cabap, 0.025), 
                       quantile(treatment_effects_cabap, 0.975))

#feeling thermometer


cf_ftj <- causal_forest(
  X = df_rdd66[, c("age","female","education","income","psu_rul")],
  Y = df_rdd66$ftj,
  W = df_rdd66$cutoff,
  seed = 2025)

treatment_effects_ftj <- predict(cf_ftj)$predictions

mean_effect_ftj <- c(mean(treatment_effects_ftj), 
                     quantile(treatment_effects_ftj, 0.025), 
                     quantile(treatment_effects_ftj, 0.975))


df_cf <- t(cbind(mean_effect_cabap, mean_effect_ftj))
colnames(df_cf) <- c("mean", "up", "low")

df_cf <- data.frame(outcome = c("mean_effect_cabap", "mean_effect_ftj"),df_cf)

df_cf$mean <- round(df_cf$mean, 3)
df_cf$up <- round(df_cf$up, 3)
df_cf$low <- round(df_cf$low, 3)

format_ci <- function(mean, low, up) {
  sprintf("%.3f\n[%.3f, %.3f]", mean, low, up)
}

formatted_results <- mapply(format_ci, df_cf$mean, df_cf$low, df_cf$up)

df_formatted <- data.frame(
  Outcome = df_cf$outcome,
  Results = formatted_results
)

Causal forest mean effects with 95% CI

Outcome variables	Results
Cabinet approval	0.056 [0.138, -0.043]
Feeling thermometer	-0.385 [3.017, -3.445]

E.2 Covariates adjustment

Figure E.1: Specification curve shows the statistical insignificance of the treatment (The first gold medal) in all covariates combinations

variables <- c("age", "female", "income", "education", "psu_rul", " patriotism")

specifications <- lapply(1:length(variables), function(n) combn(variables, n, simplify = FALSE))
specifications <- unlist(specifications, recursive = FALSE)

results <- data.frame(
  Specification = integer(),
  Coefficient = numeric(),
  ConfLow = numeric(),
  ConfHigh = numeric()
)

for (i in seq_along(specifications)) {
  formula <- as.formula(paste("cabap ~ cutoff +", paste(specifications[[i]], collapse = " + ")))
  model <- lm(formula, data = df_rdd48)
  
  cutoff_coef <- summary(model)$coefficients["cutoff", "Estimate"]
  conf_int <- confint(model)["cutoff", ]
  
  results <- rbind(results, data.frame(
    Specification = i,
    Coefficient = cutoff_coef,
    ConfLow = conf_int[1],
    ConfHigh = conf_int[2]
  ))
}

results <- results |> arrange(Coefficient)
results$Specification <- seq_along(results$Specification)


variables_included <- lapply(specifications, function(spec) {
  sapply(variables, function(var) var %in% spec)
})
variables_long <- do.call(rbind, lapply(seq_along(variables_included), function(i) {
  data.frame(Specification = i, Variable = variables, Included = variables_included[[i]])
}))
variables_long$Included <- as.factor(variables_long$Included)

upper_panel <- ggplot(results, aes(x = Specification, y = Coefficient)) +
  geom_point() +
  geom_errorbar(aes(ymin = ConfLow, ymax = ConfHigh), width = 0.2) +
  geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
  labs(
    title = "Sensitivity Analysis of Coefficient Estimates (Cutoff: 1st gold medal)",
    x = NULL,
    y = "Coefficient Estimate for 'cutoff'"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())

lower_panel <- ggplot(variables_long, aes(x = Specification, y = Variable, fill = Included)) +
  geom_tile() +
  scale_fill_manual(values = c("FALSE" = "white", "TRUE" = "gray"), guide = "none") +
  scale_y_discrete(labels = c("age" = "Age", "female" = "Female",
                              "income" = "Income", "education" = "Education",
                              "psu_rul" = "Ruling party support",
                              " patriotism" = "Patriotism")) +
  labs(
    x = "Specification Number",
    y = "Variables"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))


grid.arrange(upper_panel, lower_panel, ncol = 1, heights = c(2, 1))

Figure E.2: Specification curve shows the statistical insignificance of the treatment (The second gold medal) in all covariates combinations

variables <- c("age", "female", "income", "education", "psu_rul", " patriotism")

specifications <- lapply(1:length(variables), function(n) combn(variables, n, simplify = FALSE))
specifications <- unlist(specifications, recursive = FALSE)

results <- data.frame(
  Specification = integer(),
  Coefficient = numeric(),
  ConfLow = numeric(),
  ConfHigh = numeric()
)

for (i in seq_along(specifications)) {
  formula <- as.formula(paste("cabap ~ cutoff +", paste(specifications[[i]], collapse = " + ")))
  model <- lm(formula, data = df_rdd66)
  
  cutoff_coef <- summary(model)$coefficients["cutoff", "Estimate"]
  conf_int <- confint(model)["cutoff", ]
  
  results <- rbind(results, data.frame(
    Specification = i,
    Coefficient = cutoff_coef,
    ConfLow = conf_int[1],
    ConfHigh = conf_int[2]
  ))
}

results <- results |> arrange(Coefficient)
results$Specification <- seq_along(results$Specification)


variables_included <- lapply(specifications, function(spec) {
  sapply(variables, function(var) var %in% spec)
})
variables_long <- do.call(rbind, lapply(seq_along(variables_included), function(i) {
  data.frame(Specification = i, Variable = variables, Included = variables_included[[i]])
}))
variables_long$Included <- as.factor(variables_long$Included)

upper_panel <- ggplot(results, aes(x = Specification, y = Coefficient)) +
  geom_point() +
  geom_errorbar(aes(ymin = ConfLow, ymax = ConfHigh), width = 0.2) +
  geom_hline(yintercept = 0, linetype = "dashed", color = "red") +
  labs(
    title = "Sensitivity Analysis of Coefficient Estimates (Cutoff: 2nd gold medal)",
    x = NULL,
    y = "Coefficient Estimate for 'cutoff'"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_blank(), axis.ticks.x = element_blank())

lower_panel <- ggplot(variables_long, aes(x = Specification, y = Variable, fill = Included)) +
  geom_tile() +
  scale_fill_manual(values = c("FALSE" = "white", "TRUE" = "gray"), guide = "none") +
  scale_y_discrete(labels = c("age" = "Age", "female" = "Female",
                              "income" = "Income", "education" = "Education",
                              "psu_rul" = "Ruling party support",
                              " patriotism" = "Patriotism")) +
  labs(
    x = "Specification Number",
    y = "Variables"
  ) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))


grid.arrange(upper_panel, lower_panel, ncol = 1, heights = c(2, 1))

E.3 No response analysis

Table E.11: t-test results indicate no major difference of non-response rate across covariates

# scrutiny of attrition with attribution

source("t_test_function.R")

treatment_group <- judo48p |> filter(cutoff == 1)
control_group <- judo48p |> filter(cutoff == 0)

calculate_no_response <- function(df, var) {
  no_response <- ifelse(is.na(df[[var]]), 1, 0)
  return(no_response)
}


variables <- c("age", "female", "education", "income", "psu_rul")

results <- data.frame(
  Variable = character(),
  Control_Mean = numeric(),
  Treatment_Mean = numeric(),
  T_statistic = numeric(),
  P_value = numeric()
)

for (var in variables) {
  t_result <- t_test_function(judo48p, var)
  results <- rbind(results, data.frame(
    Variable = var, 
    Control_Mean = t_result[1], 
    Treatment_Mean = t_result[2], 
    T_statistic = t_result[3], 
    P_value = t_result[4]
  ))
}

T-Test Results for No Response Rate Across Attributes Between Treatment and Control Groups

	The first gold medal case
Variable	Control	Treatment	t-statistics	p-value
Age	0.09	0.12	1.71	0.09
Female	0.09	0.12	1.74	0.08
Education	0.09	0.12	1.80	0.07
Income	0.21	0.24	1.07	0.28
In-partisans	0.10	0.14	1.62	0.11

treatment_group <- judo66p |> filter(cutoff == 1)
control_group <- judo66p |> filter(cutoff == 0)

calculate_no_response <- function(df, var) {
  no_response <- ifelse(is.na(df[[var]]), 1, 0)
  return(no_response)
}


variables <- c("age", "female", "education", "income", "psu_rul")

results <- data.frame(
  Variable = character(),
  Control_Mean = numeric(),
  Treatment_Mean = numeric(),
  T_statistic = numeric(),
  P_value = numeric()
)

for (var in variables) {
  t_result <- t_test_function(judo66p, var)
  results <- rbind(results, data.frame(
    Variable = var, 
    Control_Mean = t_result[1], 
    Treatment_Mean = t_result[2], 
    T_statistic = t_result[3], 
    P_value = t_result[4]
  ))
}

T-Test Results for No Response Rate Across Attributes Between Treatment and Control Groups

	The second gold medal case
Variable	Control	Treatment	t-statistics	p-value
Age	0.05	0.04	-0.62	0.53
Female	0.06	0.05	-0.73	0.46
Education	0.05	0.04	-0.62	0.53
Income	0.18	0.19	0.33	0.74
In-partisans	0.10	0.12	1.01	0.31

Figure E.3: No significant difference of ‘No response’ between treatment and control group (The first gold medal)

judo48p$cutoff_f <- factor(judo48p$cutoff, levels = c(0, 1),
                           labels = c("before", "after"))

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else if (p < 0.10)  "†"   
  else "n.s."
}

judo48p$cabap_na <- as.integer(judo48p$Q1 == 3)


na_count_cabap <- aggregate(cabap_na ~ cutoff_f, data = judo48p,
                            FUN = function(x) mean(x, na.rm = TRUE))


succ_before <- sum(judo48p$cabap_na[judo48p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo48p$cabap_na[judo48p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo48p$cabap_na[judo48p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo48p$cabap_na[judo48p$cutoff_f == "after"]))

pval1 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval1 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars1 <- p_to_stars(pval1)

ymax1 <- max(na_count_cabap$cabap_na, na.rm = TRUE)
ylim_top1 <- min(1, ymax1 + 0.10)              
ypos_sig1 <- min(1, ymax1 + 0.02)             
ypos_txt1 <- min(1, ymax1 + 0.04)             

p1 <- ggplot(na_count_cabap, aes(x = cutoff_f, y = cabap_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars1,
              y_position = ypos_sig1, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of cabinet' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of cabinet approval'") +
  annotate("text", x = 1.5, y = ypos_txt1,
           label = paste("p =", ifelse(is.na(pval1), "NA", signif(pval1, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top1)) +
  theme(plot.title = element_text(size = 10))


judo48p$Q3_11_na <- as.integer(is.na(judo48p$Q3_11))

na_count_ft <- aggregate(Q3_11_na ~ cutoff_f, data = judo48p,
                         FUN = function(x) mean(x, na.rm = TRUE))

succ_before <- sum(judo48p$Q3_11_na[judo48p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo48p$Q3_11_na[judo48p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo48p$Q3_11_na[judo48p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo48p$Q3_11_na[judo48p$cutoff_f == "after"]))

pval2 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval2 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars2 <- p_to_stars(pval2)

ymax2 <- max(na_count_ft$Q3_11_na, na.rm = TRUE)
ylim_top2 <- min(1, ymax2 + 0.10)
ypos_sig2 <- min(1, ymax2 + 0.02)
ypos_txt2 <- min(1, ymax2 + 0.04)

p2 <- ggplot(na_count_ft, aes(x = cutoff_f, y = Q3_11_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars2,
              y_position = ypos_sig2, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of feeling thermometer' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of FT'") +
  annotate("text", x = 1.5, y = ypos_txt2,
           label = paste("p =", ifelse(is.na(pval2), "NA", signif(pval2, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top2)) +
  theme(plot.title = element_text(size = 10))


judo48p$deb_na <- as.integer(is.na(judo48p$deb))

na_count_deb <- aggregate(deb_na ~ cutoff_f, data = judo48p,
                          FUN = function(x) mean(x, na.rm = TRUE))

succ_before <- sum(judo48p$deb_na[judo48p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo48p$deb_na[judo48p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo48p$deb_na[judo48p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo48p$deb_na[judo48p$cutoff_f == "after"]))

pval3 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval3 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars3 <- p_to_stars(pval3)

ymax3 <- max(na_count_deb$deb_na, na.rm = TRUE)
ylim_top3 <- min(1, ymax3 + 0.10)
ypos_sig3 <- min(1, ymax3 + 0.02)
ypos_txt3 <- min(1, ymax3 + 0.04)

p3 <- ggplot(na_count_deb, aes(x = cutoff_f, y = deb_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars3,
              y_position = ypos_sig3, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of debriefing' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of debriefing'") +
  annotate("text", x = 1.5, y = ypos_txt3,
           label = paste("p =", ifelse(is.na(pval3), "NA", signif(pval3, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top3)) +
  theme(plot.title = element_text(size = 10))

 grid.arrange(p1, p2, p3, ncol = 2)

Figure E.4: No significant difference of ‘No response’ between treatment and control group (The second gold medal)

judo66p$cutoff_f <- factor(judo66p$cutoff, levels = c(0, 1),
                           labels = c("before", "after"))

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else if (p < 0.10)  "†"   
  else "n.s."
}

judo66p$cabap_na <- as.integer(judo66p$Q1 == 3)


na_count_cabap <- aggregate(cabap_na ~ cutoff_f, data = judo66p,
                            FUN = function(x) mean(x, na.rm = TRUE))


succ_before <- sum(judo66p$cabap_na[judo66p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo66p$cabap_na[judo66p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo66p$cabap_na[judo66p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo66p$cabap_na[judo66p$cutoff_f == "after"]))

pval1 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval1 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars1 <- p_to_stars(pval1)

ymax1 <- max(na_count_cabap$cabap_na, na.rm = TRUE)
ylim_top1 <- min(1, ymax1 + 0.10)               
ypos_sig1 <- min(1, ymax1 + 0.02)              
ypos_txt1 <- min(1, ymax1 + 0.04)             

p1 <- ggplot(na_count_cabap, aes(x = cutoff_f, y = cabap_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars1,
              y_position = ypos_sig1, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of cabinet' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of cabinet approval'") +
  annotate("text", x = 1.5, y = ypos_txt1,
           label = paste("p =", ifelse(is.na(pval1), "NA", signif(pval1, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top1)) +
  theme(plot.title = element_text(size = 10))


judo66p$Q3_11_na <- as.integer(is.na(judo66p$Q3_11))

na_count_ft <- aggregate(Q3_11_na ~ cutoff_f, data = judo66p,
                         FUN = function(x) mean(x, na.rm = TRUE))

succ_before <- sum(judo66p$Q3_11_na[judo66p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo66p$Q3_11_na[judo66p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo66p$Q3_11_na[judo66p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo66p$Q3_11_na[judo66p$cutoff_f == "after"]))

pval2 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval2 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars2 <- p_to_stars(pval2)

ymax2 <- max(na_count_ft$Q3_11_na, na.rm = TRUE)
ylim_top2 <- min(1, ymax2 + 0.10)
ypos_sig2 <- min(1, ymax2 + 0.02)
ypos_txt2 <- min(1, ymax2 + 0.04)

p2 <- ggplot(na_count_ft, aes(x = cutoff_f, y = Q3_11_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars2,
              y_position = ypos_sig2, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of feeling thermometer' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of FT'") +
  annotate("text", x = 1.5, y = ypos_txt2,
           label = paste("p =", ifelse(is.na(pval2), "NA", signif(pval2, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top2)) +
  theme(plot.title = element_text(size = 10))


judo66p$deb_na <- as.integer(is.na(judo66p$deb))

na_count_deb <- aggregate(deb_na ~ cutoff_f, data = judo66p,
                          FUN = function(x) mean(x, na.rm = TRUE))

succ_before <- sum(judo66p$deb_na[judo66p$cutoff_f == "before"] == 1, na.rm = TRUE)
succ_after  <- sum(judo66p$deb_na[judo66p$cutoff_f == "after"]  == 1, na.rm = TRUE)
n_before    <- sum(!is.na(judo66p$deb_na[judo66p$cutoff_f == "before"]))
n_after     <- sum(!is.na(judo66p$deb_na[judo66p$cutoff_f == "after"]))

pval3 <- NA_real_
if (n_before > 0 && n_after > 0) {
  pval3 <- prop.test(x = c(succ_before, succ_after),
                     n = c(n_before, n_after))$p.value
}
stars3 <- p_to_stars(pval3)

ymax3 <- max(na_count_deb$deb_na, na.rm = TRUE)
ylim_top3 <- min(1, ymax3 + 0.10)
ypos_sig3 <- min(1, ymax3 + 0.02)
ypos_txt3 <- min(1, ymax3 + 0.04)

p3 <- ggplot(na_count_deb, aes(x = cutoff_f, y = deb_na)) +
  geom_bar(stat = "identity", fill = "gray") +
  geom_signif(comparisons = list(c("before", "after")),
              annotations = stars3,
              y_position = ypos_sig3, tip_length = 0, textsize = 5) +
  theme_igray() +
  labs(title = "Mean 'No response of debriefing' before vs after cutoff (1st gold medal)",
       x = "Cutoff",
       y = "Mean 'No response of debriefing'") +
  annotate("text", x = 1.5, y = ypos_txt3,
           label = paste("p =", ifelse(is.na(pval3), "NA", signif(pval3, 3))),
           size = 5) +
  scale_y_continuous(limits = c(0, ylim_top3)) +
  theme(plot.title = element_text(size = 10))

 grid.arrange(p1, p2, p3, ncol = 2)

E.4 Placebo tests: Different dates of control groups

Figure E.5: Gradually shifting the cutoff (Before the first gold medal) does not alter the null results for cabinet approval

Figure E.6: Gradually shifting the cutoff (After the first gold medal) does not alter the null results for cabinet approval

#cabinet approval
cutoff_time <- as.POSIXct("2024-07-28 01:01:00")

df_rdd48 <- df_rdd48 |>
  mutate(running_var = as.numeric(difftime(StartDate, cutoff_time, units = "mins")))

cutoff_diffs <- c(-20, -15, -5, -3, -1, 0, 1, 3, 5, 15, 20)
titles <- c("20 mins before", "15 mins before", "5 mins before", "3 mins before", "1 min before",
            "At cutoff", "1 min after", "3 mins after", "5 mins after", "15 mins after", "20 mins after")

plots <- list()

for (i in 1:length(cutoff_diffs)) {
  cutoff_range <- range(df_rdd48$running_var)
  
  rd <- rdplot(df_rdd48$cabap, df_rdd48$running_var,
               covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
               x.lim = cutoff_range,
               x.lab = "Time difference from cutoff (mins)",
               y.lab = "Cabinet approval",
               title = titles[i],
               c = cutoff_diffs[i])
  
  p <- rd$rdplot + theme_igray()
  
  plots[[i]] <- rd$rdplot
}

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

ordered_plots1 <- list(
  plots[[1]], plots[[2]], 
  plots[[3]], plots[[4]],  
  plots[[5]], plots[[6]]
)

ordered_plots2 <- list(
  plots[[6]], plots[[7]], 
  plots[[8]], plots[[9]], 
  plots[[10]], plots[[11]]  
)



grid.arrange(grobs = ordered_plots1, ncol = 3)

grid.arrange(grobs = ordered_plots2, ncol = 3)

Figure E.7: Gradually shifting the cutoff (beforethe first gold medal) does not alter the null results for feeling thermometer to Japanese government

Figure E.8: Figure E.8: Gradually shifting the cutoff (After the first gold medal) does not alter the null results for feeling thermometer to Japanese government

for (i in 1:length(cutoff_diffs)) {
  cutoff_range <- range(df_rdd48$running_var)
  
  rd <- rdplot(df_rdd48$ftj, df_rdd48$running_var,
               covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
               x.lim = cutoff_range,
               x.lab = "Time difference from cutoff (mins)",
               y.lab = "Feeling thermometer",
               title = titles[i],
               c = cutoff_diffs[i])
  
  p <- rd$rdplot + theme_igray()
  
  plots[[i]] <- rd$rdplot
}

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

ordered_plots1 <- list(
  plots[[1]], plots[[2]], 
  plots[[3]], plots[[4]],  
  plots[[5]], plots[[6]]
)

ordered_plots2 <- list(
  plots[[6]], plots[[7]],  
  plots[[8]], plots[[9]], 
  plots[[10]], plots[[11]]  
)


grid.arrange(grobs = ordered_plots1, ncol = 3)

grid.arrange(grobs = ordered_plots2, ncol = 3)

Figure E.9: Gradually shifting the cutoff (Before the second gold medal) does not alter the null results for cabinet approval to Japanese government

Figure E.10: Gradually shifting the cutoff (After the second gold medal) does not alter the null results for cabinet approval to Japanese government

cutoff_diffs <- c(-5, -3, -1, 0, 1, 3, 5, 15, 20)
titles <- c( "5 mins before", "3 mins before", "1 min before",
             "At cutoff", "1 min after", "3 mins after", "5 mins after", "15 mins after", "20 mins after")

plots <- list()

for (i in 1:length(cutoff_diffs)) {
  cutoff_range <- range(df_rdd66$running_var2)
  
  rd <- rdplot(df_rdd66$cabap, df_rdd66$running_var2,
               covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
               x.lim = cutoff_range,
               x.lab = "Time difference from cutoff (mins)",
               y.lab = "Cabinet approval",
               title = titles[i],
               c = cutoff_diffs[i])
  
  p <- rd$rdplot + theme_igray()
  
  plots[[i]] <- rd$rdplot
}

ordered_plots1 <- list(
  plots[[1]], plots[[2]],  
  plots[[3]]
)


ordered_plots2 <- list(
  plots[[4]], 
  plots[[5]], plots[[6]],  
  plots[[6]], plots[[7]], 
  plots[[8]], plots[[9]]
)

grid.arrange(grobs = ordered_plots1, ncol =3)

grid.arrange(grobs = ordered_plots2, ncol = 4)

Figure E.11: Gradually shifting the cutoff (Before the second gold medal) does not alter the null results for cabinet approval to Japanese government

Figure E.12: Gradually shifting the cutoff (After the second gold medal) does not alter the null results for feeling thermometer to Japanese government

for (i in 1:length(cutoff_diffs)) {
  cutoff_range <- range(df_rdd66$running_var2)
  
  rd <- rdplot(df_rdd66$ftj, df_rdd66$running_var2,
               covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
               x.lim = cutoff_range,
               x.lab = "Time difference from cutoff (mins)",
               y.lab = "Feeling thermometer",
               title = titles[i],
               c = cutoff_diffs[i])
  
  p <- rd$rdplot + theme_igray()
  
  plots[[i]] <- rd$rdplot
}

ordered_plots1 <- list(
  plots[[1]], plots[[2]],  
  plots[[3]]
)


ordered_plots2 <- list(
  plots[[4]], 
  plots[[5]], plots[[6]],  
  plots[[6]], plots[[7]], 
  plots[[8]], plots[[9]]
)

grid.arrange(grobs = ordered_plots1, ncol =3)

grid.arrange(grobs = ordered_plots2, ncol = 4)

E.5 Time trends

Table E.12: The falsification test using the placebo treatment (the median cutoff point of the control group) also detects a null effect on cabinet approval (the first gold medal case)

Table E.13: The falsification test using the placebo treatment (the median cutoff point of the control group) also detects a null effect on feeling thermometer (the first gold medal case) (the first gold medal case)

df_rdd48_left <- df_rdd48 |> dplyr::filter(running_var < 0)
median_point  <- median(df_rdd48_left$running_var, na.rm = TRUE)
df_rdd48_left <- df_rdd48_left |>
  dplyr::mutate(
    placebo_treatment = as.integer(running_var >= median_point),
    running_var = running_var - median_point
  )

fit_set <- function(y){
  f1 <- reformulate(c("placebo_treatment","running_var",
                      "placebo_treatment:running_var","I(running_var^2)"), response = y)
  f2 <- reformulate(c("placebo_treatment","running_var",
                      "placebo_treatment:running_var"), response = y)
  f3 <- reformulate(c("running_var","I(running_var^2)"), response = y)
  f4 <- reformulate(c("running_var","placebo_treatment","I(running_var^2)"), response = y)
  list(
    m1 = lm(f1, data = df_rdd48_left),
    m2 = lm(f2, data = df_rdd48_left),
    m3 = lm(f3, data = df_rdd48_left),
    m4 = lm(f4, data = df_rdd48_left)
  )
}
mods_cab <- fit_set("cabap")
mods_ftj <- fit_set("ftj")

star_p <- function(p){
  if (is.na(p)) "" else if (p < 0.001) "***" else if (p < 0.01) "**" else if (p < 0.05) "*" else ""
}
coef_cell <- function(est, se, p, for_latex = knitr::is_latex_output()){
  est_txt <- sprintf("%.3f%s", est, star_p(p))
  se_txt  <- sprintf("(%.3f)", se)
  if (for_latex) paste0(est_txt, " \\\\ \n", se_txt) else paste0(est_txt, "<br>", se_txt)
}

var_order  <- c("placebo_treatment",
                "running_var",
                "I(running_var^2)",
                "placebo_treatment:running_var",
                "(Intercept)")
var_labels <- c("Placebo treatment",
                "Times",
                "Times^2",
                "Placebo treatment×Times","Constant")

f_value <- function(m) unname(summary(m)$fstatistic["value"])
f_numdf <- function(m) unname(summary(m)$fstatistic["numdf"])
f_dendf <- function(m) unname(summary(m)$fstatistic["dendf"])

Placebo RDD (Left of cutoff): Regression Results

	Dependent variable: Cabinet approval
	Model 1	Model 2	Model 3	Model 4
Placebo treatment	-0.001 (0.075)	-0.007 (0.074)		0.022 (0.073)
Times	0.023 (0.019)	0.016 (0.018)	0.000 (0.005)	-0.002 (0.010)
Times^2	0.001 (0.001)		-0.001 (0.001)	-0.001 (0.001)
Placebo treatment×Times	-0.044 (0.028)	-0.028 (0.020)
Constant	0.287*** (0.064)	0.278*** (0.064)	0.242*** (0.020)	0.228*** (0.047)
Observations	558	558	558	558
\(R^2\)	0.006	0.005	0.001	0.002
Adjusted \(R^2\)	-0.002	-0.001	-0.002	-0.004
Residual Std. Error	0.423	0.423	0.424	0.424
	(df = 553)	(df = 554)	(df = 555)	(df = 554)
\(F\) Statistic	0.775	0.851	0.382	0.290
	(df = 4; 553)	(df = 3; 554)	(df = 2; 555)	(df = 3; 554)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Placebo RDD (Left of cutoff): Regression Results

	Dependent variable: Feeling thermometer
	Model 1	Model 2	Model 3	Model 4
Placebo treatment	0.209 (4.499)	0.431 (4.458)		0.506 (4.311)
Times	0.096 (1.166)	0.349 (1.113)	-0.158 (0.330)	-0.219 (0.611)
Times^2	-0.037 (0.048)		-0.058 (0.033)	-0.055 (0.041)
Placebo treatment×Times	-0.556 (1.618)	-1.184 (1.234)
Constant	41.445*** (3.950)	41.779*** (3.919)	41.015*** (1.212)	40.709*** (2.939)
Observations	558	558	558	558
\(R^2\)	0.005	0.005	0.005	0.005
Adjusted \(R^2\)	-0.002	-0.001	0.001	-0.001
Residual Std. Error	26.624	26.605	26.578	26.602
	(df = 553)	(df = 554)	(df = 555)	(df = 554)
\(F\) Statistic	0.682	0.844	1.316	0.881
	(df = 4; 553)	(df = 3; 554)	(df = 2; 555)	(df = 3; 554)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.14: The falsification test using the placebo treatment (the median cutoff point of the control group) also detects a null effect on cabinet approval (the second gold medal case)

Table E.15: The falsification test using the placebo treatment (the median cutoff point of the control group) also detects a null effect on feeling thermometer (the second gold medal case)

df_rdd66_left <- df_rdd66 |> dplyr::filter(running_var < 0)
median_point  <- median(df_rdd66_left$running_var, na.rm = TRUE)
df_rdd66_left <- df_rdd66_left |>
  dplyr::mutate(
    placebo_treatment = as.integer(running_var >= median_point),
    running_var = running_var - median_point
  )

fit_set <- function(y){
  f1 <- reformulate(c("placebo_treatment","running_var",
                      "placebo_treatment:running_var","I(running_var^2)"), response = y)
  f2 <- reformulate(c("placebo_treatment","running_var",
                      "placebo_treatment:running_var"), response = y)
  f3 <- reformulate(c("running_var","I(running_var^2)"), response = y)
  f4 <- reformulate(c("running_var","placebo_treatment","I(running_var^2)"), response = y)
  list(
    m1 = lm(f1, data = df_rdd66_left),
    m2 = lm(f2, data = df_rdd66_left),
    m3 = lm(f3, data = df_rdd66_left),
    m4 = lm(f4, data = df_rdd66_left)
  )
}
mods_cab <- fit_set("cabap")
mods_ftj <- fit_set("ftj")

star_p <- function(p){
  if (is.na(p)) "" else if (p < 0.001) "***" else if (p < 0.01) "**" else if (p < 0.05) "*" else ""
}
coef_cell <- function(est, se, p, for_latex = knitr::is_latex_output()){
  est_txt <- sprintf("%.3f%s", est, star_p(p))
  se_txt  <- sprintf("(%.3f)", se)
  if (for_latex) paste0(est_txt, " \\\\ \n", se_txt) else paste0(est_txt, "<br>", se_txt)
}

var_order  <- c("placebo_treatment",
                "running_var",
                "I(running_var^2)",
                "placebo_treatment:running_var","(Intercept)")
var_labels <- c("Placebo treatment",
                "Times",
                "Times^2",
                "Placebo treatment×Times","Constant")

f_value <- function(m) unname(summary(m)$fstatistic["value"])
f_numdf <- function(m) unname(summary(m)$fstatistic["numdf"])
f_dendf <- function(m) unname(summary(m)$fstatistic["dendf"])

Placebo RDD (Left of cutoff): Regression Results

	Model 1	Model 2	Model 3	Model 4
Placebo treatment	-0.121 (0.147)	0.028 (0.106)		0.068 (0.102)
Times	0.193 (0.128)	0.020 (0.035)	-0.011 (0.012)	-0.024 (0.022)
Times^2	0.031 (0.023)		-0.006 (0.005)	-0.006 (0.005)
Placebo treatment×Times	-0.335 (0.201)	-0.070 (0.045)
Constant	0.408** (0.155)	0.234** (0.089)	0.220*** (0.037)	0.179* (0.072)
Observations	226	226	226	226
\(R^2\)	0.024	0.015	0.009	0.011
Adjusted \(R^2\)	0.006	0.002	-0.000	-0.002
Residual Std. Error	0.392	0.393	0.393	0.394
	(df = 221)	(df = 222)	(df = 223)	(df = 222)
\(F\) Statistic	1.361	1.160	0.966	0.819
	(df = 4; 221)	(df = 3; 222)	(df = 2; 223)	(df = 3; 222)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Placebo RDD (Left of cutoff): Regression Results

	Model 1	Model 2	Model 3	Model 4
Placebo treatment	-11.546 (9.439)	4.494 (5.961)		3.583 (5.711)
Times	16.103 (8.183)	-2.412 (1.972)	-0.537 (0.777)	-1.211 (1.299)
Times^2	3.360* (1.457)		0.353 (0.305)	0.356 (0.304)
Placebo treatment×Times	-26.793* (12.407)	1.690 (2.603)
Constant	53.675*** (9.501)	34.951*** (5.005)	37.482*** (2.191)	35.328*** (4.065)
Observations	226	226	226	226
\(R^2\)	0.033	0.008	0.010	0.012
Adjusted \(R^2\)	0.016	-0.006	0.001	-0.001
Residual Std. Error	24.463	24.725	24.641	24.675
	(df = 221)	(df = 222)	(df = 223)	(df = 222)
\(F\) Statistic	1.896	0.587	1.152	0.891
	(df = 4; 221)	(df = 3; 222)	(df = 2; 223)	(df = 3; 222)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.16: Dickey-Fuller Test and Fractional Integration d-value suggest both before and after series are stationary and have no trends

df_before_cutoff <- df_rdd48 |>
  filter(StartDate < cutoff_time)

df_after_cutoff <- df_rdd48 |>
  filter(StartDate >= cutoff_time)


cabap_before <- df_before_cutoff$cabap
ftj_before <- df_before_cutoff$ftj

# ADF）
adf_cabap_before <- adf.test(cabap_before)
adf_ftj_before <- adf.test(ftj_before)

# fdGPH
fdgph_cabap_before <- fdGPH(cabap_before)
fdgph_ftj_before <- fdGPH(ftj_before)

dickey_fuller_cabap <- adf_cabap_before$statistic
dickey_fuller_ftj <- adf_ftj_before$statistic
lag_order_cabap <- adf_cabap_before$parameter
lag_order_ftj <- adf_ftj_before$parameter
p_value_cabap <- adf_cabap_before$p.value
p_value_ftj <- adf_ftj_before$p.value

d_cabap <- fdgph_cabap_before$d
sd_as_cabap <- fdgph_cabap_before$sd.as
sd_reg_cabap <- fdgph_cabap_before$sd.reg

d_ftj <- fdgph_ftj_before$d
sd_as_ftj <- fdgph_ftj_before$sd.as
sd_reg_ftj <- fdgph_ftj_before$sd.reg


results_df <- data.frame(
  Test = c("ADF Test (cabap)", "ADF Test (ftj)", "fdGPH (cabap)", "fdGPH (ftj)"),
  `Dickey-Fuller / d` = c(dickey_fuller_cabap, dickey_fuller_ftj, d_cabap, d_ftj),
  `Lag Order / sd.as` = c(lag_order_cabap, lag_order_ftj, sd_as_cabap, sd_as_ftj),
  `p-value / sd.reg` = c(p_value_cabap, p_value_ftj, sd_reg_cabap, sd_reg_ftj)
)

Dickey-Fuller Test and Fractional Integration (fdGPH)

Test	Dickey-Fuller & FI d-value	Lag.Order / sd.as	p-value (ADF) / sd.reg (FI)
ADF Test (cabap)	-8.382	8.000	0.010
ADF Test (ftj)	-8.529	8.000	0.010
fdGPH (cabap)	-0.057	0.166	0.176
fdGPH (ftj)	-0.263	0.166	0.189
ADF: null is a unit root (non-stationary). FI (GPH): series is typically treated as stationary when d < 0.5.

Dickey-Fuller Test and Fractional Integration (fdGPH)

Test	Dickey-Fuller & FI d-value	Lag.Order / sd.as	p-value (ADF) / sd.reg (FI)
ADF Test (cabap)	-6.045	6.000	0.010
ADF Test (ftj)	-4.433	6.000	0.010
fdGPH (cabap)	0.027	0.220	0.183
fdGPH (ftj)	0.101	0.220	0.215
ADF: null is a unit root (non-stationary). FI (GPH): series is typically treated as stationary when d < 0.5.

E.6 Placebo tests: Different dataset of the other event

Setting variables for the first gold medal

opening <- read.csv("opening.csv") |>
  mutate(
    RecordedDate = as.POSIXct(RecordedDate, format = "%Y/%m/%d %H:%M", tz = "Asia/Tokyo")
  )

cutoff_time <- as.POSIXct("2024/07/26 11:30", format = "%Y/%m/%d %H:%M", tz = "Asia/Tokyo")

opening_proc <- opening |>
  mutate(
    cutoff      = as.integer(RecordedDate >= cutoff_time),
    running_var = as.numeric(difftime(RecordedDate, cutoff_time, units = "mins")),
    running_var2 = running_var + rnorm(n(), mean = 0, sd = 0.01),
    
    exposure = case_when(
      Q5 %in% c(1, 2) ~ 1,
      Q5 %in% c(3, 4) ~ 0,
      TRUE            ~ NA_real_
    ),
    
   
    cabap = case_when(
      Q1 == 1 ~ 1,
      Q1 == 2 ~ 0,
      Q1 == 3 ~ NA_real_,
      TRUE    ~ NA_real_
    ),
    ftj = Q3_11,
    

    busi = case_when(
      Q7_1 == 1 ~ 5,
      Q7_1 == 2 ~ 4,
      Q7_1 == 4 ~ 2,
      Q7_1 == 5 ~ 1,
      TRUE      ~ 3
    ),
    liv = case_when(
      Q7_2 == 1 ~ 5,
      Q7_2 == 2 ~ 4,
      Q7_2 == 4 ~ 2,
      Q7_2 == 5 ~ 1,
      TRUE      ~ 3
    ),
    
    psu_rul = case_when(
      Q2 %in% c(14, 15) ~ NA_real_,
      Q2 %in% c(1, 4)   ~ 1,
      TRUE              ~ 0
    ),
    
    age = Age,
    
    female = case_when(      
      Gender == 2 ~ 1,
      Gender == 1 ~ 0,
      Gender == 3 ~ NA_real_,
      TRUE        ~ NA_real_
    ),
    
    education = na_if(Q9, 5),  
    
    income = case_when(        
      Q10 %in% c(15, 16) ~ NA_real_,
      TRUE               ~ as.numeric(Q10)
    )
  )


df_rddop <- opening_proc |>
  dplyr::select(StartDate,
    RecordedDate, cutoff, running_var, running_var2,
    cabap, ftj, busi, liv,
    exposure, psu_rul,
    age, female, education, income
  )

dim(df_rddop)

## [1] 843  15

Cumlative density

data_cum <- opening_proc |>
  arrange(RecordedDate) |>
  mutate(CumulativeCount = row_number())

vline_time <- cutoff_time 

p_cum <- ggplot(data_cum, aes(x = RecordedDate, y = CumulativeCount)) +
  geom_line() +
  geom_point() +
  geom_vline(xintercept = as.numeric(vline_time), linetype = "dashed", color = "red") +
  annotate("text",
           x = vline_time,
           y = max(data_cum$CumulativeCount),
           label = "ceremony\nstart",
           angle = 90, vjust = -0.5, hjust = 1.1, size = 3) +
  labs(title = "Cumulative Data Collection Over Time",
       x = "Recorded Date",
       y = "Cumulative Count") +
  theme_igray() +
  scale_x_datetime(date_labels = "%m/%d %H:%M")

print(p_cum)

milestones <- c(50, 100, 150, 200, 250, 300)

milestone_df <- data_cum |>
  filter(CumulativeCount %in% milestones) |>
  transmute(
    Milestone       = CumulativeCount,
    TimeReached     = RecordedDate
  ) |>
  mutate(
    MinutesFromStart = as.numeric(difftime(TimeReached, first(data_cum$RecordedDate), units = "mins"))
  )

print(milestone_df)

##   Milestone         TimeReached MinutesFromStart
## 1        50 2024-07-26 07:07:00               93
## 2       100 2024-07-26 08:51:00              197
## 3       150 2024-07-26 12:39:00              425
## 4       200 2024-07-26 15:32:00              598
## 5       250 2024-07-26 16:20:00              646
## 6       300 2024-07-26 16:55:00              681

Balance check

df_balance <- df_rddop |>
  transmute(
    cutoff    = cutoff,    
    Age       = age,      
    Female    = female,     
    Education = education,       
    Income    = income,       
    Inpartisans   = psu_rul    
  ) |>
  drop_na()

df_balance <- df_balance |>
  mutate(
    cutoff = factor(cutoff, levels = c(0, 1), labels = c("Before", "After"))
  )

vtable::sumtable(
  df_balance,
  group = "cutoff",     
  group.test = TRUE     
)

Summary Statistics

cutoff	Before			After
Variable	N	Mean	SD	N	Mean	SD	Test
Age	92	49	15	490	52	15	F=2.682
Female	92	0.4	0.49	490	0.42	0.49	F=0.158
Education	92	3.4	0.83	490	3.2	0.92	F=5.901**
Income	92	7.1	3.4	490	7	3.2	F=0.089
Inpartisans	92	0.35	0.48	490	0.29	0.45	F=1.434
Statistical significance markers: * p<0.1; ** p<0.05; *** p<0.01

Balance Table by Cutoff (Before vs After)

	Before		After		Stat
Variable	Mean	SD	Mean	SD	Test	p-value
Age	48.40	15.10	50.96	15.56	t=1.82	0.071
Female	0.46	0.50	0.48	0.50	z=0.37	0.712
Education	3.34	0.87	3.13	0.93	t=-2.57	0.011
Income	7.07	3.28	6.88	3.20	t=-0.56	0.575
In-partisans	0.30	0.46	0.29	0.45	z=-0.19	0.848

Figure E.13: No significant mean difference is found, the opening ceremony

if (!"cutoff_f" %in% names(df_rddop)) {
  df_rddop <- df_rddop |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("before","after")))
}

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else "n.s."
}

summ_ci <- function(df, var){
  df |>
    group_by(cutoff_f) |>
    summarise(
      n     = sum(!is.na(.data[[var]])),
      mean  = mean(.data[[var]], na.rm = TRUE),
      sd    = sd(.data[[var]],   na.rm = TRUE),
      se    = sd / sqrt(n),
      tcrit = qt(0.975, df = pmax(n - 1, 1)),
      lo95  = mean - tcrit * se,
      up95  = mean + tcrit * se,
      .groups = "drop"
    )
}

make_mean_plot_cont <- function(df, var, main_title, ylab = "Mean") {
  
  s <- summ_ci(df, var)
  t_out <- t.test(df[[var]] ~ df$cutoff_f)
  pval  <- t_out$p.value
  stars <- p_to_stars(pval)
  
  ymax  <- max(s$up95, na.rm = TRUE)
  y_sig <- ymax + 0.05 * max(1, ymax)
  y_txt <- ymax + 0.10 * max(1, ymax)
  
  ggplot(s, aes(x = cutoff_f, y = mean)) +
    geom_bar(stat = "identity", width = 0.6, fill = "grey70", color = "grey20") +
    geom_errorbar(aes(ymin = lo95, ymax = up95), width = 0.15) +
    geom_text(aes(label = sprintf("%.2f\n[%.2f, %.2f]", mean, lo95, up95)),
              vjust = -1.1, size = 3) +
    ggsignif::geom_signif(
      comparisons = list(c("before","after")),
      annotations = stars,
      y_position  = y_sig,
      tip_length  = 0,
      textsize    = 4.2
    ) +
    annotate("text", x = 1.5, y = y_txt,
             label = paste0("Welch's t-test p = ", signif(pval, 3)),
             size = 4.2) +
    ggthemes::theme_igray() +
    labs(title = main_title, x = "Control/Treatment", y = ylab) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.18))) +
    theme(plot.title = element_text(size = 10),
          axis.title.x = element_text(margin = margin(t = 6)))
}

p_cabap <- make_mean_plot_cont(df_rddop, "cabap",
                               "Cabinet approval (mean; 95% CI)",
                               ylab = "Mean Cabinet Approval")
p_ftj   <- make_mean_plot_cont(df_rddop, "ftj",
                               "Feeling thermometer (mean; 95% CI)",
                               ylab = "Mean Feeling Thermometer")


grid.arrange(p_cabap, p_ftj, ncol = 2)

Figure E.14: No significant effect differences occurred near the cutoff, opening ceremony

covariates <- cbind(df_rddop$age, df_rddop$female, df_rddop$income, df_rddop$education,
                    df_rddop$psu_rul)

results_judorakuten <- list()

outcome_vars <- c("cabap", "ftj")
outcome_prefix <- c("c", "f")

for (i in 1:length(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix <- outcome_prefix[i]
  
  safe_rdrobust <- function(..., prefix_suffix) {
    tryCatch({
      rdrobust(..., all = TRUE)
    }, error = function(e) {
      message(paste0("Error in ", prefix_suffix, ": ", e$message))
      NULL
    })
  }
  
  results_judorakuten[[paste0("res1", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "mserd", prefix_suffix = paste0("res1", prefix))
  results_judorakuten[[paste0("res2", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "msesum", prefix_suffix = paste0("res2", prefix))
  results_judorakuten[[paste0("res3", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", prefix_suffix = paste0("res3", prefix))
  results_judorakuten[[paste0("res4", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "mserd", kernel = "uni", prefix_suffix = paste0("res4", prefix))
  results_judorakuten[[paste0("res5", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "cerrd", prefix_suffix = paste0("res5", prefix))
  results_judorakuten[[paste0("res6", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "mserd", q = 2, kernel = "triangular", prefix_suffix = paste0("res6", prefix))
  results_judorakuten[[paste0("res7", prefix)]] <- safe_rdrobust(df_rddop[[outcome_var]], df_rddop$running_var2, covs = covariates, bwselect = "mserd", kernel = "triangular", p = 2, q = 3, prefix_suffix = paste0("res7", prefix))
}


p1 <- rdplot(df_rddop$cabap, df_rddop$running_var2,
             covs = cbind(df_rddop$age, df_rddop$female, df_rddop$income, df_rddop$education, df_rddop$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Cabinet approval",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0,
             ci = 95) 

p2 <- rdplot(df_rddop$ftj, df_rddop$running_var2,
             covs = cbind(df_rddop$age, df_rddop$female, df_rddop$income, df_rddop$education, df_rddop$psu_rul),
             x.lim = cutoff_range, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Japanese government",
             title = "Cutoff: The Gold medal confiramtion of women's Judo 48kg",
             c = 0,
             ci = 95) 

grid.arrange(p1$rdplot, p2$rdplot, ncol = 1)

Figure E.15: Gradually shifting the cutoff does not alter the null effect of the opening ceremony for cabinet approval (Before opening ceremony)

df_rddop <- df_rddop |>
  mutate(running_var = as.numeric(difftime(StartDate, cutoff_time, units = "mins")))

cutoff_diffs <- c(-20, -15, -5, -3, -1, 0, 1, 3, 5, 15, 20)
titles <- c("20 mins before", "15 mins before", "5 mins before", "3 mins before", "1 min before",
            "At cutoff", "1 min after", "3 mins after", "5 mins after", "15 mins after", "20 mins after")

plots <- list()

for (i in 1:length(cutoff_diffs)) {
  cutoff_range <- range(df_rddop$running_var)
  
  rd <- rdplot(df_rddop$cabap, df_rddop$running_var,
               covs = cbind(df_rddop$age, df_rddop$female, df_rddop$income, df_rddop$education, df_rddop$psu_rul),
               x.lim = cutoff_range,
               x.lab = "Time difference from cutoff (mins)",
               y.lab = "Cabinet approval",
               title = titles[i],
               c = cutoff_diffs[i])
  
  p <- rd$rdplot + theme_igray()
  
  plots[[i]] <- rd$rdplot
}

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

## [1] "Mass points detected in the running variable."

ordered_plots1 <- list(
  plots[[1]], plots[[2]],  # "At cutoff" 
  plots[[3]], plots[[4]],  # 20 mins before, 1 min after
  plots[[5]], plots[[6]]
)# 15 mins before, 3 mins after

ordered_plots2 <- list(
  plots[[6]], plots[[7]],  # 5 mins before, 5 mins after
  plots[[8]], plots[[9]], # 3 mins before, 15 mins after
  plots[[10]], plots[[11]]  # 1 min before, 20 mins after
)


grid.arrange(grobs = ordered_plots1, ncol = 3)

grid.arrange(grobs = ordered_plots1, ncol = 3)

E.7 Placebo tests: Other outcome variables

Figure E.19: Even when we use other outcome variables, the ATE for the first gold medal is still null (t-test)

if (!"cutoff_f" %in% names(df_rdd48)) {
  df_rdd48 <- df_rdd48 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("before","after")))
}

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else if (p < 0.10)  "†" 
  else "n.s."
}

summ_ci <- function(df, var){
  df |>
    group_by(cutoff_f) |>
    summarise(
      n     = sum(!is.na(.data[[var]])),
      mean  = mean(.data[[var]], na.rm = TRUE),
      sd    = sd(.data[[var]],   na.rm = TRUE),
      se    = sd / sqrt(n),
      tcrit = qt(0.975, df = pmax(n - 1, 1)),
      lo95  = mean - tcrit * se,
      up95  = mean + tcrit * se,
      .groups = "drop"
    )
}

make_mean_plot_cont <- function(df, var, main_title, ylab = "Mean") {
  
  s <- summ_ci(df, var)
  t_out <- t.test(df[[var]] ~ df$cutoff_f)
  pval  <- t_out$p.value
  stars <- p_to_stars(pval)
  
  ymax  <- max(s$up95, na.rm = TRUE)
  y_sig <- ymax + 0.05 * max(1, ymax)
  y_txt <- ymax + 0.10 * max(1, ymax)
  
  ggplot(s, aes(x = cutoff_f, y = mean)) +
    geom_bar(stat = "identity", width = 0.6, fill = "grey70", color = "grey20") +
    geom_errorbar(aes(ymin = lo95, ymax = up95), width = 0.15) +
    geom_text(aes(label = sprintf("%.2f\n[%.2f, %.2f]", mean, lo95, up95)),
              vjust = -1.1, size = 3) +
    ggsignif::geom_signif(
      comparisons = list(c("before","after")),
      annotations = stars,
      y_position  = y_sig,
      tip_length  = 0,
      textsize    = 4.2
    ) +
    annotate("text", x = 1.5, y = y_txt,
             label = paste0("Welch's t-test p = ", signif(pval, 3)),
             size = 4.2) +
    ggthemes::theme_igray() +
    labs(title = main_title, x = "Control/Treatment", y = ylab) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.18))) +
    theme(plot.title = element_text(size = 10),
          axis.title.x = element_text(margin = margin(t = 6)))
}

p_cabap <- make_mean_plot_cont(df_rdd48, "cabap",
                               "Cabinet approval (mean; 95% CI)",
                               ylab = "Mean Cabinet Approval")
p_ftj   <- make_mean_plot_cont(df_rdd48, "ftj",
                               "Feeling thermometer (mean; 95% CI)",
                               ylab = "Mean Feeling Thermometer")

grid.arrange(p_cabap, p_ftj, ncol = 2)

Figure E.20: Even when we use other outcome variables, the ATE for the second gold medal is still null (t-test)

if (!"cutoff_f" %in% names(df_rdd66)) {
  df_rdd66 <- df_rdd66 |>
    mutate(cutoff_f = factor(cutoff, levels = c(0,1),
                             labels = c("before","after")))
}

p_to_stars <- function(p){
  if (is.na(p)) "n.s."
  else if (p < 0.001) "***"
  else if (p < 0.01)  "**"
  else if (p < 0.05)  "*"
  else "n.s."
}


make_mean_plot_cont <- function(df, var, main_title, ylab = "Mean") {
  summ <- df |>
    group_by(cutoff_f) |>
    summarise(mean_y = mean(.data[[var]], na.rm = TRUE), .groups = "drop")
  
  t_out <- t.test(df[[var]] ~ df$cutoff_f)
  pval  <- t_out$p.value
  stars <- p_to_stars(pval)
  
  ymax <- max(summ$mean_y, na.rm = TRUE)
  y_sig <- ymax + 0.02 * max(1, ymax)      
  y_txt <- ymax + 0.04 * max(1, ymax)
  
  ggplot(summ, aes(x = cutoff_f, y = mean_y)) +
    geom_bar(stat = "identity", fill = "gray") +
    ggsignif::geom_signif(
      comparisons = list(c("before","after")),
      annotations = stars,
      y_position  = y_sig,
      tip_length  = 0,
      textsize    = 5
    ) +
    ggthemes::theme_igray() +
    labs(title = main_title, x = "Cutoff", y = ylab) +
    annotate("text", x = 1.5, y = y_txt,
             label = paste("p =", signif(pval, 3)), size = 5) +
    scale_y_continuous(expand = expansion(mult = c(0.02, 0.15))) +
    theme(plot.title = element_text(size = 10))
}

outcome_vars <- c("ftl", "ftki", "busi", "liv")
plot_titles  <- c(
  "Mean of feeling thermometer to the LDP",
  "Mean of feeling thermometer to the PM",
  "Mean of sociotropic evaluation",
  "Mean of egotropic evaluation"
)

plots <- Map(function(v, ttl) make_mean_plot_cont(judo66p, v, ttl),
             outcome_vars, plot_titles)


grid.arrange(grobs = plots, ncol = 2)

grid.arrange(p_cabap, p_ftj, ncol = 2)

Table E.19: Even when we use other outcome variables, the ATE for the first gold medal is still null in almost all specifications (OLS)

form_ftl  <- ftl  ~ cutoff + age + female + income + education + psu_rul
form_ftki <- ftki ~ cutoff + age + female + income + education + psu_rul
form_busi <- busi ~ cutoff + age + female + income + education + psu_rul
form_liv  <- liv  ~ cutoff + age + female + income + education + psu_rul

m1 <- lm(form_ftl,  data = df_rdd48)  
m2 <- lm(form_ftki, data = df_rdd48)  # FT to PM Kishida
m3 <- lm(form_busi, data = df_rdd48)  # Sociotropic
m4 <- lm(form_liv,  data = df_rdd48)  # Egotropic

OLS results with robust (HC1) SE

	Dependent variable:
	FT to the LDP	FT to PM Kishida	Sociotropic	Egotropic
Treatment(Before=0; After=1)	0.237 (2.010)	1.394 (2.226)	0.268** (0.082)	-0.070 (0.102)
Age	-0.025 (0.056)	-0.071 (0.064)	0.004 (0.002)	-0.008** (0.003)
Female(Female=1; Male=0)	-2.899 (1.676)	1.397 (1.856)	-0.185** (0.069)	0.098 (0.088)
Income(20-scales)	0.005 (0.270)	-0.267 (0.290)	0.030** (0.011)	0.006 (0.013)
Education(4-scales)	-0.244 (0.905)	0.485 (1.028)	0.073 (0.039)	0.054 (0.045)
Ruling party support(In-partisans=1; Otherwise=0)	35.956*** (1.676)	25.960*** (1.976)	0.407*** (0.073)	-0.291*** (0.082)
Constant	27.079*** (4.732)	22.286*** (5.530)	1.570*** (0.202)	2.356*** (0.220)
Observations	740	740	740	740
\(R^2\)	0.386	0.218	0.093	0.039
Adjusted \(R^2\)	0.381	0.211	0.086	0.031
Residual Std. Error	21.117	22.856	0.875	1.057
	(df = 733)	(df = 733)	(df = 733)	(df = 733)
\(F\) Statistic	76.768	33.962	12.559	4.977
	(df = 6; 733)	(df = 6; 733)	(df = 6; 733)	(df = 6; 733)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.20: : Even when we use other outcome variables, the ATE for the second gold medal is still null in almost all specifications (OLS

form_ftl  <- ftl  ~ cutoff + age + female + income + education + psu_rul
form_ftki <- ftki ~ cutoff + age + female + income + education + psu_rul
form_busi <- busi ~ cutoff + age + female + income + education + psu_rul
form_liv  <- liv  ~ cutoff + age + female + income + education + psu_rul

m1 <- lm(form_ftl,  data = df_rdd66)  
m2 <- lm(form_ftki, data = df_rdd66) 
m3 <- lm(form_busi, data = df_rdd66) 
m4 <- lm(form_liv,  data = df_rdd66)  

OLS results with robust (HC1) SE

	Dependent variable:
	FT to the LDP	FT to PM Kishida	Sociotropic	Egotropic
Constant	22.078*** (3.653)	19.433*** (3.945)	2.826*** (0.186)	2.519*** (0.167)
Treatment(Before=0; After=1)	0.564 (1.718)	2.449 (1.838)	0.114 (0.084)	0.062 (0.083)
Age	0.007 (0.051)	-0.011 (0.054)	-0.009*** (0.003)	-0.008** (0.002)
Female(Female=1; Male=0)	-0.099 (1.649)	0.966 (1.736)	-0.155 (0.080)	-0.085 (0.081)
Income(20-scales)	-0.064 (0.245)	-0.420 (0.269)	-0.000 (0.013)	0.014 (0.013)
Education(4-scales)	-0.033 (0.075)	-0.016 (0.050)	-0.001 (0.001)	-0.000 (0.001)
Ruling party support(In-partisans=1; Otherwise=0)	34.115*** (1.680)	26.772*** (1.947)	-0.384*** (0.080)	-0.370*** (0.081)
Observations	712	712	712	712
\(R^2\)	0.363	0.240	0.051	0.040
Adjusted \(R^2\)	0.357	0.234	0.043	0.032
Residual Std. Error	21.338	22.589	1.039	1.053
	(df = 705)	(df = 705)	(df = 705)	(df = 705)
\(F\) Statistic	66.837	37.120	6.366	4.944
	(df = 6; 705)	(df = 6; 705)	(df = 6; 705)	(df = 6; 705)
✱ Signif. codes: * p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.21: Using different outcome variables, the null result for the first gold medal is maintained (RDD)

covariates <- cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul)

results_judo48p <- list()
outcome_vars    <- c("ftl", "ftki", "busi", "liv")
outcome_prefix  <- c("fl",  "fk",   "bs",   "lv")

for (i in seq_along(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix      <- outcome_prefix[i]

  results_judo48p[[paste0("res2", prefix)]] <- rdrobust(df_rdd48[[outcome_var]],
                                                        df_rdd48$running_var2, 
                                                        covs = covariates,
                                                        bwselect = "msesum", all = TRUE)
  results_judo48p[[paste0("res3", prefix)]] <- rdrobust(df_rdd48[[outcome_var]], 
                                                        df_rdd48$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "mserd", kernel = "triangular", all = TRUE)
  results_judo48p[[paste0("res4", prefix)]] <- rdrobust(df_rdd48[[outcome_var]], 
                                                        df_rdd48$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "mserd", kernel = "uni", all = TRUE)
  results_judo48p[[paste0("res5", prefix)]] <- rdrobust(df_rdd48[[outcome_var]], 
                                                        df_rdd48$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "cerrd", all = TRUE)
}

source("process_results_rdd.R")

result_sets <- list(
  "Feeling thermometer to the LDP" = c("res2fl","res3fl","res4fl","res5fl"),
  "Feeling thermometer to the PM"  = c("res2fk","res3fk","res4fk","res5fk"),
  "Sociotropic economic evaluation"= c("res2bs","res3bs","res4bs","res5bs"),
  "Egotropic economic evaluation"  = c("res2lv","res3lv","res4lv","res5lv")
)

The first gold medal	4.063	4.068	-0.320	6.594
Robust 95% CI	[-10.779, 18.905]	[-10.779, 18.916]	[-12.977, 12.336]	[-11.661, 24.849]
Robust \(p\)-value	0.592	0.591	0.960	0.479
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	43.547	43.5	49.202	31.263
BW bias (\(b\))	76.445	76.438	105.055	76.438
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	3.101	2.957	2.335	4.605
Robust 95% CI	[-11.092, 17.293]	[-11.177, 17.091]	[-11.454, 16.124]	[-10.327, 19.537]
Robust \(p\)-value	0.668	0.682	0.740	0.546
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	63.347	65.745	45.418	47.25
BW bias (\(b\))	90.092	90.084	111.822	90.084
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	-0.164	-0.163	-0.215	-0.166
Robust 95% CI	[-0.789, 0.462]	[-0.785, 0.460]	[-0.806, 0.375]	[-0.818, 0.486]
Robust \(p\)-value	0.608	0.608	0.475	0.618
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	110.728	114.652	61.94	82.399
BW bias (\(b\))	112.924	112.923	103.757	112.923
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	-0.525	-0.525	-0.488	-0.523
Robust 95% CI	[-1.043, -0.007]	[-1.041, -0.008]	[-1.030, 0.055]	[-1.041, -0.005]
Robust \(p\)-value	0.047	0.046	0.078	0.048
Observations	740	740	740	740
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	97.74	124.68	54.203	89.606
BW bias (\(b\))	137.791	137.787	112.109	137.787
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Table E.22: Using different outcome variables, the null result for the second gold medal is maintained (RDD)

covariates <- cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul)

results_judo66p <- list()
outcome_vars    <- c("ftl", "ftki", "busi", "liv")
outcome_prefix  <- c("fl",  "fk",   "bs",   "lv")

for (i in seq_along(outcome_vars)) {
  outcome_var <- outcome_vars[i]
  prefix      <- outcome_prefix[i]

  results_judo66p[[paste0("res2", prefix)]] <- rdrobust(df_rdd66[[outcome_var]],
                                                        df_rdd66$running_var2, 
                                                        covs = covariates,
                                                        bwselect = "msesum", all = TRUE)
  results_judo66p[[paste0("res3", prefix)]] <- rdrobust(df_rdd66[[outcome_var]], 
                                                        df_rdd66$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "mserd", kernel = "triangular", all = TRUE)
  results_judo66p[[paste0("res4", prefix)]] <- rdrobust(df_rdd66[[outcome_var]], 
                                                        df_rdd66$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "mserd", kernel = "uni", all = TRUE)
  results_judo66p[[paste0("res5", prefix)]] <- rdrobust(df_rdd66[[outcome_var]], 
                                                        df_rdd66$running_var2, 
                                                        covs = covariates, 
                                                        bwselect = "cerrd", all = TRUE)
}

source("process_results_rdd.R")

result_sets <- list(
  "Feeling thermometer to the LDP" = c("res2fl","res3fl","res4fl","res5fl"),
  "Feeling thermometer to the PM"  = c("res2fk","res3fk","res4fk","res5fk"),
  "Sociotropic economic evaluation"= c("res2bs","res3bs","res4bs","res5bs"),
  "Egotropic economic evaluation"  = c("res2lv","res3lv","res4lv","res5lv")
)

The first gold medal	-3.336	-3.308	1.848	-3.400
Robust 95% CI	[-16.027, 9.354]	[-15.701, 9.085]	[-14.873, 18.568]	[-17.775, 10.975]
Robust \(p\)-value	0.606	0.601	0.829	0.643
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	3.938	4.172	2.32	3.004
BW bias (\(b\))	5.817	5.935	4.592	5.935
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	0.338	0.358	0.991	0.101
Robust 95% CI	[-14.370, 15.045]	[-14.337, 15.054]	[-13.570, 15.552]	[-19.122, 19.324]
Robust \(p\)-value	0.964	0.962	0.894	0.992
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	3.433	3.44	2.81	2.477
BW bias (\(b\))	4.98	4.987	5.005	4.987
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	0.252	0.238	-4.934	-0.015
Robust 95% CI	[-0.543, 1.047]	[-0.560, 1.037]	[-26.266, 16.398]	[-1.387, 1.358]
Robust \(p\)-value	0.534	0.559	0.650	0.983
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	2.385	2.359	1.56	1.699
BW bias (\(b\))	3.807	3.796	3.607	3.796
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

The first gold medal	0.569	0.574	0.577	0.576
Robust 95% CI	[-0.006, 1.144]	[-0.155, 1.303]	[-0.180, 1.335]	[-0.170, 1.323]
Robust \(p\)-value	0.052	0.123	0.135	0.130
Observations	712	712	712	712
Kernel type	Triangular	Triangular	Uniform	Triangular
BW type	msesum	mserd	mserd	cerrd
Order loc. poly.(\(p\))	1	1	1	1
Order bias (\(q\))	2	2	2	2
BW loc. poly.(\(h\))	2.865	2.529	2.071	1.821
BW bias (\(b\))	4.746	4.693	4.488	4.693
Note:
* p<0.10, ** p<0.05, *** p<0.01. Standard errors in parentheses.

Figure E.21: Even when we use other outcome variables, the SATE for the first gold medal is still null (RDD)

p1 <- rdplot(df_rdd48$ftl, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to the LDP",
             title = "Cutoff: The Gold medal confiramtion of women's judo 48kg",
             c = 0) 

p2 <- rdplot(df_rdd48$ftki, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Prime Minisiter Kishida",
             title = "Cutoff: The Gold medal confiramtion of women's judo 48kg",
             c = 0) 

p3 <- rdplot(df_rdd48$busi, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Sociotropic economic evaluation",
             title = "Cutoff: The Gold medal confiramtion of women's judo 48kg",
             c = 0) 

p4 <- rdplot(df_rdd48$liv, df_rdd48$running_var2,
             covs = cbind(df_rdd48$age, df_rdd48$female, df_rdd48$income, df_rdd48$education, df_rdd48$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Egotropic economic evaluation",
             title = "Cutoff: The Gold medal confiramtion of women's judo 48kg",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot,
                  p3$rdplot, p4$rdplot,ncol = 2)

Figure E.22 Even when we use other outcome variables, the SATE for the second gold medal is still null (RDD)

p1 <- rdplot(df_rdd66$ftl, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to the LDP",
             title = "Cutoff: The Gold medal confiramtion of women's judo 66kg",
             c = 0) 

p2 <- rdplot(df_rdd66$ftki, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Feeling thermometer to Prime Minisiter Kishida",
             title = "Cutoff: The Gold medal confiramtion of women's judo 66kg",
             c = 0) 

p3 <- rdplot(df_rdd66$busi, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Sociotropic economic evaluation",
             title = "Cutoff: The Gold medal confiramtion of women's judo 66kg",
             c = 0) 

p4 <- rdplot(df_rdd66$liv, df_rdd66$running_var2,
             covs = cbind(df_rdd66$age, df_rdd66$female, df_rdd66$income, df_rdd66$education, df_rdd66$psu_rul),
             x.lim = cutoff_range2, 
             x.lab = "Time difference from cutoff (mins)",
             y.lab = "Egotropic economic evaluation",
             title = "Cutoff: The Gold medal confiramtion of women's judo 66kg",
             c = 0) 

grid.arrange(p1$rdplot, p2$rdplot,
                  p3$rdplot, p4$rdplot,ncol = 2)

E.8 Manipulation Checks

Table E.23: The t-test results show a statistically significant difference in information exposure between the treatment and control groups

t_test_exposure <- t.test(exposure ~ cutoff, data = df_rdd48)

t_val <- unname(t_test_exposure$statistic)
p_val <- unname(t_test_exposure$p.value)
p_adj <- p.adjust(p_val, method = "bonferroni")

fmt_t  <- function(x) formatC(x, format = "f", digits = 3)
fmt_p  <- function(x) ifelse(x < 0.001, "0.000", formatC(x, format = "f", digits = 3))

tab_first <- tibble::tibble(
  ` ` = "The first gold medal",
  `t-value` = fmt_t(t_val),
  `p-value` = fmt_p(p_val),
  `Bonferroni adjusted p-value` = fmt_p(p_adj)
)

	t-value	p-value	Bonferroni adjusted p-value
The first gold medal	-7.373	0.000	0.000

t_test_exposure <- t.test(exposure ~ cutoff, data = df_rdd66)

t_val <- unname(t_test_exposure$statistic)
p_val <- unname(t_test_exposure$p.value)
p_adj <- p.adjust(p_val, method = "bonferroni")

fmt_t  <- function(x) formatC(x, format = "f", digits = 3)
fmt_p  <- function(x) ifelse(x < 0.001, "0.000", formatC(x, format = "f", digits = 3))

tab_second <- tibble::tibble(
  ` ` = "The second gold medal",
  `t-value` = fmt_t(t_val),
  `p-value` = fmt_p(p_val),
  `Bonferroni adjusted p-value` = fmt_p(p_adj)
)

	t-value	p-value	Bonferroni adjusted p-value
The second gold medal	-4.393	0.000	0.000

Table E.24: The treatment has a statistically significant effect on watching and knowing the first gold medal results

m_simple <- lm(exposure ~ cutoff, data = df_rdd48)
m_cov    <- lm(exposure ~ cutoff + age + female + education + income + psu_rul,
               data = df_rdd48)

The cutoff has a statistically significant effect on watching and knowing the 1st gold medal results

	Dependent variable: Exposure
	Simple model	Model with covariates
Cutoff(After=1; Before=0)	0.299*** (0.040)	0.316*** (0.046)
Age		-0.000 (0.001)
Female(Female=1; Male=0)		-0.033 (0.033)
Education(4-scales)		-0.001 (0.017)
Income(20-scales)		0.001 (0.005)
Ruling party support(In-partisans=1; Otherwise=0)		0.063 (0.034)
Constant	0.179*** (0.016)	0.188* (0.084)
Observations	740	740
\(R^2\)	0.088	0.094
Adjusted \(R^2\)	0.086	0.086
Residual Std. Error	0.416	0.416
	(df = 738)	(df = 733)
\(F\) Statistic	70.932	12.626
	(df = 1; 738)	(df = 6; 733)

m_simple <- lm(exposure ~ cutoff, data = df_rdd66)
m_cov    <- lm(exposure ~ cutoff + age + female + education + income + psu_rul,
               data = df_rdd66)

The cutoff has a statistically significant effect on watching and knowing the 2nd gold medal results

	Dependent variable: Exposure
	Simple model	Model with covariates
Cutoff(After=1; Before=0)	0.155*** (0.035)	0.147*** (0.036)
Age		0.004*** (0.001)
Female(Female=1; Male=0)		-0.004 (0.036)
Education(4-scales)		0.002 (0.002)
Income(20-scales)		0.011* (0.005)
Ruling party support(In-partisans=1; Otherwise=0)		0.061 (0.037)
Constant	0.221*** (0.028)	-0.084 (0.073)
Observations	712	712
\(R^2\)	0.024	0.048
Adjusted \(R^2\)	0.022	0.040
Residual Std. Error	0.464	0.460
	(df = 710)	(df = 705)
\(F\) Statistic	17.263	5.919
	(df = 1; 710)	(df = 6; 705)