Data pipeline & country aggregates

The reproducible derivation of every number behind the maps, profiles, and country cards

Overview

Every choropleth, ranked bar, radar, country card, and annex table in the policy report rests on a small set of country-level aggregate tables. This page is where those tables are derived: it reads the validated, harmonised scales (academic site, Data preparation) and the fitted models, then writes one analysis-ready CSV per aggregate. No new psychometric model is estimated here — this is the deterministic reshape-and-summarise layer between the validated instrument and the designed report.

For each aggregate we show: (1) the producing script, read live from the repository so the displayed code is exactly what ran; (2) a preview of the resulting table; and (3) a download link to the full CSV. The single orchestration entry point that runs all producers in dependency order is R/policy_report/00_run_all.R.

Table 1: The nine aggregate producers and what each writes.

Section	Producer	Output
1	`01_country_means_higherorder.R`	`s4_country_means_higherorder.csv`
2	`02_country_means_fimi.R`	`s4_country_means_fimi.csv`
3	`03_country_means_long.R`	`s4_country_means_byconstruct_long.csv`
4	`05_country_fimi_difference.R`	`s4_country_fimi_difference.csv`
5	`06_country_item_means.R`	`s4_country_item_means.csv`
6	`04_s23_first_higher_order_means.R`	`s23_first_order_means.csv` + `s23_higher_order_means.csv`
7	`09_eu_pooled_benchmarks.R`	`s4_eu_pooled_benchmarks.csv`
8	`10_sample_composition.R`	`s4_sample_composition_by_country.csv`
9	`13_country_geometries.R`	`policy_report_country_geometries.rds`

All confidence intervals on this page are non-parametric bootstrap CIs (bootstrap_ci() / bootstrap_ci_paired() in R/policy_report/_helpers.R), computed with the project seed (42). The paired Russian − Chinese contrast resamples respondent pairs to preserve the within-respondent correlation.

1. Higher-order country means (S4)

Per-country means, SDs, and bootstrapped 95% CIs for the five higher-order DisInforMeter composites plus an overall DisInforMeter composite (the mean of the five domains, z-scored and rescaled to the 1–7 axis). Higher = more receptivity-relevant endorsement.

Code

R/policy_report/01_country_means_higherorder.R

#' R/policy_report/01_country_means_higherorder.R
#'
#' Country-level means + 95% bootstrap CIs for the five (six) higher-order
#' DisInforMeter domains and the overall composite, in S4.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §1.1
#'
#' Inputs:
#'   data/wrangled_data/study4_scales.parquet
#'
#' Output:
#'   outputs/policy_report/tables/s4_country_means_higherorder.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | construct_id | construct_label |
#'   n | mean | sd | se | ci_lower | ci_upper | scale_min | scale_max
#'
#' Constructs included:
#'   threat (scale_threat)
#'   aband  (scale_aband)
#'   fear   (scale_prag; legacy column name kept, latent name is FEAR)
#'   supf   (scale_supr; S4 SUPR = affective Russia admiration, canonical SUPF)
#'   supfch (scale_supch; S4-only, affective China admiration)
#'   admir  (per-respondent mean of scale_supr + scale_supch — "Foreign-power
#'           admiration (composite)", drives the F-09 5-domain story)
#'   gen    (scale_gen)
#'   overall (z-score average of threat/aband/fear/admir/gen rescaled to 1-7)
#'
#' Figures this feeds:
#'   F-08 (overall DisInforMeter receptivity ranked bar)
#'   F-09 (five-domain small-multiples; uses threat/aband/fear/admir/gen)
#'   F-16 / F-17 (country-cluster + all-country radars)
#'   country snapshots (§5)

source(here::here("R", "policy_report", "_helpers.R"))

compute_country_means_higherorder <- function(study4_scales = NULL,
                                              B = 1000L,
                                              seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study4_scales)) {
    study4_scales <- arrow::read_parquet(paths$s4_scales)
  }
  s4 <- load_s4_country_iso3(study4_scales) %>%
    dplyr::filter(!is.na(country_iso3))   # drop "Other (Please specify)" bucket

  # Build the per-respondent admiration composite (mean of supr + supch) and
  # the overall composite (mean of five domain z-scores rescaled to 1-7).
  base_cols <- c("scale_threat", "scale_aband", "scale_prag",
                 "scale_supr", "scale_supch", "scale_gen")
  stopifnot(all(base_cols %in% names(s4)))

  s4 <- s4 %>%
    dplyr::mutate(
      admir_score = rowMeans(dplyr::across(c(scale_supr, scale_supch)),
                             na.rm = FALSE)
    )

  # z-score on the *pooled* sample, then average, then rescale to 1-7.
  z_threat <- as.numeric(scale(s4$scale_threat))
  z_aband  <- as.numeric(scale(s4$scale_aband))
  z_fear   <- as.numeric(scale(s4$scale_prag))
  z_admir  <- as.numeric(scale(s4$admir_score))
  z_gen    <- as.numeric(scale(s4$scale_gen))
  overall_z <- rowMeans(cbind(z_threat, z_aband, z_fear, z_admir, z_gen),
                        na.rm = FALSE)
  # Rescale: rank-preserving min-max into 1-7 using pooled SD = 1 / range ≈ 4.
  rng <- range(overall_z, na.rm = TRUE)
  s4$overall_score <- 1 + 6 * (overall_z - rng[1]) / diff(rng)

  cmap <- higher_order_construct_map() %>%
    dplyr::mutate(value_col = dplyr::case_when(
      construct_id == "admir"   ~ "admir_score",
      construct_id == "overall" ~ "overall_score",
      TRUE ~ s4_col
    ))

  per_construct <- function(row) {
    s4 %>%
      dplyr::select(country_iso3, country_name, cluster, value = !!row$value_col) %>%
      dplyr::group_by(country_iso3, country_name, cluster) %>%
      dplyr::summarise(
        ci = list(bootstrap_ci(value, B = B, seed = seed)),
        sd = stats::sd(value, na.rm = TRUE),
        .groups = "drop"
      ) %>%
      tidyr::unnest(ci) %>%
      dplyr::mutate(
        construct_id    = row$construct_id,
        construct_label = row$display_label,
        se              = se,
        scale_min       = if (row$construct_id == "overall") 1 else 1,
        scale_max       = if (row$construct_id == "overall") 7 else 7
      ) %>%
      dplyr::select(country_iso3, country_name, cluster, construct_id,
                    construct_label, n, mean, sd, se, ci_lower, ci_upper,
                    scale_min, scale_max)
  }

  out <- purrr::map_dfr(seq_len(nrow(cmap)), function(i) per_construct(cmap[i, ]))
  dplyr::arrange(out, construct_id, dplyr::desc(mean))
}

main_01 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_country_means_higherorder()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "01 / s4_country_means_higherorder.csv",
    required_cols = c("country_iso3", "construct_id", "n", "mean",
                      "ci_lower", "ci_upper"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      mean     = c(1, 7),
      ci_lower = c(0.5, 7.5),
      ci_upper = c(0.5, 7.5)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_country_means_higherorder.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_01()

Table 2

country_iso3	country_name	cluster	construct_id	construct_label	n	mean	sd	se	ci_lower	ci_upper	scale_min	scale_max
SRB	Serbia	Southern	aband	Betrayal / abandonment	606	5.396	1.359	0.056	5.288	5.498	1	7
TUR	Turkey	Southern	aband	Betrayal / abandonment	599	5.097	1.559	0.063	4.969	5.218	1	7
BGR	Bulgaria	Central-East	aband	Betrayal / abandonment	592	4.960	1.444	0.061	4.840	5.080	1	7
ITA	Italy	Southern	aband	Betrayal / abandonment	606	4.545	1.342	0.054	4.437	4.651	1	7
HUN	Hungary	Central-East	aband	Betrayal / abandonment	599	4.455	1.319	0.055	4.346	4.564	1	7
POL	Poland	Central-East	aband	Betrayal / abandonment	600	4.408	1.494	0.061	4.286	4.529	1	7
FRA	France	Western	aband	Betrayal / abandonment	596	4.359	1.337	0.055	4.253	4.471	1	7
BEL	Belgium	Western	aband	Betrayal / abandonment	595	4.253	1.412	0.057	4.134	4.358	1	7
AUT	Austria	Western	aband	Betrayal / abandonment	599	4.244	1.570	0.064	4.122	4.367	1	7
DEU	Germany	Western	aband	Betrayal / abandonment	598	4.191	1.485	0.059	4.080	4.305	1	7

Download: s4_country_means_higherorder.csv

2. FIMI detection country means — all four operationalisations

Mean detection rating per country for Full (8 items), Russian-origin (5 items), Chinese-origin (3 items), and Short (4 items) FIMI. Higher = better detection.

Code

R/policy_report/02_country_means_fimi.R

#' R/policy_report/02_country_means_fimi.R
#'
#' Country-level FIMI means + 95% bootstrap CIs in S4, for each of the four
#' FIMI operationalisations:
#'   * full           — news1..news8 (8-item battery)
#'   * russian_origin — news1..news5
#'   * chinese_origin — news6..news8
#'   * short          — news2, news5, news7, news8 (4-item source-balanced)
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §1.2
#'
#' Inputs:
#'   data/wrangled_data/study4_scales.parquet (for the wrangled `scale_fimi*`)
#'   data/wrangled_data/study4_items.parquet  (for news1..news8 directly,
#'                                             used to compute the per-version
#'                                             row mean)
#'
#' Output:
#'   outputs/policy_report/tables/s4_country_means_fimi.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | fimi_version | n | mean | sd |
#'   se | ci_lower | ci_upper
#'
#' Direction verification:
#'   The S4 FIMI items ask respondents whether confirmed FIMI headlines are
#'   manipulated on a 1-7 Likert scale. Higher score = stronger detection.
#'   Verified directly: the wrangled `scale_fimi` column is the row-mean of
#'   news1..news8 with no reverse-coding (see
#'   full-annotated-code/01-data-preparation.qmd §FIMI canonical mapping, lines
#'   ~235, 472, 538), and the per-item range is [1, 7]. Therefore higher map
#'   colour = better detection of confirmed FIMI cases.
#'
#' Figures this feeds:
#'   F-07 (overall FIMI choropleth, version = full)
#'   F-10 (Russian-origin FIMI choropleth)
#'   F-11 (Chinese-origin FIMI choropleth)
#'   country snapshots (FIMI bars in §5)

source(here::here("R", "policy_report", "_helpers.R"))

.fimi_item_sets <- function() {
  list(
    full           = paste0("news", 1:8),
    russian_origin = paste0("news", 1:5),
    chinese_origin = paste0("news", 6:8),
    short          = c("news2", "news5", "news7", "news8")
  )
}

compute_country_means_fimi <- function(study4_items = NULL,
                                       versions = c("full", "russian_origin",
                                                    "chinese_origin", "short"),
                                       B = 1000L,
                                       seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study4_items)) {
    study4_items <- arrow::read_parquet(paths$s4_items)
  }
  s4 <- load_s4_country_iso3(study4_items) %>%
    dplyr::filter(!is.na(country_iso3))

  # Verify direction against disinformeter_items_all.parquet
  .verify_fimi_direction()

  sets <- .fimi_item_sets()[versions]

  purrr::imap_dfr(sets, function(items, version) {
    stopifnot(all(items %in% names(s4)))
    dat <- s4 %>%
      dplyr::mutate(score = rowMeans(dplyr::across(dplyr::all_of(items)),
                                     na.rm = FALSE)) %>%
      dplyr::select(country_iso3, country_name, cluster, score)
    dat %>%
      dplyr::group_by(country_iso3, country_name, cluster) %>%
      dplyr::summarise(
        ci = list(bootstrap_ci(score, B = B, seed = seed)),
        sd = stats::sd(score, na.rm = TRUE),
        .groups = "drop"
      ) %>%
      tidyr::unnest(ci) %>%
      dplyr::mutate(fimi_version = version) %>%
      dplyr::select(country_iso3, country_name, cluster, fimi_version,
                    n, mean, sd, se, ci_lower, ci_upper)
  })
}

# Direction sanity gate: confirm that the global mean of news1..news8 from the
# wrangled `scale_fimi` matches the row-mean of news1..news8 from the items
# parquet. If they diverge, the data prep has changed and the maps must be
# reviewed for colour direction.
.verify_fimi_direction <- function() {
  paths <- policy_report_paths()
  all_items <- arrow::read_parquet(paths$items_all)
  s4 <- arrow::read_parquet(paths$s4_scales)
  s4i <- arrow::read_parquet(paths$s4_items)
  news <- paste0("news", 1:8)
  scale_mean <- mean(s4$scale_fimi, na.rm = TRUE)
  item_mean  <- mean(rowMeans(s4i[news], na.rm = FALSE), na.rm = TRUE)
  if (abs(scale_mean - item_mean) > 1e-3) {
    stop(sprintf(
      "FIMI direction sanity check failed: scale_fimi mean = %.4f, ",
      "row-mean of news1..news8 = %.4f. Re-verify against ",
      "full-annotated-code/01-data-preparation.qmd before publishing maps.",
      scale_mean, item_mean), call. = FALSE)
  }
  s4_news_range <- range(unlist(s4i[news]), na.rm = TRUE)
  if (s4_news_range[1] < 1 - 1e-6 || s4_news_range[2] > 7 + 1e-6) {
    stop(sprintf("FIMI item range outside [1,7]: %s",
                 paste(s4_news_range, collapse = ", ")), call. = FALSE)
  }
  policy_report_message(sprintf(
    "FIMI direction OK: scale_fimi mean = %.3f matches row-mean of news1..news8 (= %.3f); items in [1,7].",
    scale_mean, item_mean))
  invisible(TRUE)
}

main_02 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_country_means_fimi()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "02 / s4_country_means_fimi.csv",
    required_cols = c("country_iso3", "fimi_version", "n", "mean",
                      "ci_lower", "ci_upper"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      mean     = c(1, 7),
      ci_lower = c(0.5, 7.5),
      ci_upper = c(0.5, 7.5)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_country_means_fimi.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_02()

Table 3

country_iso3	country_name	cluster	fimi_version	n	mean	sd	se	ci_lower	ci_upper
AUT	Austria	Western	full	599	4.765	0.879	0.037	4.689	4.835
BEL	Belgium	Western	full	595	4.824	0.909	0.037	4.751	4.892
BGR	Bulgaria	Central-East	full	592	4.749	1.011	0.043	4.659	4.830
DEU	Germany	Western	full	598	4.616	0.954	0.039	4.537	4.692
EST	Estonia	Baltic	full	604	5.035	0.982	0.041	4.956	5.116
FRA	France	Western	full	596	4.711	0.949	0.038	4.639	4.789
HUN	Hungary	Central-East	full	599	4.784	0.998	0.041	4.704	4.865
ITA	Italy	Southern	full	606	4.784	0.942	0.038	4.709	4.860
LTU	Lithuania	Baltic	full	593	5.254	1.020	0.043	5.170	5.338
LVA	Latvia	Baltic	full	596	5.141	0.890	0.035	5.072	5.211

Download: s4_country_means_fimi.csv

3. Canonical long-form country × construct table

The single long-format source consumed by the choropleths, ranked bars, radars, and country cards. Long form makes faceting by construct or by country trivial.

Code

R/policy_report/03_country_means_long.R

#' R/policy_report/03_country_means_long.R
#'
#' Canonical long-form CSV that combines the outputs of 01 and 02 into a
#' single source-of-truth for the choropleths, ranked-bar, and radar plots in
#' the policy report.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §1.3
#'
#' Inputs (read from disk if present, recomputed via 01/02 otherwise):
#'   outputs/policy_report/tables/s4_country_means_higherorder.csv
#'   outputs/policy_report/tables/s4_country_means_fimi.csv
#'
#' Output:
#'   outputs/policy_report/tables/s4_country_means_byconstruct_long.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | construct_id | construct_label |
#'   construct_family (higher_order | fimi) |
#'   n | mean | sd | se | ci_lower | ci_upper | scale_min | scale_max
#'
#' Figures this feeds:
#'   F-07, F-08, F-09, F-16, F-17, country snapshots.

source(here::here("R", "policy_report", "_helpers.R"))
source(here::here("R", "policy_report", "01_country_means_higherorder.R"))
source(here::here("R", "policy_report", "02_country_means_fimi.R"))

compute_country_means_long <- function(higher_order = NULL, fimi = NULL) {
  paths <- policy_report_paths()
  ho_path <- file.path(paths$tables, "s4_country_means_higherorder.csv")
  fi_path <- file.path(paths$tables, "s4_country_means_fimi.csv")

  if (is.null(higher_order)) {
    higher_order <- if (file.exists(ho_path)) {
      readr::read_csv(ho_path, show_col_types = FALSE)
    } else compute_country_means_higherorder()
  }
  if (is.null(fimi)) {
    fimi <- if (file.exists(fi_path)) {
      readr::read_csv(fi_path, show_col_types = FALSE)
    } else compute_country_means_fimi()
  }

  ho_long <- higher_order %>%
    dplyr::mutate(construct_family = "higher_order") %>%
    dplyr::select(country_iso3, country_name, cluster, construct_id,
                  construct_label, construct_family,
                  n, mean, sd, se, ci_lower, ci_upper, scale_min, scale_max)

  fimi_long <- fimi %>%
    dplyr::transmute(
      country_iso3, country_name, cluster,
      construct_id = paste0("fimi_", fimi_version),
      construct_label = dplyr::case_when(
        fimi_version == "full"           ~ "FIMI: Full (news1-8)",
        fimi_version == "russian_origin" ~ "FIMI: Russian-origin (news1-5)",
        fimi_version == "chinese_origin" ~ "FIMI: Chinese-origin (news6-8)",
        fimi_version == "short"          ~ "FIMI: Short (news2/5/7/8)"
      ),
      construct_family = "fimi",
      n, mean, sd, se, ci_lower, ci_upper,
      scale_min = 1, scale_max = 7
    )

  dplyr::bind_rows(ho_long, fimi_long) %>%
    dplyr::arrange(construct_family, construct_id, dplyr::desc(mean))
}

main_03 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_country_means_long()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "03 / s4_country_means_byconstruct_long.csv",
    required_cols = c("country_iso3", "construct_id", "construct_family",
                      "n", "mean", "ci_lower", "ci_upper",
                      "scale_min", "scale_max"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      mean     = c(1, 7),
      ci_lower = c(0.5, 7.5),
      ci_upper = c(0.5, 7.5)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_country_means_byconstruct_long.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_03()

Table 4

country_iso3	country_name	cluster	construct_id	construct_label	construct_family	n	mean	sd	se	ci_lower	ci_upper	scale_min	scale_max
LTU	Lithuania	Baltic	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	593	4.845	1.200	0.049	4.743	4.937	1	7
POL	Poland	Central-East	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	600	4.699	1.195	0.048	4.606	4.793	1	7
LVA	Latvia	Baltic	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	596	4.681	1.095	0.043	4.598	4.764	1	7
EST	Estonia	Baltic	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	604	4.598	1.106	0.046	4.509	4.688	1	7
SRB	Serbia	Southern	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	606	4.530	1.158	0.047	4.439	4.617	1	7
BEL	Belgium	Western	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	595	4.477	1.130	0.047	4.383	4.568	1	7
BGR	Bulgaria	Central-East	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	592	4.446	1.213	0.050	4.346	4.544	1	7
AUT	Austria	Western	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	599	4.445	1.143	0.047	4.355	4.541	1	7
TUR	Turkey	Southern	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	599	4.378	1.325	0.056	4.265	4.481	1	7
HUN	Hungary	Central-East	fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	599	4.364	1.156	0.047	4.266	4.458	1	7

Download: s4_country_means_byconstruct_long.csv

4. Paired Russian − Chinese detection difference

Per-respondent paired difference (Russian-origin detection − Chinese-origin detection), aggregated by country with a bootstrapped 95% CI for the difference. This is the primary source-asymmetry contrast (F-12).

Code

R/policy_report/05_country_fimi_difference.R

#' R/policy_report/05_country_fimi_difference.R
#'
#' Per-country mean of the paired (within-respondent) difference
#' (Russian-origin FIMI - Chinese-origin FIMI) with bootstrap 95% CI.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §1.5
#'
#' Why paired? Each S4 respondent rated both Russian-origin and Chinese-origin
#' headlines. Aggregating two independent country means and subtracting them
#' would ignore the within-respondent covariance. We instead compute the
#' difference at the respondent level (russian_mean_i - chinese_mean_i), and
#' resample respondents (not items) to honour the paired structure.
#'
#' Inputs:
#'   data/wrangled_data/study4_items.parquet
#'
#' Output:
#'   outputs/policy_report/tables/s4_country_fimi_difference.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | n | mean_R | mean_CH |
#'   difference | se | ci_lower | ci_upper | ci_excludes_zero
#'
#' Figures this feeds:
#'   F-12 (Russian minus Chinese difference choropleth).

source(here::here("R", "policy_report", "_helpers.R"))

compute_country_fimi_difference <- function(study4_items = NULL,
                                            B = 1000L,
                                            seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study4_items)) {
    study4_items <- arrow::read_parquet(paths$s4_items)
  }

  ru <- paste0("news", 1:5)
  ch <- paste0("news", 6:8)

  s4 <- load_s4_country_iso3(study4_items) %>%
    dplyr::filter(!is.na(country_iso3)) %>%
    dplyr::mutate(
      r_score  = rowMeans(dplyr::across(dplyr::all_of(ru)), na.rm = FALSE),
      ch_score = rowMeans(dplyr::across(dplyr::all_of(ch)), na.rm = FALSE)
    ) %>%
    dplyr::select(country_iso3, country_name, cluster, r_score, ch_score)

  countries <- s4 %>% dplyr::distinct(country_iso3, country_name, cluster)

  per_country <- function(iso) {
    d <- s4 %>% dplyr::filter(country_iso3 == iso)
    ci <- bootstrap_ci_paired(d$r_score, d$ch_score, B = B, seed = seed)
    ci %>%
      dplyr::transmute(
        country_iso3 = iso,
        n,
        mean_R = mean_x,
        mean_CH = mean_y,
        difference = diff,
        se,
        ci_lower,
        ci_upper,
        ci_excludes_zero = (ci_lower > 0) | (ci_upper < 0)
      )
  }

  rows <- purrr::map_dfr(countries$country_iso3, per_country)
  countries %>%
    dplyr::left_join(rows, by = "country_iso3") %>%
    dplyr::select(country_iso3, country_name, cluster, n, mean_R, mean_CH,
                  difference, se, ci_lower, ci_upper, ci_excludes_zero) %>%
    dplyr::arrange(dplyr::desc(difference))
}

main_05 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_country_fimi_difference()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "05 / s4_country_fimi_difference.csv",
    required_cols = c("country_iso3", "n", "mean_R", "mean_CH",
                      "difference", "ci_lower", "ci_upper"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      mean_R     = c(1, 7),
      mean_CH    = c(1, 7),
      difference = c(-6, 6),
      ci_lower   = c(-6.5, 6.5),
      ci_upper   = c(-6.5, 6.5)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_country_fimi_difference.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_05()

Table 5

country_iso3	country_name	cluster	n	mean_R	mean_CH	difference	se	ci_lower	ci_upper	ci_excludes_zero
FRA	France	Western	596	5.058	4.134	0.924	0.059	0.809	1.049	TRUE
ITA	Italy	Southern	606	5.093	4.268	0.824	0.050	0.732	0.922	TRUE
LVA	Latvia	Baltic	596	5.417	4.681	0.736	0.048	0.641	0.830	TRUE
EST	Estonia	Baltic	604	5.298	4.598	0.700	0.048	0.605	0.795	TRUE
HUN	Hungary	Central-East	599	5.037	4.364	0.673	0.052	0.561	0.770	TRUE
LTU	Lithuania	Baltic	593	5.500	4.845	0.655	0.052	0.558	0.756	TRUE
SRB	Serbia	Southern	606	5.093	4.530	0.563	0.050	0.466	0.667	TRUE
BEL	Belgium	Western	595	5.032	4.477	0.555	0.049	0.460	0.655	TRUE
AUT	Austria	Western	599	4.957	4.445	0.512	0.048	0.420	0.612	TRUE
BGR	Bulgaria	Central-East	592	4.931	4.446	0.485	0.053	0.379	0.583	TRUE

Download: s4_country_fimi_difference.csv

5. Country × FIMI-item detection means

Per-country mean detection rating for each of the eight news items, joined with item metadata (origin, truth value, short label). Drives the country × item heatmap (F-13).

Code

R/policy_report/06_country_item_means.R

#' R/policy_report/06_country_item_means.R
#'
#' Per-country mean rating for each of the eight FIMI news items, with item
#' metadata (origin, truth_value, short-form membership) attached.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §2.1
#'
#' Inputs:
#'   data/wrangled_data/study4_items.parquet
#'   item metadata from helpers::fimi_item_metadata()
#'
#' Output:
#'   outputs/policy_report/tables/s4_country_item_means.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | item_code | item_short_label |
#'   origin | truth_value | short_form | n | mean | sd | se
#'
#' Figures this feeds:
#'   F-13 (country × item heatmap).

source(here::here("R", "policy_report", "_helpers.R"))

compute_country_item_means <- function(study4_items = NULL,
                                       B = 1000L,
                                       seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study4_items)) {
    study4_items <- arrow::read_parquet(paths$s4_items)
  }

  meta <- fimi_item_metadata()
  items <- meta$item_code
  s4 <- load_s4_country_iso3(study4_items) %>%
    dplyr::filter(!is.na(country_iso3)) %>%
    dplyr::select(country_iso3, country_name, cluster,
                  dplyr::all_of(items)) %>%
    tidyr::pivot_longer(dplyr::all_of(items),
                        names_to = "item_code",
                        values_to = "value")

  s4 %>%
    dplyr::group_by(country_iso3, country_name, cluster, item_code) %>%
    dplyr::summarise(
      n  = sum(!is.na(value)),
      mean = mean(value, na.rm = TRUE),
      sd = stats::sd(value, na.rm = TRUE),
      se = sd / sqrt(n),
      .groups = "drop"
    ) %>%
    dplyr::left_join(meta, by = "item_code") %>%
    dplyr::select(country_iso3, country_name, cluster, item_code,
                  item_short_label, origin, truth_value, short_form,
                  n, mean, sd, se) %>%
    dplyr::arrange(country_iso3, item_code)
}

main_06 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_country_item_means()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "06 / s4_country_item_means.csv",
    required_cols = c("country_iso3", "item_code", "origin", "truth_value",
                      "n", "mean"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      mean = c(1, 7)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_country_item_means.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_06()

Table 6

country_iso3	country_name	cluster	item_code	item_short_label	origin	truth_value	short_form	n	mean	sd	se
AUT	Austria	Western	news1	Zelensky / King Charles mansion	Russian-origin	FALSE	FALSE	599	5.573	1.665	0.068
AUT	Austria	Western	news2	France / Russia in Ukraine	Russian-origin	FALSE	TRUE	599	5.259	1.717	0.070
AUT	Austria	Western	news3	Milan-Cortina 'openly LGBT' Olympics	Russian-origin	FALSE	FALSE	599	3.898	1.849	0.076
AUT	Austria	Western	news4	Ukrainian army tolerance mentor	Russian-origin	FALSE	FALSE	599	4.740	1.621	0.066
AUT	Austria	Western	news5	Kyiv LGBT brigades	Russian-origin	FALSE	TRUE	599	5.314	1.683	0.069
AUT	Austria	Western	news6	Li-Meng Yan COVID rumour	Chinese-origin	FALSE	FALSE	599	4.364	1.835	0.075
AUT	Austria	Western	news7	CGTN: China-Vietnam friendship	Chinese-origin	FALSE	TRUE	599	4.406	1.602	0.065
AUT	Austria	Western	news8	Banned-leader Li Hongzhi 'plague-rule'	Chinese-origin	FALSE	TRUE	599	4.564	1.776	0.073
BEL	Belgium	Western	news1	Zelensky / King Charles mansion	Russian-origin	FALSE	FALSE	595	5.613	1.619	0.066
BEL	Belgium	Western	news2	France / Russia in Ukraine	Russian-origin	FALSE	TRUE	595	5.007	1.733	0.071

Download: s4_country_item_means.csv

6. S2 (Lithuania) and S3 (Germany) means

First-order and higher-order means with 95% CIs for the Lithuanian (S2) and German (S3) samples — the two waves that fielded the full first-order battery. These feed the Lithuania-vs-Germany radar and bar comparisons (F-14, F-15).

Code

R/policy_report/04_s23_first_higher_order_means.R

#' R/policy_report/04_s23_first_higher_order_means.R
#'
#' Lithuania (S2) vs Germany (S3) means + 95% bootstrap CIs for
#' (a) the first-order belief items used in F-15, and
#' (b) the five higher-order affective domains (threat, aband, fear, admir, gen)
#'     used in F-14. These mirror the canonical S4 five-domain story
#'     (see R/policy_report/01_country_means_higherorder.R +
#'      higher_order_construct_map()):
#'       threat - scale_threat   (Ideological threat)
#'       aband  - scale_aband    (Betrayal / abandonment)
#'       fear   - scale_prag     (Fear / pragmatic accommodation; legacy col)
#'       admir  - mean(scale_supf, scale_supfch) per respondent
#'                (Foreign-power admiration — Russia + China affective anchors)
#'       gen    - scale_gen      (General disinformation acceptance)
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §1.4
#'
#' Inputs:
#'   data/wrangled_data/study2_scales.parquet
#'   data/wrangled_data/study3_scales.parquet
#'
#' Outputs:
#'   outputs/policy_report/tables/s23_first_order_means.csv
#'   outputs/policy_report/tables/s23_higher_order_means.csv
#'
#' Columns (both):
#'   study | country_iso3 | country_name | construct_id | construct_label |
#'   n | mean | sd | se | ci_lower | ci_upper | scale_min | scale_max
#'
#' Figures this feeds:
#'   F-14 (LT vs DE five-domain radar)
#'   F-15 (LT vs DE first-order side-by-side bars)
#'   country snapshots for LT and DE.

source(here::here("R", "policy_report", "_helpers.R"))

.aggregate_construct <- function(df, columns, labels, study, iso3, name,
                                 B, seed, ids = NULL) {
  # `ids` overrides the default construct_id (derived by stripping the
  # "scale_" prefix). Needed for the higher-order set where the canonical
  # id (e.g. "fear", "admir") differs from the wrangled column name
  # ("scale_prag", "admir_score").
  if (is.null(ids)) ids <- sub("^scale_", "", columns)
  purrr::pmap_dfr(list(columns, labels, ids), function(col, lbl, id) {
    if (!col %in% names(df)) return(NULL)
    tibble::tibble(
      study = study,
      country_iso3 = iso3,
      country_name = name,
      construct_id = id,
      construct_label = lbl,
      value = df[[col]]
    ) %>%
      dplyr::summarise(
        ci = list(bootstrap_ci(value, B = B, seed = seed)),
        sd = stats::sd(value, na.rm = TRUE),
        .by = c(study, country_iso3, country_name, construct_id, construct_label)
      ) %>%
      tidyr::unnest(ci) %>%
      dplyr::mutate(scale_min = 1, scale_max = 7) %>%
      dplyr::select(study, country_iso3, country_name, construct_id,
                    construct_label, n, mean, sd, se, ci_lower, ci_upper,
                    scale_min, scale_max)
  })
}

#' Augment S2/S3 scale tables with China-side first-order composites that
#' the upstream wrangling did not pre-compute. The S2 / S3 item parquet
#' files carry pch1..pch6 (Pragmatism toward China) and ski1..ski11
#' (Superiority of China beliefs); we compute the same row-mean rule used
#' for the Russia-side scale_pragr / scale_supr.
.augment_china_first_order_scales <- function(study_scales, study_items) {
  pch_cols <- intersect(sprintf("pch%d", 1:6), names(study_items))
  ski_cols <- intersect(sprintf("ski%d", 1:11), names(study_items))
  if (length(pch_cols) == 0L || length(ski_cols) == 0L) {
    stop(".augment_china_first_order_scales(): expected pch* / ski* items missing.",
         call. = FALSE)
  }
  id_col <- intersect(c("response_id", "ppt", "id"),
                      intersect(names(study_scales), names(study_items)))
  if (length(id_col) == 0L) {
    stop(".augment_china_first_order_scales(): need a shared id column ",
         "(response_id / ppt / id) in both tables.", call. = FALSE)
  }
  id_col <- id_col[1L]
  derived <- study_items %>%
    dplyr::select(dplyr::all_of(id_col),
                  dplyr::all_of(c(pch_cols, ski_cols))) %>%
    dplyr::mutate(
      scale_pragch = rowMeans(dplyr::across(dplyr::all_of(pch_cols)),
                              na.rm = TRUE),
      scale_supch  = rowMeans(dplyr::across(dplyr::all_of(ski_cols)),
                              na.rm = TRUE)
    ) %>%
    dplyr::mutate(
      scale_pragch = ifelse(is.nan(scale_pragch), NA_real_, scale_pragch),
      scale_supch  = ifelse(is.nan(scale_supch),  NA_real_, scale_supch)
    ) %>%
    dplyr::select(dplyr::all_of(id_col), scale_pragch, scale_supch)

  study_scales %>%
    dplyr::left_join(derived, by = id_col)
}

#' Augment S2/S3 scale tables with the higher-order inputs that upstream
#' wrangling did not pre-compute, so F-14 can show the canonical five
#' affective domains (matching the S4 story in
#' R/policy_report/01_country_means_higherorder.R):
#'
#'   scale_gen    - General disinformation acceptance. Row-mean of the
#'                  gen1/gen2/gen3/gen5/gen7 anchor (the same 5-item subset
#'                  S4's `GEN` registry uses), so the General domain is
#'                  measured identically across waves.
#'   scale_supfch - Foreign-power *affective* admiration, China anchor.
#'                  Row-mean of fch1/fch2/fch3 (matching S4 `SUPCH`). Note
#'                  this is the affective `fch*` admiration battery, NOT the
#'                  belief-based `ski*` "Superiority of China" used for the
#'                  first-order SUPF axis.
#'   admir_score  - Per-respondent mean of the Russia (scale_supf, the
#'                  canonical fru-based S2/S3 SUPF) and China (scale_supfch)
#'                  affective-admiration anchors. This is the "Foreign-power
#'                  admiration (composite)" higher-order domain.
.augment_higher_order_scales <- function(study_scales, study_items) {
  gen_cols <- intersect(c("gen1", "gen2", "gen3", "gen5", "gen7"),
                        names(study_items))
  fch_cols <- intersect(sprintf("fch%d", 1:3), names(study_items))
  if (length(gen_cols) == 0L || length(fch_cols) == 0L) {
    stop(".augment_higher_order_scales(): expected gen* / fch* items missing.",
         call. = FALSE)
  }
  if (!"scale_supf" %in% names(study_scales)) {
    stop(".augment_higher_order_scales(): scale_supf (Russia admiration ",
         "anchor) missing from the scale table.", call. = FALSE)
  }
  id_col <- intersect(c("response_id", "ppt", "id"),
                      intersect(names(study_scales), names(study_items)))
  if (length(id_col) == 0L) {
    stop(".augment_higher_order_scales(): need a shared id column ",
         "(response_id / ppt / id) in both tables.", call. = FALSE)
  }
  id_col <- id_col[1L]
  derived <- study_items %>%
    dplyr::select(dplyr::all_of(id_col),
                  dplyr::all_of(c(gen_cols, fch_cols))) %>%
    dplyr::mutate(
      scale_gen    = rowMeans(dplyr::across(dplyr::all_of(gen_cols)),
                              na.rm = TRUE),
      scale_supfch = rowMeans(dplyr::across(dplyr::all_of(fch_cols)),
                              na.rm = TRUE)
    ) %>%
    dplyr::mutate(
      scale_gen    = ifelse(is.nan(scale_gen),    NA_real_, scale_gen),
      scale_supfch = ifelse(is.nan(scale_supfch), NA_real_, scale_supfch)
    ) %>%
    dplyr::select(dplyr::all_of(id_col), scale_gen, scale_supfch)

  study_scales %>%
    dplyr::left_join(derived, by = id_col) %>%
    # Per-respondent foreign-power admiration composite (Russia + China
    # affective anchors). na.rm = FALSE mirrors the S4 admir_score rule.
    dplyr::mutate(
      admir_score = rowMeans(dplyr::across(c(scale_supf, scale_supfch)),
                             na.rm = FALSE)
    )
}

compute_s23_first_order_means <- function(study2_scales = NULL,
                                          study3_scales = NULL,
                                          study2_items  = NULL,
                                          study3_items  = NULL,
                                          B = 1000L,
                                          seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study2_scales)) study2_scales <- arrow::read_parquet(paths$s2_scales)
  if (is.null(study3_scales)) study3_scales <- arrow::read_parquet(paths$s3_scales)
  if (is.null(study2_items))  study2_items  <- arrow::read_parquet(paths$s2_items)
  if (is.null(study3_items))  study3_items  <- arrow::read_parquet(paths$s3_items)

  study2_scales <- .augment_china_first_order_scales(study2_scales, study2_items)
  study3_scales <- .augment_china_first_order_scales(study3_scales, study3_items)

  fmap <- s23_first_order_construct_map()
  cols <- fmap$column
  lbls <- fmap$display_label

  dplyr::bind_rows(
    .aggregate_construct(study2_scales, cols, lbls,
                         study = "S2", iso3 = "LTU", name = "Lithuania",
                         B = B, seed = seed),
    .aggregate_construct(study3_scales, cols, lbls,
                         study = "S3", iso3 = "DEU", name = "Germany",
                         B = B, seed = seed)
  )
}

compute_s23_higher_order_means <- function(study2_scales = NULL,
                                           study3_scales = NULL,
                                           study2_items  = NULL,
                                           study3_items  = NULL,
                                           B = 1000L,
                                           seed = policy_report_seed()) {
  paths <- policy_report_paths()
  if (is.null(study2_scales)) study2_scales <- arrow::read_parquet(paths$s2_scales)
  if (is.null(study3_scales)) study3_scales <- arrow::read_parquet(paths$s3_scales)
  if (is.null(study2_items))  study2_items  <- arrow::read_parquet(paths$s2_items)
  if (is.null(study3_items))  study3_items  <- arrow::read_parquet(paths$s3_items)

  study2_scales <- .augment_higher_order_scales(study2_scales, study2_items)
  study3_scales <- .augment_higher_order_scales(study3_scales, study3_items)

  # Canonical S2/S3 five-domain higher-order set, matching the S4 story
  # (R/policy_report/01_country_means_higherorder.R + higher_order_construct_map()):
  #   threat -> scale_threat   (Ideological threat)
  #   aband  -> scale_aband    (Betrayal / abandonment)
  #   fear   -> scale_prag     (Fear / pragmatic accommodation; legacy col name,
  #             canonical SEM latent FEAR — see R/sem_specs.R §canonical-names)
  #   admir  -> admir_score    (mean of the Russia [scale_supf] + China
  #             [scale_supfch] affective-admiration anchors)
  #   gen    -> scale_gen      (General disinformation acceptance)
  cols <- c("scale_threat", "scale_aband", "scale_prag",
            "admir_score", "scale_gen")
  ids  <- c("threat", "aband", "fear", "admir", "gen")
  lbls <- c("Ideological threat",
            "Betrayal / abandonment",
            "Fear / pragmatic accommodation",
            "Foreign-power admiration",
            "General disinformation acceptance")

  dplyr::bind_rows(
    .aggregate_construct(study2_scales, cols, lbls,
                         study = "S2", iso3 = "LTU", name = "Lithuania",
                         B = B, seed = seed, ids = ids),
    .aggregate_construct(study3_scales, cols, lbls,
                         study = "S3", iso3 = "DEU", name = "Germany",
                         B = B, seed = seed, ids = ids)
  )
}

main_04 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  first <- compute_s23_first_order_means()
  higher <- compute_s23_higher_order_means()

  validate_policy_report_table(
    first,
    label = "04a / s23_first_order_means.csv",
    required_cols = c("study", "country_iso3", "construct_id",
                      "n", "mean", "ci_lower", "ci_upper"),
    country_col = "country_iso3",
    expected_countries = c("LTU", "DEU"),
    range_checks = list(
      mean     = c(1, 7),
      ci_lower = c(0.5, 7.5),
      ci_upper = c(0.5, 7.5)
    ),
    min_country_n = 100L
  )

  validate_policy_report_table(
    higher,
    label = "04b / s23_higher_order_means.csv",
    required_cols = c("study", "country_iso3", "construct_id",
                      "n", "mean", "ci_lower", "ci_upper"),
    country_col = "country_iso3",
    expected_countries = c("LTU", "DEU"),
    range_checks = list(
      mean     = c(1, 7),
      ci_lower = c(0.5, 7.5),
      ci_upper = c(0.5, 7.5)
    ),
    min_country_n = 100L
  )

  out_first  <- file.path(paths$tables, "s23_first_order_means.csv")
  out_higher <- file.path(paths$tables, "s23_higher_order_means.csv")
  readr::write_csv(first,  out_first)
  readr::write_csv(higher, out_higher)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_first, nrow(first)))
  policy_report_message(sprintf("wrote %s (rows = %d)", out_higher, nrow(higher)))
  invisible(list(first = first, higher = higher))
}

if (sys.nframe() == 0L) main_04()

Table 7: S2 / S3 higher-order means (full table).

study	country_iso3	country_name	construct_id	construct_label	n	mean	sd	se	ci_lower	ci_upper	scale_min	scale_max
S2	LTU	Lithuania	threat	Ideological threat	582	4.054	1.629	0.070	3.916	4.189	1	7
S2	LTU	Lithuania	aband	Betrayal / abandonment	582	3.798	1.667	0.070	3.663	3.941	1	7
S2	LTU	Lithuania	fear	Fear / pragmatic accommodation	582	4.329	1.922	0.083	4.162	4.498	1	7
S2	LTU	Lithuania	admir	Foreign-power admiration	582	2.141	1.441	0.058	2.030	2.263	1	7
S2	LTU	Lithuania	gen	General disinformation acceptance	582	3.861	1.082	0.046	3.768	3.948	1	7
S3	DEU	Germany	threat	Ideological threat	782	3.349	1.670	0.059	3.236	3.461	1	7
S3	DEU	Germany	aband	Betrayal / abandonment	782	3.721	1.727	0.061	3.599	3.838	1	7
S3	DEU	Germany	fear	Fear / pragmatic accommodation	782	4.043	2.017	0.070	3.905	4.183	1	7
S3	DEU	Germany	admir	Foreign-power admiration	782	2.479	1.519	0.055	2.373	2.597	1	7
S3	DEU	Germany	gen	General disinformation acceptance	782	3.809	1.230	0.044	3.727	3.898	1	7

Table 8

study	country_iso3	country_name	construct_id	construct_label	n	mean	sd	se	ci_lower	ci_upper	scale_min	scale_max
S2	LTU	Lithuania	expl	Exploitation by foreign powers	582	3.851	1.697	0.073	3.719	3.995	1	7
S2	LTU	Lithuania	gay	Opposition to LGBT+ values	582	4.347	2.135	0.090	4.176	4.521	1	7
S2	LTU	Lithuania	migr	Opposition to migration	582	5.113	1.610	0.067	4.980	5.242	1	7
S2	LTU	Lithuania	abanf	Abandoned by foreign allies	582	3.835	1.669	0.067	3.708	3.976	1	7
S2	LTU	Lithuania	abanh	Abandoned by own state	582	3.888	1.843	0.078	3.741	4.047	1	7
S2	LTU	Lithuania	abanm	Abandoned by media	582	3.566	1.940	0.080	3.402	3.720	1	7
S2	LTU	Lithuania	pragr	Pragmatism toward Russia	582	3.020	1.855	0.078	2.859	3.169	1	7
S2	LTU	Lithuania	pragch	Pragmatism toward China	582	3.738	1.614	0.068	3.602	3.874	1	7
S2	LTU	Lithuania	supr	Superiority of Russia	582	2.342	1.562	0.064	2.217	2.468	1	7
S2	LTU	Lithuania	supch	Superiority of China	582	3.303	1.413	0.059	3.185	3.420	1	7

Download: s23_higher_order_means.csv · s23_first_order_means.csv

7. EU pooled benchmarks

One row per construct: the pooled-EU mean and CI plus the minimum and maximum country mean. Country cards overlay these as the EU range and EU mean reference lines.

Code

R/policy_report/09_eu_pooled_benchmarks.R

#' R/policy_report/09_eu_pooled_benchmarks.R
#'
#' EU-pooled benchmarks (mean, CI, country-range) for each higher-order
#' construct and FIMI version. Country snapshots show their country value
#' against this single source of truth.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §5.1
#'
#' Inputs (read from disk if present, recomputed otherwise):
#'   outputs/policy_report/tables/s4_country_means_byconstruct_long.csv
#'   data/wrangled_data/study4_scales.parquet
#'   data/wrangled_data/study4_items.parquet
#'
#' Output:
#'   outputs/policy_report/tables/s4_eu_pooled_benchmarks.csv
#'
#' Columns:
#'   construct_id | construct_label | construct_family | n_total |
#'   mean | sd | se | ci_lower | ci_upper |
#'   min_country_mean | max_country_mean | min_country_iso3 | max_country_iso3
#'
#' Note: the pooled mean is the unweighted *country-mean of country-means*,
#' so each country contributes equally regardless of its respondent count.
#' This is the convention requested by the EU policy framing — readers
#' compare countries to a country-democracy of equal weight.

source(here::here("R", "policy_report", "_helpers.R"))
source(here::here("R", "policy_report", "03_country_means_long.R"))

compute_eu_pooled_benchmarks <- function(country_long = NULL,
                                         B = 1000L,
                                         seed = policy_report_seed()) {
  paths <- policy_report_paths()
  long_path <- file.path(paths$tables, "s4_country_means_byconstruct_long.csv")
  if (is.null(country_long)) {
    country_long <- if (file.exists(long_path)) {
      readr::read_csv(long_path, show_col_types = FALSE)
    } else compute_country_means_long()
  }

  # Defensive: drop tiny-n countries from the pooled benchmark so they don't
  # distort the range. Currently a no-op (the GEO singleton — the original
  # motivating case — is filtered earlier by `policy_report_country_table()`
  # while country-of-residence data is pending from the panel provider) but
  # we keep the guard so future low-n countries do not silently skew the EU
  # range / min / max columns.
  cl <- country_long %>%
    dplyr::filter(!is.na(country_iso3), n >= 30)

  cl %>%
    dplyr::group_by(construct_id, construct_label, construct_family) %>%
    dplyr::summarise(
      n_total      = sum(n, na.rm = TRUE),
      n_countries  = dplyr::n_distinct(country_iso3),
      ci           = list(bootstrap_ci(mean, B = B, seed = seed)),
      sd           = stats::sd(mean, na.rm = TRUE),
      min_country_mean = min(mean, na.rm = TRUE),
      max_country_mean = max(mean, na.rm = TRUE),
      min_country_iso3 = country_iso3[which.min(mean)],
      max_country_iso3 = country_iso3[which.max(mean)],
      .groups = "drop"
    ) %>%
    tidyr::unnest(ci, names_sep = "_") %>%
    dplyr::transmute(
      construct_id, construct_label, construct_family,
      n_total, n_countries,
      mean = ci_mean, se = ci_se, ci_lower = ci_ci_lower, ci_upper = ci_ci_upper,
      sd,
      min_country_mean, max_country_mean,
      min_country_iso3, max_country_iso3
    )
}

main_09 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_eu_pooled_benchmarks()

  validate_policy_report_table(
    df,
    label = "09 / s4_eu_pooled_benchmarks.csv",
    required_cols = c("construct_id", "construct_family", "n_total",
                      "mean", "ci_lower", "ci_upper",
                      "min_country_mean", "max_country_mean"),
    country_col = NULL,
    range_checks = list(
      mean             = c(1, 7),
      min_country_mean = c(1, 7),
      max_country_mean = c(1, 7)
    )
  )

  out_path <- file.path(paths$tables, "s4_eu_pooled_benchmarks.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_09()

Table 9: EU pooled benchmark per construct (full table).

construct_id	construct_label	construct_family	n_total	n_countries	mean	se	ci_lower	ci_upper	sd	min_country_mean	max_country_mean	min_country_iso3	max_country_iso3
aband	Betrayal / abandonment	higher_order	7783	13	4.430	0.128	4.186	4.689	0.488	3.537	5.396	EST	SRB
admir	Foreign-power admiration (composite)	higher_order	7783	13	2.858	0.173	2.544	3.203	0.652	1.875	4.032	EST	BGR
fear	Fear / pragmatic accommodation	higher_order	7783	13	4.671	0.117	4.433	4.886	0.454	3.535	5.215	EST	BGR
fimi_chinese_origin	FIMI: Chinese-origin (news6-8)	fimi	7783	13	4.476	0.051	4.381	4.577	0.194	4.134	4.845	FRA	LTU
fimi_full	FIMI: Full (news1-8)	fimi	7783	13	4.857	0.050	4.765	4.960	0.190	4.616	5.254	DEU	LTU
fimi_russian_origin	FIMI: Russian-origin (news1-5)	fimi	7783	13	5.085	0.056	4.986	5.201	0.211	4.792	5.500	DEU	LTU
fimi_short	FIMI: Short (news2/5/7/8)	fimi	7783	13	4.863	0.055	4.759	4.974	0.208	4.495	5.250	TUR	LTU
gen	General disinformation acceptance	higher_order	7783	13	4.049	0.099	3.858	4.247	0.378	3.287	4.730	EST	SRB
overall	Overall DisInforMeter composite	higher_order	7783	13	4.074	0.117	3.855	4.310	0.445	3.221	4.847	EST	SRB
supf	Foreign-power admiration (Russia)	higher_order	7783	13	2.683	0.200	2.318	3.092	0.756	1.593	4.004	EST	BGR
supfch	Foreign-power admiration (China)	higher_order	7783	13	3.033	0.147	2.764	3.326	0.558	2.157	4.060	EST	BGR
threat	Ideological threat	higher_order	7783	13	4.400	0.113	4.193	4.633	0.429	3.834	5.209	EST	SRB

Download: s4_eu_pooled_benchmarks.csv

8. S4 sample composition by country

Per-country N, age, gender, education, and other background shares. Feeds the sample-composition figure (F-04) and Annex B/C.

Code

R/policy_report/10_sample_composition.R

#' R/policy_report/10_sample_composition.R
#'
#' Per-country demographic composition of the S4 multinational sample.
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §6.1
#'
#' Inputs:
#'   data/wrangled_data/study4_scales.parquet
#'
#' Output:
#'   outputs/policy_report/tables/s4_sample_composition_by_country.csv
#'
#' Columns:
#'   country_iso3 | country_name | cluster | n |
#'   age_mean | age_sd | age_min | age_max |
#'   pct_female | pct_male | pct_other_gender | pct_pref_not_say |
#'   pct_tertiary_education | pct_lower_education |
#'   pct_media_daily
#'
#' Notes on field availability:
#'   - `pct_urban` was requested in the roadmap but is not present in the
#'     wrangled S4 dataset; documented as missing. Source-survey item for
#'     urban / rural settlement was not asked in S4.
#'   - `pct_daily_internet` is approximated from `scale_media_freq` >= 6 ("at
#'     least daily" on the 1-7 frequency scale). Document this proxy when
#'     reporting.
#'   - "Tertiary" = Bachelor's, Master's, Doctoral.
#'     "Lower"    = No formal education, Primary, Secondary.
#'     (Vocational education is reported separately as % vocational.)

source(here::here("R", "policy_report", "_helpers.R"))

compute_sample_composition <- function(study4_scales = NULL) {
  paths <- policy_report_paths()
  if (is.null(study4_scales)) {
    study4_scales <- arrow::read_parquet(paths$s4_scales)
  }
  s4 <- load_s4_country_iso3(study4_scales) %>%
    dplyr::filter(!is.na(country_iso3))

  tertiary <- c("Bachelor's degree", "Master’s degree",
                "Doctoral degree (PhD)")
  lower    <- c("No formal education", "Primary education",
                "Secondary education")
  vocational <- "Vocational education"

  s4 %>%
    dplyr::group_by(country_iso3, country_name, cluster) %>%
    dplyr::summarise(
      n              = dplyr::n(),
      age_mean       = mean(age_midpoint, na.rm = TRUE),
      age_sd         = stats::sd(age_midpoint, na.rm = TRUE),
      age_min        = min(age_midpoint, na.rm = TRUE),
      age_max        = max(age_midpoint, na.rm = TRUE),
      pct_female        = 100 * mean(gender_fct == "Female", na.rm = TRUE),
      pct_male          = 100 * mean(gender_fct == "Male", na.rm = TRUE),
      pct_other_gender  = 100 * mean(gender_fct == "Other", na.rm = TRUE),
      pct_pref_not_say  = 100 * mean(gender_fct == "Prefer not to say", na.rm = TRUE),
      pct_tertiary_education = 100 * mean(education_fct %in% tertiary, na.rm = TRUE),
      pct_lower_education    = 100 * mean(education_fct %in% lower, na.rm = TRUE),
      pct_vocational_education = 100 * mean(education_fct == vocational, na.rm = TRUE),
      pct_media_daily        = 100 * mean(scale_media_freq >= 6, na.rm = TRUE),
      .groups = "drop"
    ) %>%
    dplyr::arrange(country_iso3)
}

main_10 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  df <- compute_sample_composition()

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)

  validate_policy_report_table(
    df,
    label = "10 / s4_sample_composition_by_country.csv",
    required_cols = c("country_iso3", "n", "age_mean", "pct_female",
                      "pct_male", "pct_tertiary_education"),
    country_col = "country_iso3",
    expected_countries = expected,
    range_checks = list(
      age_mean         = c(0, 110),
      pct_female       = c(0, 100),
      pct_male         = c(0, 100),
      pct_tertiary_education = c(0, 100),
      pct_lower_education    = c(0, 100),
      pct_media_daily        = c(0, 100)
    ),
    min_country_n = 100L
  )

  out_path <- file.path(paths$tables, "s4_sample_composition_by_country.csv")
  readr::write_csv(df, out_path)
  policy_report_message(sprintf("wrote %s (rows = %d)", out_path, nrow(df)))
  invisible(df)
}

if (sys.nframe() == 0L) main_10()

Table 10

country_iso3	country_name	cluster	n	age_mean	age_sd	age_min	age_max	pct_female	pct_male	pct_other_gender	pct_pref_not_say	pct_tertiary_education	pct_lower_education	pct_vocational_education	pct_media_daily
AUT	Austria	Western	599	45.62	16.51	23.5	67	51.75	47.91	0.33	0.00	28.21	28.88	42.90	7.68
BEL	Belgium	Western	595	46.42	15.71	23.5	67	48.91	51.09	0.00	0.00	45.04	41.18	13.78	10.42
BGR	Bulgaria	Central-East	592	43.76	15.10	23.5	67	54.22	45.78	0.00	0.00	44.76	32.94	22.30	8.61
DEU	Germany	Western	598	45.82	15.75	23.5	67	50.00	50.00	0.00	0.00	36.62	17.06	46.32	8.86
EST	Estonia	Baltic	604	47.11	15.87	23.5	67	54.30	45.36	0.33	0.00	37.09	43.21	19.70	4.80
FRA	France	Western	596	45.97	15.43	23.5	67	48.66	51.01	0.34	0.00	40.77	32.72	26.51	6.04
HUN	Hungary	Central-East	599	44.03	15.36	23.5	67	52.25	47.75	0.00	0.00	23.87	50.58	25.54	5.84
ITA	Italy	Southern	606	48.58	15.01	23.5	67	46.37	53.63	0.00	0.00	35.97	50.33	13.70	11.22
LTU	Lithuania	Baltic	593	48.07	15.93	23.5	67	55.14	44.18	0.17	0.51	50.08	22.43	27.49	7.42
LVA	Latvia	Baltic	596	47.90	15.99	23.5	67	55.70	43.96	0.17	0.17	38.26	27.01	34.73	3.19
POL	Poland	Central-East	600	42.62	15.27	23.5	67	53.50	46.33	0.00	0.17	31.50	57.83	10.67	11.17
SRB	Serbia	Southern	606	43.47	11.65	23.5	67	67.66	32.34	0.00	0.00	52.64	33.50	13.86	7.59
TUR	Turkey	Southern	599	41.79	14.59	23.5	67	47.25	52.75	0.00	0.00	56.09	23.87	20.03	27.38

Download: s4_sample_composition_by_country.csv

9. Country geometry layer

A reusable sf object: Natural Earth admin-0 (1:50 m) filtered to the 13 S4 countries plus a grey neighbourhood backdrop, reprojected to EPSG:3035 (ETRS89 / Lambert Azimuthal Equal-Area Europe) — the convention every EU report uses. It is cached as RDS so the map scripts never re-download or re-project. Because re-projection is slow and the layer never changes, the builder is dormant on render; re-run it manually when the country set changes.

Code

R/policy_report/13_country_geometries.R

#' R/policy_report/13_country_geometries.R
#'
#' Build a single sf object that map scripts join country-level CSVs against.
#' Uses Natural Earth admin-0 1:50 m via the `rnaturalearth` package and
#' projects to EPSG:3035 (ETRS89 / LAEA Europe).
#'
#' Roadmap reference:
#'   docs/reports/2026-05-21_policy-report-content/03_new-analyses-roadmap.md §9.1
#'
#' Inputs:
#'   rnaturalearth::ne_countries(scale = 50)
#'
#' Outputs:
#'   outputs/policy_report/geometries/policy_report_country_geometries.rds
#'     sf object with columns: country_iso3 | country_name | cluster |
#'                              in_s4 | geometry  (EPSG:3035)
#'   outputs/policy_report/cache/policy_report_country_geometries_audit.csv
#'     iso3 | name | in_s4 | resolved (TRUE if found in Natural Earth) |
#'     ne_admin (the matched admin name) | note
#'
#' Special cases verified:
#'   * Kosovo (XKX) — Natural Earth uses iso_a3 = "-99" with sovereignt =
#'     "Kosovo"; we resolve by name.
#'   * Serbia (SRB) — straightforward iso_a3 = "SRB".
#'   * Georgia (GEO) — straightforward iso_a3 = "GEO".
#'   * Turkey  (TUR) — straightforward iso_a3 = "TUR".

source(here::here("R", "policy_report", "_helpers.R"))

# Optional: include Kosovo for the neighbourhood backdrop even though S4 did
# not include it as a wave.
.policy_report_extra_countries <- function() {
  tibble::tribble(
    ~country_iso3, ~country_name, ~cluster,            ~in_s4,
    "XKX",         "Kosovo",      "Southern",          FALSE
  )
}

build_country_geometries <- function() {
  if (!requireNamespace("rnaturalearth", quietly = TRUE)) {
    stop("Install `rnaturalearth` to build country geometries.")
  }
  if (!requireNamespace("sf", quietly = TRUE)) {
    stop("Install `sf` to build country geometries.")
  }

  ne <- suppressWarnings(rnaturalearth::ne_countries(scale = 50,
                                                     returnclass = "sf"))
  # Some Natural Earth releases use the field `iso_a3`, others `iso_a3_eh`.
  iso_col <- intersect(c("iso_a3_eh", "iso_a3"), names(ne))[1]
  if (is.na(iso_col)) stop("Natural Earth missing iso_a3 column")
  name_col <- intersect(c("sovereignt", "name_long", "admin"), names(ne))[1]

  s4_tbl <- policy_report_country_table() %>%
    dplyr::filter(!is.na(country_iso3)) %>%
    dplyr::transmute(country_iso3, country_name, cluster, in_s4 = TRUE)
  extra <- .policy_report_extra_countries()
  countries <- dplyr::bind_rows(s4_tbl, extra)

  # First-pass: iso3 lookup.
  iso3_lookup <- function(iso3) {
    hit <- ne[ne[[iso_col]] == iso3 & !is.na(ne[[iso_col]]), , drop = FALSE]
    if (nrow(hit) == 0L) return(NULL)
    hit
  }
  # Fallback: name-based for entries Natural Earth marks "-99" (Kosovo).
  name_lookup <- function(name) {
    hit <- ne[!is.na(ne[[name_col]]) &
                stringr::str_to_lower(ne[[name_col]]) == stringr::str_to_lower(name), ,
              drop = FALSE]
    if (nrow(hit) == 0L) return(NULL)
    hit
  }

  audit <- tibble::tibble(
    country_iso3 = character(),
    country_name = character(),
    in_s4        = logical(),
    resolved     = logical(),
    ne_admin     = character(),
    note         = character()
  )

  feats <- list()
  for (i in seq_len(nrow(countries))) {
    iso <- countries$country_iso3[i]; nm <- countries$country_name[i]
    feat <- iso3_lookup(iso)
    note <- ""
    if (is.null(feat) || nrow(feat) == 0L) {
      feat <- name_lookup(nm)
      note <- "resolved by name (iso_a3 != ISO3 in Natural Earth)"
    }
    if (is.null(feat) || nrow(feat) == 0L) {
      audit <- dplyr::bind_rows(audit, tibble::tibble(
        country_iso3 = iso, country_name = nm,
        in_s4 = countries$in_s4[i], resolved = FALSE,
        ne_admin = NA_character_, note = "NOT FOUND in Natural Earth"))
      next
    }
    feat$country_iso3 <- iso
    feat$country_name <- nm
    feat$cluster      <- countries$cluster[i]
    feat$in_s4        <- countries$in_s4[i]
    feats[[length(feats) + 1L]] <- feat[, c("country_iso3", "country_name",
                                            "cluster", "in_s4")] %>%
      sf::st_as_sf()
    audit <- dplyr::bind_rows(audit, tibble::tibble(
      country_iso3 = iso, country_name = nm,
      in_s4 = countries$in_s4[i], resolved = TRUE,
      ne_admin = as.character(feat[[name_col]][1]), note = note))
  }

  if (length(feats) == 0L) stop("No country geometries resolved.", call. = FALSE)
  out <- do.call(rbind, feats)
  out <- sf::st_transform(out, 3035)
  list(geom = out, audit = audit)
}

main_13 <- function() {
  paths <- policy_report_paths()
  ensure_policy_report_dirs()

  res <- build_country_geometries()
  geom <- res$geom
  audit <- res$audit

  expected <- setdiff(policy_report_country_table()$country_iso3, NA)
  unresolved <- audit %>% dplyr::filter(!resolved)
  if (nrow(unresolved) > 0L) {
    stop(sprintf("13 / geometries: unresolved countries: %s",
                 paste(unresolved$country_iso3, collapse = ", ")),
         call. = FALSE)
  }

  policy_report_message(sprintf(
    "13 / geometries: resolved %d countries (S4 = %d, neighbourhood = %d) in EPSG:3035",
    nrow(audit), sum(audit$in_s4), sum(!audit$in_s4)))
  policy_report_message(sprintf(
    "  S4 coverage check: missing = %s; extra = %s",
    paste(setdiff(expected, audit$country_iso3[audit$in_s4]), collapse = ", "),
    paste(setdiff(audit$country_iso3[audit$in_s4], expected), collapse = ", ")
  ))

  out_rds <- file.path(paths$geometries, "policy_report_country_geometries.rds")
  fs::dir_create(dirname(out_rds), recurse = TRUE)
  saveRDS(geom, out_rds)
  out_audit <- file.path(paths$cache, "policy_report_country_geometries_audit.csv")
  readr::write_csv(audit, out_audit)
  policy_report_message(sprintf("wrote %s (features = %d)", out_rds, nrow(geom)))
  policy_report_message(sprintf("wrote %s (rows = %d)", out_audit, nrow(audit)))
  invisible(res)
}

if (sys.nframe() == 0L) main_13()

Note

The in-scope country set is Austria, Belgium, Bulgaria, Estonia, France, Germany, Hungary, Italy, Latvia, Lithuania, Poland, Serbia, Turkey. Georgia is held out of the current cut: the S4 wrangled parquet still carries country-of-origin rather than residence, which leaves Georgia with a single respondent — too few for any country-level visualisation. It is restored once the panel provider returns residence data.

Country reference table

Table 11: The 13 in-scope S4 countries and their regional clusters (from `R/policy_report/_helpers.R`).

Country	ISO3	Regional cluster
Estonia	EST	Baltic
Latvia	LVA	Baltic
Lithuania	LTU	Baltic
Bulgaria	BGR	Central-East
Hungary	HUN	Central-East
Poland	POL	Central-East
Italy	ITA	Southern
Serbia	SRB	Southern
Turkey	TUR	Southern
Austria	AUT	Western
Belgium	BEL	Western
France	FRA	Western
Germany	DEU	Western