オンライン上での補遺と再現コード

多党制は経済投票を弱めるのか？：政党の手がかりと経済の手がかりをめぐるコンジョイント実験

Show All Code Hide All Code

README：再現方法とファイル構成

このオンライン補遺と再現コードは、論文「多党制は経済投票を弱めるのか？：政党の手がかりと経済の手がかりをめぐるコンジョイント実験」で報告する3つの実験の分析について、本文図、補遺図表、頑健性分析、無作為化・バランス診断、および支持政党別分析結果をまとめ、さらにそれらを再現するためのコードをまとめたものである。以下の手順で、入力データの読込みから最終的な図表・診断結果の整理までを一括して実行できる。

1. 再現に必要なファイル等

次の4ファイルを同じ作業ディレクトリに置いてもらう。データファイル名や保存場所を変更する場合は、このRmd冒頭の params を変更してもらえばよい。

ファイル	内容
partynum.csv	実験1の入力データ
conjoint_study2.csv	実験2の入力データ
conjoint_S3.csv	実験3の入力データ

2. 必要なRパッケージ

分析コードで使用する主要パッケージは以下のとおりである。

install.packages(c(
  "dplyr", "tidyr", "stringr", "purrr", "readr",
  "fixest", "tibble", "forcats", "ggplot2", "scales",
  "survival", "ggtext", "patchwork", "rmarkdown", "knitr"
))

3. 各種のデフォルト設定

冒頭の params で、入力ファイル、出力先、ブートストラップ回数を変更可能である。現在の主要なデフォルト値は次のとおりである。

パラメータ	デフォルト	意味
output_root	conjoint_replication_results	全出力を保存するルートディレクトリ
relative_cue_bootstrap_B	2000	主要な重要度・相対比重のブートストラップ反復数
support_bootstrap_B	500	支持政党別分析のブートストラップ反復数

4. 出力ファイル

分析結果はデフォルトで conjoint_replication_results/ 内に保存される設定になっている。主な構成は以下の通り。

• main_text/：本文用の図と表
• supplement/：実験別および実験横断の補遺図表（CSV、LaTeX、図）
• diagnostics/：標本スクリーニング、割付バランス、プロフィール無作為化の診断
• model_objects/：再利用可能なモデル・分析オブジェクト
• logs/：sessionInfo などの再現性情報

各分析の途中の経過作成される各種オブジェクトなどは _working/ に保存され、最終段階で上記のディレクトリに整理するように設定した。Rおよび各パッケージの実行環境は、分析完了後に sessionInfo として保存される設定となっている。

5. このオンライン補遺と再現コードの読み方

A節は本文・補遺の図表を生成する実行コード、B節以降は分析標本、推定量、無作為化・バランス診断、および各補足結果を、コードと対応させて確認するためのセクションである。画面上部の Show All Code / Hide All Code または右上の Code メニューから、コード全体の表示・非表示を切り替えられる。

A. 各図表の再現コード

A.1 共通コード

# 共通コード
options(stringsAsFactors = FALSE)

unified_output_root <- getOption(
  "conjoint.output_root",
  "conjoint_replication_results"
)

dir.create(
  unified_output_root,
  showWarnings = FALSE,
  recursive = TRUE
)

unified_config <- list(
  output_root = unified_output_root,

  cue_importance_metric_version = "v4_screening_autodetect",

  relative_cue_bootstrap_B = as.integer(
    getOption("conjoint.relative_cue_bootstrap_B", 2000L)
  ),
  relative_cue_bootstrap_seed = as.integer(
    getOption("conjoint.relative_cue_bootstrap_seed", 20260730L)
  ),
  relative_cue_bootstrap_progress_every = as.integer(
    getOption("conjoint.relative_cue_bootstrap_progress_every", 100L)
  ),
  rerun_relative_cue_bootstrap = isTRUE(
    getOption("conjoint.rerun_relative_cue_bootstrap", FALSE)
  ),

  min_support_total_n = as.integer(
    getOption("conjoint.min_support_total_n", 150L)
  ),
  min_support_cell_n = as.integer(
    getOption("conjoint.min_support_cell_n", 40L)
  ),
  support_bootstrap_B = as.integer(
    getOption("conjoint.support_bootstrap_B", 500L)
  ),
  support_bootstrap_seed = as.integer(
    getOption("conjoint.support_bootstrap_seed", 20260806L)
  ),
  rerun_support_bootstrap = isTRUE(
    getOption("conjoint.rerun_support_bootstrap", FALSE)
  ),

  study1 = list(
    data_file = getOption("conjoint.study1_data", "partynum.csv"),
    output_dir = file.path(unified_output_root, "_working", "study1")
  ),
  study2 = list(
    data_file = getOption("conjoint.study2_data", "conjoint_study2.csv"),
    output_dir = file.path(unified_output_root, "_working", "study2")
  ),
  study3 = list(
    data_file = getOption("conjoint.study3_data", "conjoint_S3.csv"),
    output_dir = file.path(unified_output_root, "_working", "study3")
  )
)

cat(
  "Unified conjoint replication pipeline\n",
  "Output root: ", unified_config$output_root, "\n",
  "Study 1 data: ", unified_config$study1$data_file, "\n",
  "Study 2 data: ", unified_config$study2$data_file, "\n",
  "Study 3 data: ", unified_config$study3$data_file, "\n",
  sep = ""
)


detect_final_consent_column <- function(
  raw,
  preferred_candidates = c("Q8.1", "Q9.1", "Q10.1"),
  study_label = "Study"
) {
  if (!is.data.frame(raw) || ncol(raw) == 0L) {
    stop("Check data")
  }

  preview_n <- min(12L, nrow(raw))

  normalize_preview <- function(x) {
    x <- as.character(x)
    x[is.na(x)] <- ""
    x <- gsub("　", " ", x, fixed = TRUE)
    x <- gsub("[[:space:]]+", " ", x)
    trimws(x)
  }

  score_one <- function(column_name) {
    preview <- paste(
      normalize_preview(utils::head(raw[[column_name]], preview_n)),
      collapse = " "
    )

    score <- 0L

    if (grepl("最終意思確認", preview, fixed = TRUE)) {
      score <- score + 8L
    }
    if (grepl("こちらが調査の最後の画面", preview, fixed = TRUE) ||
        grepl("調査の最後の画面", preview, fixed = TRUE)) {
      score <- score + 6L
    }
    if (grepl("回答結果を送信する", preview, fixed = TRUE)) {
      score <- score + 8L
    }
    if (grepl("回答結果を送信しない", preview, fixed = TRUE) ||
        grepl("回答を送信しない", preview, fixed = TRUE)) {
      score <- score + 5L
    }
    if (grepl("本調査の主旨に同意", preview, fixed = TRUE) ||
        grepl("本調査の趣旨に同意", preview, fixed = TRUE)) {
      score <- score + 3L
    }
    if (column_name %in% preferred_candidates) {
      score <- score + 1L
    }

    score
  }

  candidate_table <- data.frame(
    column = names(raw),
    score = vapply(names(raw), score_one, integer(1)),
    stringsAsFactors = FALSE
  )

  candidate_table <- candidate_table[candidate_table$score > 0L, , drop = FALSE]

  if (nrow(candidate_table) == 0L) {
    existing_preferred <- preferred_candidates[
      preferred_candidates %in% names(raw)
    ]

    if (length(existing_preferred) == 1L) {
      message("Final consent: ", existing_preferred[[1]])
      return(existing_preferred[[1]])
    }

    likely_question_columns <- names(raw)[
      grepl("^Q[0-9]+(\\.[0-9]+)?(_[0-9]+)?$", names(raw))
    ]

    stop("Check final consent")
  }

  max_score <- max(candidate_table$score)
  best <- candidate_table$column[candidate_table$score == max_score]

  if (length(best) > 1L) {
    preferred_best <- preferred_candidates[
      preferred_candidates %in% best
    ]

    if (length(preferred_best) >= 1L) {
      best <- preferred_best[[1]]
    } else {
      stop("Check final consent")
    }
  }

  message("Final consent: ", best[[1]])


  best[[1]]
}

qualtrics_preview_text <- function(raw, column_name, preview_n = 12L) {
  if (!column_name %in% names(raw)) {
    return("")
  }

  x <- as.character(utils::head(raw[[column_name]], min(preview_n, nrow(raw))))
  x[is.na(x)] <- ""
  x <- gsub("　", " ", x, fixed = TRUE)
  x <- gsub("[[:space:]]+", " ", x)
  trimws(paste(x, collapse = " "))
}

fullwidth_digit <- function(n) {
  substr("０１２３４５６７８９", n + 1L, n + 1L)
}

question_order_key <- function(x) {
  m <- regexec("^Q([0-9]+)\\.([0-9]+)", x)
  parts <- regmatches(x, m)

  vapply(
    parts,
    function(z) {
      if (length(z) < 3L) {
        return(Inf)
      }
      as.numeric(z[[2]]) * 1000 + as.numeric(z[[3]])
    },
    numeric(1)
  )
}

detect_attention_check_column <- function(
  raw,
  preferred_candidates = c("Q25.1_11", "Q25.1_10"),
  study_label = "Study"
) {
  metadata <- data.frame(
    column = names(raw),
    text = vapply(names(raw), function(v) qualtrics_preview_text(raw, v), character(1)),
    stringsAsFactors = FALSE
  )

  score <- integer(nrow(metadata))
  score <- score + ifelse(grepl("必ず", metadata$text, fixed = TRUE), 8L, 0L)
  score <- score + ifelse(grepl("選ん", metadata$text, fixed = TRUE), 5L, 0L)
  score <- score + ifelse(grepl("3|３", metadata$text), 4L, 0L)
  score <- score + ifelse(metadata$column %in% preferred_candidates, 1L, 0L)
  metadata$score <- score

  candidates <- metadata[
    grepl("必ず", metadata$text, fixed = TRUE) &
      grepl("選ん", metadata$text, fixed = TRUE) &
      grepl("3|３", metadata$text),
    ,
    drop = FALSE
  ]

  if (nrow(candidates) == 0L) {
    stop("Check attention item")
  }

  candidates <- candidates[order(-candidates$score), , drop = FALSE]
  best_score <- candidates$score[[1]]
  best <- candidates$column[candidates$score == best_score]

  if (length(best) > 1L) {
    preferred_best <- preferred_candidates[preferred_candidates %in% best]
    if (length(preferred_best) == 1L) {
      best <- preferred_best
    } else {
      stop("Check attention item")
    }
  }

  message("Attention item: ", best[[1]])
  best[[1]]
}

response_code_numeric <- function(x) {
  x <- as.character(x)
  x[is.na(x)] <- ""
  x <- gsub("　", " ", x, fixed = TRUE)
  x <- trimws(gsub("[[:space:]]+", " ", x))

  exact <- grepl("^[0-9]+(?:\\.0+)?$", x, perl = TRUE)
  out <- rep(NA_real_, length(x))
  out[exact] <- suppressWarnings(as.numeric(x[exact]))

  trailing <- regexec("\\(([0-9]+)\\)\\s*$", x)
  trailing_parts <- regmatches(x, trailing)
  trailing_code <- vapply(
    trailing_parts,
    function(z) if (length(z) >= 2L) as.numeric(z[[2]]) else NA_real_,
    numeric(1)
  )
  out[is.na(out) & !is.na(trailing_code)] <- trailing_code[is.na(out) & !is.na(trailing_code)]

  first_num <- suppressWarnings(readr::parse_number(x))
  out[is.na(out)] <- first_num[is.na(out)]
  out
}

detect_attention_correct_code <- function(
  x,
  displayed_answer = 3L,
  recoded_answer = 6L,
  study_label = "Study"
) {
  code <- response_code_numeric(x)
  tab <- sort(table(code, useNA = "no"), decreasing = TRUE)

  n_display <- sum(code == displayed_answer, na.rm = TRUE)
  n_recode <- sum(code == recoded_answer, na.rm = TRUE)

  chosen <- if (n_recode > n_display) recoded_answer else displayed_answer
  n_nonmissing <- sum(!is.na(code))
  n_chosen <- sum(code == chosen, na.rm = TRUE)

  cat("\n", study_label, "：指示項目の回答コード分布\n", sep = "")
  print(utils::head(tab, 15L))
  cat(
    "採用する正答コード: ", chosen,
    "（表示上の正答は3）\n",
    sep = ""
  )

  if (n_nonmissing == 0L || n_chosen / n_nonmissing < 0.50) {
    stop("Check attention item")
  }

  as.character(chosen)
}

detect_conjoint_choice_map <- function(
  raw,
  party_numbers = 2:5,
  study_label = "Study"
) {
  metadata <- data.frame(
    column = names(raw),
    text = vapply(names(raw), function(v) qualtrics_preview_text(raw, v), character(1)),
    stringsAsFactors = FALSE
  )

  maps <- lapply(
    party_numbers,
    function(n_party) {
      digit_pattern <- paste0("(?:", n_party, "|", fullwidth_digit(n_party), ")\\s*つの選択肢")

      hit <- grepl("以下に", metadata$text, fixed = TRUE) &
        grepl("選択肢", metadata$text, fixed = TRUE) &
        grepl(digit_pattern, metadata$text, perl = TRUE) &
        grepl("衆議院", metadata$text, fixed = TRUE) &
        !grepl("提示された.*選択肢の数", metadata$text, perl = TRUE) &
        grepl("^Q[0-9]+\\.[0-9]+$", metadata$column)

      candidates <- metadata[hit, , drop = FALSE]
      candidates <- candidates[
        order(question_order_key(candidates$column)),
        ,
        drop = FALSE
      ]

      if (nrow(candidates) != 5L) {
        stop("Check choice columns")
      }

      data.frame(
        party_n = n_party,
        task = seq_len(5L),
        choice_var = candidates$column,
        stringsAsFactors = FALSE
      )
    }
  )

  out <- dplyr::bind_rows(maps)
  message("Choice columns: OK")
  print(out)
  out
}

detect_manipulation_map <- function(raw, choice_map, study_label = "Study") {
  metadata_text <- setNames(
    vapply(names(raw), function(v) qualtrics_preview_text(raw, v), character(1)),
    names(raw)
  )

  out <- lapply(
    sort(unique(choice_map$party_n)),
    function(n_party) {
      vars <- choice_map$choice_var[choice_map$party_n == n_party]
      roots <- sub("\\.[0-9]+$", "", vars)
      root <- names(sort(table(roots), decreasing = TRUE))[[1]]
      suffix <- suppressWarnings(as.integer(sub("^.*\\.", "", vars)))
      expected <- paste0(root, ".", max(suffix, na.rm = TRUE) + 1L)

      candidates <- names(metadata_text)[
        startsWith(names(metadata_text), paste0(root, ".")) &
          grepl("提示された", metadata_text, fixed = TRUE) &
          grepl("選択肢の数", metadata_text, fixed = TRUE)
      ]

      if (expected %in% candidates) {
        chosen <- expected
      } else if (length(candidates) == 1L) {
        chosen <- candidates[[1]]
      } else {
        stop("Check manipulation item")
      }

      data.frame(
        party_n = n_party,
        manipulation_var = chosen,
        correct_answer = as.character(n_party),
        stringsAsFactors = FALSE
      )
    }
  )

  out <- dplyr::bind_rows(out)
  message("Manipulation item: OK")
  print(out)
  out
}

parse_choice_position <- function(x) {
  x <- as.character(x)
  x[is.na(x)] <- ""
  x <- gsub("　", " ", x, fixed = TRUE)
  x <- trimws(gsub("[[:space:]]+", " ", x))

  label_match <- regexec("(?:政党|状況|選択肢)\\s*([1-5])", x, perl = TRUE)
  label_parts <- regmatches(x, label_match)
  label_num <- vapply(
    label_parts,
    function(z) if (length(z) >= 2L) as.numeric(z[[2]]) else NA_real_,
    numeric(1)
  )

  exact <- grepl("^[1-5](?:\\.0+)?$", x, perl = TRUE)
  exact_num <- rep(NA_real_, length(x))
  exact_num[exact] <- suppressWarnings(as.numeric(x[exact]))

  trailing <- regexec("\\(([1-5])\\)\\s*$", x)
  trailing_parts <- regmatches(x, trailing)
  trailing_num <- vapply(
    trailing_parts,
    function(z) if (length(z) >= 2L) as.numeric(z[[2]]) else NA_real_,
    numeric(1)
  )

  out <- label_num
  out[is.na(out)] <- exact_num[is.na(out)]
  out[is.na(out)] <- trailing_num[is.na(out)]
  out
}

A.2 実験1：本文の図4・図5

# 本文コード
study1_env <- local({
required_packages <- c(
    "dplyr",
    "tidyr",
    "stringr",
    "purrr",
    "readr",
    "fixest",
    "tibble",
    "forcats",
    "ggplot2",
    "scales",
    "survival",
    "ggtext",
    "patchwork"
  )

  missing_packages <- required_packages[
    !vapply(required_packages, requireNamespace, logical(1), quietly = TRUE)
  ]

  if (length(missing_packages) > 0) {
    stop("No packages")
  }

  library(dplyr)
  library(tidyr)
  library(stringr)
  library(purrr)
  library(readr)
  library(fixest)
  library(tibble)
  library(forcats)
  library(ggplot2)
  library(scales)
  library(survival)
  library(patchwork)

  data_file <- unified_config$study1$data_file
  output_dir <- unified_config$study1$output_dir

  dir.create(output_dir, showWarnings = FALSE, recursive = TRUE)

  require_initial_consent <- TRUE
  require_final_consent <- TRUE
  initial_consent_var <- "Q1.1"
  final_consent_var <- "Q8.1"

  require_attention_check <- FALSE
  require_manipulation_check <- FALSE
  attention_check_var <- NA_character_
  attention_check_correct <- NA_character_

  require_all_five_tasks <- TRUE

  use_education_covariate <- FALSE

  relative_cue_bootstrap_B <- unified_config$relative_cue_bootstrap_B
  relative_cue_bootstrap_seed <- unified_config$relative_cue_bootstrap_seed + 1L
  relative_cue_bootstrap_progress_every <- unified_config$relative_cue_bootstrap_progress_every

  rerun_relative_cue_bootstrap <- unified_config$rerun_relative_cue_bootstrap


  norm_text <- function(x) {
    x %>%
      as.character() %>%
      str_squish() %>%
      str_replace_all("～", "~") %>%
      str_replace_all("〜", "~")
  }

  as_num <- function(x) {
    suppressWarnings(readr::parse_number(norm_text(x)))
  }

  is_response_code <- function(x, code) {
    x_norm <- norm_text(x)
    code_chr <- as.character(code)

    x_norm == code_chr |
      stringr::str_detect(x_norm, paste0("\\(", code_chr, "\\)$"))
  }

  first_existing <- function(dat, candidates) {
    out <- candidates[candidates %in% names(dat)]
    if (length(out) == 0) NA_character_ else out[1]
  }

  get_var <- function(dat, candidates) {
    v <- first_existing(dat, candidates)
    if (is.na(v)) {
      rep(NA_character_, nrow(dat))
    } else {
      dat[[v]]
    }
  }

  relevel_if_present <- function(x, ref) {
    x <- factor(x)
    if (ref %in% levels(x)) {
      relevel(x, ref = ref)
    } else {
      x
    }
  }

  factor_miss <- function(x, miss = "欠損・無回答") {
    x <- norm_text(x)
    x[is.na(x) | x == "" | x == "NA"] <- miss
    factor(x)
  }

  mean_impute <- function(x) {
    x <- as.numeric(x)
    miss <- as.integer(is.na(x))

    if (all(is.na(x))) {
      value <- x
    } else {
      value <- ifelse(is.na(x), mean(x, na.rm = TRUE), x)
    }

    list(value = value, miss = miss)
  }

  write_csv_safely <- function(x, filename) {
    readr::write_csv(x, file.path(output_dir, filename), na = "")
  }

  save_plot <- function(filename, plot, width, height, dpi = 300) {
    ggplot2::ggsave(
      filename = file.path(output_dir, filename),
      plot = plot,
      width = width,
      height = height,
      dpi = dpi
    )
  }


  if (!file.exists(data_file)) {
    stop("Check data")
  }

  raw <- readr::read_csv(
    data_file,
    col_types = cols(.default = col_character()),
    show_col_types = FALSE,
    name_repair = "minimal"
  )

  if (!"ResponseId" %in% names(raw)) {
    stop("Check data")
  }

  names(raw) <- names(raw) %>%
    str_replace("^F\\.(\\d+)\\.(\\d+)\\.(\\d+)$", "F-\\1-\\2-\\3") %>%
    str_replace("^F\\.(\\d+)\\.(\\d+)$", "F-\\1-\\2")

  if (
    require_final_consent &&
      (
        is.na(final_consent_var) ||
          !final_consent_var %in% names(raw)
      )
  ) {
    consent_question_pattern <- paste0(
      "回答結果を送信する|",
      "回答を送信しない|",
      "回答結果を送信しない|",
      "最終意思確認"
    )

    preview_n <- min(10L, nrow(raw))

    detected_final_consent_vars <- names(raw)[
      vapply(
        raw,
        function(column) {
          preview <- norm_text(
            utils::head(
              column,
              preview_n
            )
          )

          any(
            stringr::str_detect(
              preview,
              consent_question_pattern
            ),
            na.rm = TRUE
          )
        },
        logical(1)
      )
    ]

    if (length(detected_final_consent_vars) == 1L) {
      final_consent_var <- detected_final_consent_vars[[1]]

      message("Final consent: ", final_consent_var)
    } else if (length(detected_final_consent_vars) > 1L) {
      stop("Check final consent")
    } else {
      likely_question_columns <- names(raw)[
        stringr::str_detect(
          names(raw),
          "^Q[0-9]+(?:\\.[0-9]+)?$"
        )
      ]

      stop("Check final consent")
    }
  }

  df_header_removed <- raw %>%
    filter(
      !is.na(ResponseId),
      ResponseId != "",
      !str_detect(
        norm_text(ResponseId),
        "^(Response ID|回答ID)$|ImportId"
      )
    ) %>%
    mutate(ID = as.character(ResponseId))

  duplicate_ids <- df_header_removed %>%
    count(ID) %>%
    filter(n > 1)

  if (nrow(duplicate_ids) > 0) {
    print(duplicate_ids)
    stop("Check")
  }

  sample_flow <- tibble(
    stage = "Qualtrics質問文行・ImportId行を除外後",
    n = nrow(df_header_removed)
  )

  df <- df_header_removed

  if (require_initial_consent) {
    if (is.na(initial_consent_var) || !initial_consent_var %in% names(df)) {
      stop("Check initial consent")
    }
    df <- df %>%
      filter(
        is_response_code(.data[[initial_consent_var]], 1) |
          str_detect(
            norm_text(.data[[initial_consent_var]]),
            "趣旨に同意して.*協力する"
          )
      )
    sample_flow <- bind_rows(
      sample_flow,
      tibble(stage = "初回同意回答を保持", n = nrow(df))
    )
  }

  if (require_final_consent) {
    if (is.na(final_consent_var) || !final_consent_var %in% names(df)) {
      stop("Check final consent")
    }
    df <- df %>%
      filter(
        is_response_code(.data[[final_consent_var]], 1) |
          str_detect(
            norm_text(.data[[final_consent_var]]),
            "同意し.*回答結果を送信する"
          )
      )
    sample_flow <- bind_rows(
      sample_flow,
      tibble(stage = "最終同意回答を保持", n = nrow(df))
    )
  }

  print(sample_flow)
  write_csv_safely(sample_flow, "sample_flow_before_conjoint.csv")


  choice_map <- tribble(
    ~party_n, ~task, ~choice_var,
    2, 1, "Q240",
    2, 2, "Q253",
    2, 3, "Q254",
    2, 4, "Q255",
    2, 5, "Q256",

    3, 1, "Q235",
    3, 2, "Q241",
    3, 3, "Q242",
    3, 4, "Q243",
    3, 5, "Q244",

    4, 1, "Q238",
    4, 2, "Q245",
    4, 3, "Q246",
    4, 4, "Q247",
    4, 5, "Q248",

    5, 1, "Q239",
    5, 2, "Q249",
    5, 3, "Q250",
    5, 4, "Q251",
    5, 5, "Q252"
  )

  if (require_manipulation_check) {
    stop("Check")
  }


  level_to_attr_var <- function(x) {
    x <- norm_text(x)

    case_when(
      x %in% c("右派・保守的", "中道", "左派・革新的") ~
        "policy_position",

      x %in% c("与党", "野党") ~
        "government_status",

      str_detect(x, "GDP成長率") ~
        "gdp_growth",

      str_detect(x, "日経平均") ~
        "nikkei",

      x %in% c("10以下", "10~49", "50~99", "100~199", "200以上") ~
        "seats",

      str_detect(x, "CPI|物価") ~
        "cpi",

      str_detect(x, "失業率|雇用") ~
        "unemployment",

      TRUE ~ NA_character_
    )
  }

  required_attr_vars <- c(
    "policy_position",
    "government_status",
    "gdp_growth",
    "nikkei",
    "seats",
    "cpi",
    "unemployment"
  )

  allowed_levels <- list(
    policy_position = c("右派・保守的", "中道", "左派・革新的"),
    government_status = c("与党", "野党"),
    gdp_growth = c(
      "GDP成長率±0％",
      "GDP成長率プラス1％",
      "GDP成長率マイナス1％"
    ),
    nikkei = c(
      "日経平均前月同期比プラス1000円",
      "日経平均前月同期比マイナス1000円",
      "日経平均前月同期比変わらず"
    ),
    seats = c("10以下", "10~49", "50~99", "100~199", "200以上"),
    cpi = c(
      "CPI前期比±0ポイント",
      "CPI前期比プラス1ポイント",
      "CPI前期比マイナス1ポイント"
    ),
    unemployment = c(
      "失業率前期比±0％",
      "失業率前期比プラス1％",
      "失業率前期比マイナス1％"
    )
  )


  make_profile_long <- function(dat, n_party) {

    map_n <- choice_map %>%
      filter(party_n == n_party)

    qvars <- map_n$choice_var

    missing_q <- setdiff(qvars, names(dat))
    if (length(missing_q) > 0) {
      stop("Check choice columns")
    }

    dat_n <- dat %>%
      filter(
        if_any(
          all_of(qvars),
          ~ !is.na(.x) & norm_text(.x) != ""
        )
      )

    choice_long <- dat_n %>%
      select(ID, all_of(qvars)) %>%
      pivot_longer(
        cols = all_of(qvars),
        names_to = "choice_var",
        values_to = "choice_raw"
      ) %>%
      left_join(map_n, by = "choice_var") %>%
      mutate(choice = as_num(choice_raw)) %>%
      filter(!is.na(choice)) %>%
      select(ID, party_n, task, choice)

    invalid_choice <- choice_long %>%
      filter(choice < 1 | choice > n_party)

    if (nrow(invalid_choice) > 0) {
      print(invalid_choice)
      stop("Check choice values")
    }

    duplicate_choice <- choice_long %>%
      count(ID, task) %>%
      filter(n != 1)

    if (nrow(duplicate_choice) > 0) {
      print(duplicate_choice)
      stop("Check duplicate choices")
    }

    level_regex <- "^F-([1-5])-([1-5])-([1-7])$"
    level_cols <- names(dat_n)[str_detect(names(dat_n), level_regex)]

    if (length(level_cols) == 0) {
      stop("Check attributes")
    }

    level_long <- dat_n %>%
      select(ID, all_of(level_cols)) %>%
      pivot_longer(
        cols = all_of(level_cols),
        names_to = "fvar",
        values_to = "level"
      ) %>%
      extract(
        fvar,
        into = c("task", "profile", "attr_order"),
        regex = level_regex,
        convert = TRUE
      ) %>%
      mutate(level = norm_text(level)) %>%
      filter(
        task %in% 1:5,
        profile %in% 1:n_party,
        attr_order %in% 1:7,
        !is.na(level),
        level != ""
      ) %>%
      mutate(attr_var = level_to_attr_var(level))

    unknown_levels <- level_long %>%
      filter(is.na(attr_var)) %>%
      distinct(level)

    if (nrow(unknown_levels) > 0) {
      print(unknown_levels)
      stop("Check attributes")
    }

    profile_attribute_count <- level_long %>%
      count(ID, task, profile, name = "n_attribute_rows") %>%
      filter(n_attribute_rows != 7)

    if (nrow(profile_attribute_count) > 0) {
      print(head(profile_attribute_count, 50))
      stop("Check attributes")
    }

    duplicate_attribute <- level_long %>%
      count(ID, task, profile, attr_var) %>%
      filter(n != 1)

    if (nrow(duplicate_attribute) > 0) {
      print(head(duplicate_attribute, 50))
      stop("Check attributes")
    }

    profile_wide <- level_long %>%
      inner_join(choice_long, by = c("ID", "task")) %>%
      mutate(
        party_n = n_party,
        selected = as.integer(profile == choice),
        task_id = paste(ID, party_n, task, sep = "_"),
        profile_id = paste(ID, party_n, task, profile, sep = "_")
      ) %>%
      select(
        ID, party_n, task, profile, choice, selected,
        task_id, profile_id, attr_var, level
      ) %>%
      pivot_wider(
        names_from = attr_var,
        values_from = level,
        values_fn = list(level = ~ first(.x))
      )

    missing_attr <- setdiff(required_attr_vars, names(profile_wide))

    if (length(missing_attr) > 0) {
      stop("Check attributes")
    }

    profile_wide %>%
      select(
        ID, party_n, task, profile, choice, selected,
        task_id, profile_id,
        all_of(required_attr_vars)
      ) %>%
      arrange(ID, task, profile)
  }


  conjoint_2 <- make_profile_long(df, 2)
  conjoint_3 <- make_profile_long(df, 3)
  conjoint_4 <- make_profile_long(df, 4)
  conjoint_5 <- make_profile_long(df, 5)

  conjoint_all_unfiltered <- bind_rows(
    conjoint_2,
    conjoint_3,
    conjoint_4,
    conjoint_5
  )


  id_task_check <- conjoint_all_unfiltered %>%
    group_by(ID, party_n, task) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    group_by(ID, party_n) %>%
    summarise(
      n_tasks = n_distinct(task),
      all_tasks_ok = all(n_profiles == party_n & selected_sum == 1),
      .groups = "drop"
    )

  if (require_all_five_tasks) {
    valid_ids <- id_task_check %>%
      filter(n_tasks == 5, all_tasks_ok)
  } else {
    valid_ids <- id_task_check %>%
      filter(all_tasks_ok)
  }

  conjoint_all <- conjoint_all_unfiltered %>%
    semi_join(valid_ids, by = c("ID", "party_n"))

  n_by_party <- valid_ids %>%
    count(party_n, name = "n") %>%
    complete(party_n = 2:5, fill = list(n = 0)) %>%
    arrange(party_n)

  n_total <- valid_ids %>%
    summarise(n = n_distinct(ID)) %>%
    pull(n)

  figure_n_labels <- bind_rows(
    tibble(
      position = "全サンプル",
      label = paste0("全サンプル, n=", scales::comma(n_total))
    ),
    n_by_party %>%
      mutate(
        position = paste0(party_n, "政党選択"),
        label = paste0("n=", scales::comma(n))
      ) %>%
      select(position, label)
  )

  sample_flow <- bind_rows(
    sample_flow,
    tibble(
      stage = "完全な5課題をもつ分析対象者",
      n = n_total
    )
  )

  cat("\n分析対象者数\n")
  print(n_by_party)
  cat("全サンプル n=", n_total, "\n", sep = "")

  write_csv_safely(sample_flow, "sample_flow.csv")
  write_csv_safely(id_task_check, "id_task_check.csv")
  write_csv_safely(valid_ids, "valid_ids.csv")
  write_csv_safely(n_by_party, "n_by_party.csv")
  write_csv_safely(figure_n_labels, "figure_n_labels.csv")


  check_profile <- conjoint_all %>%
    group_by(party_n, ID, task, task_id) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    count(party_n, n_profiles, selected_sum)

  print(check_profile)
  stopifnot(all(check_profile$n_profiles == check_profile$party_n))
  stopifnot(all(check_profile$selected_sum == 1))

  allowed_df <- enframe(allowed_levels, name = "name", value = "value") %>%
    unnest(value)

  unexpected_values <- conjoint_all %>%
    select(all_of(required_attr_vars)) %>%
    pivot_longer(
      cols = everything(),
      names_to = "name",
      values_to = "value"
    ) %>%
    filter(!is.na(value), value != "") %>%
    distinct(name, value) %>%
    anti_join(allowed_df, by = c("name", "value"))

  print(unexpected_values)
  stopifnot(nrow(unexpected_values) == 0)

  observed_levels <- conjoint_all %>%
    select(all_of(required_attr_vars)) %>%
    pivot_longer(
      cols = everything(),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    distinct(attribute, level) %>%
    arrange(attribute, level)

  write_csv_safely(check_profile, "profile_expansion_check.csv")
  write_csv_safely(observed_levels, "observed_attribute_levels.csv")
  write_csv_safely(conjoint_all, "study1_profile_level_data.csv")


  if (require_attention_check) {
    if (
      is.na(attention_check_var) ||
        !attention_check_var %in% names(df) ||
        is.na(attention_check_correct)
    ) {
      stop("Check attention item")
    }
  }

  attention_summary <- tibble(
    note = "2023年元コードでは注意チェックの確定対応表を使用していないため、標準分析では集計を省略。"
  )

  manipulation_summary <- tibble(
    note = "2023年元コードでは政党数確認質問の確定対応表を使用していないため、標準分析では集計を省略。"
  )

  write_csv_safely(attention_summary, "attention_check_summary.csv")
  write_csv_safely(manipulation_summary, "party_number_check_summary.csv")


  conjoint_all_m <- conjoint_all %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),

      policy_position = factor(
        policy_position,
        levels = c("中道", "右派・保守的", "左派・革新的")
      ),

      government_status = factor(
        government_status,
        levels = c("野党", "与党")
      ),

      gdp_growth = factor(
        gdp_growth,
        levels = c(
          "GDP成長率±0％",
          "GDP成長率プラス1％",
          "GDP成長率マイナス1％"
        )
      ),

      nikkei = factor(
        nikkei,
        levels = c(
          "日経平均前月同期比変わらず",
          "日経平均前月同期比プラス1000円",
          "日経平均前月同期比マイナス1000円"
        )
      ),

      seats = factor(
        seats,
        levels = c("10以下", "10~49", "50~99", "100~199", "200以上")
      ),

      cpi = factor(
        cpi,
        levels = c(
          "CPI前期比±0ポイント",
          "CPI前期比プラス1ポイント",
          "CPI前期比マイナス1ポイント"
        )
      ),

      unemployment = factor(
        unemployment,
        levels = c(
          "失業率前期比±0％",
          "失業率前期比プラス1％",
          "失業率前期比マイナス1％"
        )
      ),

      party_n_f = factor(
        as.character(party_n),
        levels = c("2", "3", "4", "5")
      )
    )

  attr_terms <- c(
    "policy_position",
    "government_status",
    "gdp_growth",
    "nikkei",
    "seats",
    "cpi",
    "unemployment"
  )


  formula_nocov <- as.formula(
    paste("selected ~", paste(attr_terms, collapse = " + "))
  )

  run_amce_nocov <- function(dat) {
    feols(
      formula_nocov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_nocov <- conjoint_all_m %>%
    split(.$party_n) %>%
    map(run_amce_nocov)

  capture.output(
    etable(models_by_party_n_nocov),
    file = file.path(output_dir, "amce_nocov_models.txt")
  )


  m_interaction <- feols(
    selected ~
      party_n_f *
      (
        policy_position +
          government_status +
          gdp_growth +
          nikkei +
          seats +
          cpi +
          unemployment
      ),
    data = conjoint_all_m,
    vcov = ~ ID
  )

  capture.output(
    summary(m_interaction),
    file = file.path(output_dir, "amce_interaction_model.txt")
  )


  tidy_fixest <- function(model) {
    ct <- as.data.frame(fixest::coeftable(model))
    ct$term <- rownames(ct)

    ct %>%
      as_tibble() %>%
      rename(
        estimate = Estimate,
        std.error = `Std. Error`,
        statistic = `t value`,
        p.value = `Pr(>|t|)`
      ) %>%
      mutate(
        conf.low = estimate - 1.96 * std.error,
        conf.high = estimate + 1.96 * std.error
      ) %>%
      select(
        term, estimate, std.error, statistic, p.value,
        conf.low, conf.high
      )
  }

  term_labels <- tribble(
    ~term, ~attribute, ~cue_type, ~label, ~order,

    "government_status与党",
    "与党／野党", "政党の手がかり", "与党", 1,

    "policy_position右派・保守的",
    "政策位置", "政党の手がかり", "右派・保守的", 2,

    "policy_position左派・革新的",
    "政策位置", "政党の手がかり", "左派・革新的", 3,

    "seats10~49",
    "議席数", "政党の手がかり", "議席数：10～49", 4,

    "seats50~99",
    "議席数", "政党の手がかり", "議席数：50～99", 5,

    "seats100~199",
    "議席数", "政党の手がかり", "議席数：100～199", 6,

    "seats200以上",
    "議席数", "政党の手がかり", "議席数：200以上", 7,

    "gdp_growthGDP成長率プラス1％",
    "GDP成長率", "経済の手がかり", "GDP：プラス1％", 8,

    "gdp_growthGDP成長率マイナス1％",
    "GDP成長率", "経済の手がかり", "GDP：マイナス1％", 9,

    "nikkei日経平均前月同期比プラス1000円",
    "日経平均", "経済の手がかり", "日経平均：プラス1000円", 10,

    "nikkei日経平均前月同期比マイナス1000円",
    "日経平均", "経済の手がかり", "日経平均：マイナス1000円", 11,

    "cpiCPI前期比プラス1ポイント",
    "CPI", "経済の手がかり", "CPI：プラス1ポイント", 12,

    "cpiCPI前期比マイナス1ポイント",
    "CPI", "経済の手がかり", "CPI：マイナス1ポイント", 13,

    "unemployment失業率前期比プラス1％",
    "失業率", "経済の手がかり", "失業率：プラス1％", 14,

    "unemployment失業率前期比マイナス1％",
    "失業率", "経済の手がかり", "失業率：マイナス1％", 15
  )

  attribute_order <- c(
    "与党／野党",
    "政策位置",
    "議席数",
    "GDP成長率",
    "日経平均",
    "CPI",
    "失業率"
  )

  label_order <- term_labels %>%
    arrange(order) %>%
    pull(label)

  make_amce_plot_df <- function(models) {
    imap_dfr(
      models,
      ~ tidy_fixest(.x) %>%
        mutate(party_n = as.character(.y))
    ) %>%
      left_join(term_labels, by = "term") %>%
      filter(!is.na(attribute)) %>%
      mutate(
        estimate_pp = estimate * 100,
        conf.low_pp = conf.low * 100,
        conf.high_pp = conf.high * 100,
        party_n = factor(
          party_n,
          levels = c("2", "3", "4", "5"),
          labels = c("2政党", "3政党", "4政党", "5政党")
        ),
        attribute = factor(attribute, levels = attribute_order),
        label = factor(label, levels = rev(label_order))
      )
  }

  amce_plot_nocov <- make_amce_plot_df(models_by_party_n_nocov)
  write_csv_safely(amce_plot_nocov, "amce_nocov_coefficients.csv")

  interaction_plot_df <- tidy_fixest(m_interaction) %>%
    filter(str_detect(term, "party_n_f[345]")) %>%
    mutate(
      party_n_code = str_extract(term, "party_n_f[345]"),
      party_n = str_remove(party_n_code, "party_n_f"),
      base_term = term %>%
        str_remove("party_n_f[345]:") %>%
        str_remove(":party_n_f[345]")
    ) %>%
    left_join(term_labels, by = c("base_term" = "term")) %>%
    filter(!is.na(attribute)) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      party_n_label = factor(
        party_n,
        levels = c("3", "4", "5"),
        labels = c("3政党", "4政党", "5政党")
      ),
      attribute = factor(attribute, levels = attribute_order),
      label = factor(label, levels = rev(label_order))
    )

  write_csv_safely(interaction_plot_df, "amce_interaction_coefficients.csv")


  recode_female_study1 <- function(x) {
    x_chr <- norm_text(x)
    x_num <- as_num(x_chr)

    case_when(
      str_detect(x_chr, "女性") | x_num == 1 ~ 1L,
      str_detect(x_chr, "男性") | x_num == 2 ~ 0L,
      TRUE ~ NA_integer_
    )
  }

  recode_college_grad_study1 <- function(x) {
    x_chr <- norm_text(x)
    x_num <- as_num(x_chr)

    case_when(
      str_detect(x_chr, "4年制大学|４年制大学|大学院") |
        x_num %in% c(4, 5) ~ 1L,
      str_detect(x_chr, "小学校|高校|高等専門|短期大学|専修学校") |
        x_num %in% c(1, 2, 3) ~ 0L,
      TRUE ~ NA_integer_
    )
  }

  recode_party_support_study1 <- function(x) {
    x_chr <- norm_text(x)
    x_num <- as_num(x_chr)

    case_when(
      str_detect(x_chr, "自由民主|自民") | x_num == 1 ~ "自由民主党",
      str_detect(x_chr, "立憲民主") | x_num == 2 ~ "立憲民主党",
      str_detect(x_chr, "公明") | x_num == 3 ~ "公明党",
      str_detect(x_chr, "維新") | x_num == 4 ~ "日本維新の会",
      str_detect(x_chr, "共産") | x_num == 5 ~ "日本共産党",
      str_detect(x_chr, "国民民主") | x_num == 6 ~ "国民民主党",
      str_detect(x_chr, "社会民主|社民") | x_num == 7 ~ "社会民主党",
      str_detect(x_chr, "れいわ") | x_num == 8 ~ "れいわ新選組",
      str_detect(x_chr, "その他") | x_num == 11 ~ "その他",
      str_detect(x_chr, "支持する政党はない|支持政党なし") |
        x_num == 12 ~ "支持政党なし",
      str_detect(x_chr, "わからない") | x_num == 13 ~ "わからない",
      str_detect(x_chr, "答えない|こたえない") | x_num == 14 ~ "答えない",
      TRUE ~ NA_character_
    )
  }

  gender_raw <- get_var(
    df,
    c("Q2.1", "Q2_1", "Q2.1.", "性別", "gender", "Gender")
  )

  age_raw <- get_var(
    df,
    c("Q2.2", "Q2_2", "Q2.2.", "年齢", "age", "Age")
  )

  education_raw <- get_var(
    df,
    c(
      "Q2.3", "Q2_3", "Q2.3.",
      "学歴", "教育歴", "最終学歴", "education", "Education"
    )
  )

  party_support_raw <- get_var(
    df,
    c("Q2.4", "Q2_4", "Q2.4.", "政党支持", "支持政党", "party_support")
  )

  income_gross_raw <- get_var(
    df,
    c("Q3.1_1", "Q3.1.1", "Q3_1_1", "税引き前世帯年収", "income_gross")
  )

  income_net_raw <- get_var(
    df,
    c("Q3.1_2", "Q3.1.2", "Q3_1_2", "手取りの年収", "income_net")
  )

  covar_id <- df %>%
    transmute(
      ID = as.character(ResponseId),
      female = recode_female_study1(gender_raw),
      age_raw_num = as_num(age_raw),
      college_grad = recode_college_grad_study1(education_raw),
      party_support = recode_party_support_study1(party_support_raw),
      party_support_f = factor_miss(party_support),
      income_gross = as_num(income_gross_raw),
      income_net = as_num(income_net_raw),
      income_gross_log = log1p(income_gross),
      income_net_log = log1p(income_net)
    ) %>%
    mutate(
      age = case_when(
        !is.na(age_raw_num) & age_raw_num >= 18 & age_raw_num <= 80 ~
          age_raw_num,
        !is.na(age_raw_num) & age_raw_num >= 1 & age_raw_num <= 63 ~
          age_raw_num + 17,
        TRUE ~ NA_real_
      )
    ) %>%
    semi_join(valid_ids %>% select(ID), by = "ID") %>%
    distinct(ID, .keep_all = TRUE)

  age_imp_obj <- mean_impute(covar_id$age)
  income_gross_imp_obj <- mean_impute(covar_id$income_gross_log)

  covar_id <- covar_id %>%
    mutate(
      female_imp = if_else(is.na(female), 0L, female),
      female_miss = as.integer(is.na(female)),

      college_grad_imp = if_else(is.na(college_grad), 0L, college_grad),
      college_grad_miss = as.integer(is.na(college_grad)),

      age_imp = age_imp_obj$value,
      age_miss = age_imp_obj$miss,

      income_gross_log_imp = income_gross_imp_obj$value,
      income_gross_log_miss = income_gross_imp_obj$miss
    )

  covariate_missing_summary <- covar_id %>%
    summarise(
      n_ids = n_distinct(ID),
      female_missing = sum(is.na(female)),
      age_missing = sum(is.na(age)),
      college_grad_missing = sum(is.na(college_grad)),
      income_gross_missing = sum(is.na(income_gross_log)),
      party_support_missing = sum(is.na(party_support))
    )

  print(covariate_missing_summary)
  write_csv_safely(covar_id, "respondent_covariates.csv")
  write_csv_safely(covariate_missing_summary, "covariate_missing_summary.csv")


  conjoint_all_cov <- conjoint_all_m %>%
    left_join(covar_id, by = "ID")

  covariate_terms <- c(
    "female_imp",
    "female_miss",
    "age_imp",
    "age_miss",
    "income_gross_log_imp",
    "income_gross_log_miss",
    "party_support_f"
  )

  if (use_education_covariate) {
    covariate_terms <- c(
      covariate_terms,
      "college_grad_imp",
      "college_grad_miss"
    )
  }

  has_variation <- function(dat, v) {
    if (!v %in% names(dat)) return(FALSE)
    dplyr::n_distinct(dat[[v]], na.rm = TRUE) > 1
  }

  covariate_terms_use <- covariate_terms[
    map_lgl(covariate_terms, ~ has_variation(conjoint_all_cov, .x))
  ]

  formula_cov <- as.formula(
    paste(
      "selected ~",
      paste(c(attr_terms, covariate_terms_use), collapse = " + ")
    )
  )

  run_amce_cov <- function(dat) {
    feols(
      formula_cov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_cov <- conjoint_all_cov %>%
    split(.$party_n) %>%
    map(run_amce_cov)

  capture.output(
    etable(
      models_by_party_n_nocov,
      models_by_party_n_cov,
      headers = c(
        rep("共変量なし", length(models_by_party_n_nocov)),
        rep("共変量あり", length(models_by_party_n_cov))
      )
    ),
    file = file.path(output_dir, "amce_nocov_and_cov_models.txt")
  )

  amce_plot_cov <- make_amce_plot_df(models_by_party_n_cov)
  write_csv_safely(amce_plot_cov, "amce_cov_coefficients.csv")


  study_label <- "実験1（2023年）"

  term_labels_facet <- term_labels %>%
    mutate(
      attribute_facet = attribute
    )

  attribute_order_facet <- c(
    "与党／野党",
    "政策位置",
    "議席数",
    "GDP成長率",
    "日経平均",
    "CPI",
    "失業率"
  )

  make_amce_facet_df <- function(models) {
    imap_dfr(
      models,
      ~ tidy_fixest(.x) %>%
        mutate(party_n = as.character(.y))
    ) %>%
      left_join(term_labels_facet, by = "term") %>%
      filter(!is.na(attribute_facet)) %>%
      mutate(
        estimate_pp = estimate * 100,
        conf.low_pp = conf.low * 100,
        conf.high_pp = conf.high * 100,
        party_n = factor(
          party_n,
          levels = c("2", "3", "4", "5"),
          labels = c("2政党", "3政党", "4政党", "5政党")
        ),
        attribute_facet = factor(
          attribute_facet,
          levels = attribute_order_facet
        ),
        label = factor(
          label,
          levels = rev(label_order)
        )
      )
  }

  amce_plot_df_cov_facet <- make_amce_facet_df(models_by_party_n_cov)
  amce_plot_df_nocov_facet <- make_amce_facet_df(models_by_party_n_nocov)

  write_csv_safely(
    amce_plot_df_cov_facet,
    "amce_cov_facet_coefficients.csv"
  )

  write_csv_safely(
    amce_plot_df_nocov_facet,
    "amce_nocov_facet_coefficients.csv"
  )


  p_amce_cov_facet <- ggplot(
    amce_plot_df_cov_facet,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute_facet ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-12, 12, by = 2)
    ) +
    scale_shape_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = "Yu Gothic"
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_amce_cov_facet)

  save_plot(
    "amce_cov_facet_model.png",
    p_amce_cov_facet,
    width = 10.5,
    height = 8.5
  )

  p_amce_cov_main <- p_amce_cov_facet


  make_heatmap_df <- function(amce_plot_df) {
    heat_df <- amce_plot_df %>%
      mutate(
        abs_amce = abs(estimate_pp),
        cue_type_code = case_when(
          cue_type == "政党の手がかり" ~ "party",
          cue_type == "経済の手がかり" ~ "economy",
          TRUE ~ "other"
        )
      ) %>%
      group_by(party_n) %>%
      mutate(
        rank_within_party = min_rank(desc(abs_amce)),
        n_in_col = n(),
        rank_score = if_else(
          n_in_col == 1,
          1,
          1 - (rank_within_party - 1) / (n_in_col - 1)
        )
      ) %>%
      ungroup()

    row_order_df <- heat_df %>%
      group_by(label, cue_type_code) %>%
      summarise(
        mean_abs_amce = mean(abs_amce, na.rm = TRUE),
        .groups = "drop"
      ) %>%
      arrange(desc(mean_abs_amce))

    row_levels <- as.character(row_order_df$label)

    heat_df <- heat_df %>%
      mutate(
        label = factor(
          as.character(label),
          levels = rev(row_levels)
        )
      )

    label_color_map <- row_order_df %>%
      mutate(
        label_markdown = case_when(
          cue_type_code == "party" ~
            paste0(
              "<span style='color:#111111;'>",
              label,
              "</span>"
            ),
          cue_type_code == "economy" ~
            paste0(
              "<span style='color:#8A8A8A;'>",
              label,
              "</span>"
            ),
          TRUE ~ as.character(label)
        )
      )

    label_markdown_vec <- setNames(
      label_color_map$label_markdown,
      as.character(label_color_map$label)
    )

    list(
      heat_df = heat_df,
      label_markdown_vec = label_markdown_vec
    )
  }

  plot_amce_heatmap <- function(
      heat_df,
      label_markdown_vec,
      with_rank = TRUE,
      title_text = NULL) {

    if (with_rank) {
      heat_df <- heat_df %>%
        mutate(
          cell_label = paste0(
            sprintf("%.1f", estimate_pp),
            "\n(",
            rank_within_party,
            "位)"
          )
        )

      text_size <- 3.0
      lineheight <- 0.9
    } else {
      heat_df <- heat_df %>%
        mutate(
          cell_label = sprintf("%.1f", estimate_pp)
        )

      text_size <- 3.4
      lineheight <- 1.0
    }

    ggplot(
      heat_df,
      aes(
        x = party_n,
        y = label,
        fill = rank_score
      )
    ) +
      geom_tile(
        color = "white",
        linewidth = 0.7
      ) +
      geom_text(
        aes(label = cell_label),
        size = text_size,
        fontface = "bold",
        color = "black",
        lineheight = lineheight
      ) +
      scale_y_discrete(
        labels = label_markdown_vec
      ) +
      scale_fill_gradient(
        low = "grey95",
        high = "grey15",
        limits = c(0, 1),
        breaks = c(0, 0.25, 0.50, 0.75, 1.00),
        labels = c("低", "", "", "", "高"),
        name = "列内順位\n（濃いほど高位）"
      ) +
      labs(
        title = title_text,
        x = "政党数選択肢",
        y = NULL
      ) +
      theme_bw(base_size = 12) +
      theme(
        legend.position = "right",
        panel.grid = element_blank(),
        plot.title = element_text(face = "bold"),
        axis.text.x = element_text(size = 10),
        axis.text.y = ggtext::element_markdown(size = 9),
        axis.title.y = element_blank()
      )
  }

  heatmap_input <- make_heatmap_df(amce_plot_cov)

  p_heat_amce_mixed <- plot_amce_heatmap(
    heatmap_input$heat_df,
    heatmap_input$label_markdown_vec,
    with_rank = FALSE,
    title_text = NULL
  )

  print(p_heat_amce_mixed)

  save_plot(
    "amce_heatmap_mixed_rank_colored_labels.png",
    p_heat_amce_mixed,
    width = 8.8,
    height = 8.8
  )

  p_heat_amce_mixed_ranklabel <- plot_amce_heatmap(
    heatmap_input$heat_df,
    heatmap_input$label_markdown_vec,
    with_rank = TRUE,
    title_text = NULL
  )

  print(p_heat_amce_mixed_ranklabel)

  save_plot(
    "amce_heatmap_mixed_rank_colored_labels_withrank.png",
    p_heat_amce_mixed_ranklabel,
    width = 8.8,
    height = 8.8
  )

  p_heat_amce <- p_heat_amce_mixed
  p_heat_amce_rank <- p_heat_amce_mixed_ranklabel


  p_amce_facet_nocov <- ggplot(
    amce_plot_df_nocov_facet,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute_facet ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-12, 12, by = 2)
    ) +
    scale_shape_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(base_size = 12) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_amce_facet_nocov)

  save_plot(
    "amce_facet_nocov.png",
    p_amce_facet_nocov,
    width = 10.5,
    height = 9
  )

  p_amce_nocov_appendix <- p_amce_facet_nocov


  p_interaction <- ggplot(
    interaction_plot_df,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n_label,
      linetype = party_n_label,
      group = party_n_label
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-8, 8, by = 2)
    ) +
    scale_shape_manual(
      name = "2政党の場合との比較",
      values = c(
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "2政党の場合との比較",
      values = c(
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "2政党条件との差",
      y = NULL
    ) +
    theme_bw(base_size = 12) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 15
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_interaction)

  save_plot(
    "amce_interaction_difference_from_2party.png",
    p_interaction,
    width = 10.5,
    height = 9
  )


  conjoint_clogit <- conjoint_all_m %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),
      task_id = factor(task_id),
      policy_position = relevel_if_present(
        policy_position,
        "中道"
      ),
      government_status = relevel_if_present(
        government_status,
        "野党"
      ),
      gdp_growth = relevel_if_present(
        gdp_growth,
        "GDP成長率±0％"
      ),
      nikkei = relevel_if_present(
        nikkei,
        "日経平均前月同期比変わらず"
      ),
      seats = relevel_if_present(
        seats,
        "10以下"
      ),
      cpi = relevel_if_present(
        cpi,
        "CPI前期比±0ポイント"
      ),
      unemployment = relevel_if_present(
        unemployment,
        "失業率前期比±0％"
      )
    )

  formula_clogit_nocov <- as.formula(
    paste0(
      "selected ~ ",
      paste(attr_terms, collapse = " + "),
      " + strata(task_id) + cluster(ID)"
    )
  )

  run_clogit_nocov <- function(dat) {
    survival::clogit(
      formula_clogit_nocov,
      data = dat,
      method = "efron"
    )
  }

  models_clogit_nocov <- conjoint_clogit %>%
    split(.$party_n) %>%
    map(run_clogit_nocov)

  capture.output(
    lapply(models_clogit_nocov, summary),
    file = file.path(
      output_dir,
      "conditional_logit_models.txt"
    )
  )

  tidy_clogit <- function(model) {
    s <- summary(model)
    ct <- as.data.frame(s$coefficients)
    ct$term <- rownames(ct)

    se_col <- if ("robust se" %in% names(ct)) {
      "robust se"
    } else if ("se(coef)" %in% names(ct)) {
      "se(coef)"
    } else {
      stop("Check clogit")
    }

    p_col <- if ("Pr(>|z|)" %in% names(ct)) {
      "Pr(>|z|)"
    } else if ("Pr(>|t|)" %in% names(ct)) {
      "Pr(>|t|)"
    } else {
      NA_character_
    }

    ct %>%
      as_tibble() %>%
      transmute(
        term = term,
        estimate = coef,
        std.error = .data[[se_col]],
        p.value = if (!is.na(p_col)) {
          .data[[p_col]]
        } else {
          NA_real_
        },
        conf.low = estimate - 1.96 * std.error,
        conf.high = estimate + 1.96 * std.error,
        odds_ratio = exp(estimate),
        odds_ratio_low = exp(conf.low),
        odds_ratio_high = exp(conf.high)
      )
  }

  clogit_plot_df <- imap_dfr(
    models_clogit_nocov,
    ~ tidy_clogit(.x) %>%
      mutate(party_n = as.character(.y))
  ) %>%
    left_join(term_labels, by = "term") %>%
    filter(!is.na(attribute)) %>%
    mutate(
      party_n = factor(
        party_n,
        levels = c("2", "3", "4", "5"),
        labels = c("2政党", "3政党", "4政党", "5政党")
      ),
      label = factor(
        label,
        levels = rev(label_order)
      )
    )

  write_csv_safely(
    clogit_plot_df,
    "conditional_logit_coefficients.csv"
  )


  p_clogit_or <- ggplot(
    clogit_plot_df,
    aes(
      x = odds_ratio,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 1,
      linetype = "dashed",
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = odds_ratio_low,
        xmax = odds_ratio_high
      ),
      position = position_dodge(width = 0.72),
      height = 0.15,
      linewidth = 0.45,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.72),
      size = 2.4,
      stroke = 0.7,
      color = "black"
    ) +
    scale_x_log10(
      breaks = c(
        0.6,
        0.8,
        1.0,
        1.25,
        1.5,
        2.0
      ),
      labels = c(
        "0.6",
        "0.8",
        "1.0",
        "1.25",
        "1.5",
        "2.0"
      )
    ) +
    scale_shape_manual(
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotdash",
        "5政党" = "twodash"
      )
    ) +
    labs(
      x = "オッズ比",
      y = NULL,
      shape = "政党数選択肢",
      linetype = "政党数選択肢"
    ) +
    theme_bw(base_size = 12) +
    theme(
      legend.position = "bottom",
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      plot.title = element_text(face = "bold"),
      axis.text.y = element_text(size = 9)
    )

  print(p_clogit_or)

  save_plot(
    "clogit_oddsratio_nocov.png",
    p_clogit_or,
    width = 10.5,
    height = 8.5
  )


  relative_cue_map <- c(
    policy_position = "party",
    government_status = "party",
    seats = "party",
    gdp_growth = "economic",
    nikkei = "economic",
    cpi = "economic",
    unemployment = "economic"
  )

  mean_absolute_pairwise_difference <- function(x) {
    x <- x[is.finite(x)]

    if (length(x) < 2) {
      return(NA_real_)
    }

    pairwise_differences <- combn(
      x,
      2,
      FUN = function(z) abs(z[1] - z[2])
    )

    mean(pairwise_differences)
  }

  linear_slope <- function(y, x) {
    keep <- is.finite(y) & is.finite(x)
    y <- y[keep]
    x <- x[keep]

    if (length(y) < 2 || length(unique(x)) < 2) {
      return(NA_real_)
    }

    unname(coef(lm(y ~ x))[2])
  }

  bootstrap_two_sided_p <- function(x) {
    x <- x[is.finite(x)]
    B_valid <- length(x)

    if (B_valid == 0) {
      return(NA_real_)
    }

    p_lower <- (1 + sum(x <= 0)) / (B_valid + 1)
    p_upper <- (1 + sum(x >= 0)) / (B_valid + 1)

    min(1, 2 * min(p_lower, p_upper))
  }

  safe_quantile <- function(x, probability) {
    x <- x[is.finite(x)]

    if (length(x) == 0) {
      return(NA_real_)
    }

    unname(
      quantile(
        x,
        probs = probability,
        type = 6,
        na.rm = TRUE
      )
    )
  }

  prepare_relative_cue_analysis <- function(data, cue_map) {
    attributes <- names(cue_map)

    required_columns <- c(
      "ID",
      "party_n",
      "selected",
      attributes
    )

    missing_columns <- setdiff(
      required_columns,
      names(data)
    )

    if (length(missing_columns) > 0) {
      stop("Check relative weight")
    }

    if (!all(unname(cue_map) %in% c("party", "economic"))) {
      stop("Check relative weight")
    }

    analysis_data <- data %>%
      select(
        ID,
        party_n,
        selected,
        all_of(attributes)
      ) %>%
      mutate(
        ID = as.character(ID),
        party_n = as.integer(as.character(party_n)),
        selected = as.integer(selected),
        across(
          all_of(attributes),
          as.character
        )
      ) %>%
      filter(
        !is.na(ID),
        party_n %in% 2:5,
        selected %in% c(0L, 1L)
      )

    observed_conditions <- sort(
      unique(analysis_data$party_n)
    )

    if (!identical(observed_conditions, 2:5)) {
      stop("Check")
    }

    long_data <- analysis_data %>%
      pivot_longer(
        cols = all_of(attributes),
        names_to = "attribute",
        values_to = "level"
      ) %>%
      filter(
        !is.na(level),
        level != ""
      )

    expected_cells <- long_data %>%
      distinct(
        attribute,
        level
      ) %>%
      mutate(
        attribute_order = match(
          attribute,
          attributes
        )
      ) %>%
      arrange(
        attribute_order,
        attribute,
        level
      ) %>%
      select(-attribute_order) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    respondent_cell <- long_data %>%
      group_by(
        party_n,
        ID,
        attribute,
        level
      ) %>%
      summarise(
        y_sum = sum(selected),
        n_obs = n(),
        .groups = "drop"
      ) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    condition_objects <- lapply(
      2:5,
      function(n_value) {
        condition_data <- respondent_cell %>%
          filter(
            party_n == n_value
          )

        id_values <- sort(
          unique(condition_data$ID)
        )
        n_ids <- length(id_values)
        n_cells <- nrow(expected_cells)

        if (n_ids == 0) {
          stop("Check")
        }

        y_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        n_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        row_index <- match(
          condition_data$ID,
          id_values
        )
        column_index <- match(
          condition_data$cell_key,
          expected_cells$cell_key
        )

        y_matrix[cbind(row_index, column_index)] <-
          condition_data$y_sum
        n_matrix[cbind(row_index, column_index)] <-
          condition_data$n_obs

        if (any(colSums(n_matrix) == 0)) {
          missing_cells <- expected_cells$cell_key[
            colSums(n_matrix) == 0
          ]

          stop("Check attributes")
        }

        list(
          party_n = n_value,
          ids = id_values,
          cell_info = expected_cells,
          y_matrix = y_matrix,
          n_matrix = n_matrix
        )
      }
    )

    names(condition_objects) <- as.character(2:5)

    list(
      cue_map = cue_map,
      attributes = attributes,
      conditions = condition_objects
    )
  }

  estimate_relative_cue_indices <- function(
      prepared,
      cluster_weights = NULL
  ) {
    condition_results <- lapply(
      names(prepared$conditions),
      function(condition_name) {
        object <- prepared$conditions[[condition_name]]

        if (is.null(cluster_weights)) {
          weights <- rep(
            1,
            length(object$ids)
          )
        } else {
          weights <- cluster_weights[[condition_name]]
        }

        if (length(weights) != length(object$ids)) {
          stop("Check")
        }

        numerator <- as.numeric(
          crossprod(
            weights,
            object$y_matrix
          )
        )

        denominator <- as.numeric(
          crossprod(
            weights,
            object$n_matrix
          )
        )

        if (any(denominator <= 0)) {
          stop("Check attributes")
        }

        marginal_means <- numerator / denominator

        mm_table <- object$cell_info %>%
          transmute(
            party_n = object$party_n,
            attribute,
            level,
            marginal_mean = marginal_means
          )

        attribute_table <- mm_table %>%
          group_by(
            party_n,
            attribute
          ) %>%
          summarise(
            importance_pairwise =
              mean_absolute_pairwise_difference(
                marginal_mean
              ),
            n_levels = n(),
            .groups = "drop"
          ) %>%
          mutate(
            cue_family = unname(
              prepared$cue_map[attribute]
            ),
            baseline_selection_probability = 1 / party_n,
            importance_pairwise_adjusted =
              importance_pairwise /
                baseline_selection_probability
          )

        cue_table_long <- attribute_table %>%
          group_by(
            party_n,
            cue_family
          ) %>%
          summarise(
            importance_pairwise = mean(
              importance_pairwise,
              na.rm = TRUE
            ),
            importance_pairwise_adjusted = mean(
              importance_pairwise_adjusted,
              na.rm = TRUE
            ),
            .groups = "drop"
          )

        party_table <- cue_table_long %>%
          filter(
            cue_family == "party"
          ) %>%
          transmute(
            party_n,
            party_importance_pairwise =
              importance_pairwise,
            party_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        economic_table <- cue_table_long %>%
          filter(
            cue_family == "economic"
          ) %>%
          transmute(
            party_n,
            economic_importance_pairwise =
              importance_pairwise,
            economic_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        cue_table <- full_join(
          party_table,
          economic_table,
          by = "party_n"
        ) %>%
          mutate(
            baseline_selection_probability = 1 / party_n,

            total_importance_pairwise =
              party_importance_pairwise +
              economic_importance_pairwise,

            total_importance_pairwise_adjusted =
              party_importance_pairwise_adjusted +
              economic_importance_pairwise_adjusted,

            relative_party_weight_pairwise = if_else(
              total_importance_pairwise > 0,
              party_importance_pairwise /
                total_importance_pairwise,
              NA_real_
            ),

            relative_economic_weight_pairwise =
              1 - relative_party_weight_pairwise,

            relative_party_weight_pairwise_adjusted = if_else(
              total_importance_pairwise_adjusted > 0,
              party_importance_pairwise_adjusted /
                total_importance_pairwise_adjusted,
              NA_real_
            ),

            relative_economic_weight_pairwise_adjusted =
              1 - relative_party_weight_pairwise_adjusted,

            adjustment_identity_difference =
              relative_party_weight_pairwise_adjusted -
                relative_party_weight_pairwise
          )

        if (
          any(
            abs(cue_table$adjustment_identity_difference) > 1e-10,
            na.rm = TRUE
          )
        ) {
          stop("Check relative weight")
        }

        list(
          marginal_means = mm_table,
          attribute_importance = attribute_table,
          cue_importance = cue_table
        )
      }
    )

    list(
      marginal_means = bind_rows(
        lapply(
          condition_results,
          function(x) x$marginal_means
        )
      ),
      attribute_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$attribute_importance
        )
      ),
      cue_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$cue_importance
        )
      ) %>%
        arrange(party_n)
    )
  }

  estimate_relative_cue_slopes <- function(cue_importance) {
    cue_importance <- cue_importance %>%
      arrange(party_n)

    if (!identical(cue_importance$party_n, 2:5)) {
      stop("Check relative weight")
    }

    x <- cue_importance$party_n

    c(
      relative_party_weight_pairwise =
        linear_slope(
          cue_importance$relative_party_weight_pairwise,
          x
        ),

      party_importance_pairwise =
        linear_slope(
          cue_importance$party_importance_pairwise,
          x
        ),

      economic_importance_pairwise =
        linear_slope(
          cue_importance$economic_importance_pairwise,
          x
        ),

      party_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$party_importance_pairwise_adjusted,
          x
        ),

      economic_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$economic_importance_pairwise_adjusted,
          x
        )
    )
  }

  run_relative_cue_bootstrap <- function(
      prepared,
      B,
      seed,
      progress_every = 100
  ) {
    set.seed(seed)

    condition_results <- vector(
      "list",
      B
    )

    slope_names <- c(
      "relative_party_weight_pairwise",
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted"
    )

    slope_matrix <- matrix(
      NA_real_,
      nrow = B,
      ncol = length(slope_names),
      dimnames = list(
        NULL,
        slope_names
      )
    )

    for (b in seq_len(B)) {
      cluster_weights <- lapply(
        prepared$conditions,
        function(object) {
          n_ids <- length(object$ids)

          sampled_positions <- sample.int(
            n = n_ids,
            size = n_ids,
            replace = TRUE
          )

          tabulate(
            sampled_positions,
            nbins = n_ids
          )
        }
      )

      bootstrap_estimates <- estimate_relative_cue_indices(
        prepared = prepared,
        cluster_weights = cluster_weights
      )

      condition_results[[b]] <-
        bootstrap_estimates$cue_importance %>%
        select(
          party_n,
          party_importance_pairwise,
          economic_importance_pairwise,
          party_importance_pairwise_adjusted,
          economic_importance_pairwise_adjusted,
          relative_party_weight_pairwise
        ) %>%
        mutate(
          bootstrap_replication = b,
          .before = 1
        )

      slope_matrix[b, ] <- estimate_relative_cue_slopes(
        bootstrap_estimates$cue_importance
      )

      if (
        progress_every > 0 &&
        (b %% progress_every == 0 || b == B)
      ) {
        message("Bootstrap: ", b, "/", B)
      }
    }

    list(
      condition_estimates = bind_rows(
        condition_results
      ),
      slopes = as_tibble(
        slope_matrix
      ) %>%
        mutate(
          bootstrap_replication = row_number(),
          .before = 1
        )
    )
  }

  summarise_condition_intervals <- function(
      observed_cue_importance,
      bootstrap_condition_results
  ) {
    statistics <- c(
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted",
      "relative_party_weight_pairwise"
    )

    observed_long <- observed_cue_importance %>%
      select(
        party_n,
        all_of(statistics)
      ) %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "estimate"
      )

    bootstrap_long <- bootstrap_condition_results %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "value"
      ) %>%
      group_by(
        party_n,
        statistic
      ) %>%
      summarise(
        conf_low = safe_quantile(
          value,
          0.025
        ),
        conf_high = safe_quantile(
          value,
          0.975
        ),
        .groups = "drop"
      )

    observed_long %>%
      left_join(
        bootstrap_long,
        by = c(
          "party_n",
          "statistic"
        )
      )
  }

  summarise_slope_inference <- function(
      observed_slopes,
      bootstrap_slopes
  ) {
    statistic_names <- names(observed_slopes)

    map_dfr(
      statistic_names,
      function(statistic_name) {
        bootstrap_values <- bootstrap_slopes[[statistic_name]]
        bootstrap_values <- bootstrap_values[
          is.finite(bootstrap_values)
        ]

        expected_direction <- case_when(
          statistic_name ==
            "economic_importance_pairwise" ~ "negative",
          statistic_name %in% c(
            "party_importance_pairwise",
            "relative_party_weight_pairwise",
            "party_importance_pairwise_adjusted"
          ) ~ "positive",
          TRUE ~ "none"
        )

        analysis_role <- case_when(
          statistic_name %in% c(
            "party_importance_pairwise_adjusted",
            "economic_importance_pairwise_adjusted"
          ) ~ "exploratory_choice_set_adjusted",
          statistic_name == "relative_party_weight_pairwise" ~
            "derived_relative_share",
          TRUE ~ "manuscript_primary_unadjusted"
        )

        estimate <- unname(
          observed_slopes[[statistic_name]]
        )

        tibble(
          study = "Study 1",
          statistic = statistic_name,
          estimate = estimate,
          conf_low = safe_quantile(
            bootstrap_values,
            0.025
          ),
          conf_high = safe_quantile(
            bootstrap_values,
            0.975
          ),
          p_value_two_sided =
            bootstrap_two_sided_p(
              bootstrap_values
            ),
          expected_direction = expected_direction,
          analysis_role = analysis_role,
          estimate_in_expected_direction = case_when(
            expected_direction == "positive" ~ estimate > 0,
            expected_direction == "negative" ~ estimate < 0,
            TRUE ~ NA
          )
        )
      }
    )
  }

  relative_cue_prepared <- prepare_relative_cue_analysis(
    data = conjoint_all_m,
    cue_map = relative_cue_map
  )

  relative_cue_observed <- estimate_relative_cue_indices(
    prepared = relative_cue_prepared
  )

  relative_cue_observed_slopes <- estimate_relative_cue_slopes(
    relative_cue_observed$cue_importance
  )

  write_csv_safely(
    relative_cue_observed$marginal_means,
    "study1_relative_cue_marginal_means.csv"
  )

  write_csv_safely(
    relative_cue_observed$attribute_importance,
    "study1_relative_cue_attribute_importance.csv"
  )

  write_csv_safely(
    relative_cue_observed$cue_importance,
    "study1_relative_cue_importance_and_weight.csv"
  )

  relative_condition_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study1_relative_cue_condition_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  relative_slope_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study1_relative_cue_slope_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  use_saved_relative_bootstrap <-
    !rerun_relative_cue_bootstrap &&
    file.exists(relative_condition_bootstrap_file) &&
    file.exists(relative_slope_bootstrap_file)

  if (use_saved_relative_bootstrap) {
    message("Bootstrap cache")

    relative_cue_condition_bootstrap <- readr::read_csv(
      relative_condition_bootstrap_file,
      show_col_types = FALSE
    )

    relative_cue_slope_bootstrap <- readr::read_csv(
      relative_slope_bootstrap_file,
      show_col_types = FALSE
    )

    saved_B_condition <- n_distinct(
      relative_cue_condition_bootstrap$bootstrap_replication
    )
    saved_B_slope <- n_distinct(
      relative_cue_slope_bootstrap$bootstrap_replication
    )

    if (
      saved_B_condition != relative_cue_bootstrap_B ||
      saved_B_slope != relative_cue_bootstrap_B
    ) {
      message("Bootstrap cache")
      use_saved_relative_bootstrap <- FALSE
    }
  }

  if (!use_saved_relative_bootstrap) {
    relative_cue_bootstrap <- run_relative_cue_bootstrap(
      prepared = relative_cue_prepared,
      B = relative_cue_bootstrap_B,
      seed = relative_cue_bootstrap_seed,
      progress_every = relative_cue_bootstrap_progress_every
    )

    relative_cue_condition_bootstrap <-
      relative_cue_bootstrap$condition_estimates

    relative_cue_slope_bootstrap <-
      relative_cue_bootstrap$slopes

    readr::write_csv(
      relative_cue_condition_bootstrap,
      relative_condition_bootstrap_file
    )

    readr::write_csv(
      relative_cue_slope_bootstrap,
      relative_slope_bootstrap_file
    )
  }

  relative_cue_condition_intervals <- summarise_condition_intervals(
    observed_cue_importance =
      relative_cue_observed$cue_importance,
    bootstrap_condition_results =
      relative_cue_condition_bootstrap
  )

  relative_cue_slope_inference <- summarise_slope_inference(
    observed_slopes =
      relative_cue_observed_slopes,
    bootstrap_slopes =
      relative_cue_slope_bootstrap
  )

  write_csv_safely(
    relative_cue_condition_intervals,
    "study1_relative_cue_condition_intervals.csv"
  )

  write_csv_safely(
    relative_cue_slope_inference,
    "study1_relative_cue_slope_inference.csv"
  )

  relative_cue_primary_result <- relative_cue_slope_inference %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    )

  cat("\nStudy 1：相対比重の線形傾向\n")
  print(relative_cue_primary_result)


  relative_x_offset <- 0.075

  relative_panel_a_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise",
        "economic_importance_pairwise"
      )
    ) %>%
    mutate(
      cue_family = recode(
        statistic,
        party_importance_pairwise = "政党手がかり",
        economic_importance_pairwise = "経済手がかり"
      ),
      cue_family = factor(
        cue_family,
        levels = c(
          "政党手がかり",
          "経済手がかり"
        )
      ),
      x_plot = case_when(
        cue_family == "政党手がかり" ~
          party_n + relative_x_offset,
        cue_family == "経済手がかり" ~
          party_n - relative_x_offset,
        TRUE ~ as.numeric(party_n)
      ),
      value_label = sprintf(
        "%.3f",
        estimate
      )
    )

  relative_panel_b_data <- relative_cue_condition_intervals %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    ) %>%
    mutate(
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_adjusted_label_map <- relative_panel_a_data %>%
    distinct(
      statistic,
      cue_family
    ) %>%
    mutate(
      statistic = paste0(
        statistic,
        "_adjusted"
      ),
      cue_family = as.character(
        cue_family
      )
    )

  relative_panel_adjusted_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise_adjusted",
        "economic_importance_pairwise_adjusted"
      )
    ) %>%
    left_join(
      relative_adjusted_label_map,
      by = "statistic"
    ) %>%
    mutate(
      cue_family = factor(
        cue_family,
        levels = levels(
          relative_panel_a_data$cue_family
        )
      ),
      x_plot = if_else(
        as.integer(cue_family) == 1L,
        party_n + relative_x_offset,
        party_n - relative_x_offset
      ),
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_condition_suffix <- if (
    "政党名手がかり" %in%
      levels(relative_panel_a_data$cue_family)
  ) {
    "選択肢"
  } else {
    "政党"
  }

  relative_condition_axis_title <- if (
    relative_condition_suffix == "選択肢"
  ) {
    "政治経済状況の選択肢数"
  } else {
    "政党選択肢数"
  }

  relative_figure_font_family <- if (
    .Platform$OS.type == "windows"
  ) {
    "Yu Gothic"
  } else {
    "sans"
  }

  relative_theme_japanese_bw <- theme_bw(
    base_size = 12,
    base_family = relative_figure_font_family
  ) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(
        linewidth = 0.30,
        color = "grey88"
      ),
      panel.border = element_rect(
        linewidth = 0.65,
        color = "black"
      ),
      axis.text = element_text(
        color = "black"
      ),
      axis.title = element_text(
        color = "black"
      ),
      plot.title = element_text(
        size = 12.5,
        face = "bold",
        hjust = 0
      ),
      plot.subtitle = element_text(
        size = 9.5,
        hjust = 0,
        margin = margin(
          b = 8
        )
      ),
      legend.position = "top",
      legend.justification = "center",
      legend.key.width = grid::unit(
        1.25,
        "cm"
      ),
      plot.margin = margin(
        8,
        10,
        8,
        8
      )
    )

  relative_panel_a <- ggplot(
    relative_panel_a_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = c(
        "政党手がかり" = "solid",
        "経済手がかり" = "dashed"
      )
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "政党"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_number(
        accuracy = 0.005
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：両手がかりの絶対的重要度",
      subtitle = "",
      x = "政党選択肢数",
      y = "手がかり重要度",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_adjusted_linetypes <- setNames(
    c(
      "solid",
      "dashed"
    ),
    levels(
      relative_panel_adjusted_data$cue_family
    )
  )

  relative_panel_adjusted <- ggplot(
    relative_panel_adjusted_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = relative_adjusted_linetypes
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        relative_condition_suffix
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：選択肢数調整済み重要度",
      subtitle =
        "未調整重要度 ÷ 平均選択確率（1／選択肢数）",
      x = relative_condition_axis_title,
      y = "平均選択確率に対する水準間差",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_b_range <- range(
    c(
      relative_panel_b_data$conf_low,
      relative_panel_b_data$conf_high,
      0.5
    ),
    na.rm = TRUE
  )

  relative_b_padding <- max(
    0.025,
    0.10 * diff(relative_b_range)
  )

  relative_b_lower <- max(
    0,
    floor(
      20 *
        (relative_b_range[1] - relative_b_padding)
    ) / 20
  )

  relative_b_upper <- min(
    1,
    ceiling(
      20 *
        (relative_b_range[2] + relative_b_padding)
    ) / 20
  )

  if (relative_b_lower >= relative_b_upper) {
    relative_b_lower <- max(
      0,
      relative_b_lower - 0.05
    )
    relative_b_upper <- min(
      1,
      relative_b_upper + 0.05
    )
  }

  relative_panel_b <- ggplot(
    relative_panel_b_data,
    aes(
      x = party_n,
      y = estimate
    )
  ) +
    geom_hline(
      yintercept = 0.5,
      linetype = "dashed",
      linewidth = 0.55,
      color = "black"
    ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "政党"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      breaks = seq(
        relative_b_lower,
        relative_b_upper,
        by = 0.05
      ),
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.05,
          0.08
        )
      )
    ) +
    coord_cartesian(
      ylim = c(
        relative_b_lower,
        relative_b_upper
      )
    ) +
    labs(
      title = "B：相対的な政党手がかりの比重",
      subtitle =
        "政党手がかり重要度 ÷（政党手がかり重要度＋経済手がかり重要度）",
      x = "政党選択肢数",
      y = "相対的な政党手がかり比重"
    ) +
    relative_theme_japanese_bw +
    theme(
      legend.position = "none"
    )

  relative_panel_c <- relative_panel_b +
    labs(
      title = paste0(
        "B：相対的な",
        levels(relative_panel_a_data$cue_family)[1],
        "の比重"
      )
    )

  figure_relative_weight_jp <- (
    relative_panel_a |
      relative_panel_b
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_jp
  )

  save_plot(
    "fig_study1_relative_cue_weight_jp_bw.png",
    figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      "fig_study1_relative_cue_weight_jp_bw.pdf"
    ),
    plot = figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  figure_relative_weight_adjusted_jp <- (
    relative_panel_adjusted |
      relative_panel_c
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_adjusted_jp
  )

  relative_adjusted_figure_stub <- paste0(
    "fig_study",
    stringr::str_extract(
      study_label,
      "[123]"
    ),
    "_relative_cue_weight_choice_set_adjusted_jp_bw"
  )

  save_plot(
    paste0(
      relative_adjusted_figure_stub,
      ".png"
    ),
    figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      paste0(
        relative_adjusted_figure_stub,
        ".pdf"
      )
    ),
    plot = figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  relative_cue_results <- list(
    prepared = relative_cue_prepared,
    marginal_means =
      relative_cue_observed$marginal_means,
    attribute_importance =
      relative_cue_observed$attribute_importance,
    cue_importance =
      relative_cue_observed$cue_importance,
    observed_slopes =
      relative_cue_observed_slopes,
    condition_bootstrap =
      relative_cue_condition_bootstrap,
    slope_bootstrap =
      relative_cue_slope_bootstrap,
    condition_intervals =
      relative_cue_condition_intervals,
    slope_inference =
      relative_cue_slope_inference,
    primary_result =
      relative_cue_primary_result,
    plots = list(
      absolute_importance = relative_panel_a,
      choice_set_adjusted_importance =
        relative_panel_adjusted,
      relative_party_weight = relative_panel_b,
      relative_party_weight_panel_c =
        relative_panel_c,
      combined = figure_relative_weight_jp,
      combined_with_choice_set_adjustment =
        figure_relative_weight_adjusted_jp
    )
  )

  saveRDS(
    relative_cue_results,
    file = file.path(
      output_dir,
      "study1_relative_cue_results.rds"
    )
  )


  saveRDS(
    list(
      settings = list(
        require_initial_consent = require_initial_consent,
        require_final_consent = require_final_consent,
        require_attention_check = require_attention_check,
        require_manipulation_check = require_manipulation_check
      ),
      sample_flow = sample_flow,
      n_by_party = n_by_party,
      valid_ids = valid_ids,
      conjoint_all = conjoint_all,
      conjoint_all_m = conjoint_all_m,
      covar_id = covar_id,
      models_by_party_n_nocov = models_by_party_n_nocov,
      models_by_party_n_cov = models_by_party_n_cov,
      m_interaction = m_interaction,
      models_clogit_nocov = models_clogit_nocov,
      relative_cue = relative_cue_results,
      plots = list(
        amce_cov = p_amce_cov_main,
        amce_nocov = p_amce_nocov_appendix,
        interaction = p_interaction,
        heatmap = p_heat_amce,
        heatmap_rank = p_heat_amce_rank,
        clogit_odds_ratio = p_clogit_or,
        relative_cue_weight = figure_relative_weight_jp,
        relative_cue_weight_choice_set_adjusted =
          figure_relative_weight_adjusted_jp
      )
    ),
    file = file.path(output_dir, "study1_analysis_objects.rds")
  )

  capture.output(
    sessionInfo(),
    file = file.path(output_dir, "sessionInfo.txt")
  )

  cat("
Done: ", normalizePath(output_dir), "
", sep = "")

  environment()
})

A.3 実験2：本文の図6

# 本文コード
study2_env <- local({
required_packages <- c(
    "dplyr",
    "tidyr",
    "stringr",
    "purrr",
    "readr",
    "fixest",
    "tibble",
    "forcats",
    "ggplot2",
    "scales",
    "survival",
    "ggtext",
    "patchwork"
  )

  missing_packages <- required_packages[
    !vapply(required_packages, requireNamespace, logical(1), quietly = TRUE)
  ]

  if (length(missing_packages) > 0) {
    stop("No packages")
  }

  library(dplyr)
  library(tidyr)
  library(stringr)
  library(purrr)
  library(readr)
  library(fixest)
  library(tibble)
  library(forcats)
  library(ggplot2)
  library(scales)
  library(survival)
  library(patchwork)

  data_file <- unified_config$study2$data_file
  output_dir <- unified_config$study2$output_dir

  dir.create(output_dir, showWarnings = FALSE, recursive = TRUE)

  require_initial_consent <- TRUE
  require_final_consent <- TRUE
  final_consent_var <- "Q8.1"

  require_attention_check <- TRUE
  require_manipulation_check <- TRUE

  attention_check_var <- "Q25.1_11"
  attention_check_correct <- "3"

  relative_cue_bootstrap_B <- unified_config$relative_cue_bootstrap_B
  relative_cue_bootstrap_seed <- unified_config$relative_cue_bootstrap_seed + 2L
  relative_cue_bootstrap_progress_every <- unified_config$relative_cue_bootstrap_progress_every

  rerun_relative_cue_bootstrap <- unified_config$rerun_relative_cue_bootstrap


  norm_text <- function(x) {
    x %>%
      as.character() %>%
      str_squish() %>%
      str_replace_all("～", "~") %>%
      str_replace_all("〜", "~")
  }

  as_num <- function(x) {
    suppressWarnings(readr::parse_number(norm_text(x)))
  }

  is_response_code <- function(x, code) {
    x_norm <- norm_text(x)
    code_chr <- as.character(code)

    x_norm == code_chr |
      stringr::str_detect(x_norm, paste0("\\(", code_chr, "\\)$"))
  }

  first_existing <- function(dat, candidates) {
    out <- candidates[candidates %in% names(dat)]
    if (length(out) == 0) NA_character_ else out[1]
  }

  get_var <- function(dat, candidates) {
    v <- first_existing(dat, candidates)
    if (is.na(v)) {
      rep(NA_character_, nrow(dat))
    } else {
      dat[[v]]
    }
  }

  relevel_if_present <- function(x, ref) {
    x <- factor(x)
    if (ref %in% levels(x)) {
      relevel(x, ref = ref)
    } else {
      x
    }
  }

  factor_miss <- function(x, miss = "欠損・無回答") {
    x <- norm_text(x)
    x[is.na(x) | x == "" | x == "NA"] <- miss
    factor(x)
  }

  mean_impute <- function(x) {
    x <- as.numeric(x)
    miss <- as.integer(is.na(x))

    if (all(is.na(x))) {
      value <- x
    } else {
      value <- ifelse(is.na(x), mean(x, na.rm = TRUE), x)
    }

    list(value = value, miss = miss)
  }

  write_csv_safely <- function(x, filename) {
    readr::write_csv(x, file.path(output_dir, filename), na = "")
  }

  save_plot <- function(filename, plot, width, height, dpi = 300) {
    ggplot2::ggsave(
      filename = file.path(output_dir, filename),
      plot = plot,
      width = width,
      height = height,
      dpi = dpi
    )
  }


  if (!file.exists(data_file)) {
    stop("Check data")
  }

  raw <- readr::read_csv(
    data_file,
    col_types = cols(.default = col_character()),
    show_col_types = FALSE,
    name_repair = "minimal"
  )


  if (require_final_consent) {
    final_consent_var <- detect_final_consent_column(
      raw = raw,
      preferred_candidates = c("Q8.1", "Q9.1", "Q10.1"),
      study_label = "Study 2"
    )
  }

  if (require_attention_check) {
    attention_check_var <- detect_attention_check_column(
      raw = raw,
      preferred_candidates = c("Q25.1_11", "Q25.1_10"),
      study_label = "Study 2"
    )
  }

  df_header_removed <- raw %>%
    filter(
      !is.na(ResponseId),
      ResponseId != "",
      !str_detect(
        norm_text(ResponseId),
        "^(Response ID|回答ID)$|ImportId"
      )
    ) %>%
    mutate(ID = as.character(ResponseId))

  duplicate_ids <- df_header_removed %>%
    count(ID) %>%
    filter(n > 1)

  if (nrow(duplicate_ids) > 0) {
    print(duplicate_ids)
    stop("Check")
  }

  sample_flow <- tibble(
    stage = "Qualtrics質問文行を除外後",
    n = nrow(df_header_removed)
  )

  df <- df_header_removed

  if (require_initial_consent) {
    if (!"Q1.1" %in% names(df)) {
      stop("Check initial consent")
    }

    df <- df %>%
      filter(
        is_response_code(Q1.1, 1) |
          str_detect(norm_text(Q1.1), "趣旨に同意して.*協力する")
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(stage = "初回同意 Q1.1 = 1", n = nrow(df))
    )
  }

  if (require_final_consent) {
    if (is.na(final_consent_var) || !final_consent_var %in% names(df)) {
      stop("Check final consent")
    }

    df <- df %>%
      filter(
        is_response_code(.data[[final_consent_var]], 1) |
          str_detect(
            norm_text(.data[[final_consent_var]]),
            "同意し.*回答結果を送信する"
          )
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(
        stage = paste0("最終同意 ", final_consent_var, " = 1"),
        n = nrow(df)
      )
    )
  }

  if (require_attention_check) {
    if (!attention_check_var %in% names(df)) {
      stop("Check attention item")
    }

    attention_check_correct <- detect_attention_correct_code(
      df[[attention_check_var]],
      displayed_answer = 3L,
      recoded_answer = 6L,
      study_label = "Study 2"
    )

    df <- df %>%
      filter(
        is_response_code(
          .data[[attention_check_var]],
          attention_check_correct
        )
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(
        stage = paste0(
          "指示項目正答（",
          attention_check_var,
          "、保存コード=",
          attention_check_correct,
          "）"
        ),
        n = nrow(df)
      )
    )
  }

  print(sample_flow)
  write_csv_safely(sample_flow, "sample_flow_before_conjoint.csv")


  choice_map <- detect_conjoint_choice_map(
    raw = raw,
    party_numbers = 2:5,
    study_label = "Study 2"
  )

  manipulation_map <- detect_manipulation_map(
    raw = raw,
    choice_map = choice_map,
    study_label = "Study 2"
  )

  write_csv_safely(choice_map, "detected_choice_question_map.csv")
  write_csv_safely(manipulation_map, "detected_manipulation_question_map.csv")


  level_to_attr_var <- function(x) {
    x <- norm_text(x)

    case_when(
      x %in% c("右派・保守的", "中道", "左派・革新的") ~
        "policy_position",

      x %in% c("与党", "野党") ~
        "government_status",

      str_detect(x, "GDP成長率") ~
        "gdp_growth",

      str_detect(x, "日経平均") ~
        "nikkei",

      x %in% c("10以下", "10~49", "50~99", "100~199", "200以上") ~
        "seats",

      str_detect(x, "CPI|物価") ~
        "cpi",

      str_detect(x, "失業率|雇用") ~
        "unemployment",

      TRUE ~ NA_character_
    )
  }

  required_attr_vars <- c(
    "policy_position",
    "government_status",
    "gdp_growth",
    "nikkei",
    "seats",
    "cpi",
    "unemployment"
  )

  allowed_levels <- list(
    policy_position = c("右派・保守的", "中道", "左派・革新的"),
    government_status = c("与党", "野党"),
    gdp_growth = c(
      "GDP成長率±0％",
      "GDP成長率プラス1％",
      "GDP成長率マイナス1％"
    ),
    nikkei = c(
      "日経平均前月同期比プラス1000円",
      "日経平均前月同期比マイナス1000円",
      "日経平均前月同期比変わらず"
    ),
    seats = c("10以下", "10~49", "50~99", "100~199", "200以上"),
    cpi = c(
      "CPI前期比±0ポイント",
      "CPI前期比プラス1ポイント",
      "CPI前期比マイナス1ポイント"
    ),
    unemployment = c(
      "失業率前期比±0％",
      "失業率前期比プラス1％",
      "失業率前期比マイナス1％"
    )
  )


  make_profile_long <- function(dat, n_party) {

    map_n <- choice_map %>%
      filter(party_n == n_party)

    qvars <- map_n$choice_var

    missing_q <- setdiff(qvars, names(dat))
    if (length(missing_q) > 0) {
      stop("Check choice columns")
    }

    dat_n <- dat %>%
      filter(if_any(all_of(qvars), ~ !is.na(.x) & norm_text(.x) != ""))

    if (require_manipulation_check) {
      manipulation_row <- manipulation_map %>%
        filter(party_n == n_party)

      manipulation_var <- manipulation_row$manipulation_var
      correct_answer <- manipulation_row$correct_answer

      if (!manipulation_var %in% names(dat_n)) {
        stop("Check manipulation item")
      }

      dat_n <- dat_n %>%
        filter(
          is_response_code(
            .data[[manipulation_var]],
            correct_answer
          )
        )
    }

    choice_long <- dat_n %>%
      select(ID, all_of(qvars)) %>%
      pivot_longer(
        cols = all_of(qvars),
        names_to = "choice_var",
        values_to = "choice_raw"
      ) %>%
      left_join(map_n, by = "choice_var") %>%
      mutate(choice = parse_choice_position(choice_raw)) %>%
      filter(!is.na(choice)) %>%
      select(ID, party_n, task, choice)

    invalid_choice <- choice_long %>%
      filter(choice < 1 | choice > n_party)

    if (nrow(invalid_choice) > 0) {
      print(invalid_choice)
      stop("Check choice values")
    }

    duplicate_choice <- choice_long %>%
      count(ID, task) %>%
      filter(n != 1)

    if (nrow(duplicate_choice) > 0) {
      print(duplicate_choice)
      stop("Check duplicate choices")
    }

    level_regex <- paste0(
      "^S2_P", n_party,
      "_F_([1-5])_([1-", n_party, "])_([1-7])$"
    )

    level_cols <- names(dat_n)[str_detect(names(dat_n), level_regex)]

    expected_level_cols <- 5 * n_party * 7
    if (length(level_cols) != expected_level_cols) {
      stop("Check attributes")
    }

    level_long <- dat_n %>%
      select(ID, all_of(level_cols)) %>%
      pivot_longer(
        cols = all_of(level_cols),
        names_to = "fvar",
        values_to = "level"
      ) %>%
      extract(
        fvar,
        into = c("task", "profile", "attr_order"),
        regex = level_regex,
        convert = TRUE
      ) %>%
      mutate(level = norm_text(level)) %>%
      filter(
        task %in% 1:5,
        profile %in% 1:n_party,
        attr_order %in% 1:7,
        !is.na(level),
        level != ""
      ) %>%
      mutate(attr_var = level_to_attr_var(level))

    unknown_levels <- level_long %>%
      filter(is.na(attr_var)) %>%
      distinct(level)

    if (nrow(unknown_levels) > 0) {
      print(unknown_levels)
      stop("Check attributes")
    }

    profile_attribute_count <- level_long %>%
      count(ID, task, profile, name = "n_attribute_rows") %>%
      filter(n_attribute_rows != 7)

    if (nrow(profile_attribute_count) > 0) {
      print(head(profile_attribute_count, 50))
      stop("Check attributes")
    }

    duplicate_attribute <- level_long %>%
      count(ID, task, profile, attr_var) %>%
      filter(n != 1)

    if (nrow(duplicate_attribute) > 0) {
      print(head(duplicate_attribute, 50))
      stop("Check attributes")
    }

    profile_wide <- level_long %>%
      inner_join(choice_long, by = c("ID", "task")) %>%
      mutate(
        party_n = n_party,
        selected = as.integer(profile == choice),
        task_id = paste(ID, party_n, task, sep = "_"),
        profile_id = paste(ID, party_n, task, profile, sep = "_")
      ) %>%
      select(
        ID, party_n, task, profile, choice, selected,
        task_id, profile_id, attr_var, level
      ) %>%
      pivot_wider(
        names_from = attr_var,
        values_from = level,
        values_fn = list(level = ~ first(.x))
      )

    missing_attr <- setdiff(required_attr_vars, names(profile_wide))

    if (length(missing_attr) > 0) {
      stop("Check attributes")
    }

    profile_wide <- profile_wide %>%
      select(
        ID, party_n, task, profile, choice, selected,
        task_id, profile_id,
        all_of(required_attr_vars)
      ) %>%
      arrange(ID, task, profile)

    return(profile_wide)
  }


  conjoint_2 <- make_profile_long(df, 2)
  conjoint_3 <- make_profile_long(df, 3)
  conjoint_4 <- make_profile_long(df, 4)
  conjoint_5 <- make_profile_long(df, 5)

  conjoint_all_unfiltered <- bind_rows(
    conjoint_2,
    conjoint_3,
    conjoint_4,
    conjoint_5
  )


  id_task_check <- conjoint_all_unfiltered %>%
    group_by(ID, party_n, task) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    group_by(ID, party_n) %>%
    summarise(
      n_tasks = n_distinct(task),
      all_tasks_ok = all(n_profiles == party_n & selected_sum == 1),
      .groups = "drop"
    )

  valid_ids <- id_task_check %>%
    filter(n_tasks == 5, all_tasks_ok)

  conjoint_all <- conjoint_all_unfiltered %>%
    semi_join(valid_ids, by = c("ID", "party_n"))

  n_by_party <- valid_ids %>%
    count(party_n, name = "n") %>%
    complete(party_n = 2:5, fill = list(n = 0)) %>%
    arrange(party_n)

  n_total <- valid_ids %>%
    summarise(n = n_distinct(ID)) %>%
    pull(n)

  figure_n_labels <- bind_rows(
    tibble(
      position = "全サンプル",
      label = paste0("全サンプル, n=", scales::comma(n_total))
    ),
    n_by_party %>%
      mutate(
        position = paste0(party_n, "政党選択"),
        label = paste0("n=", scales::comma(n))
      ) %>%
      select(position, label)
  )

  cat("\n分析対象者数\n")
  print(n_by_party)
  cat("全サンプル n=", n_total, "\n", sep = "")

  write_csv_safely(id_task_check, "id_task_check.csv")
  write_csv_safely(valid_ids, "valid_ids.csv")
  write_csv_safely(n_by_party, "n_by_party.csv")
  write_csv_safely(figure_n_labels, "figure_n_labels.csv")


  check_profile <- conjoint_all %>%
    group_by(party_n, ID, task, task_id) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    count(party_n, n_profiles, selected_sum)

  print(check_profile)

  stopifnot(all(check_profile$n_profiles == check_profile$party_n))
  stopifnot(all(check_profile$selected_sum == 1))

  allowed_df <- enframe(allowed_levels, name = "name", value = "value") %>%
    unnest(value)

  unexpected_values <- conjoint_all %>%
    select(all_of(required_attr_vars)) %>%
    pivot_longer(
      cols = everything(),
      names_to = "name",
      values_to = "value"
    ) %>%
    filter(!is.na(value), value != "") %>%
    distinct(name, value) %>%
    anti_join(allowed_df, by = c("name", "value"))

  print(unexpected_values)
  stopifnot(nrow(unexpected_values) == 0)

  observed_levels <- conjoint_all %>%
    select(all_of(required_attr_vars)) %>%
    pivot_longer(
      cols = everything(),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    distinct(attribute, level) %>%
    arrange(attribute, level)

  write_csv_safely(check_profile, "profile_expansion_check.csv")
  write_csv_safely(observed_levels, "observed_attribute_levels.csv")
  write_csv_safely(conjoint_all, "study2_profile_level_data.csv")


  analysis_ids <- valid_ids %>%
    select(ID, party_n)

  attention_summary <- df %>%
    semi_join(analysis_ids, by = "ID") %>%
    transmute(
      ID,
      attention_response = norm_text(.data[[attention_check_var]]),
      attention_pass = is_response_code(
        .data[[attention_check_var]],
        attention_check_correct
      )
    ) %>%
    count(attention_response, attention_pass, name = "n") %>%
    arrange(desc(attention_pass), attention_response)

  manipulation_summary <- map_dfr(2:5, function(n_party) {
    manipulation_row <- manipulation_map %>%
      filter(party_n == n_party)

    v <- manipulation_row$manipulation_var
    correct <- manipulation_row$correct_answer

    df %>%
      semi_join(
        analysis_ids %>% filter(party_n == n_party),
        by = "ID"
      ) %>%
      transmute(
        party_n = n_party,
        response = norm_text(.data[[v]]),
        correct = is_response_code(.data[[v]], correct)
      ) %>%
      count(party_n, response, correct, name = "n")
  })

  write_csv_safely(attention_summary, "attention_check_summary.csv")
  write_csv_safely(manipulation_summary, "party_number_check_summary.csv")


  conjoint_all_m <- conjoint_all %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),

      policy_position = factor(
        policy_position,
        levels = c("中道", "右派・保守的", "左派・革新的")
      ),

      government_status = factor(
        government_status,
        levels = c("野党", "与党")
      ),

      gdp_growth = factor(
        gdp_growth,
        levels = c(
          "GDP成長率±0％",
          "GDP成長率プラス1％",
          "GDP成長率マイナス1％"
        )
      ),

      nikkei = factor(
        nikkei,
        levels = c(
          "日経平均前月同期比変わらず",
          "日経平均前月同期比プラス1000円",
          "日経平均前月同期比マイナス1000円"
        )
      ),

      seats = factor(
        seats,
        levels = c("10以下", "10~49", "50~99", "100~199", "200以上")
      ),

      cpi = factor(
        cpi,
        levels = c(
          "CPI前期比±0ポイント",
          "CPI前期比プラス1ポイント",
          "CPI前期比マイナス1ポイント"
        )
      ),

      unemployment = factor(
        unemployment,
        levels = c(
          "失業率前期比±0％",
          "失業率前期比プラス1％",
          "失業率前期比マイナス1％"
        )
      ),

      party_n_f = factor(
        as.character(party_n),
        levels = c("2", "3", "4", "5")
      )
    )

  attr_terms <- c(
    "policy_position",
    "government_status",
    "gdp_growth",
    "nikkei",
    "seats",
    "cpi",
    "unemployment"
  )


  formula_nocov <- as.formula(
    paste("selected ~", paste(attr_terms, collapse = " + "))
  )

  run_amce_nocov <- function(dat) {
    feols(
      formula_nocov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_nocov <- conjoint_all_m %>%
    split(.$party_n) %>%
    map(run_amce_nocov)

  capture.output(
    etable(models_by_party_n_nocov),
    file = file.path(output_dir, "amce_nocov_models.txt")
  )


  m_interaction <- feols(
    selected ~
      party_n_f *
      (
        policy_position +
          government_status +
          gdp_growth +
          nikkei +
          seats +
          cpi +
          unemployment
      ),
    data = conjoint_all_m,
    vcov = ~ ID
  )

  capture.output(
    summary(m_interaction),
    file = file.path(output_dir, "amce_interaction_model.txt")
  )


  tidy_fixest <- function(model) {
    ct <- as.data.frame(fixest::coeftable(model))
    ct$term <- rownames(ct)

    ct %>%
      as_tibble() %>%
      rename(
        estimate = Estimate,
        std.error = `Std. Error`,
        statistic = `t value`,
        p.value = `Pr(>|t|)`
      ) %>%
      mutate(
        conf.low = estimate - 1.96 * std.error,
        conf.high = estimate + 1.96 * std.error
      ) %>%
      select(
        term, estimate, std.error, statistic, p.value,
        conf.low, conf.high
      )
  }

  term_labels <- tribble(
    ~term, ~attribute, ~cue_type, ~label, ~order,

    "government_status与党",
    "与党／野党", "政党の手がかり", "与党", 1,

    "policy_position右派・保守的",
    "政策位置", "政党の手がかり", "右派・保守的", 2,

    "policy_position左派・革新的",
    "政策位置", "政党の手がかり", "左派・革新的", 3,

    "seats10~49",
    "議席数", "政党の手がかり", "議席数：10～49", 4,

    "seats50~99",
    "議席数", "政党の手がかり", "議席数：50～99", 5,

    "seats100~199",
    "議席数", "政党の手がかり", "議席数：100～199", 6,

    "seats200以上",
    "議席数", "政党の手がかり", "議席数：200以上", 7,

    "gdp_growthGDP成長率プラス1％",
    "GDP成長率", "経済の手がかり", "GDP：プラス1％", 8,

    "gdp_growthGDP成長率マイナス1％",
    "GDP成長率", "経済の手がかり", "GDP：マイナス1％", 9,

    "nikkei日経平均前月同期比プラス1000円",
    "日経平均", "経済の手がかり", "日経平均：プラス1000円", 10,

    "nikkei日経平均前月同期比マイナス1000円",
    "日経平均", "経済の手がかり", "日経平均：マイナス1000円", 11,

    "cpiCPI前期比プラス1ポイント",
    "CPI", "経済の手がかり", "CPI：プラス1ポイント", 12,

    "cpiCPI前期比マイナス1ポイント",
    "CPI", "経済の手がかり", "CPI：マイナス1ポイント", 13,

    "unemployment失業率前期比プラス1％",
    "失業率", "経済の手がかり", "失業率：プラス1％", 14,

    "unemployment失業率前期比マイナス1％",
    "失業率", "経済の手がかり", "失業率：マイナス1％", 15
  )

  attribute_order <- c(
    "与党／野党",
    "政策位置",
    "議席数",
    "GDP成長率",
    "日経平均",
    "CPI",
    "失業率"
  )

  label_order <- term_labels %>%
    arrange(order) %>%
    pull(label)

  make_amce_plot_df <- function(models) {
    imap_dfr(
      models,
      ~ tidy_fixest(.x) %>%
        mutate(party_n = as.character(.y))
    ) %>%
      left_join(term_labels, by = "term") %>%
      filter(!is.na(attribute)) %>%
      mutate(
        estimate_pp = estimate * 100,
        conf.low_pp = conf.low * 100,
        conf.high_pp = conf.high * 100,
        party_n = factor(
          party_n,
          levels = c("2", "3", "4", "5"),
          labels = c("2政党", "3政党", "4政党", "5政党")
        ),
        attribute = factor(attribute, levels = attribute_order),
        label = factor(label, levels = rev(label_order))
      )
  }

  amce_plot_nocov <- make_amce_plot_df(models_by_party_n_nocov)
  write_csv_safely(amce_plot_nocov, "amce_nocov_coefficients.csv")

  interaction_plot_df <- tidy_fixest(m_interaction) %>%
    filter(str_detect(term, "party_n_f[345]")) %>%
    mutate(
      party_n_code = str_extract(term, "party_n_f[345]"),
      party_n = str_remove(party_n_code, "party_n_f"),
      base_term = term %>%
        str_remove("party_n_f[345]:") %>%
        str_remove(":party_n_f[345]")
    ) %>%
    left_join(term_labels, by = c("base_term" = "term")) %>%
    filter(!is.na(attribute)) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      party_n_label = factor(
        party_n,
        levels = c("3", "4", "5"),
        labels = c("3政党", "4政党", "5政党")
      ),
      attribute = factor(attribute, levels = attribute_order),
      label = factor(label, levels = rev(label_order))
    )

  write_csv_safely(interaction_plot_df, "amce_interaction_coefficients.csv")


  recode_female_study2 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num == 2 ~ 1L,
      x_num == 1 ~ 0L,
      TRUE ~ NA_integer_
    )
  }

  recode_college_grad_study2 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num %in% c(4, 5) ~ 1L,
      x_num %in% c(1, 2, 3) ~ 0L,
      TRUE ~ NA_integer_
    )
  }

  recode_party_support_study2 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num == 1 ~ "自由民主党",
      x_num == 2 ~ "中道改革連合",
      x_num == 3 ~ "立憲民主党",
      x_num == 4 ~ "公明党",
      x_num == 5 ~ "日本維新の会",
      x_num == 6 ~ "国民民主党",
      x_num == 7 ~ "れいわ新選組",
      x_num == 8 ~ "日本共産党",
      x_num == 9 ~ "参政党",
      x_num == 10 ~ "日本保守党",
      x_num == 11 ~ "社会民主党",
      x_num == 12 ~ "チームみらい",
      x_num == 13 ~ "その他",
      x_num == 14 ~ "支持政党なし",
      x_num == 15 ~ "わからない",
      x_num == 16 ~ "答えたくない",
      TRUE ~ NA_character_
    )
  }

  gender_raw <- get_var(df, c("Q2.1", "Q2_1"))
  age_raw <- get_var(df, c("Q2.2_2", "Q2.2.2", "Q2_2_2"))
  education_raw <- get_var(df, c("Q2.3", "Q2_3"))
  income_gross_raw <- get_var(df, c("Q2.5_1", "Q2.5.1", "Q2_5_1"))
  income_net_raw <- get_var(df, c("Q2.5_2", "Q2.5.2", "Q2_5_2"))
  party_support_raw <- get_var(df, c("Q8.2", "Q8_2"))

  covar_id <- df %>%
    transmute(
      ID = as.character(ResponseId),
      female = recode_female_study2(gender_raw),
      age = as_num(age_raw),
      college_grad = recode_college_grad_study2(education_raw),
      income_gross = as_num(income_gross_raw),
      income_net = as_num(income_net_raw),
      income_gross_log = log1p(income_gross),
      income_net_log = log1p(income_net),
      party_support = recode_party_support_study2(party_support_raw),
      party_support_f = factor_miss(party_support)
    ) %>%
    semi_join(valid_ids %>% select(ID), by = "ID") %>%
    distinct(ID, .keep_all = TRUE)

  covar_id <- covar_id %>%
    mutate(
      age = if_else(age >= 18 & age <= 79, age, NA_real_)
    )

  age_imp_obj <- mean_impute(covar_id$age)
  income_gross_imp_obj <- mean_impute(covar_id$income_gross_log)

  covar_id <- covar_id %>%
    mutate(
      female_imp = if_else(is.na(female), 0L, female),
      female_miss = as.integer(is.na(female)),

      college_grad_imp = if_else(is.na(college_grad), 0L, college_grad),
      college_grad_miss = as.integer(is.na(college_grad)),

      age_imp = age_imp_obj$value,
      age_miss = age_imp_obj$miss,

      income_gross_log_imp = income_gross_imp_obj$value,
      income_gross_log_miss = income_gross_imp_obj$miss
    )

  covariate_missing_summary <- covar_id %>%
    summarise(
      n_ids = n_distinct(ID),
      female_missing = sum(is.na(female)),
      age_missing = sum(is.na(age)),
      college_grad_missing = sum(is.na(college_grad)),
      income_gross_missing = sum(is.na(income_gross_log)),
      party_support_missing = sum(is.na(party_support))
    )

  print(covariate_missing_summary)
  write_csv_safely(covar_id, "respondent_covariates.csv")
  write_csv_safely(covariate_missing_summary, "covariate_missing_summary.csv")


  conjoint_all_cov <- conjoint_all_m %>%
    left_join(covar_id, by = "ID")

  covariate_terms <- c(
    "female_imp",
    "female_miss",
    "age_imp",
    "age_miss",
    "college_grad_imp",
    "college_grad_miss",
    "income_gross_log_imp",
    "income_gross_log_miss",
    "party_support_f"
  )

  has_variation <- function(dat, v) {
    if (!v %in% names(dat)) return(FALSE)
    dplyr::n_distinct(dat[[v]], na.rm = TRUE) > 1
  }

  covariate_terms_use <- covariate_terms[
    map_lgl(covariate_terms, ~ has_variation(conjoint_all_cov, .x))
  ]

  formula_cov <- as.formula(
    paste(
      "selected ~",
      paste(c(attr_terms, covariate_terms_use), collapse = " + ")
    )
  )

  run_amce_cov <- function(dat) {
    feols(
      formula_cov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_cov <- conjoint_all_cov %>%
    split(.$party_n) %>%
    map(run_amce_cov)

  capture.output(
    etable(
      models_by_party_n_nocov,
      models_by_party_n_cov,
      headers = c(
        rep("共変量なし", length(models_by_party_n_nocov)),
        rep("共変量あり", length(models_by_party_n_cov))
      )
    ),
    file = file.path(output_dir, "amce_nocov_and_cov_models.txt")
  )

  amce_plot_cov <- make_amce_plot_df(models_by_party_n_cov)
  write_csv_safely(amce_plot_cov, "amce_cov_coefficients.csv")


  study_label <- "実験2（2026年）"

  term_labels_facet <- term_labels %>%
    mutate(
      attribute_facet = attribute
    )

  attribute_order_facet <- c(
    "与党／野党",
    "政策位置",
    "議席数",
    "GDP成長率",
    "日経平均",
    "CPI",
    "失業率"
  )

  make_amce_facet_df <- function(models) {
    imap_dfr(
      models,
      ~ tidy_fixest(.x) %>%
        mutate(party_n = as.character(.y))
    ) %>%
      left_join(term_labels_facet, by = "term") %>%
      filter(!is.na(attribute_facet)) %>%
      mutate(
        estimate_pp = estimate * 100,
        conf.low_pp = conf.low * 100,
        conf.high_pp = conf.high * 100,
        party_n = factor(
          party_n,
          levels = c("2", "3", "4", "5"),
          labels = c("2政党", "3政党", "4政党", "5政党")
        ),
        attribute_facet = factor(
          attribute_facet,
          levels = attribute_order_facet
        ),
        label = factor(
          label,
          levels = rev(label_order)
        )
      )
  }

  amce_plot_df_cov_facet <- make_amce_facet_df(models_by_party_n_cov)
  amce_plot_df_nocov_facet <- make_amce_facet_df(models_by_party_n_nocov)

  write_csv_safely(
    amce_plot_df_cov_facet,
    "amce_cov_facet_coefficients.csv"
  )

  write_csv_safely(
    amce_plot_df_nocov_facet,
    "amce_nocov_facet_coefficients.csv"
  )


  p_amce_cov_facet <- ggplot(
    amce_plot_df_cov_facet,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute_facet ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-12, 12, by = 2)
    ) +
    scale_shape_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = "Yu Gothic"
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_amce_cov_facet)

  save_plot(
    "amce_cov_facet_model.png",
    p_amce_cov_facet,
    width = 10.5,
    height = 8.5
  )

  p_amce_cov_main <- p_amce_cov_facet


  make_heatmap_df <- function(amce_plot_df) {
    heat_df <- amce_plot_df %>%
      mutate(
        abs_amce = abs(estimate_pp),
        cue_type_code = case_when(
          cue_type == "政党の手がかり" ~ "party",
          cue_type == "経済の手がかり" ~ "economy",
          TRUE ~ "other"
        )
      ) %>%
      group_by(party_n) %>%
      mutate(
        rank_within_party = min_rank(desc(abs_amce)),
        n_in_col = n(),
        rank_score = if_else(
          n_in_col == 1,
          1,
          1 - (rank_within_party - 1) / (n_in_col - 1)
        )
      ) %>%
      ungroup()

    row_order_df <- heat_df %>%
      group_by(label, cue_type_code) %>%
      summarise(
        mean_abs_amce = mean(abs_amce, na.rm = TRUE),
        .groups = "drop"
      ) %>%
      arrange(desc(mean_abs_amce))

    row_levels <- as.character(row_order_df$label)

    heat_df <- heat_df %>%
      mutate(
        label = factor(
          as.character(label),
          levels = rev(row_levels)
        )
      )

    label_color_map <- row_order_df %>%
      mutate(
        label_markdown = case_when(
          cue_type_code == "party" ~
            paste0(
              "<span style='color:#111111;'>",
              label,
              "</span>"
            ),
          cue_type_code == "economy" ~
            paste0(
              "<span style='color:#8A8A8A;'>",
              label,
              "</span>"
            ),
          TRUE ~ as.character(label)
        )
      )

    label_markdown_vec <- setNames(
      label_color_map$label_markdown,
      as.character(label_color_map$label)
    )

    list(
      heat_df = heat_df,
      label_markdown_vec = label_markdown_vec
    )
  }

  plot_amce_heatmap <- function(
      heat_df,
      label_markdown_vec,
      with_rank = TRUE,
      title_text = NULL) {

    if (with_rank) {
      heat_df <- heat_df %>%
        mutate(
          cell_label = paste0(
            sprintf("%.1f", estimate_pp),
            "\n(",
            rank_within_party,
            "位)"
          )
        )

      text_size <- 3.0
      lineheight <- 0.9
    } else {
      heat_df <- heat_df %>%
        mutate(
          cell_label = sprintf("%.1f", estimate_pp)
        )

      text_size <- 3.4
      lineheight <- 1.0
    }

    ggplot(
      heat_df,
      aes(
        x = party_n,
        y = label,
        fill = rank_score
      )
    ) +
      geom_tile(
        color = "white",
        linewidth = 0.7
      ) +
      geom_text(
        aes(label = cell_label),
        size = text_size,
        fontface = "bold",
        color = "black",
        lineheight = lineheight
      ) +
      scale_y_discrete(
        labels = label_markdown_vec
      ) +
      scale_fill_gradient(
        low = "grey95",
        high = "grey15",
        limits = c(0, 1),
        breaks = c(0, 0.25, 0.50, 0.75, 1.00),
        labels = c("低", "", "", "", "高"),
        name = "列内順位\n（濃いほど高位）"
      ) +
      labs(
        title = title_text,
        x = "政党数選択肢",
        y = NULL
      ) +
      theme_bw(base_size = 12) +
      theme(
        legend.position = "right",
        panel.grid = element_blank(),
        plot.title = element_text(face = "bold"),
        axis.text.x = element_text(size = 10),
        axis.text.y = ggtext::element_markdown(size = 9),
        axis.title.y = element_blank()
      )
  }

  heatmap_input <- make_heatmap_df(amce_plot_cov)

  p_heat_amce_mixed <- plot_amce_heatmap(
    heatmap_input$heat_df,
    heatmap_input$label_markdown_vec,
    with_rank = FALSE,
    title_text = NULL
  )

  print(p_heat_amce_mixed)

  save_plot(
    "amce_heatmap_mixed_rank_colored_labels.png",
    p_heat_amce_mixed,
    width = 8.8,
    height = 8.8
  )

  p_heat_amce_mixed_ranklabel <- plot_amce_heatmap(
    heatmap_input$heat_df,
    heatmap_input$label_markdown_vec,
    with_rank = TRUE,
    title_text = NULL
  )

  print(p_heat_amce_mixed_ranklabel)

  save_plot(
    "amce_heatmap_mixed_rank_colored_labels_withrank.png",
    p_heat_amce_mixed_ranklabel,
    width = 8.8,
    height = 8.8
  )

  p_heat_amce <- p_heat_amce_mixed
  p_heat_amce_rank <- p_heat_amce_mixed_ranklabel


  p_amce_facet_nocov <- ggplot(
    amce_plot_df_nocov_facet,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute_facet ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-12, 12, by = 2)
    ) +
    scale_shape_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "政党数選択肢",
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(base_size = 12) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_amce_facet_nocov)

  save_plot(
    "amce_facet_nocov.png",
    p_amce_facet_nocov,
    width = 10.5,
    height = 9
  )

  p_amce_nocov_appendix <- p_amce_facet_nocov


  p_interaction <- ggplot(
    interaction_plot_df,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n_label,
      linetype = party_n_label,
      group = party_n_label
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(width = 0.65),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.65),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) paste0(x, " pp"),
      breaks = seq(-8, 8, by = 2)
    ) +
    scale_shape_manual(
      name = "2政党の場合との比較",
      values = c(
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      name = "2政党の場合との比較",
      values = c(
        "3政党" = "dashed",
        "4政党" = "dotted",
        "5政党" = "dotdash"
      )
    ) +
    labs(
      x = "2政党条件との差",
      y = NULL
    ) +
    theme_bw(base_size = 12) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 15
      ),
      plot.subtitle = element_text(size = 11),
      legend.position = "top",
      legend.title = element_text(face = "bold"),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(size = 9),
      axis.title.x = element_text(face = "bold")
    )

  print(p_interaction)

  save_plot(
    "amce_interaction_difference_from_2party.png",
    p_interaction,
    width = 10.5,
    height = 9
  )


  conjoint_clogit <- conjoint_all_m %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),
      task_id = factor(task_id),
      policy_position = relevel_if_present(
        policy_position,
        "中道"
      ),
      government_status = relevel_if_present(
        government_status,
        "野党"
      ),
      gdp_growth = relevel_if_present(
        gdp_growth,
        "GDP成長率±0％"
      ),
      nikkei = relevel_if_present(
        nikkei,
        "日経平均前月同期比変わらず"
      ),
      seats = relevel_if_present(
        seats,
        "10以下"
      ),
      cpi = relevel_if_present(
        cpi,
        "CPI前期比±0ポイント"
      ),
      unemployment = relevel_if_present(
        unemployment,
        "失業率前期比±0％"
      )
    )

  formula_clogit_nocov <- as.formula(
    paste0(
      "selected ~ ",
      paste(attr_terms, collapse = " + "),
      " + strata(task_id) + cluster(ID)"
    )
  )

  run_clogit_nocov <- function(dat) {
    survival::clogit(
      formula_clogit_nocov,
      data = dat,
      method = "efron"
    )
  }

  models_clogit_nocov <- conjoint_clogit %>%
    split(.$party_n) %>%
    map(run_clogit_nocov)

  capture.output(
    lapply(models_clogit_nocov, summary),
    file = file.path(
      output_dir,
      "conditional_logit_models.txt"
    )
  )

  tidy_clogit <- function(model) {
    s <- summary(model)
    ct <- as.data.frame(s$coefficients)
    ct$term <- rownames(ct)

    se_col <- if ("robust se" %in% names(ct)) {
      "robust se"
    } else if ("se(coef)" %in% names(ct)) {
      "se(coef)"
    } else {
      stop("Check clogit")
    }

    p_col <- if ("Pr(>|z|)" %in% names(ct)) {
      "Pr(>|z|)"
    } else if ("Pr(>|t|)" %in% names(ct)) {
      "Pr(>|t|)"
    } else {
      NA_character_
    }

    ct %>%
      as_tibble() %>%
      transmute(
        term = term,
        estimate = coef,
        std.error = .data[[se_col]],
        p.value = if (!is.na(p_col)) {
          .data[[p_col]]
        } else {
          NA_real_
        },
        conf.low = estimate - 1.96 * std.error,
        conf.high = estimate + 1.96 * std.error,
        odds_ratio = exp(estimate),
        odds_ratio_low = exp(conf.low),
        odds_ratio_high = exp(conf.high)
      )
  }

  clogit_plot_df <- imap_dfr(
    models_clogit_nocov,
    ~ tidy_clogit(.x) %>%
      mutate(party_n = as.character(.y))
  ) %>%
    left_join(term_labels, by = "term") %>%
    filter(!is.na(attribute)) %>%
    mutate(
      party_n = factor(
        party_n,
        levels = c("2", "3", "4", "5"),
        labels = c("2政党", "3政党", "4政党", "5政党")
      ),
      label = factor(
        label,
        levels = rev(label_order)
      )
    )

  write_csv_safely(
    clogit_plot_df,
    "conditional_logit_coefficients.csv"
  )


  p_clogit_or <- ggplot(
    clogit_plot_df,
    aes(
      x = odds_ratio,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 1,
      linetype = "dashed",
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = odds_ratio_low,
        xmax = odds_ratio_high
      ),
      position = position_dodge(width = 0.72),
      height = 0.15,
      linewidth = 0.45,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(width = 0.72),
      size = 2.4,
      stroke = 0.7,
      color = "black"
    ) +
    scale_x_log10(
      breaks = c(
        0.6,
        0.8,
        1.0,
        1.25,
        1.5,
        2.0
      ),
      labels = c(
        "0.6",
        "0.8",
        "1.0",
        "1.25",
        "1.5",
        "2.0"
      )
    ) +
    scale_shape_manual(
      values = c(
        "2政党" = 16,
        "3政党" = 17,
        "4政党" = 15,
        "5政党" = 1
      )
    ) +
    scale_linetype_manual(
      values = c(
        "2政党" = "solid",
        "3政党" = "dashed",
        "4政党" = "dotdash",
        "5政党" = "twodash"
      )
    ) +
    labs(
      x = "オッズ比",
      y = NULL,
      shape = "政党数選択肢",
      linetype = "政党数選択肢"
    ) +
    theme_bw(base_size = 12) +
    theme(
      legend.position = "bottom",
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      plot.title = element_text(face = "bold"),
      axis.text.y = element_text(size = 9)
    )

  print(p_clogit_or)

  save_plot(
    "clogit_oddsratio_nocov.png",
    p_clogit_or,
    width = 10.5,
    height = 8.5
  )


  relative_cue_map <- c(
    policy_position = "party",
    government_status = "party",
    seats = "party",
    gdp_growth = "economic",
    nikkei = "economic",
    cpi = "economic",
    unemployment = "economic"
  )

  mean_absolute_pairwise_difference <- function(x) {
    x <- x[is.finite(x)]

    if (length(x) < 2) {
      return(NA_real_)
    }

    pairwise_differences <- combn(
      x,
      2,
      FUN = function(z) abs(z[1] - z[2])
    )

    mean(pairwise_differences)
  }

  linear_slope <- function(y, x) {
    keep <- is.finite(y) & is.finite(x)
    y <- y[keep]
    x <- x[keep]

    if (length(y) < 2 || length(unique(x)) < 2) {
      return(NA_real_)
    }

    unname(coef(lm(y ~ x))[2])
  }

  bootstrap_two_sided_p <- function(x) {
    x <- x[is.finite(x)]
    B_valid <- length(x)

    if (B_valid == 0) {
      return(NA_real_)
    }

    p_lower <- (1 + sum(x <= 0)) / (B_valid + 1)
    p_upper <- (1 + sum(x >= 0)) / (B_valid + 1)

    min(1, 2 * min(p_lower, p_upper))
  }

  safe_quantile <- function(x, probability) {
    x <- x[is.finite(x)]

    if (length(x) == 0) {
      return(NA_real_)
    }

    unname(
      quantile(
        x,
        probs = probability,
        type = 6,
        na.rm = TRUE
      )
    )
  }

  prepare_relative_cue_analysis <- function(data, cue_map) {
    attributes <- names(cue_map)

    required_columns <- c(
      "ID",
      "party_n",
      "selected",
      attributes
    )

    missing_columns <- setdiff(
      required_columns,
      names(data)
    )

    if (length(missing_columns) > 0) {
      stop("Check relative weight")
    }

    if (!all(unname(cue_map) %in% c("party", "economic"))) {
      stop("Check relative weight")
    }

    analysis_data <- data %>%
      select(
        ID,
        party_n,
        selected,
        all_of(attributes)
      ) %>%
      mutate(
        ID = as.character(ID),
        party_n = as.integer(as.character(party_n)),
        selected = as.integer(selected),
        across(
          all_of(attributes),
          as.character
        )
      ) %>%
      filter(
        !is.na(ID),
        party_n %in% 2:5,
        selected %in% c(0L, 1L)
      )

    observed_conditions <- sort(
      unique(analysis_data$party_n)
    )

    if (!identical(observed_conditions, 2:5)) {
      stop("Check")
    }

    long_data <- analysis_data %>%
      pivot_longer(
        cols = all_of(attributes),
        names_to = "attribute",
        values_to = "level"
      ) %>%
      filter(
        !is.na(level),
        level != ""
      )

    expected_cells <- long_data %>%
      distinct(
        attribute,
        level
      ) %>%
      mutate(
        attribute_order = match(
          attribute,
          attributes
        )
      ) %>%
      arrange(
        attribute_order,
        attribute,
        level
      ) %>%
      select(-attribute_order) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    respondent_cell <- long_data %>%
      group_by(
        party_n,
        ID,
        attribute,
        level
      ) %>%
      summarise(
        y_sum = sum(selected),
        n_obs = n(),
        .groups = "drop"
      ) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    condition_objects <- lapply(
      2:5,
      function(n_value) {
        condition_data <- respondent_cell %>%
          filter(
            party_n == n_value
          )

        id_values <- sort(
          unique(condition_data$ID)
        )
        n_ids <- length(id_values)
        n_cells <- nrow(expected_cells)

        if (n_ids == 0) {
          stop("Check")
        }

        y_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        n_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        row_index <- match(
          condition_data$ID,
          id_values
        )
        column_index <- match(
          condition_data$cell_key,
          expected_cells$cell_key
        )

        y_matrix[cbind(row_index, column_index)] <-
          condition_data$y_sum
        n_matrix[cbind(row_index, column_index)] <-
          condition_data$n_obs

        if (any(colSums(n_matrix) == 0)) {
          missing_cells <- expected_cells$cell_key[
            colSums(n_matrix) == 0
          ]

          stop("Check attributes")
        }

        list(
          party_n = n_value,
          ids = id_values,
          cell_info = expected_cells,
          y_matrix = y_matrix,
          n_matrix = n_matrix
        )
      }
    )

    names(condition_objects) <- as.character(2:5)

    list(
      cue_map = cue_map,
      attributes = attributes,
      conditions = condition_objects
    )
  }

  estimate_relative_cue_indices <- function(
      prepared,
      cluster_weights = NULL
  ) {
    condition_results <- lapply(
      names(prepared$conditions),
      function(condition_name) {
        object <- prepared$conditions[[condition_name]]

        if (is.null(cluster_weights)) {
          weights <- rep(
            1,
            length(object$ids)
          )
        } else {
          weights <- cluster_weights[[condition_name]]
        }

        if (length(weights) != length(object$ids)) {
          stop("Check")
        }

        numerator <- as.numeric(
          crossprod(
            weights,
            object$y_matrix
          )
        )

        denominator <- as.numeric(
          crossprod(
            weights,
            object$n_matrix
          )
        )

        if (any(denominator <= 0)) {
          stop("Check attributes")
        }

        marginal_means <- numerator / denominator

        mm_table <- object$cell_info %>%
          transmute(
            party_n = object$party_n,
            attribute,
            level,
            marginal_mean = marginal_means
          )

        attribute_table <- mm_table %>%
          group_by(
            party_n,
            attribute
          ) %>%
          summarise(
            importance_pairwise =
              mean_absolute_pairwise_difference(
                marginal_mean
              ),
            n_levels = n(),
            .groups = "drop"
          ) %>%
          mutate(
            cue_family = unname(
              prepared$cue_map[attribute]
            ),
            baseline_selection_probability = 1 / party_n,
            importance_pairwise_adjusted =
              importance_pairwise /
                baseline_selection_probability
          )

        cue_table_long <- attribute_table %>%
          group_by(
            party_n,
            cue_family
          ) %>%
          summarise(
            importance_pairwise = mean(
              importance_pairwise,
              na.rm = TRUE
            ),
            importance_pairwise_adjusted = mean(
              importance_pairwise_adjusted,
              na.rm = TRUE
            ),
            .groups = "drop"
          )

        party_table <- cue_table_long %>%
          filter(
            cue_family == "party"
          ) %>%
          transmute(
            party_n,
            party_importance_pairwise =
              importance_pairwise,
            party_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        economic_table <- cue_table_long %>%
          filter(
            cue_family == "economic"
          ) %>%
          transmute(
            party_n,
            economic_importance_pairwise =
              importance_pairwise,
            economic_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        cue_table <- full_join(
          party_table,
          economic_table,
          by = "party_n"
        ) %>%
          mutate(
            baseline_selection_probability = 1 / party_n,

            total_importance_pairwise =
              party_importance_pairwise +
              economic_importance_pairwise,

            total_importance_pairwise_adjusted =
              party_importance_pairwise_adjusted +
              economic_importance_pairwise_adjusted,

            relative_party_weight_pairwise = if_else(
              total_importance_pairwise > 0,
              party_importance_pairwise /
                total_importance_pairwise,
              NA_real_
            ),

            relative_economic_weight_pairwise =
              1 - relative_party_weight_pairwise,

            relative_party_weight_pairwise_adjusted = if_else(
              total_importance_pairwise_adjusted > 0,
              party_importance_pairwise_adjusted /
                total_importance_pairwise_adjusted,
              NA_real_
            ),

            relative_economic_weight_pairwise_adjusted =
              1 - relative_party_weight_pairwise_adjusted,

            adjustment_identity_difference =
              relative_party_weight_pairwise_adjusted -
                relative_party_weight_pairwise
          )

        if (
          any(
            abs(cue_table$adjustment_identity_difference) > 1e-10,
            na.rm = TRUE
          )
        ) {
          stop("Check relative weight")
        }

        list(
          marginal_means = mm_table,
          attribute_importance = attribute_table,
          cue_importance = cue_table
        )
      }
    )

    list(
      marginal_means = bind_rows(
        lapply(
          condition_results,
          function(x) x$marginal_means
        )
      ),
      attribute_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$attribute_importance
        )
      ),
      cue_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$cue_importance
        )
      ) %>%
        arrange(party_n)
    )
  }

  estimate_relative_cue_slopes <- function(cue_importance) {
    cue_importance <- cue_importance %>%
      arrange(party_n)

    if (!identical(cue_importance$party_n, 2:5)) {
      stop("Check relative weight")
    }

    x <- cue_importance$party_n

    c(
      relative_party_weight_pairwise =
        linear_slope(
          cue_importance$relative_party_weight_pairwise,
          x
        ),

      party_importance_pairwise =
        linear_slope(
          cue_importance$party_importance_pairwise,
          x
        ),

      economic_importance_pairwise =
        linear_slope(
          cue_importance$economic_importance_pairwise,
          x
        ),

      party_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$party_importance_pairwise_adjusted,
          x
        ),

      economic_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$economic_importance_pairwise_adjusted,
          x
        )
    )
  }

  run_relative_cue_bootstrap <- function(
      prepared,
      B,
      seed,
      progress_every = 100
  ) {
    set.seed(seed)

    condition_results <- vector(
      "list",
      B
    )

    slope_names <- c(
      "relative_party_weight_pairwise",
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted"
    )

    slope_matrix <- matrix(
      NA_real_,
      nrow = B,
      ncol = length(slope_names),
      dimnames = list(
        NULL,
        slope_names
      )
    )

    for (b in seq_len(B)) {
      cluster_weights <- lapply(
        prepared$conditions,
        function(object) {
          n_ids <- length(object$ids)

          sampled_positions <- sample.int(
            n = n_ids,
            size = n_ids,
            replace = TRUE
          )

          tabulate(
            sampled_positions,
            nbins = n_ids
          )
        }
      )

      bootstrap_estimates <- estimate_relative_cue_indices(
        prepared = prepared,
        cluster_weights = cluster_weights
      )

      condition_results[[b]] <-
        bootstrap_estimates$cue_importance %>%
        select(
          party_n,
          party_importance_pairwise,
          economic_importance_pairwise,
          party_importance_pairwise_adjusted,
          economic_importance_pairwise_adjusted,
          relative_party_weight_pairwise
        ) %>%
        mutate(
          bootstrap_replication = b,
          .before = 1
        )

      slope_matrix[b, ] <- estimate_relative_cue_slopes(
        bootstrap_estimates$cue_importance
      )

      if (
        progress_every > 0 &&
        (b %% progress_every == 0 || b == B)
      ) {
        message("Bootstrap: ", b, "/", B)
      }
    }

    list(
      condition_estimates = bind_rows(
        condition_results
      ),
      slopes = as_tibble(
        slope_matrix
      ) %>%
        mutate(
          bootstrap_replication = row_number(),
          .before = 1
        )
    )
  }

  summarise_condition_intervals <- function(
      observed_cue_importance,
      bootstrap_condition_results
  ) {
    statistics <- c(
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted",
      "relative_party_weight_pairwise"
    )

    observed_long <- observed_cue_importance %>%
      select(
        party_n,
        all_of(statistics)
      ) %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "estimate"
      )

    bootstrap_long <- bootstrap_condition_results %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "value"
      ) %>%
      group_by(
        party_n,
        statistic
      ) %>%
      summarise(
        conf_low = safe_quantile(
          value,
          0.025
        ),
        conf_high = safe_quantile(
          value,
          0.975
        ),
        .groups = "drop"
      )

    observed_long %>%
      left_join(
        bootstrap_long,
        by = c(
          "party_n",
          "statistic"
        )
      )
  }

  summarise_slope_inference <- function(
      observed_slopes,
      bootstrap_slopes
  ) {
    statistic_names <- names(observed_slopes)

    map_dfr(
      statistic_names,
      function(statistic_name) {
        bootstrap_values <- bootstrap_slopes[[statistic_name]]
        bootstrap_values <- bootstrap_values[
          is.finite(bootstrap_values)
        ]

        expected_direction <- case_when(
          statistic_name ==
            "economic_importance_pairwise" ~ "negative",
          statistic_name %in% c(
            "party_importance_pairwise",
            "relative_party_weight_pairwise",
            "party_importance_pairwise_adjusted"
          ) ~ "positive",
          TRUE ~ "none"
        )

        analysis_role <- case_when(
          statistic_name %in% c(
            "party_importance_pairwise_adjusted",
            "economic_importance_pairwise_adjusted"
          ) ~ "exploratory_choice_set_adjusted",
          statistic_name == "relative_party_weight_pairwise" ~
            "derived_relative_share",
          TRUE ~ "manuscript_primary_unadjusted"
        )

        estimate <- unname(
          observed_slopes[[statistic_name]]
        )

        tibble(
          study = "Study 2",
          statistic = statistic_name,
          estimate = estimate,
          conf_low = safe_quantile(
            bootstrap_values,
            0.025
          ),
          conf_high = safe_quantile(
            bootstrap_values,
            0.975
          ),
          p_value_two_sided =
            bootstrap_two_sided_p(
              bootstrap_values
            ),
          expected_direction = expected_direction,
          analysis_role = analysis_role,
          estimate_in_expected_direction = case_when(
            expected_direction == "positive" ~ estimate > 0,
            expected_direction == "negative" ~ estimate < 0,
            TRUE ~ NA
          )
        )
      }
    )
  }

  relative_cue_prepared <- prepare_relative_cue_analysis(
    data = conjoint_all_m,
    cue_map = relative_cue_map
  )

  relative_cue_observed <- estimate_relative_cue_indices(
    prepared = relative_cue_prepared
  )

  relative_cue_observed_slopes <- estimate_relative_cue_slopes(
    relative_cue_observed$cue_importance
  )

  write_csv_safely(
    relative_cue_observed$marginal_means,
    "study2_relative_cue_marginal_means.csv"
  )

  write_csv_safely(
    relative_cue_observed$attribute_importance,
    "study2_relative_cue_attribute_importance.csv"
  )

  write_csv_safely(
    relative_cue_observed$cue_importance,
    "study2_relative_cue_importance_and_weight.csv"
  )

  relative_condition_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study2_relative_cue_condition_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  relative_slope_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study2_relative_cue_slope_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  use_saved_relative_bootstrap <-
    !rerun_relative_cue_bootstrap &&
    file.exists(relative_condition_bootstrap_file) &&
    file.exists(relative_slope_bootstrap_file)

  if (use_saved_relative_bootstrap) {
    message("Bootstrap cache")

    relative_cue_condition_bootstrap <- readr::read_csv(
      relative_condition_bootstrap_file,
      show_col_types = FALSE
    )

    relative_cue_slope_bootstrap <- readr::read_csv(
      relative_slope_bootstrap_file,
      show_col_types = FALSE
    )

    saved_B_condition <- n_distinct(
      relative_cue_condition_bootstrap$bootstrap_replication
    )
    saved_B_slope <- n_distinct(
      relative_cue_slope_bootstrap$bootstrap_replication
    )

    if (
      saved_B_condition != relative_cue_bootstrap_B ||
      saved_B_slope != relative_cue_bootstrap_B
    ) {
      message("Bootstrap cache")
      use_saved_relative_bootstrap <- FALSE
    }
  }

  if (!use_saved_relative_bootstrap) {
    relative_cue_bootstrap <- run_relative_cue_bootstrap(
      prepared = relative_cue_prepared,
      B = relative_cue_bootstrap_B,
      seed = relative_cue_bootstrap_seed,
      progress_every = relative_cue_bootstrap_progress_every
    )

    relative_cue_condition_bootstrap <-
      relative_cue_bootstrap$condition_estimates

    relative_cue_slope_bootstrap <-
      relative_cue_bootstrap$slopes

    readr::write_csv(
      relative_cue_condition_bootstrap,
      relative_condition_bootstrap_file
    )

    readr::write_csv(
      relative_cue_slope_bootstrap,
      relative_slope_bootstrap_file
    )
  }

  relative_cue_condition_intervals <- summarise_condition_intervals(
    observed_cue_importance =
      relative_cue_observed$cue_importance,
    bootstrap_condition_results =
      relative_cue_condition_bootstrap
  )

  relative_cue_slope_inference <- summarise_slope_inference(
    observed_slopes =
      relative_cue_observed_slopes,
    bootstrap_slopes =
      relative_cue_slope_bootstrap
  )

  write_csv_safely(
    relative_cue_condition_intervals,
    "study2_relative_cue_condition_intervals.csv"
  )

  write_csv_safely(
    relative_cue_slope_inference,
    "study2_relative_cue_slope_inference.csv"
  )

  relative_cue_primary_result <- relative_cue_slope_inference %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    )

  cat("\nStudy 2：相対比重の線形傾向\n")
  print(relative_cue_primary_result)


  relative_x_offset <- 0.075

  relative_panel_a_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise",
        "economic_importance_pairwise"
      )
    ) %>%
    mutate(
      cue_family = recode(
        statistic,
        party_importance_pairwise = "政党手がかり",
        economic_importance_pairwise = "経済手がかり"
      ),
      cue_family = factor(
        cue_family,
        levels = c(
          "政党手がかり",
          "経済手がかり"
        )
      ),
      x_plot = case_when(
        cue_family == "政党手がかり" ~
          party_n + relative_x_offset,
        cue_family == "経済手がかり" ~
          party_n - relative_x_offset,
        TRUE ~ as.numeric(party_n)
      ),
      value_label = sprintf(
        "%.3f",
        estimate
      )
    )

  relative_panel_b_data <- relative_cue_condition_intervals %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    ) %>%
    mutate(
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_adjusted_label_map <- relative_panel_a_data %>%
    distinct(
      statistic,
      cue_family
    ) %>%
    mutate(
      statistic = paste0(
        statistic,
        "_adjusted"
      ),
      cue_family = as.character(
        cue_family
      )
    )

  relative_panel_adjusted_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise_adjusted",
        "economic_importance_pairwise_adjusted"
      )
    ) %>%
    left_join(
      relative_adjusted_label_map,
      by = "statistic"
    ) %>%
    mutate(
      cue_family = factor(
        cue_family,
        levels = levels(
          relative_panel_a_data$cue_family
        )
      ),
      x_plot = if_else(
        as.integer(cue_family) == 1L,
        party_n + relative_x_offset,
        party_n - relative_x_offset
      ),
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_condition_suffix <- if (
    "政党名手がかり" %in%
      levels(relative_panel_a_data$cue_family)
  ) {
    "選択肢"
  } else {
    "政党"
  }

  relative_condition_axis_title <- if (
    relative_condition_suffix == "選択肢"
  ) {
    "政治経済状況の選択肢数"
  } else {
    "政党選択肢数"
  }

  relative_figure_font_family <- if (
    .Platform$OS.type == "windows"
  ) {
    "Yu Gothic"
  } else {
    "sans"
  }

  relative_theme_japanese_bw <- theme_bw(
    base_size = 12,
    base_family = relative_figure_font_family
  ) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(
        linewidth = 0.30,
        color = "grey88"
      ),
      panel.border = element_rect(
        linewidth = 0.65,
        color = "black"
      ),
      axis.text = element_text(
        color = "black"
      ),
      axis.title = element_text(
        color = "black"
      ),
      plot.title = element_text(
        size = 12.5,
        face = "bold",
        hjust = 0
      ),
      plot.subtitle = element_text(
        size = 9.5,
        hjust = 0,
        margin = margin(
          b = 8
        )
      ),
      legend.position = "top",
      legend.justification = "center",
      legend.key.width = grid::unit(
        1.25,
        "cm"
      ),
      plot.margin = margin(
        8,
        10,
        8,
        8
      )
    )

  relative_panel_a <- ggplot(
    relative_panel_a_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = c(
        "政党手がかり" = "solid",
        "経済手がかり" = "dashed"
      )
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "政党"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_number(
        accuracy = 0.005
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：両手がかりの絶対的重要度",
      subtitle = "",
      x = "政党選択肢数",
      y = "手がかり重要度",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_adjusted_linetypes <- setNames(
    c(
      "solid",
      "dashed"
    ),
    levels(
      relative_panel_adjusted_data$cue_family
    )
  )

  relative_panel_adjusted <- ggplot(
    relative_panel_adjusted_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = relative_adjusted_linetypes
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        relative_condition_suffix
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：選択肢数調整済み重要度",
      subtitle =
        "未調整重要度 ÷ 平均選択確率（1／選択肢数）",
      x = relative_condition_axis_title,
      y = "平均選択確率に対する水準間差",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_b_range <- range(
    c(
      relative_panel_b_data$conf_low,
      relative_panel_b_data$conf_high,
      0.5
    ),
    na.rm = TRUE
  )

  relative_b_padding <- max(
    0.025,
    0.10 * diff(relative_b_range)
  )

  relative_b_lower <- max(
    0,
    floor(
      20 *
        (relative_b_range[1] - relative_b_padding)
    ) / 20
  )

  relative_b_upper <- min(
    1,
    ceiling(
      20 *
        (relative_b_range[2] + relative_b_padding)
    ) / 20
  )

  if (relative_b_lower >= relative_b_upper) {
    relative_b_lower <- max(
      0,
      relative_b_lower - 0.05
    )
    relative_b_upper <- min(
      1,
      relative_b_upper + 0.05
    )
  }

  relative_panel_b <- ggplot(
    relative_panel_b_data,
    aes(
      x = party_n,
      y = estimate
    )
  ) +
    geom_hline(
      yintercept = 0.5,
      linetype = "dashed",
      linewidth = 0.55,
      color = "black"
    ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "政党"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      breaks = seq(
        relative_b_lower,
        relative_b_upper,
        by = 0.05
      ),
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.05,
          0.08
        )
      )
    ) +
    coord_cartesian(
      ylim = c(
        relative_b_lower,
        relative_b_upper
      )
    ) +
    labs(
      title = "B：相対的な政党手がかりの比重",
      subtitle =
        "政党手がかり重要度 ÷（政党手がかり重要度＋経済手がかり重要度）",
      x = "政党選択肢数",
      y = "相対的な政党手がかり比重"
    ) +
    relative_theme_japanese_bw +
    theme(
      legend.position = "none"
    )

  relative_panel_c <- relative_panel_b +
    labs(
      title = paste0(
        "B：相対的な",
        levels(relative_panel_a_data$cue_family)[1],
        "の比重"
      )
    )

  figure_relative_weight_jp <- (
    relative_panel_a |
      relative_panel_b
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_jp
  )

  save_plot(
    "fig_study2_relative_cue_weight_jp_bw.png",
    figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      "fig_study2_relative_cue_weight_jp_bw.pdf"
    ),
    plot = figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  figure_relative_weight_adjusted_jp <- (
    relative_panel_adjusted |
      relative_panel_c
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_adjusted_jp
  )

  relative_adjusted_figure_stub <- paste0(
    "fig_study",
    stringr::str_extract(
      study_label,
      "[123]"
    ),
    "_relative_cue_weight_choice_set_adjusted_jp_bw"
  )

  save_plot(
    paste0(
      relative_adjusted_figure_stub,
      ".png"
    ),
    figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      paste0(
        relative_adjusted_figure_stub,
        ".pdf"
      )
    ),
    plot = figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  relative_cue_results <- list(
    prepared = relative_cue_prepared,
    marginal_means =
      relative_cue_observed$marginal_means,
    attribute_importance =
      relative_cue_observed$attribute_importance,
    cue_importance =
      relative_cue_observed$cue_importance,
    observed_slopes =
      relative_cue_observed_slopes,
    condition_bootstrap =
      relative_cue_condition_bootstrap,
    slope_bootstrap =
      relative_cue_slope_bootstrap,
    condition_intervals =
      relative_cue_condition_intervals,
    slope_inference =
      relative_cue_slope_inference,
    primary_result =
      relative_cue_primary_result,
    plots = list(
      absolute_importance = relative_panel_a,
      choice_set_adjusted_importance =
        relative_panel_adjusted,
      relative_party_weight = relative_panel_b,
      relative_party_weight_panel_c =
        relative_panel_c,
      combined = figure_relative_weight_jp,
      combined_with_choice_set_adjustment =
        figure_relative_weight_adjusted_jp
    )
  )

  saveRDS(
    relative_cue_results,
    file = file.path(
      output_dir,
      "study2_relative_cue_results.rds"
    )
  )


  saveRDS(
    list(
      settings = list(
        require_initial_consent = require_initial_consent,
        require_final_consent = require_final_consent,
        require_attention_check = require_attention_check,
        require_manipulation_check = require_manipulation_check
      ),
      sample_flow = sample_flow,
      n_by_party = n_by_party,
      valid_ids = valid_ids,
      conjoint_all = conjoint_all,
      conjoint_all_m = conjoint_all_m,
      covar_id = covar_id,
      models_by_party_n_nocov = models_by_party_n_nocov,
      models_by_party_n_cov = models_by_party_n_cov,
      m_interaction = m_interaction,
      models_clogit_nocov = models_clogit_nocov,
      relative_cue = relative_cue_results,
      plots = list(
        amce_cov = p_amce_cov_main,
        amce_nocov = p_amce_nocov_appendix,
        interaction = p_interaction,
        heatmap = p_heat_amce,
        heatmap_rank = p_heat_amce_rank,
        clogit_odds_ratio = p_clogit_or,
        relative_cue_weight = figure_relative_weight_jp,
        relative_cue_weight_choice_set_adjusted =
          figure_relative_weight_adjusted_jp
      )
    ),
    file = file.path(output_dir, "study2_analysis_objects.rds")
  )

  capture.output(
    sessionInfo(),
    file = file.path(output_dir, "sessionInfo.txt")
  )

  cat("
Done: ", normalizePath(output_dir), "
", sep = "")

  environment()
})

A.4 実験3：本文の図7・図8・図9

# 本文コード
study3_env <- local({
required_packages <- c(
    "dplyr",
    "tidyr",
    "stringr",
    "purrr",
    "readr",
    "fixest",
    "tibble",
    "forcats",
    "ggplot2",
    "scales",
    "survival",
    "patchwork"
  )

  missing_packages <- required_packages[
    !vapply(required_packages, requireNamespace, logical(1), quietly = TRUE)
  ]

  if (length(missing_packages) > 0) {
    stop("No packages")
  }

  library(dplyr)
  library(tidyr)
  library(stringr)
  library(purrr)
  library(readr)
  library(fixest)
  library(tibble)
  library(forcats)
  library(ggplot2)
  library(scales)
  library(survival)
  library(patchwork)

  data_file <- unified_config$study3$data_file
  output_dir <- unified_config$study3$output_dir

  dir.create(output_dir, showWarnings = FALSE, recursive = TRUE)

  require_initial_consent <- TRUE
  require_final_consent <- TRUE
  final_consent_var <- "Q8.1"

  require_attention_check <- TRUE
  require_manipulation_check <- TRUE

  require_all_five_tasks <- TRUE

  attention_check_var <- "Q25.1_11"
  attention_check_correct <- "3"

  relative_cue_bootstrap_B <- unified_config$relative_cue_bootstrap_B
  relative_cue_bootstrap_seed <- unified_config$relative_cue_bootstrap_seed + 3L
  relative_cue_bootstrap_progress_every <- unified_config$relative_cue_bootstrap_progress_every

  rerun_relative_cue_bootstrap <- unified_config$rerun_relative_cue_bootstrap

  figure_font_family <- if (.Platform$OS.type == "windows") {
    "Yu Gothic"
  } else {
    ""
  }


  norm_text <- function(x) {
    x %>%
      as.character() %>%
      str_replace_all("\u3000", " ") %>%
      str_squish() %>%
      str_replace_all("～", "~") %>%
      str_replace_all("〜", "~")
  }

  as_num <- function(x) {
    suppressWarnings(readr::parse_number(norm_text(x)))
  }

  first_existing <- function(dat, candidates) {
    out <- candidates[candidates %in% names(dat)]
    if (length(out) == 0) {
      NA_character_
    } else {
      out[1]
    }
  }

  get_var <- function(dat, candidates) {
    v <- first_existing(dat, candidates)

    if (is.na(v)) {
      rep(NA_character_, nrow(dat))
    } else {
      dat[[v]]
    }
  }

  is_response_code <- function(x, code) {
    x_norm <- norm_text(x)
    code_chr <- as.character(code)

    x_norm == code_chr |
      str_detect(x_norm, paste0("\\(", code_chr, "\\)$"))
  }

  relevel_if_present <- function(x, ref) {
    x <- factor(x)

    if (ref %in% levels(x)) {
      relevel(x, ref = ref)
    } else {
      x
    }
  }

  factor_miss <- function(x, miss = "欠損・無回答") {
    x <- norm_text(x)
    x[is.na(x) | x == "" | x == "NA"] <- miss
    factor(x)
  }

  mean_impute <- function(x) {
    x <- as.numeric(x)
    miss <- as.integer(is.na(x))

    if (all(is.na(x))) {
      value <- x
    } else {
      value <- ifelse(
        is.na(x),
        mean(x, na.rm = TRUE),
        x
      )
    }

    list(
      value = value,
      miss = miss
    )
  }

  write_csv_safely <- function(x, filename) {
    readr::write_csv(
      x,
      file.path(output_dir, filename),
      na = ""
    )
  }

  save_plot <- function(
    filename,
    plot,
    width,
    height,
    dpi = 300
  ) {
    ggplot2::ggsave(
      filename = file.path(output_dir, filename),
      plot = plot,
      width = width,
      height = height,
      dpi = dpi
    )
  }

  canonicalize_party_name <- function(x) {
    x_norm <- norm_text(x)
    x_compact <- str_replace_all(x_norm, "\\s+", "")

    case_when(
      is.na(x_compact) | x_compact == "" ~ NA_character_,

      x_compact %in% c(
        "自由民主党",
        "自民党",
        "自民"
      ) ~ "自由民主党",

      x_compact %in% c(
        "立憲民主党",
        "立民"
      ) ~ "立憲民主党",

      x_compact %in% c(
        "日本維新の会",
        "維新"
      ) ~ "日本維新の会",

      x_compact == "公明党" ~ "公明党",

      x_compact %in% c(
        "国民民主党",
        "国民"
      ) ~ "国民民主党",

      x_compact %in% c(
        "れいわ新選組",
        "れいわ"
      ) ~ "れいわ新選組",

      x_compact == "参政党" ~ "参政党",

      x_compact %in% c(
        "日本共産党",
        "共産党"
      ) ~ "日本共産党",

      x_compact == "中道改革連合" ~ "中道改革連合",

      x_compact == "日本保守党" ~ "日本保守党",

      x_compact %in% c(
        "社会民主党",
        "社民党"
      ) ~ "社会民主党",

      x_compact == "チームみらい" ~ "チームみらい",

      TRUE ~ x_norm
    )
  }

  canonicalize_economic_level <- function(x) {
    x_norm <- norm_text(x) %>%
      str_replace_all("＋", "+") %>%
      str_replace_all("−|－|―", "-") %>%
      str_replace_all("%", "％")

    case_when(
      is.na(x_norm) | x_norm == "" ~ NA_character_,

      str_detect(x_norm, "GDP") &
        str_detect(x_norm, "プラス|\\+\\s*1") ~
        "GDP成長率プラス1％",

      str_detect(x_norm, "GDP") &
        str_detect(x_norm, "マイナス|-\\s*1") ~
        "GDP成長率マイナス1％",

      str_detect(x_norm, "GDP") &
        str_detect(x_norm, "±\\s*0|0\\s*％|変わらず|変化なし") ~
        "GDP成長率±0％",

      str_detect(x_norm, "日経平均") &
        str_detect(x_norm, "プラス|\\+\\s*1000") ~
        "日経平均前月同期比プラス1000円",

      str_detect(x_norm, "日経平均") &
        str_detect(x_norm, "マイナス|-\\s*1000") ~
        "日経平均前月同期比マイナス1000円",

      str_detect(x_norm, "日経平均") &
        str_detect(x_norm, "変わらず|変化なし|±\\s*0|0\\s*円") ~
        "日経平均前月同期比変わらず",

      str_detect(x_norm, "CPI|物価") &
        str_detect(x_norm, "プラス|\\+\\s*1") ~
        "CPI前期比プラス1ポイント",

      str_detect(x_norm, "CPI|物価") &
        str_detect(x_norm, "マイナス|-\\s*1") ~
        "CPI前期比マイナス1ポイント",

      str_detect(x_norm, "CPI|物価") &
        str_detect(x_norm, "±\\s*0|0\\s*ポイント|変わらず|変化なし") ~
        "CPI前期比±0ポイント",

      str_detect(x_norm, "失業率|雇用") &
        str_detect(x_norm, "プラス|\\+\\s*1") ~
        "失業率前期比プラス1％",

      str_detect(x_norm, "失業率|雇用") &
        str_detect(x_norm, "マイナス|-\\s*1") ~
        "失業率前期比マイナス1％",

      str_detect(x_norm, "失業率|雇用") &
        str_detect(x_norm, "±\\s*0|0\\s*％|変わらず|変化なし") ~
        "失業率前期比±0％",

      TRUE ~ x_norm
    )
  }

  level_to_attr_var <- function(x) {
    x_norm <- canonicalize_economic_level(x)

    case_when(
      str_detect(x_norm, "^GDP成長率") ~ "gdp_growth",
      str_detect(x_norm, "^日経平均") ~ "nikkei",
      str_detect(x_norm, "^CPI") ~ "cpi",
      str_detect(x_norm, "^失業率") ~ "unemployment",
      TRUE ~ NA_character_
    )
  }

  tidy_fixest <- function(model) {
    ct <- as.data.frame(fixest::coeftable(model))
    ct$term <- rownames(ct)

    estimate_col <- intersect(
      c("Estimate", "estimate"),
      names(ct)
    )[1]

    se_col <- intersect(
      c("Std. Error", "Std. error", "std.error"),
      names(ct)
    )[1]

    statistic_col <- intersect(
      c("t value", "z value", "statistic"),
      names(ct)
    )[1]

    p_col <- intersect(
      c("Pr(>|t|)", "Pr(>|z|)", "p.value"),
      names(ct)
    )[1]

    if (
      is.na(estimate_col) |
        is.na(se_col) |
        is.na(statistic_col) |
        is.na(p_col)
    ) {
      stop("Check data")
    }

    ct %>%
      as_tibble() %>%
      transmute(
        term = term,
        estimate = .data[[estimate_col]],
        std.error = .data[[se_col]],
        statistic = .data[[statistic_col]],
        p.value = .data[[p_col]],
        conf.low = estimate - 1.96 * std.error,
        conf.high = estimate + 1.96 * std.error
      )
  }


  if (!file.exists(data_file)) {
    stop("Check data")
  }

  raw <- readr::read_csv(
    data_file,
    col_types = cols(.default = col_character()),
    show_col_types = FALSE,
    name_repair = "minimal"
  )


  if (require_final_consent) {
    final_consent_var <- detect_final_consent_column(
      raw = raw,
      preferred_candidates = c("Q8.1", "Q9.1", "Q10.1"),
      study_label = "Study 3"
    )
  }

  if (require_attention_check) {
    attention_check_var <- detect_attention_check_column(
      raw = raw,
      preferred_candidates = c("Q25.1_11", "Q25.1_10"),
      study_label = "Study 3"
    )
  }

  if (!"ResponseId" %in% names(raw)) {
    stop("Check data")
  }

  df_header_removed <- raw %>%
    filter(
      !is.na(ResponseId),
      ResponseId != "",
      !str_detect(
        norm_text(ResponseId),
        "^(Response ID|回答ID)$|ImportId"
      )
    ) %>%
    mutate(ID = as.character(ResponseId))

  duplicate_ids <- df_header_removed %>%
    count(ID) %>%
    filter(n > 1)

  if (nrow(duplicate_ids) > 0) {
    print(duplicate_ids)
    stop("Check")
  }

  sample_flow <- tibble(
    stage = "Qualtrics質問文行・ImportId行を除外後",
    n = nrow(df_header_removed)
  )

  df <- df_header_removed

  if (require_initial_consent) {
    if (!"Q1.1" %in% names(df)) {
      stop("Check initial consent")
    }

    df <- df %>%
      filter(
        is_response_code(Q1.1, 1) |
          str_detect(
            norm_text(Q1.1),
            "趣旨に同意して.*協力する"
          )
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(
        stage = "初回同意 Q1.1 = 1",
        n = nrow(df)
      )
    )
  }

  if (require_final_consent) {
    if (is.na(final_consent_var) || !final_consent_var %in% names(df)) {
      stop("Check final consent")
    }

    df <- df %>%
      filter(
        is_response_code(.data[[final_consent_var]], 1) |
          str_detect(
            norm_text(.data[[final_consent_var]]),
            "同意し.*回答結果を送信する"
          )
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(
        stage = paste0("最終同意 ", final_consent_var, " = 1"),
        n = nrow(df)
      )
    )
  }

  if (require_attention_check) {
    if (!attention_check_var %in% names(df)) {
      stop("Check attention item")
    }

    attention_check_correct <- detect_attention_correct_code(
      df[[attention_check_var]],
      displayed_answer = 3L,
      recoded_answer = 6L,
      study_label = "Study 3"
    )

    df <- df %>%
      filter(
        is_response_code(
          .data[[attention_check_var]],
          attention_check_correct
        )
      )

    sample_flow <- bind_rows(
      sample_flow,
      tibble(
        stage = paste0(
          "指示項目正答（",
          attention_check_var,
          "、保存コード=",
          attention_check_correct,
          "）"
        ),
        n = nrow(df)
      )
    )
  }

  print(sample_flow)
  write_csv_safely(
    sample_flow,
    "sample_flow_before_conjoint.csv"
  )


  choice_map <- detect_conjoint_choice_map(
    raw = raw,
    party_numbers = 2:5,
    study_label = "Study 3"
  )

  manipulation_map <- detect_manipulation_map(
    raw = raw,
    choice_map = choice_map,
    study_label = "Study 3"
  )

  write_csv_safely(choice_map, "detected_choice_question_map.csv")
  write_csv_safely(manipulation_map, "detected_manipulation_question_map.csv")


  required_attr_vars <- c(
    "party_name",
    "gdp_growth",
    "nikkei",
    "cpi",
    "unemployment"
  )

  expected_party_levels <- c(
    "自由民主党",
    "立憲民主党",
    "日本維新の会",
    "公明党",
    "国民民主党",
    "れいわ新選組",
    "参政党",
    "日本共産党",
    "中道改革連合"
  )

  allowed_economic_levels <- list(
    gdp_growth = c(
      "GDP成長率±0％",
      "GDP成長率プラス1％",
      "GDP成長率マイナス1％"
    ),

    nikkei = c(
      "日経平均前月同期比変わらず",
      "日経平均前月同期比プラス1000円",
      "日経平均前月同期比マイナス1000円"
    ),

    cpi = c(
      "CPI前期比±0ポイント",
      "CPI前期比プラス1ポイント",
      "CPI前期比マイナス1ポイント"
    ),

    unemployment = c(
      "失業率前期比±0％",
      "失業率前期比プラス1％",
      "失業率前期比マイナス1％"
    )
  )


  make_profile_long <- function(dat, n_party) {

    map_n <- choice_map %>%
      filter(party_n == n_party)

    qvars <- map_n$choice_var

    missing_q <- setdiff(qvars, names(dat))

    if (length(missing_q) > 0) {
      stop("Check choice columns")
    }

    dat_n <- dat %>%
      filter(
        if_any(
          all_of(qvars),
          ~ !is.na(.x) & norm_text(.x) != ""
        )
      )

    if (require_manipulation_check) {
      manipulation_row <- manipulation_map %>%
        filter(party_n == n_party)

      manipulation_var <- manipulation_row$manipulation_var
      correct_answer <- manipulation_row$correct_answer

      if (!manipulation_var %in% names(dat_n)) {
        stop("Check manipulation item")
      }

      dat_n <- dat_n %>%
        filter(
          is_response_code(
            .data[[manipulation_var]],
            correct_answer
          )
        )
    }

    choice_long <- dat_n %>%
      select(
        ID,
        all_of(qvars)
      ) %>%
      pivot_longer(
        cols = all_of(qvars),
        names_to = "choice_var",
        values_to = "choice_raw"
      ) %>%
      left_join(
        map_n,
        by = "choice_var"
      ) %>%
      mutate(
        choice = parse_choice_position(choice_raw)
      ) %>%
      filter(!is.na(choice)) %>%
      select(
        ID,
        party_n,
        task,
        choice
      )

    invalid_choice <- choice_long %>%
      filter(
        choice < 1 |
          choice > n_party
      )

    if (nrow(invalid_choice) > 0) {
      print(invalid_choice)
      stop("Check choice values")
    }

    duplicate_choice <- choice_long %>%
      count(
        ID,
        task
      ) %>%
      filter(n != 1)

    if (nrow(duplicate_choice) > 0) {
      print(duplicate_choice)
      stop("Check duplicate choices")
    }

    party_regex <- paste0(
      "^S3_P",
      n_party,
      "_PARTY_([1-5])_([1-",
      n_party,
      "])$"
    )

    party_cols <- names(dat_n)[
      str_detect(
        names(dat_n),
        party_regex
      )
    ]

    expected_party_cols_n <- 5 * n_party

    if (length(party_cols) != expected_party_cols_n) {
      stop("Check")
    }

    party_long <- dat_n %>%
      select(
        ID,
        all_of(party_cols)
      ) %>%
      pivot_longer(
        cols = all_of(party_cols),
        names_to = "party_var",
        values_to = "party_name_raw"
      ) %>%
      extract(
        party_var,
        into = c(
          "task",
          "profile"
        ),
        regex = party_regex,
        convert = TRUE
      ) %>%
      mutate(
        party_name = canonicalize_party_name(
          party_name_raw
        )
      ) %>%
      filter(
        task %in% 1:5,
        profile %in% 1:n_party,
        !is.na(party_name),
        party_name != ""
      ) %>%
      select(
        ID,
        task,
        profile,
        party_name
      )

    duplicate_party_name <- party_long %>%
      count(
        ID,
        task,
        profile
      ) %>%
      filter(n != 1)

    if (nrow(duplicate_party_name) > 0) {
      print(
        head(
          duplicate_party_name,
          50
        )
      )
      stop("Check")
    }

    level_regex <- paste0(
      "^S3_P",
      n_party,
      "_F_([1-5])_([1-",
      n_party,
      "])_([1-4])$"
    )

    level_cols <- names(dat_n)[
      str_detect(
        names(dat_n),
        level_regex
      )
    ]

    expected_level_cols_n <- 5 * n_party * 4

    if (length(level_cols) != expected_level_cols_n) {
      stop("Check attributes")
    }

    level_long <- dat_n %>%
      select(
        ID,
        all_of(level_cols)
      ) %>%
      pivot_longer(
        cols = all_of(level_cols),
        names_to = "fvar",
        values_to = "level_raw"
      ) %>%
      extract(
        fvar,
        into = c(
          "task",
          "profile",
          "attr_order"
        ),
        regex = level_regex,
        convert = TRUE
      ) %>%
      mutate(
        level = canonicalize_economic_level(
          level_raw
        ),
        attr_var = level_to_attr_var(
          level
        )
      ) %>%
      filter(
        task %in% 1:5,
        profile %in% 1:n_party,
        attr_order %in% 1:4,
        !is.na(level),
        level != ""
      )

    unknown_levels <- level_long %>%
      filter(
        is.na(attr_var)
      ) %>%
      distinct(
        level_raw,
        level
      )

    if (nrow(unknown_levels) > 0) {
      print(unknown_levels)
      stop("Check attributes")
    }

    profile_attribute_count <- level_long %>%
      count(
        ID,
        task,
        profile,
        name = "n_attribute_rows"
      ) %>%
      filter(
        n_attribute_rows != 4
      )

    if (nrow(profile_attribute_count) > 0) {
      print(
        head(
          profile_attribute_count,
          50
        )
      )
      stop("Check attributes")
    }

    duplicate_attribute <- level_long %>%
      count(
        ID,
        task,
        profile,
        attr_var
      ) %>%
      filter(n != 1)

    if (nrow(duplicate_attribute) > 0) {
      print(
        head(
          duplicate_attribute,
          50
        )
      )
      stop("Check attributes")
    }

    economic_wide <- level_long %>%
      select(
        ID,
        task,
        profile,
        attr_var,
        level
      ) %>%
      pivot_wider(
        names_from = attr_var,
        values_from = level,
        values_fn = list(
          level = ~ first(.x)
        )
      )

    profile_wide <- party_long %>%
      inner_join(
        economic_wide,
        by = c(
          "ID",
          "task",
          "profile"
        )
      ) %>%
      inner_join(
        choice_long,
        by = c(
          "ID",
          "task"
        )
      ) %>%
      mutate(
        party_n = n_party,
        selected = as.integer(
          profile == choice
        ),
        task_id = paste(
          ID,
          party_n,
          task,
          sep = "_"
        ),
        profile_id = paste(
          ID,
          party_n,
          task,
          profile,
          sep = "_"
        )
      )

    missing_attr <- setdiff(
      required_attr_vars,
      names(profile_wide)
    )

    if (length(missing_attr) > 0) {
      stop("Check attributes")
    }

    profile_wide <- profile_wide %>%
      select(
        ID,
        party_n,
        task,
        profile,
        choice,
        selected,
        task_id,
        profile_id,
        all_of(required_attr_vars)
      ) %>%
      arrange(
        ID,
        task,
        profile
      )

    return(profile_wide)
  }


  conjoint_2 <- make_profile_long(
    df,
    2
  )

  conjoint_3 <- make_profile_long(
    df,
    3
  )

  conjoint_4 <- make_profile_long(
    df,
    4
  )

  conjoint_5 <- make_profile_long(
    df,
    5
  )

  conjoint_all_unfiltered <- bind_rows(
    conjoint_2,
    conjoint_3,
    conjoint_4,
    conjoint_5
  )


  id_task_check <- conjoint_all_unfiltered %>%
    group_by(
      ID,
      party_n,
      task
    ) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    group_by(
      ID,
      party_n
    ) %>%
    summarise(
      n_tasks = n_distinct(task),
      all_tasks_ok = all(
        n_profiles == party_n &
          selected_sum == 1
      ),
      .groups = "drop"
    )

  if (require_all_five_tasks) {
    valid_ids <- id_task_check %>%
      filter(
        n_tasks == 5,
        all_tasks_ok
      )
  } else {
    valid_ids <- id_task_check %>%
      filter(all_tasks_ok)
  }

  conjoint_all <- conjoint_all_unfiltered %>%
    semi_join(
      valid_ids,
      by = c(
        "ID",
        "party_n"
      )
    )

  sample_flow <- bind_rows(
    sample_flow,
    tibble(
      stage = if (require_all_five_tasks) {
        "5課題すべてが完全な回答者"
      } else {
        "回答済み課題がすべて完全な回答者"
      },
      n = n_distinct(conjoint_all$ID)
    )
  )

  n_by_party <- valid_ids %>%
    count(
      party_n,
      name = "n"
    ) %>%
    complete(
      party_n = 2:5,
      fill = list(n = 0)
    ) %>%
    arrange(party_n)

  n_total <- valid_ids %>%
    summarise(
      n = n_distinct(ID)
    ) %>%
    pull(n)

  figure_n_labels <- bind_rows(
    tibble(
      position = "全サンプル",
      label = paste0(
        "全サンプル, n=",
        scales::comma(n_total)
      )
    ),

    n_by_party %>%
      mutate(
        position = paste0(
          party_n,
          "選択肢"
        ),
        label = paste0(
          "n=",
          scales::comma(n)
        )
      ) %>%
      select(
        position,
        label
      )
  )

  cat("\n分析対象者数\n")
  print(n_by_party)
  cat(
    "全サンプル n=",
    n_total,
    "\n",
    sep = ""
  )

  write_csv_safely(
    sample_flow,
    "sample_flow.csv"
  )

  write_csv_safely(
    id_task_check,
    "id_task_check.csv"
  )

  write_csv_safely(
    valid_ids,
    "valid_ids.csv"
  )

  write_csv_safely(
    n_by_party,
    "n_by_party.csv"
  )

  write_csv_safely(
    figure_n_labels,
    "figure_n_labels.csv"
  )


  check_profile <- conjoint_all %>%
    group_by(
      party_n,
      ID,
      task,
      task_id
    ) %>%
    summarise(
      n_profiles = n(),
      selected_sum = sum(selected),
      .groups = "drop"
    ) %>%
    count(
      party_n,
      n_profiles,
      selected_sum
    )

  print(check_profile)

  stopifnot(
    all(
      check_profile$n_profiles ==
        check_profile$party_n
    )
  )

  stopifnot(
    all(
      check_profile$selected_sum == 1
    )
  )

  allowed_economic_df <- enframe(
    allowed_economic_levels,
    name = "name",
    value = "value"
  ) %>%
    unnest(value)

  unexpected_economic_values <- conjoint_all %>%
    select(
      all_of(
        names(allowed_economic_levels)
      )
    ) %>%
    pivot_longer(
      cols = everything(),
      names_to = "name",
      values_to = "value"
    ) %>%
    filter(
      !is.na(value),
      value != ""
    ) %>%
    distinct(
      name,
      value
    ) %>%
    anti_join(
      allowed_economic_df,
      by = c(
        "name",
        "value"
      )
    )

  print(unexpected_economic_values)

  stopifnot(
    nrow(unexpected_economic_values) == 0
  )

  observed_party_levels <- conjoint_all %>%
    distinct(party_name) %>%
    arrange(party_name)

  observed_economic_levels <- conjoint_all %>%
    select(
      all_of(
        names(allowed_economic_levels)
      )
    ) %>%
    pivot_longer(
      cols = everything(),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    distinct(
      attribute,
      level
    ) %>%
    arrange(
      attribute,
      level
    )

  party_level_frequency <- conjoint_all %>%
    count(
      party_n,
      party_name,
      name = "n_profiles"
    ) %>%
    group_by(party_n) %>%
    mutate(
      proportion = n_profiles /
        sum(n_profiles)
    ) %>%
    ungroup()

  economic_level_frequency <- conjoint_all %>%
    select(
      party_n,
      all_of(
        names(allowed_economic_levels)
      )
    ) %>%
    pivot_longer(
      cols = all_of(
        names(allowed_economic_levels)
      ),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    count(
      party_n,
      attribute,
      level,
      name = "n_profiles"
    ) %>%
    group_by(
      party_n,
      attribute
    ) %>%
    mutate(
      proportion = n_profiles /
        sum(n_profiles)
    ) %>%
    ungroup()

  write_csv_safely(
    check_profile,
    "profile_expansion_check.csv"
  )

  write_csv_safely(
    observed_party_levels,
    "observed_party_levels.csv"
  )

  write_csv_safely(
    observed_economic_levels,
    "observed_economic_levels.csv"
  )

  write_csv_safely(
    party_level_frequency,
    "party_level_frequency.csv"
  )

  write_csv_safely(
    economic_level_frequency,
    "economic_level_frequency.csv"
  )

  write_csv_safely(
    conjoint_all,
    "study3_profile_level_data.csv"
  )


  analysis_ids <- valid_ids %>%
    select(
      ID,
      party_n
    )

  if (attention_check_var %in% names(df)) {
    attention_summary <- df %>%
      semi_join(
        analysis_ids,
        by = "ID"
      ) %>%
      transmute(
        ID,
        attention_response = norm_text(
          .data[[attention_check_var]]
        ),
        attention_pass = is_response_code(
          .data[[attention_check_var]],
          attention_check_correct
        )
      ) %>%
      count(
        attention_response,
        attention_pass,
        name = "n"
      ) %>%
      arrange(
        desc(attention_pass),
        attention_response
      )
  } else {
    attention_summary <- tibble(
      attention_response = character(),
      attention_pass = logical(),
      n = integer()
    )
  }

  manipulation_summary <- map_dfr(
    2:5,
    function(n_party) {
      manipulation_row <- manipulation_map %>%
        filter(
          party_n == n_party
        )

      v <- manipulation_row$manipulation_var
      correct <- manipulation_row$correct_answer

      if (!v %in% names(df)) {
        return(
          tibble(
            party_n = n_party,
            response = NA_character_,
            correct = NA,
            n = 0L
          )
        )
      }

      df %>%
        semi_join(
          analysis_ids %>%
            filter(
              party_n == n_party
            ),
          by = "ID"
        ) %>%
        transmute(
          party_n = n_party,
          response = norm_text(
            .data[[v]]
          ),
          correct = is_response_code(
            .data[[v]],
            correct
          )
        ) %>%
        count(
          party_n,
          response,
          correct,
          name = "n"
        )
    }
  )

  write_csv_safely(
    attention_summary,
    "attention_check_summary.csv"
  )

  write_csv_safely(
    manipulation_summary,
    "party_number_check_summary.csv"
  )


  observed_party_vector <- conjoint_all %>%
    distinct(party_name) %>%
    pull(party_name)

  party_reference <- if (
    "自由民主党" %in% observed_party_vector
  ) {
    "自由民主党"
  } else {
    sort(observed_party_vector)[1]
  }

  if (party_reference != "自由民主党") {
    warning("Check")
  }

  party_levels_use <- c(
    party_reference,

    expected_party_levels[
      expected_party_levels %in%
        observed_party_vector &
        expected_party_levels !=
        party_reference
    ],

    sort(
      setdiff(
        observed_party_vector,
        expected_party_levels
      )
    )
  ) %>%
    unique()

  conjoint_all_m <- conjoint_all %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),

      party_name = factor(
        party_name,
        levels = party_levels_use
      ),

      gdp_growth = factor(
        gdp_growth,
        levels = allowed_economic_levels$gdp_growth
      ),

      nikkei = factor(
        nikkei,
        levels = allowed_economic_levels$nikkei
      ),

      cpi = factor(
        cpi,
        levels = allowed_economic_levels$cpi
      ),

      unemployment = factor(
        unemployment,
        levels = allowed_economic_levels$unemployment
      ),

      party_n_f = factor(
        as.character(party_n),
        levels = c(
          "2",
          "3",
          "4",
          "5"
        )
      ),

      party_n_c = party_n - 2
    )

  attr_terms <- c(
    "party_name",
    "gdp_growth",
    "nikkei",
    "cpi",
    "unemployment"
  )

  economic_attr_terms <- c(
    "gdp_growth",
    "nikkei",
    "cpi",
    "unemployment"
  )


  formula_nocov <- as.formula(
    paste(
      "selected ~",
      paste(
        attr_terms,
        collapse = " + "
      )
    )
  )

  run_amce_nocov <- function(dat) {
    feols(
      formula_nocov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_nocov <- conjoint_all_m %>%
    split(.$party_n) %>%
    map(run_amce_nocov)

  capture.output(
    etable(
      models_by_party_n_nocov
    ),
    file = file.path(
      output_dir,
      "amce_nocov_models.txt"
    )
  )


  m_interaction <- feols(
    selected ~
      party_n_f *
      (
        party_name +
          gdp_growth +
          nikkei +
          cpi +
          unemployment
      ),
    data = conjoint_all_m,
    vcov = ~ ID
  )

  capture.output(
    summary(m_interaction),
    file = file.path(
      output_dir,
      "amce_interaction_model.txt"
    )
  )


  m_linear_trend <- feols(
    selected ~
      party_n_c *
      (
        party_name +
          gdp_growth +
          nikkei +
          cpi +
          unemployment
      ),
    data = conjoint_all_m,
    vcov = ~ ID
  )

  capture.output(
    summary(m_linear_trend),
    file = file.path(
      output_dir,
      "amce_linear_trend_model.txt"
    )
  )


  party_term_labels <- tibble(
    term = paste0(
      "party_name",
      party_levels_use[-1]
    ),
    attribute = "政権与党の政党名",
    cue_type = "政党名の手がかり",
    label = party_levels_use[-1],
    order = seq_along(
      party_levels_use[-1]
    )
  )

  economic_term_labels <- tribble(
    ~term, ~attribute, ~cue_type, ~label, ~order,

    "gdp_growthGDP成長率プラス1％",
    "GDP成長率",
    "経済の手がかり",
    "GDP：プラス1％",
    1,

    "gdp_growthGDP成長率マイナス1％",
    "GDP成長率",
    "経済の手がかり",
    "GDP：マイナス1％",
    2,

    "nikkei日経平均前月同期比プラス1000円",
    "日経平均",
    "経済の手がかり",
    "日経平均：プラス1000円",
    3,

    "nikkei日経平均前月同期比マイナス1000円",
    "日経平均",
    "経済の手がかり",
    "日経平均：マイナス1000円",
    4,

    "cpiCPI前期比プラス1ポイント",
    "CPI",
    "経済の手がかり",
    "CPI：プラス1ポイント",
    5,

    "cpiCPI前期比マイナス1ポイント",
    "CPI",
    "経済の手がかり",
    "CPI：マイナス1ポイント",
    6,

    "unemployment失業率前期比プラス1％",
    "失業率",
    "経済の手がかり",
    "失業率：プラス1％",
    7,

    "unemployment失業率前期比マイナス1％",
    "失業率",
    "経済の手がかり",
    "失業率：マイナス1％",
    8
  )

  term_labels <- bind_rows(
    party_term_labels %>%
      mutate(
        order_global = order
      ),

    economic_term_labels %>%
      mutate(
        order_global =
          max(
            c(
              party_term_labels$order,
              0
            )
          ) +
          order
      )
  ) %>%
    select(
      term,
      attribute,
      cue_type,
      label,
      order = order_global
    )

  attribute_order <- c(
    "政権与党の政党名",
    "GDP成長率",
    "日経平均",
    "CPI",
    "失業率"
  )

  label_order <- term_labels %>%
    arrange(order) %>%
    pull(label)

  make_amce_plot_df <- function(models) {
    imap_dfr(
      models,
      ~ tidy_fixest(.x) %>%
        mutate(
          party_n = as.character(.y)
        )
    ) %>%
      left_join(
        term_labels,
        by = "term"
      ) %>%
      filter(
        !is.na(attribute)
      ) %>%
      mutate(
        estimate_pp = estimate * 100,
        conf.low_pp = conf.low * 100,
        conf.high_pp = conf.high * 100,

        party_n = factor(
          party_n,
          levels = c(
            "2",
            "3",
            "4",
            "5"
          ),
          labels = c(
            "2選択肢",
            "3選択肢",
            "4選択肢",
            "5選択肢"
          )
        ),

        attribute = factor(
          attribute,
          levels = attribute_order
        ),

        label = factor(
          label,
          levels = rev(
            label_order
          )
        )
      )
  }

  amce_plot_nocov <- make_amce_plot_df(
    models_by_party_n_nocov
  )

  write_csv_safely(
    amce_plot_nocov,
    "amce_nocov_coefficients.csv"
  )

  interaction_plot_df <- tidy_fixest(
    m_interaction
  ) %>%
    filter(
      str_detect(
        term,
        "party_n_f[345]"
      )
    ) %>%
    mutate(
      party_n_code = str_extract(
        term,
        "party_n_f[345]"
      ),

      party_n = str_remove(
        party_n_code,
        "party_n_f"
      ),

      base_term = term %>%
        str_remove(
          "party_n_f[345]:"
        ) %>%
        str_remove(
          ":party_n_f[345]"
        )
    ) %>%
    left_join(
      term_labels,
      by = c(
        "base_term" = "term"
      )
    ) %>%
    filter(
      !is.na(attribute)
    ) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,

      party_n_label = factor(
        party_n,
        levels = c(
          "3",
          "4",
          "5"
        ),
        labels = c(
          "3選択肢",
          "4選択肢",
          "5選択肢"
        )
      ),

      attribute = factor(
        attribute,
        levels = attribute_order
      ),

      label = factor(
        label,
        levels = rev(
          label_order
        )
      )
    )

  write_csv_safely(
    interaction_plot_df,
    "amce_interaction_coefficients.csv"
  )

  linear_trend_plot_df <- tidy_fixest(
    m_linear_trend
  ) %>%
    filter(
      str_detect(
        term,
        "party_n_c:"
      ) |
        str_detect(
          term,
          ":party_n_c"
        )
    ) %>%
    mutate(
      base_term = term %>%
        str_remove(
          "party_n_c:"
        ) %>%
        str_remove(
          ":party_n_c"
        )
    ) %>%
    left_join(
      term_labels,
      by = c(
        "base_term" = "term"
      )
    ) %>%
    filter(
      !is.na(attribute)
    ) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,

      attribute = factor(
        attribute,
        levels = attribute_order
      ),

      label = factor(
        label,
        levels = rev(
          label_order
        )
      )
    )

  write_csv_safely(
    linear_trend_plot_df,
    "amce_linear_trend_coefficients.csv"
  )


  recode_female_study3 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num == 2 ~ 1L,
      x_num == 1 ~ 0L,
      TRUE ~ NA_integer_
    )
  }

  recode_college_grad_study3 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num %in% c(
        4,
        5
      ) ~ 1L,

      x_num %in% c(
        1,
        2,
        3
      ) ~ 0L,

      TRUE ~ NA_integer_
    )
  }

  recode_self_ideology_study3 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num %in% 1:8 ~ x_num,
      x_num == 12 ~ 9,
      x_num == 13 ~ 10,
      x_num == 14 ~ 11,
      TRUE ~ NA_real_
    )
  }

  recode_party_support_study3 <- function(x) {
    x_num <- as_num(x)

    case_when(
      x_num == 1 ~ "自由民主党",
      x_num == 2 ~ "中道改革連合",
      x_num == 3 ~ "立憲民主党",
      x_num == 4 ~ "公明党",
      x_num == 5 ~ "日本維新の会",
      x_num == 6 ~ "国民民主党",
      x_num == 7 ~ "れいわ新選組",
      x_num == 8 ~ "日本共産党",
      x_num == 9 ~ "参政党",
      x_num == 10 ~ "日本保守党",
      x_num == 11 ~ "社会民主党",
      x_num == 12 ~ "チームみらい",
      x_num == 13 ~ "その他",
      x_num == 14 ~ "支持政党なし",
      x_num == 15 ~ "わからない",
      x_num == 16 ~ "答えたくない",
      TRUE ~ NA_character_
    )
  }

  gender_raw <- get_var(
    df,
    c(
      "Q2.1",
      "Q2_1"
    )
  )

  age_raw <- get_var(
    df,
    c(
      "Q2.2_13",
      "Q2.2.13",
      "Q2_2_13",
      "Q2.2_2",
      "Q2.2.2",
      "Q2_2_2"
    )
  )

  education_raw <- get_var(
    df,
    c(
      "Q2.3",
      "Q2_3"
    )
  )

  region_raw <- get_var(
    df,
    c(
      "Q2.4_1",
      "Q2.4.1",
      "Q2_4_1"
    )
  )

  prefecture_raw <- get_var(
    df,
    c(
      "Q2.4_2",
      "Q2.4.2",
      "Q2_4_2"
    )
  )

  income_gross_raw <- get_var(
    df,
    c(
      "Q2.5_1",
      "Q2.5.1",
      "Q2_5_1"
    )
  )

  income_net_raw <- get_var(
    df,
    c(
      "Q2.5_2",
      "Q2.5.2",
      "Q2_5_2"
    )
  )

  zero_income_reason_raw <- get_var(
    df,
    c(
      "Q2.6",
      "Q2_6"
    )
  )

  self_ideology_raw <- get_var(
    df,
    c(
      "Q25.1_1",
      "Q25.1.1",
      "Q25_1_1"
    )
  )

  party_support_raw <- get_var(
    df,
    c(
      "Q7.2",
      "Q7_2"
    )
  )

  covar_id <- df %>%
    transmute(
      ID = as.character(ResponseId),

      female = recode_female_study3(
        gender_raw
      ),

      age = as_num(
        age_raw
      ),

      college_grad = recode_college_grad_study3(
        education_raw
      ),

      region = factor_miss(
        region_raw
      ),

      prefecture = factor_miss(
        prefecture_raw
      ),

      income_gross = as_num(
        income_gross_raw
      ),

      income_net = as_num(
        income_net_raw
      ),

      income_gross_log = log1p(
        income_gross
      ),

      income_net_log = log1p(
        income_net
      ),

      zero_income_reason = factor_miss(
        zero_income_reason_raw
      ),

      self_ideology = recode_self_ideology_study3(
        self_ideology_raw
      ),

      party_support = recode_party_support_study3(
        party_support_raw
      ),

      party_support_f = factor_miss(
        party_support
      ),

      party_support_profile = canonicalize_party_name(
        party_support
      )
    ) %>%
    semi_join(
      valid_ids %>%
        select(ID),
      by = "ID"
    ) %>%
    distinct(
      ID,
      .keep_all = TRUE
    )

  covar_id <- covar_id %>%
    mutate(
      age = if_else(
        age >= 18 &
          age <= 79,
        age,
        NA_real_
      )
    )

  age_imp_obj <- mean_impute(
    covar_id$age
  )

  income_gross_imp_obj <- mean_impute(
    covar_id$income_gross_log
  )

  self_ideology_imp_obj <- mean_impute(
    covar_id$self_ideology
  )

  covar_id <- covar_id %>%
    mutate(
      female_imp = if_else(
        is.na(female),
        0L,
        female
      ),

      female_miss = as.integer(
        is.na(female)
      ),

      college_grad_imp = if_else(
        is.na(college_grad),
        0L,
        college_grad
      ),

      college_grad_miss = as.integer(
        is.na(college_grad)
      ),

      age_imp = age_imp_obj$value,

      age_miss = age_imp_obj$miss,

      income_gross_log_imp =
        income_gross_imp_obj$value,

      income_gross_log_miss =
        income_gross_imp_obj$miss,

      self_ideology_imp =
        self_ideology_imp_obj$value,

      self_ideology_miss =
        self_ideology_imp_obj$miss
    )

  covariate_missing_summary <- covar_id %>%
    summarise(
      n_ids = n_distinct(ID),
      female_missing = sum(
        is.na(female)
      ),
      age_missing = sum(
        is.na(age)
      ),
      college_grad_missing = sum(
        is.na(college_grad)
      ),
      income_gross_missing = sum(
        is.na(income_gross_log)
      ),
      self_ideology_missing = sum(
        is.na(self_ideology)
      ),
      party_support_missing = sum(
        is.na(party_support)
      )
    )

  zero_income_summary <- covar_id %>%
    count(
      zero_income_reason,
      name = "n"
    ) %>%
    arrange(
      desc(n)
    )

  print(covariate_missing_summary)

  write_csv_safely(
    covar_id,
    "respondent_covariates.csv"
  )

  write_csv_safely(
    covariate_missing_summary,
    "covariate_missing_summary.csv"
  )

  write_csv_safely(
    zero_income_summary,
    "zero_income_reason_summary.csv"
  )


  conjoint_all_cov <- conjoint_all_m %>%
    left_join(
      covar_id,
      by = "ID"
    )

  covariate_terms <- c(
    "female_imp",
    "female_miss",
    "age_imp",
    "age_miss",
    "college_grad_imp",
    "college_grad_miss",
    "income_gross_log_imp",
    "income_gross_log_miss",
    "self_ideology_imp",
    "self_ideology_miss",
    "party_support_f"
  )

  has_variation <- function(dat, v) {
    if (!v %in% names(dat)) {
      return(FALSE)
    }

    dplyr::n_distinct(
      dat[[v]],
      na.rm = TRUE
    ) > 1
  }

  covariate_terms_use <- covariate_terms[
    map_lgl(
      covariate_terms,
      ~ has_variation(
        conjoint_all_cov,
        .x
      )
    )
  ]

  formula_cov <- as.formula(
    paste(
      "selected ~",
      paste(
        c(
          attr_terms,
          covariate_terms_use
        ),
        collapse = " + "
      )
    )
  )

  run_amce_cov <- function(dat) {
    feols(
      formula_cov,
      data = dat,
      vcov = ~ ID
    )
  }

  models_by_party_n_cov <- conjoint_all_cov %>%
    split(.$party_n) %>%
    map(run_amce_cov)

  capture.output(
    etable(
      models_by_party_n_nocov,
      models_by_party_n_cov,
      headers = c(
        rep(
          "共変量なし",
          length(
            models_by_party_n_nocov
          )
        ),
        rep(
          "共変量あり",
          length(
            models_by_party_n_cov
          )
        )
      )
    ),
    file = file.path(
      output_dir,
      "amce_nocov_and_cov_models.txt"
    )
  )

  amce_plot_cov <- make_amce_plot_df(
    models_by_party_n_cov
  )

  write_csv_safely(
    amce_plot_cov,
    "amce_cov_coefficients.csv"
  )


  study_label <- "実験3（2026年）"

  p_amce_cov <- ggplot(
    amce_plot_cov,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(
        width = 0.65
      ),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(
        width = 0.65
      ),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) {
        paste0(x, " pp")
      },
      breaks = scales::pretty_breaks(
        n = 8
      )
    ) +
    scale_shape_manual(
      name = "選択肢数",
      values = c(
        "2選択肢" = 16,
        "3選択肢" = 17,
        "4選択肢" = 15,
        "5選択肢" = 1
      )
    ) +
    scale_linetype_manual(
      name = "選択肢数",
      values = c(
        "2選択肢" = "solid",
        "3選択肢" = "dashed",
        "4選択肢" = "dotted",
        "5選択肢" = "dotdash"
      )
    ) +
    labs(
      subtitle = paste0(
        "政党名の基準カテゴリ：",
        party_reference,
        "。経済属性は変化なしを基準とする。"
      ),
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(
        size = 10
      ),
      legend.position = "top",
      legend.title = element_text(
        face = "bold"
      ),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(
        size = 9
      ),
      axis.title.x = element_text(
        face = "bold"
      )
    )

  print(p_amce_cov)

  save_plot(
    "amce_cov_facet_model.png",
    p_amce_cov,
    width = 10.5,
    height = 11.5
  )


  p_amce_nocov <- ggplot(
    amce_plot_nocov,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(
        width = 0.65
      ),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(
        width = 0.65
      ),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) {
        paste0(x, " pp")
      },
      breaks = scales::pretty_breaks(
        n = 8
      )
    ) +
    scale_shape_manual(
      name = "選択肢数",
      values = c(
        "2選択肢" = 16,
        "3選択肢" = 17,
        "4選択肢" = 15,
        "5選択肢" = 1
      )
    ) +
    scale_linetype_manual(
      name = "選択肢数",
      values = c(
        "2選択肢" = "solid",
        "3選択肢" = "dashed",
        "4選択肢" = "dotted",
        "5選択肢" = "dotdash"
      )
    ) +
    labs(
      subtitle = paste0(
        "政党名の基準カテゴリ：",
        party_reference,
        "。経済属性は変化なしを基準とする。"
      ),
      x = "選択確率の変化",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 16
      ),
      plot.subtitle = element_text(
        size = 10
      ),
      legend.position = "top",
      legend.title = element_text(
        face = "bold"
      ),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(
        size = 9
      ),
      axis.title.x = element_text(
        face = "bold"
      )
    )

  print(p_amce_nocov)

  save_plot(
    "amce_nocov_facet_model.png",
    p_amce_nocov,
    width = 10.5,
    height = 11.5
  )


  p_interaction <- ggplot(
    interaction_plot_df,
    aes(
      x = estimate_pp,
      y = label,
      shape = party_n_label,
      linetype = party_n_label,
      group = party_n_label
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      position = position_dodge(
        width = 0.65
      ),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(
        width = 0.65
      ),
      size = 2.5,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) {
        paste0(x, " pp")
      },
      breaks = scales::pretty_breaks(
        n = 8
      )
    ) +
    scale_shape_manual(
      name = "2選択肢条件との比較",
      values = c(
        "3選択肢" = 17,
        "4選択肢" = 15,
        "5選択肢" = 1
      )
    ) +
    scale_linetype_manual(
      name = "2選択肢条件との比較",
      values = c(
        "3選択肢" = "dashed",
        "4選択肢" = "dotted",
        "5選択肢" = "dotdash"
      )
    ) +
    labs(
      x = "2選択肢条件との差",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 15
      ),
      legend.position = "top",
      legend.title = element_text(
        face = "bold"
      ),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(
        size = 9
      ),
      axis.title.x = element_text(
        face = "bold"
      )
    )

  print(p_interaction)

  save_plot(
    "amce_interaction_difference_from_2choice.png",
    p_interaction,
    width = 10.5,
    height = 11.5
  )


  p_linear_trend <- ggplot(
    linear_trend_plot_df,
    aes(
      x = estimate_pp,
      y = label
    )
  ) +
    geom_vline(
      xintercept = 0,
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      height = 0.16,
      linewidth = 0.55,
      color = "black"
    ) +
    geom_point(
      size = 2.5,
      shape = 21,
      color = "black",
      fill = "white",
      stroke = 0.8
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_x_continuous(
      labels = function(x) {
        paste0(x, " pp")
      },
      breaks = scales::pretty_breaks(
        n = 8
      )
    ) +
    labs(
      subtitle = "横軸は、選択肢数が1つ増えたときの属性効果の変化",
      x = "1選択肢増加当たりのAMCE変化",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      plot.title = element_text(
        face = "bold",
        size = 15
      ),
      plot.subtitle = element_text(
        size = 10
      ),
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold",
        size = 10
      ),
      axis.text.y = element_text(
        size = 9
      ),
      axis.title.x = element_text(
        face = "bold"
      )
    )

  print(p_linear_trend)

  save_plot(
    "amce_linear_trend.png",
    p_linear_trend,
    width = 10.5,
    height = 11.5
  )


  heatmap_df <- amce_plot_cov %>%
    mutate(
      abs_amce = abs(
        estimate_pp
      )
    ) %>%
    group_by(party_n) %>%
    mutate(
      rank_within_condition =
        min_rank(
          desc(abs_amce)
        ),

      n_in_condition = n(),

      rank_score = if_else(
        n_in_condition == 1,
        1,
        1 -
          (
            rank_within_condition - 1
          ) /
          (
            n_in_condition - 1
          )
      )
    ) %>%
    ungroup()

  heatmap_row_order <- heatmap_df %>%
    group_by(
      label,
      attribute
    ) %>%
    summarise(
      mean_abs_amce = mean(
        abs_amce,
        na.rm = TRUE
      ),
      .groups = "drop"
    ) %>%
    arrange(
      desc(mean_abs_amce)
    ) %>%
    pull(label) %>%
    as.character()

  heatmap_df <- heatmap_df %>%
    mutate(
      label_heat = factor(
        as.character(label),
        levels = rev(
          heatmap_row_order
        )
      )
    )

  p_heat_amce <- ggplot(
    heatmap_df,
    aes(
      x = party_n,
      y = label_heat,
      fill = abs_amce
    )
  ) +
    geom_tile(
      color = "grey45",
      linewidth = 0.3
    ) +
    geom_text(
      aes(
        label = sprintf(
          "%.1f",
          estimate_pp
        ),
        color = if_else(
          rank_score >= 0.55,
          "white",
          "black"
        )
      ),
      size = 3.1
    ) +
    scale_color_identity() +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    scale_fill_gradient(
      low = "white",
      high = "grey20",
      name = "|AMCE|\n(pp)"
    ) +
    labs(
      subtitle = "セル内の数値は符号付きAMCE（percentage points）",
      x = "選択肢数",
      y = NULL
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      plot.title = element_text(
        face = "bold"
      ),
      legend.position = "right",
      panel.grid = element_blank(),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold"
      ),
      axis.text.y = element_text(
        size = 8.5
      )
    )

  print(p_heat_amce)

  save_plot(
    "amce_cov_heatmap.png",
    p_heat_amce,
    width = 10.5,
    height = 11.5
  )


  conjoint_clogit <- conjoint_all_m %>%
    mutate(
      selected = as.integer(selected),
      ID = as.character(ID),
      task_id = factor(task_id),

      party_name = relevel_if_present(
        party_name,
        party_reference
      ),

      gdp_growth = relevel_if_present(
        gdp_growth,
        allowed_economic_levels$gdp_growth[1]
      ),

      nikkei = relevel_if_present(
        nikkei,
        allowed_economic_levels$nikkei[1]
      ),

      cpi = relevel_if_present(
        cpi,
        allowed_economic_levels$cpi[1]
      ),

      unemployment = relevel_if_present(
        unemployment,
        allowed_economic_levels$unemployment[1]
      )
    )

  formula_clogit_nocov <- as.formula(
    paste0(
      "selected ~ ",
      paste(
        attr_terms,
        collapse = " + "
      ),
      " + strata(task_id) + cluster(ID)"
    )
  )

  run_clogit_nocov <- function(dat) {
    survival::clogit(
      formula_clogit_nocov,
      data = dat,
      method = "efron"
    )
  }

  models_clogit_nocov <- conjoint_clogit %>%
    split(.$party_n) %>%
    map(run_clogit_nocov)

  capture.output(
    lapply(
      models_clogit_nocov,
      summary
    ),
    file = file.path(
      output_dir,
      "conditional_logit_models.txt"
    )
  )

  tidy_clogit <- function(model) {
    s <- summary(model)
    ct <- as.data.frame(
      s$coefficients
    )
    ct$term <- rownames(ct)

    se_col <- if (
      "robust se" %in% names(ct)
    ) {
      "robust se"
    } else if (
      "se(coef)" %in% names(ct)
    ) {
      "se(coef)"
    } else {
      stop("Check clogit")
    }

    p_col <- if (
      "Pr(>|z|)" %in% names(ct)
    ) {
      "Pr(>|z|)"
    } else if (
      "Pr(>|t|)" %in% names(ct)
    ) {
      "Pr(>|t|)"
    } else {
      NA_character_
    }

    ct %>%
      as_tibble() %>%
      transmute(
        term = term,
        estimate = coef,
        std.error = .data[[se_col]],

        p.value = if (
          !is.na(p_col)
        ) {
          .data[[p_col]]
        } else {
          NA_real_
        },

        conf.low =
          estimate -
          1.96 *
          std.error,

        conf.high =
          estimate +
          1.96 *
          std.error,

        odds_ratio = exp(
          estimate
        ),

        odds_ratio_low = exp(
          conf.low
        ),

        odds_ratio_high = exp(
          conf.high
        )
      )
  }

  clogit_plot_df <- imap_dfr(
    models_clogit_nocov,
    ~ tidy_clogit(.x) %>%
      mutate(
        party_n = as.character(.y)
      )
  ) %>%
    left_join(
      term_labels,
      by = "term"
    ) %>%
    filter(
      !is.na(attribute)
    ) %>%
    mutate(
      party_n = factor(
        party_n,
        levels = c(
          "2",
          "3",
          "4",
          "5"
        ),
        labels = c(
          "2選択肢",
          "3選択肢",
          "4選択肢",
          "5選択肢"
        )
      ),

      attribute = factor(
        attribute,
        levels = attribute_order
      ),

      label = factor(
        label,
        levels = rev(
          label_order
        )
      )
    )

  write_csv_safely(
    clogit_plot_df,
    "conditional_logit_coefficients.csv"
  )


  p_clogit_or <- ggplot(
    clogit_plot_df,
    aes(
      x = odds_ratio,
      y = label,
      shape = party_n,
      linetype = party_n,
      group = party_n
    )
  ) +
    geom_vline(
      xintercept = 1,
      linetype = "dashed",
      linewidth = 0.45,
      color = "grey35"
    ) +
    geom_errorbarh(
      aes(
        xmin = odds_ratio_low,
        xmax = odds_ratio_high
      ),
      position = position_dodge(
        width = 0.72
      ),
      height = 0.15,
      linewidth = 0.45,
      color = "black"
    ) +
    geom_point(
      position = position_dodge(
        width = 0.72
      ),
      size = 2.4,
      stroke = 0.7,
      color = "black"
    ) +
    scale_x_log10(
      breaks = scales::log_breaks(
        n = 8
      )
    ) +
    scale_shape_manual(
      values = c(
        "2選択肢" = 16,
        "3選択肢" = 17,
        "4選択肢" = 15,
        "5選択肢" = 1
      )
    ) +
    scale_linetype_manual(
      values = c(
        "2選択肢" = "solid",
        "3選択肢" = "dashed",
        "4選択肢" = "dotdash",
        "5選択肢" = "twodash"
      )
    ) +
    facet_grid(
      attribute ~ .,
      scales = "free_y",
      space = "free_y",
      switch = "y"
    ) +
    labs(
      x = "オッズ比",
      y = NULL,
      shape = "選択肢数",
      linetype = "選択肢数"
    ) +
    theme_bw(
      base_size = 12,
      base_family = figure_font_family
    ) +
    theme(
      legend.position = "bottom",
      panel.grid.major.y = element_blank(),
      panel.grid.minor = element_blank(),
      plot.title = element_text(
        face = "bold"
      ),
      strip.placement = "outside",
      strip.background = element_rect(
        fill = "grey92",
        color = "grey55"
      ),
      strip.text.y.left = element_text(
        angle = 0,
        face = "bold"
      ),
      axis.text.y = element_text(
        size = 8.5
      )
    )

  print(p_clogit_or)

  save_plot(
    "clogit_oddsratio_nocov.png",
    p_clogit_or,
    width = 10.5,
    height = 11.5
  )


  experimental_party_names <- as.character(
    party_levels_use
  )

  conjoint_match <- conjoint_all_cov %>%
    mutate(
      party_name_chr = as.character(party_name),
      
      support_party_valid = if_else(
        party_support_profile %in% experimental_party_names,
        party_support_profile,
        NA_character_
      ),
      
      party_match = case_when(
        is.na(support_party_valid) ~ NA_integer_,
        party_name_chr == support_party_valid ~ 1L,
        TRUE ~ 0L
      )
    ) %>%
    filter(
      !is.na(party_match)
    )

  party_match_sample <- conjoint_match %>%
    distinct(
      ID,
      party_n,
      support_party_valid
    ) %>%
    count(
      party_n,
      support_party_valid,
      name = "n_respondents"
    )

  write_csv_safely(
    party_match_sample,
    "party_match_sample.csv"
  )


  formula_party_match_overall <- as.formula(
    paste(
      "selected ~",
      paste(
        c(
          "party_name",
          "party_match",
          economic_attr_terms
        ),
        collapse = " + "
      )
    )
  )

  run_party_match_overall <- function(dat) {
    feols(
      formula_party_match_overall,
      data = dat,
      vcov = ~ ID
    )
  }

  models_party_match_by_n <- conjoint_match %>%
    split(.$party_n) %>%
    map(run_party_match_overall)

  m_party_match_interaction <- feols(
    selected ~
      party_n_f *
      party_match +
      party_name +
      gdp_growth +
      nikkei +
      cpi +
      unemployment,
    data = conjoint_match,
    vcov = ~ ID
  )

  capture.output(
    lapply(
      models_party_match_by_n,
      summary
    ),
    file = file.path(
      output_dir,
      "party_match_models_by_choice_number.txt"
    )
  )

  capture.output(
    summary(m_party_match_interaction),
    file = file.path(
      output_dir,
      "party_match_interaction_model.txt"
    )
  )

  extract_party_match_term <- function(model) {
    out <- tidy_fixest(model) %>%
      filter(term == "party_match")
    
    if (nrow(out) == 0) {
      return(
        tibble(
          term = "party_match",
          estimate = NA_real_,
          std.error = NA_real_,
          statistic = NA_real_,
          p.value = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_
        )
      )
    }
    
    out
  }

  party_match_coef_df <- imap_dfr(
    models_party_match_by_n,
    ~ extract_party_match_term(.x) %>%
      mutate(
        support_group = "全体",
        support_group_label = "全体",
        party_n = as.integer(.y)
      )
  ) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      
      party_n_label = factor(
        party_n,
        levels = 2:5,
        labels = c(
          "2選択肢",
          "3選択肢",
          "4選択肢",
          "5選択肢"
        )
      )
    )

  write_csv_safely(
    party_match_coef_df,
    "party_match_coefficients.csv"
  )


  target_support_groups <- c(
    "自由民主党",
    "中道改革連合",
    "立憲民主党",
    "参政党"
  )

  target_support_labels <- c(
    "自由民主党"   = "自民党支持者",
    "中道改革連合" = "中道改革支持者",
    "立憲民主党"   = "立憲支持者",
    "参政党"       = "参政党支持者"
  )

  party_match_subgroup_sample <- conjoint_match %>%
    distinct(
      ID,
      party_n,
      support_party_valid
    ) %>%
    filter(
      support_party_valid %in% target_support_groups
    ) %>%
    count(
      support_party_valid,
      party_n,
      name = "n_respondents"
    ) %>%
    mutate(
      support_group_label = recode(
        support_party_valid,
        !!!target_support_labels
      )
    )

  write_csv_safely(
    party_match_subgroup_sample,
    "party_match_subgroup_sample.csv"
  )

  support_group_total_n <- conjoint_match %>%
    distinct(
      ID,
      support_party_valid
    ) %>%
    filter(
      support_party_valid %in% target_support_groups
    ) %>%
    count(
      support_party_valid,
      name = "n_total"
    )

  formula_party_match_subgroup <- as.formula(
    paste(
      "selected ~",
      paste(
        c(
          "party_match",
          economic_attr_terms
        ),
        collapse = " + "
      )
    )
  )

  run_party_match_subgroup <- function(dat) {
    feols(
      formula_party_match_subgroup,
      data = dat,
      vcov = ~ ID
    )
  }

  estimate_party_match_subgroup <- function(
      dat,
      support_group_value
  ) {
    map_dfr(
      2:5,
      function(n_value) {
        
        dat_n <- dat %>%
          filter(
            party_n == n_value,
            support_party_valid == support_group_value
          )
        
        n_ids <- n_distinct(dat_n$ID)
        
        if (nrow(dat_n) == 0 || n_ids == 0) {
          return(
            tibble(
              term = "party_match",
              estimate = NA_real_,
              std.error = NA_real_,
              statistic = NA_real_,
              p.value = NA_real_,
              conf.low = NA_real_,
              conf.high = NA_real_,
              support_group = support_group_value,
              support_group_label = unname(
                target_support_labels[[support_group_value]]
              ),
              party_n = n_value,
              n_ids = n_ids
            )
          )
        }
        
        model_n <- tryCatch(
          run_party_match_subgroup(dat_n),
          error = function(e) NULL
        )
        
        if (is.null(model_n)) {
          return(
            tibble(
              term = "party_match",
              estimate = NA_real_,
              std.error = NA_real_,
              statistic = NA_real_,
              p.value = NA_real_,
              conf.low = NA_real_,
              conf.high = NA_real_,
              support_group = support_group_value,
              support_group_label = unname(
                target_support_labels[[support_group_value]]
              ),
              party_n = n_value,
              n_ids = n_ids
            )
          )
        }
        
        extract_party_match_term(model_n) %>%
          mutate(
            support_group = support_group_value,
            support_group_label = unname(
              target_support_labels[[support_group_value]]
            ),
            party_n = n_value,
            n_ids = n_ids
          )
      }
    )
  }

  party_match_subgroup_coef_df <- map_dfr(
    target_support_groups,
    ~ estimate_party_match_subgroup(
      conjoint_match,
      .x
    )
  ) %>%
    left_join(
      support_group_total_n,
      by = c(
        "support_group" = "support_party_valid"
      )
    ) %>%
    mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      party_n_label = factor(
        party_n,
        levels = 2:5,
        labels = c(
          "2選択肢",
          "3選択肢",
          "4選択肢",
          "5選択肢"
        )
      )
    )

  write_csv_safely(
    party_match_subgroup_coef_df,
    "party_match_subgroup_coefficients.csv"
  )


  party_match_plot_df_all <- bind_rows(
    party_match_coef_df %>%
      mutate(panel = "overall"),
    party_match_subgroup_coef_df %>%
      mutate(panel = "subgroup")
  ) %>%
    filter(
      is.finite(estimate_pp),
      is.finite(conf.low_pp),
      is.finite(conf.high_pp)
    )

  if (nrow(party_match_plot_df_all) == 0) {
    stop("Check data")
  }

  y_range_match <- range(
    c(
      party_match_plot_df_all$conf.low_pp,
      party_match_plot_df_all$conf.high_pp
    ),
    na.rm = TRUE
  )

  y_span_match <- diff(y_range_match)

  if (!is.finite(y_span_match) || y_span_match <= 0) {
    y_span_match <- 5
  }

  y_pad_match <- max(1.2, 0.10 * y_span_match)

  y_limits_match <- c(
    y_range_match[1] - y_pad_match,
    y_range_match[2] + y_pad_match
  )


  theme_party_match_bw <- theme_bw(
    base_size = 12,
    base_family = figure_font_family
  ) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(
        linewidth = 0.30,
        color = "grey88"
      ),
      panel.border = element_rect(
        linewidth = 0.65,
        color = "black"
      ),
      axis.text = element_text(color = "black"),
      axis.title = element_text(color = "black"),
      plot.title = element_text(
        face = "bold"
      ),
      plot.subtitle = element_text(
        size = rel(0.92)
      ),
      plot.margin = margin(
        8, 10, 8, 8
      )
    )


  make_party_match_panel_plot <- function(
      dat,
      panel_title,
      panel_subtitle = NULL,
      base_size = 11,
      show_y_title = TRUE,
      show_x_title = TRUE
  ) {
    ggplot(
      dat,
      aes(
        x = party_n,
        y = estimate_pp
      )
    ) +
      geom_line(
        linewidth = 0.80,
        color = "black",
        na.rm = TRUE
      ) +
      geom_errorbar(
        aes(
          ymin = conf.low_pp,
          ymax = conf.high_pp
        ),
        width = 0.075,
        linewidth = 0.80,
        color = "black",
        na.rm = TRUE
      ) +
      geom_label(
        aes(
          label = sprintf("%.1f pp", estimate_pp)
        ),
        size = 3.45,
        family = figure_font_family,
        label.size = 0,
        label.padding = unit(
          0.12,
          "lines"
        ),
        fill = "white",
        color = "black",
        na.rm = TRUE
      ) +
      scale_x_continuous(
        breaks = 2:5,
        labels = paste0(
          2:5,
          "選択肢"
        ),
        limits = c(1.72, 5.28)
      ) +
      scale_y_continuous(
        labels = function(x) {
          paste0(x, " pp")
        },
        breaks = scales::pretty_breaks(n = 6),
        expand = expansion(
          mult = c(0.05, 0.08)
        )
      ) +
      coord_cartesian(
        ylim = y_limits_match
      ) +
      labs(
        title = panel_title,
        subtitle = panel_subtitle,
        x = if (show_x_title) "選択肢数" else NULL,
        y = if (show_y_title) "一致した場合の選択確率の変化" else NULL
      ) +
      theme_bw(
        base_size = base_size,
        base_family = figure_font_family
      ) +
      theme_party_match_bw +
      theme(
        plot.title = element_text(
          face = "bold"
        ),
        axis.title.x = if (show_x_title) element_text() else element_blank(),
        axis.title.y = if (show_y_title) element_text() else element_blank()
      )
  }

  make_support_group_title <- function(
      support_group_value
  ) {
    n_value <- support_group_total_n %>%
      filter(
        support_party_valid == support_group_value
      ) %>%
      pull(n_total)
    
    if (length(n_value) == 0 || is.na(n_value)) {
      n_value <- 0
    }
    
    paste0(
      target_support_labels[[support_group_value]],
      "\n(n=",
      scales::comma(n_value),
      ")"
    )
  }


  p_party_match_overall <- make_party_match_panel_plot(
    party_match_coef_df,
    panel_title = NULL,
    panel_subtitle =
      "上段は全体、下段は支持政党別（自民・中道改革・立憲・参政）。政党名と経済属性を統制した線形確率モデル。",
    base_size = 12,
    show_y_title = TRUE,
    show_x_title = TRUE
  )


  p_party_match_ldp <- make_party_match_panel_plot(
    party_match_subgroup_coef_df %>%
      filter(support_group == "自由民主党"),
    panel_title = make_support_group_title("自由民主党"),
    base_size = 10,
    show_y_title = TRUE,
    show_x_title = TRUE
  )

  p_party_match_chr <- make_party_match_panel_plot(
    party_match_subgroup_coef_df %>%
      filter(support_group == "中道改革連合"),
    panel_title = make_support_group_title("中道改革連合"),
    base_size = 10,
    show_y_title = FALSE,
    show_x_title = TRUE
  )

  p_party_match_cdp <- make_party_match_panel_plot(
    party_match_subgroup_coef_df %>%
      filter(support_group == "立憲民主党"),
    panel_title = make_support_group_title("立憲民主党"),
    base_size = 10,
    show_y_title = FALSE,
    show_x_title = TRUE
  )

  p_party_match_sansei <- make_party_match_panel_plot(
    party_match_subgroup_coef_df %>%
      filter(support_group == "参政党"),
    panel_title = make_support_group_title("参政党"),
    base_size = 10,
    show_y_title = FALSE,
    show_x_title = TRUE
  )

  p_party_match_bottom <-
    p_party_match_ldp +
    p_party_match_chr +
    p_party_match_cdp +
    p_party_match_sansei +
    patchwork::plot_layout(ncol = 4)

  p_party_match <-
    p_party_match_overall /
    p_party_match_bottom +
    patchwork::plot_layout(
      heights = c(1.25, 1)
    )

  print(p_party_match)

  save_plot(
    "party_match_effect_combined.png",
    p_party_match,
    width = 14,
    height = 8.8
  )


  relative_cue_map <- c(
    party_name = "party",
    gdp_growth = "economic",
    nikkei = "economic",
    cpi = "economic",
    unemployment = "economic"
  )

  mean_absolute_pairwise_difference <- function(x) {
    x <- x[is.finite(x)]

    if (length(x) < 2) {
      return(NA_real_)
    }

    pairwise_differences <- combn(
      x,
      2,
      FUN = function(z) abs(z[1] - z[2])
    )

    mean(pairwise_differences)
  }

  linear_slope <- function(y, x) {
    keep <- is.finite(y) & is.finite(x)
    y <- y[keep]
    x <- x[keep]

    if (length(y) < 2 || length(unique(x)) < 2) {
      return(NA_real_)
    }

    unname(coef(lm(y ~ x))[2])
  }

  bootstrap_two_sided_p <- function(x) {
    x <- x[is.finite(x)]
    B_valid <- length(x)

    if (B_valid == 0) {
      return(NA_real_)
    }

    p_lower <- (1 + sum(x <= 0)) / (B_valid + 1)
    p_upper <- (1 + sum(x >= 0)) / (B_valid + 1)

    min(1, 2 * min(p_lower, p_upper))
  }

  safe_quantile <- function(x, probability) {
    x <- x[is.finite(x)]

    if (length(x) == 0) {
      return(NA_real_)
    }

    unname(
      quantile(
        x,
        probs = probability,
        type = 6,
        na.rm = TRUE
      )
    )
  }

  prepare_relative_cue_analysis <- function(data, cue_map) {
    attributes <- names(cue_map)

    required_columns <- c(
      "ID",
      "party_n",
      "selected",
      attributes
    )

    missing_columns <- setdiff(
      required_columns,
      names(data)
    )

    if (length(missing_columns) > 0) {
      stop("Check relative weight")
    }

    if (!all(unname(cue_map) %in% c("party", "economic"))) {
      stop("Check relative weight")
    }

    analysis_data <- data %>%
      select(
        ID,
        party_n,
        selected,
        all_of(attributes)
      ) %>%
      mutate(
        ID = as.character(ID),
        party_n = as.integer(as.character(party_n)),
        selected = as.integer(selected),
        across(
          all_of(attributes),
          as.character
        )
      ) %>%
      filter(
        !is.na(ID),
        party_n %in% 2:5,
        selected %in% c(0L, 1L)
      )

    observed_conditions <- sort(
      unique(analysis_data$party_n)
    )

    if (!identical(observed_conditions, 2:5)) {
      stop("Check")
    }

    long_data <- analysis_data %>%
      pivot_longer(
        cols = all_of(attributes),
        names_to = "attribute",
        values_to = "level"
      ) %>%
      filter(
        !is.na(level),
        level != ""
      )

    expected_cells <- long_data %>%
      distinct(
        attribute,
        level
      ) %>%
      mutate(
        attribute_order = match(
          attribute,
          attributes
        )
      ) %>%
      arrange(
        attribute_order,
        attribute,
        level
      ) %>%
      select(-attribute_order) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    respondent_cell <- long_data %>%
      group_by(
        party_n,
        ID,
        attribute,
        level
      ) %>%
      summarise(
        y_sum = sum(selected),
        n_obs = n(),
        .groups = "drop"
      ) %>%
      mutate(
        cell_key = paste(
          attribute,
          level,
          sep = "\r"
        )
      )

    condition_objects <- lapply(
      2:5,
      function(n_value) {
        condition_data <- respondent_cell %>%
          filter(
            party_n == n_value
          )

        id_values <- sort(
          unique(condition_data$ID)
        )
        n_ids <- length(id_values)
        n_cells <- nrow(expected_cells)

        if (n_ids == 0) {
          stop("Check")
        }

        y_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        n_matrix <- matrix(
          0,
          nrow = n_ids,
          ncol = n_cells,
          dimnames = list(
            id_values,
            expected_cells$cell_key
          )
        )

        row_index <- match(
          condition_data$ID,
          id_values
        )
        column_index <- match(
          condition_data$cell_key,
          expected_cells$cell_key
        )

        y_matrix[cbind(row_index, column_index)] <-
          condition_data$y_sum
        n_matrix[cbind(row_index, column_index)] <-
          condition_data$n_obs

        if (any(colSums(n_matrix) == 0)) {
          missing_cells <- expected_cells$cell_key[
            colSums(n_matrix) == 0
          ]

          stop("Check attributes")
        }

        list(
          party_n = n_value,
          ids = id_values,
          cell_info = expected_cells,
          y_matrix = y_matrix,
          n_matrix = n_matrix
        )
      }
    )

    names(condition_objects) <- as.character(2:5)

    list(
      cue_map = cue_map,
      attributes = attributes,
      conditions = condition_objects
    )
  }

  estimate_relative_cue_indices <- function(
      prepared,
      cluster_weights = NULL
  ) {
    condition_results <- lapply(
      names(prepared$conditions),
      function(condition_name) {
        object <- prepared$conditions[[condition_name]]

        if (is.null(cluster_weights)) {
          weights <- rep(
            1,
            length(object$ids)
          )
        } else {
          weights <- cluster_weights[[condition_name]]
        }

        if (length(weights) != length(object$ids)) {
          stop("Check")
        }

        numerator <- as.numeric(
          crossprod(
            weights,
            object$y_matrix
          )
        )

        denominator <- as.numeric(
          crossprod(
            weights,
            object$n_matrix
          )
        )

        if (any(denominator <= 0)) {
          stop("Check attributes")
        }

        marginal_means <- numerator / denominator

        mm_table <- object$cell_info %>%
          transmute(
            party_n = object$party_n,
            attribute,
            level,
            marginal_mean = marginal_means
          )

        attribute_table <- mm_table %>%
          group_by(
            party_n,
            attribute
          ) %>%
          summarise(
            importance_pairwise =
              mean_absolute_pairwise_difference(
                marginal_mean
              ),
            n_levels = n(),
            .groups = "drop"
          ) %>%
          mutate(
            cue_family = unname(
              prepared$cue_map[attribute]
            ),
            baseline_selection_probability = 1 / party_n,
            importance_pairwise_adjusted =
              importance_pairwise /
                baseline_selection_probability
          )

        cue_table_long <- attribute_table %>%
          group_by(
            party_n,
            cue_family
          ) %>%
          summarise(
            importance_pairwise = mean(
              importance_pairwise,
              na.rm = TRUE
            ),
            importance_pairwise_adjusted = mean(
              importance_pairwise_adjusted,
              na.rm = TRUE
            ),
            .groups = "drop"
          )

        party_table <- cue_table_long %>%
          filter(
            cue_family == "party"
          ) %>%
          transmute(
            party_n,
            party_importance_pairwise =
              importance_pairwise,
            party_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        economic_table <- cue_table_long %>%
          filter(
            cue_family == "economic"
          ) %>%
          transmute(
            party_n,
            economic_importance_pairwise =
              importance_pairwise,
            economic_importance_pairwise_adjusted =
              importance_pairwise_adjusted
          )

        cue_table <- full_join(
          party_table,
          economic_table,
          by = "party_n"
        ) %>%
          mutate(
            baseline_selection_probability = 1 / party_n,

            total_importance_pairwise =
              party_importance_pairwise +
              economic_importance_pairwise,

            total_importance_pairwise_adjusted =
              party_importance_pairwise_adjusted +
              economic_importance_pairwise_adjusted,

            relative_party_weight_pairwise = if_else(
              total_importance_pairwise > 0,
              party_importance_pairwise /
                total_importance_pairwise,
              NA_real_
            ),

            relative_economic_weight_pairwise =
              1 - relative_party_weight_pairwise,

            relative_party_weight_pairwise_adjusted = if_else(
              total_importance_pairwise_adjusted > 0,
              party_importance_pairwise_adjusted /
                total_importance_pairwise_adjusted,
              NA_real_
            ),

            relative_economic_weight_pairwise_adjusted =
              1 - relative_party_weight_pairwise_adjusted,

            adjustment_identity_difference =
              relative_party_weight_pairwise_adjusted -
                relative_party_weight_pairwise
          )

        if (
          any(
            abs(cue_table$adjustment_identity_difference) > 1e-10,
            na.rm = TRUE
          )
        ) {
          stop("Check relative weight")
        }

        list(
          marginal_means = mm_table,
          attribute_importance = attribute_table,
          cue_importance = cue_table
        )
      }
    )

    list(
      marginal_means = bind_rows(
        lapply(
          condition_results,
          function(x) x$marginal_means
        )
      ),
      attribute_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$attribute_importance
        )
      ),
      cue_importance = bind_rows(
        lapply(
          condition_results,
          function(x) x$cue_importance
        )
      ) %>%
        arrange(party_n)
    )
  }

  estimate_relative_cue_slopes <- function(cue_importance) {
    cue_importance <- cue_importance %>%
      arrange(party_n)

    if (!identical(cue_importance$party_n, 2:5)) {
      stop("Check relative weight")
    }

    x <- cue_importance$party_n

    c(
      relative_party_weight_pairwise =
        linear_slope(
          cue_importance$relative_party_weight_pairwise,
          x
        ),

      party_importance_pairwise =
        linear_slope(
          cue_importance$party_importance_pairwise,
          x
        ),

      economic_importance_pairwise =
        linear_slope(
          cue_importance$economic_importance_pairwise,
          x
        ),

      party_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$party_importance_pairwise_adjusted,
          x
        ),

      economic_importance_pairwise_adjusted =
        linear_slope(
          cue_importance$economic_importance_pairwise_adjusted,
          x
        )
    )
  }

  run_relative_cue_bootstrap <- function(
      prepared,
      B,
      seed,
      progress_every = 100
  ) {
    set.seed(seed)

    condition_results <- vector(
      "list",
      B
    )

    slope_names <- c(
      "relative_party_weight_pairwise",
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted"
    )

    slope_matrix <- matrix(
      NA_real_,
      nrow = B,
      ncol = length(slope_names),
      dimnames = list(
        NULL,
        slope_names
      )
    )

    for (b in seq_len(B)) {
      cluster_weights <- lapply(
        prepared$conditions,
        function(object) {
          n_ids <- length(object$ids)

          sampled_positions <- sample.int(
            n = n_ids,
            size = n_ids,
            replace = TRUE
          )

          tabulate(
            sampled_positions,
            nbins = n_ids
          )
        }
      )

      bootstrap_estimates <- estimate_relative_cue_indices(
        prepared = prepared,
        cluster_weights = cluster_weights
      )

      condition_results[[b]] <-
        bootstrap_estimates$cue_importance %>%
        select(
          party_n,
          party_importance_pairwise,
          economic_importance_pairwise,
          party_importance_pairwise_adjusted,
          economic_importance_pairwise_adjusted,
          relative_party_weight_pairwise
        ) %>%
        mutate(
          bootstrap_replication = b,
          .before = 1
        )

      slope_matrix[b, ] <- estimate_relative_cue_slopes(
        bootstrap_estimates$cue_importance
      )

      if (
        progress_every > 0 &&
        (b %% progress_every == 0 || b == B)
      ) {
        message("Bootstrap: ", b, "/", B)
      }
    }

    list(
      condition_estimates = bind_rows(
        condition_results
      ),
      slopes = as_tibble(
        slope_matrix
      ) %>%
        mutate(
          bootstrap_replication = row_number(),
          .before = 1
        )
    )
  }

  summarise_condition_intervals <- function(
      observed_cue_importance,
      bootstrap_condition_results
  ) {
    statistics <- c(
      "party_importance_pairwise",
      "economic_importance_pairwise",
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted",
      "relative_party_weight_pairwise"
    )

    observed_long <- observed_cue_importance %>%
      select(
        party_n,
        all_of(statistics)
      ) %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "estimate"
      )

    bootstrap_long <- bootstrap_condition_results %>%
      pivot_longer(
        cols = all_of(statistics),
        names_to = "statistic",
        values_to = "value"
      ) %>%
      group_by(
        party_n,
        statistic
      ) %>%
      summarise(
        conf_low = safe_quantile(
          value,
          0.025
        ),
        conf_high = safe_quantile(
          value,
          0.975
        ),
        .groups = "drop"
      )

    observed_long %>%
      left_join(
        bootstrap_long,
        by = c(
          "party_n",
          "statistic"
        )
      )
  }

  summarise_slope_inference <- function(
      observed_slopes,
      bootstrap_slopes
  ) {
    statistic_names <- names(observed_slopes)

    map_dfr(
      statistic_names,
      function(statistic_name) {
        bootstrap_values <- bootstrap_slopes[[statistic_name]]
        bootstrap_values <- bootstrap_values[
          is.finite(bootstrap_values)
        ]

        expected_direction <- case_when(
          statistic_name ==
            "economic_importance_pairwise" ~ "negative",
          statistic_name %in% c(
            "party_importance_pairwise",
            "relative_party_weight_pairwise",
            "party_importance_pairwise_adjusted"
          ) ~ "positive",
          TRUE ~ "none"
        )

        analysis_role <- case_when(
          statistic_name %in% c(
            "party_importance_pairwise_adjusted",
            "economic_importance_pairwise_adjusted"
          ) ~ "exploratory_choice_set_adjusted",
          statistic_name == "relative_party_weight_pairwise" ~
            "derived_relative_share",
          TRUE ~ "manuscript_primary_unadjusted"
        )

        estimate <- unname(
          observed_slopes[[statistic_name]]
        )

        tibble(
          study = "Study 3",
          statistic = statistic_name,
          estimate = estimate,
          conf_low = safe_quantile(
            bootstrap_values,
            0.025
          ),
          conf_high = safe_quantile(
            bootstrap_values,
            0.975
          ),
          p_value_two_sided =
            bootstrap_two_sided_p(
              bootstrap_values
            ),
          expected_direction = expected_direction,
          analysis_role = analysis_role,
          estimate_in_expected_direction = case_when(
            expected_direction == "positive" ~ estimate > 0,
            expected_direction == "negative" ~ estimate < 0,
            TRUE ~ NA
          )
        )
      }
    )
  }

  relative_cue_prepared <- prepare_relative_cue_analysis(
    data = conjoint_all_m,
    cue_map = relative_cue_map
  )

  relative_cue_observed <- estimate_relative_cue_indices(
    prepared = relative_cue_prepared
  )

  relative_cue_observed_slopes <- estimate_relative_cue_slopes(
    relative_cue_observed$cue_importance
  )

  write_csv_safely(
    relative_cue_observed$marginal_means,
    "study3_relative_cue_marginal_means.csv"
  )

  write_csv_safely(
    relative_cue_observed$attribute_importance,
    "study3_relative_cue_attribute_importance.csv"
  )

  write_csv_safely(
    relative_cue_observed$cue_importance,
    "study3_relative_cue_importance_and_weight.csv"
  )

  relative_condition_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study3_relative_cue_condition_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  relative_slope_bootstrap_file <- file.path(
    output_dir,
    paste0(
      "study3_relative_cue_slope_bootstrap_",
      unified_config$cue_importance_metric_version,
      "_B",
      relative_cue_bootstrap_B,
      ".csv"
    )
  )

  use_saved_relative_bootstrap <-
    !rerun_relative_cue_bootstrap &&
    file.exists(relative_condition_bootstrap_file) &&
    file.exists(relative_slope_bootstrap_file)

  if (use_saved_relative_bootstrap) {
    message("Bootstrap cache")

    relative_cue_condition_bootstrap <- readr::read_csv(
      relative_condition_bootstrap_file,
      show_col_types = FALSE
    )

    relative_cue_slope_bootstrap <- readr::read_csv(
      relative_slope_bootstrap_file,
      show_col_types = FALSE
    )

    saved_B_condition <- n_distinct(
      relative_cue_condition_bootstrap$bootstrap_replication
    )
    saved_B_slope <- n_distinct(
      relative_cue_slope_bootstrap$bootstrap_replication
    )

    if (
      saved_B_condition != relative_cue_bootstrap_B ||
      saved_B_slope != relative_cue_bootstrap_B
    ) {
      message("Bootstrap cache")
      use_saved_relative_bootstrap <- FALSE
    }
  }

  if (!use_saved_relative_bootstrap) {
    relative_cue_bootstrap <- run_relative_cue_bootstrap(
      prepared = relative_cue_prepared,
      B = relative_cue_bootstrap_B,
      seed = relative_cue_bootstrap_seed,
      progress_every = relative_cue_bootstrap_progress_every
    )

    relative_cue_condition_bootstrap <-
      relative_cue_bootstrap$condition_estimates

    relative_cue_slope_bootstrap <-
      relative_cue_bootstrap$slopes

    readr::write_csv(
      relative_cue_condition_bootstrap,
      relative_condition_bootstrap_file
    )

    readr::write_csv(
      relative_cue_slope_bootstrap,
      relative_slope_bootstrap_file
    )
  }

  relative_cue_condition_intervals <- summarise_condition_intervals(
    observed_cue_importance =
      relative_cue_observed$cue_importance,
    bootstrap_condition_results =
      relative_cue_condition_bootstrap
  )

  relative_cue_slope_inference <- summarise_slope_inference(
    observed_slopes =
      relative_cue_observed_slopes,
    bootstrap_slopes =
      relative_cue_slope_bootstrap
  )

  write_csv_safely(
    relative_cue_condition_intervals,
    "study3_relative_cue_condition_intervals.csv"
  )

  write_csv_safely(
    relative_cue_slope_inference,
    "study3_relative_cue_slope_inference.csv"
  )

  relative_cue_primary_result <- relative_cue_slope_inference %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    )

  cat("\nStudy 3：相対比重の線形傾向\n")
  print(relative_cue_primary_result)


  relative_x_offset <- 0.075

  relative_panel_a_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise",
        "economic_importance_pairwise"
      )
    ) %>%
    mutate(
      cue_family = recode(
        statistic,
        party_importance_pairwise = "政党名手がかり",
        economic_importance_pairwise = "経済手がかり"
      ),
      cue_family = factor(
        cue_family,
        levels = c(
          "政党名手がかり",
          "経済手がかり"
        )
      ),
      x_plot = case_when(
        cue_family == "政党名手がかり" ~
          party_n + relative_x_offset,
        cue_family == "経済手がかり" ~
          party_n - relative_x_offset,
        TRUE ~ as.numeric(party_n)
      ),
      value_label = sprintf(
        "%.3f",
        estimate
      )
    )

  relative_panel_b_data <- relative_cue_condition_intervals %>%
    filter(
      statistic ==
        "relative_party_weight_pairwise"
    ) %>%
    mutate(
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_adjusted_label_map <- relative_panel_a_data %>%
    distinct(
      statistic,
      cue_family
    ) %>%
    mutate(
      statistic = paste0(
        statistic,
        "_adjusted"
      ),
      cue_family = as.character(
        cue_family
      )
    )

  relative_panel_adjusted_data <- relative_cue_condition_intervals %>%
    filter(
      statistic %in% c(
        "party_importance_pairwise_adjusted",
        "economic_importance_pairwise_adjusted"
      )
    ) %>%
    left_join(
      relative_adjusted_label_map,
      by = "statistic"
    ) %>%
    mutate(
      cue_family = factor(
        cue_family,
        levels = levels(
          relative_panel_a_data$cue_family
        )
      ),
      x_plot = if_else(
        as.integer(cue_family) == 1L,
        party_n + relative_x_offset,
        party_n - relative_x_offset
      ),
      value_label = sprintf(
        "%.1f%%",
        100 * estimate
      )
    )

  relative_condition_suffix <- if (
    "政党名手がかり" %in%
      levels(relative_panel_a_data$cue_family)
  ) {
    "選択肢"
  } else {
    "政党"
  }

  relative_condition_axis_title <- if (
    relative_condition_suffix == "選択肢"
  ) {
    "政治経済状況の選択肢数"
  } else {
    "政党選択肢数"
  }

  relative_figure_font_family <- if (
    .Platform$OS.type == "windows"
  ) {
    "Yu Gothic"
  } else {
    "sans"
  }

  relative_theme_japanese_bw <- theme_bw(
    base_size = 12,
    base_family = relative_figure_font_family
  ) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(
        linewidth = 0.30,
        color = "grey88"
      ),
      panel.border = element_rect(
        linewidth = 0.65,
        color = "black"
      ),
      axis.text = element_text(
        color = "black"
      ),
      axis.title = element_text(
        color = "black"
      ),
      plot.title = element_text(
        size = 12.5,
        face = "bold",
        hjust = 0
      ),
      plot.subtitle = element_text(
        size = 9.5,
        hjust = 0,
        margin = margin(
          b = 8
        )
      ),
      legend.position = "top",
      legend.justification = "center",
      legend.key.width = grid::unit(
        1.25,
        "cm"
      ),
      plot.margin = margin(
        8,
        10,
        8,
        8
      )
    )

  relative_panel_a <- ggplot(
    relative_panel_a_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = c(
        "政党名手がかり" = "solid",
        "経済手がかり" = "dashed"
      )
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "選択肢"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_number(
        accuracy = 0.005
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：両手がかりの絶対的重要度",
      subtitle = "",
      x = "政党選択肢数",
      y = "手がかり重要度",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_adjusted_linetypes <- setNames(
    c(
      "solid",
      "dashed"
    ),
    levels(
      relative_panel_adjusted_data$cue_family
    )
  )

  relative_panel_adjusted <- ggplot(
    relative_panel_adjusted_data,
    aes(
      x = x_plot,
      y = estimate,
      group = cue_family,
      linetype = cue_family
    )
  ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_linetype_manual(
      values = relative_adjusted_linetypes
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        relative_condition_suffix
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.07,
          0.10
        )
      )
    ) +
    labs(
      title = "A：選択肢数調整済み重要度",
      subtitle =
        "未調整重要度 ÷ 平均選択確率（1／選択肢数）",
      x = relative_condition_axis_title,
      y = "平均選択確率に対する水準間差",
      linetype = NULL
    ) +
    guides(
      linetype = guide_legend(
        override.aes = list(
          linewidth = 0.90
        )
      )
    ) +
    relative_theme_japanese_bw

  relative_b_range <- range(
    c(
      relative_panel_b_data$conf_low,
      relative_panel_b_data$conf_high,
      0.5
    ),
    na.rm = TRUE
  )

  relative_b_padding <- max(
    0.025,
    0.10 * diff(relative_b_range)
  )

  relative_b_lower <- max(
    0,
    floor(
      20 *
        (relative_b_range[1] - relative_b_padding)
    ) / 20
  )

  relative_b_upper <- min(
    1,
    ceiling(
      20 *
        (relative_b_range[2] + relative_b_padding)
    ) / 20
  )

  if (relative_b_lower >= relative_b_upper) {
    relative_b_lower <- max(
      0,
      relative_b_lower - 0.05
    )
    relative_b_upper <- min(
      1,
      relative_b_upper + 0.05
    )
  }

  relative_panel_b <- ggplot(
    relative_panel_b_data,
    aes(
      x = party_n,
      y = estimate
    )
  ) +
    geom_hline(
      yintercept = 0.5,
      linetype = "dashed",
      linewidth = 0.55,
      color = "black"
    ) +
    geom_line(
      linewidth = 0.80,
      color = "black"
    ) +
    geom_errorbar(
      aes(
        ymin = conf_low,
        ymax = conf_high
      ),
      width = 0.075,
      linewidth = 0.80,
      color = "black"
    ) +
    geom_label(
      aes(
        label = value_label
      ),
      size = 3.55,
      family = relative_figure_font_family,
      label.size = 0,
      label.padding = grid::unit(
        0.12,
        "lines"
      ),
      fill = "white",
      color = "black"
    ) +
    scale_x_continuous(
      breaks = 2:5,
      labels = paste0(
        2:5,
        "選択肢"
      ),
      limits = c(
        1.72,
        5.28
      )
    ) +
    scale_y_continuous(
      breaks = seq(
        relative_b_lower,
        relative_b_upper,
        by = 0.05
      ),
      labels = label_percent(
        accuracy = 1
      ),
      expand = expansion(
        mult = c(
          0.05,
          0.08
        )
      )
    ) +
    coord_cartesian(
      ylim = c(
        relative_b_lower,
        relative_b_upper
      )
    ) +
    labs(
      title = "B：相対的な政党名手がかりの比重",
      subtitle =
        "政党名手がかり重要度 ÷（政党名手がかり重要度＋経済手がかり重要度）",
      x = "政党選択肢数",
      y = "相対的な政党名手がかり比重"
    ) +
    relative_theme_japanese_bw +
    theme(
      legend.position = "none"
    )

  relative_panel_c <- relative_panel_b +
    labs(
      title = paste0(
        "B：相対的な",
        levels(relative_panel_a_data$cue_family)[1],
        "の比重"
      )
    )

  figure_relative_weight_jp <- (
    relative_panel_a |
      relative_panel_b
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_jp
  )

  save_plot(
    "fig_study3_relative_cue_weight_jp_bw.png",
    figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      "fig_study3_relative_cue_weight_jp_bw.pdf"
    ),
    plot = figure_relative_weight_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  figure_relative_weight_adjusted_jp <- (
    relative_panel_adjusted |
      relative_panel_c
  ) +
    patchwork::plot_layout(
      widths = c(
        1,
        1
      )
    )

  print(
    figure_relative_weight_adjusted_jp
  )

  relative_adjusted_figure_stub <- paste0(
    "fig_study",
    stringr::str_extract(
      study_label,
      "[123]"
    ),
    "_relative_cue_weight_choice_set_adjusted_jp_bw"
  )

  save_plot(
    paste0(
      relative_adjusted_figure_stub,
      ".png"
    ),
    figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    dpi = 400
  )

  ggsave(
    filename = file.path(
      output_dir,
      paste0(
        relative_adjusted_figure_stub,
        ".pdf"
      )
    ),
    plot = figure_relative_weight_adjusted_jp,
    width = 11.2,
    height = 5.4,
    device = grDevices::cairo_pdf,
    bg = "white"
  )

  relative_cue_results <- list(
    prepared = relative_cue_prepared,
    marginal_means =
      relative_cue_observed$marginal_means,
    attribute_importance =
      relative_cue_observed$attribute_importance,
    cue_importance =
      relative_cue_observed$cue_importance,
    observed_slopes =
      relative_cue_observed_slopes,
    condition_bootstrap =
      relative_cue_condition_bootstrap,
    slope_bootstrap =
      relative_cue_slope_bootstrap,
    condition_intervals =
      relative_cue_condition_intervals,
    slope_inference =
      relative_cue_slope_inference,
    primary_result =
      relative_cue_primary_result,
    plots = list(
      absolute_importance = relative_panel_a,
      choice_set_adjusted_importance =
        relative_panel_adjusted,
      relative_party_weight = relative_panel_b,
      relative_party_weight_panel_c =
        relative_panel_c,
      combined = figure_relative_weight_jp,
      combined_with_choice_set_adjustment =
        figure_relative_weight_adjusted_jp
    )
  )

  saveRDS(
    relative_cue_results,
    file = file.path(
      output_dir,
      "study3_relative_cue_results.rds"
    )
  )


  saveRDS(
    list(
      settings = list(
        data_file = data_file,
        require_initial_consent =
          require_initial_consent,
        require_final_consent =
          require_final_consent,
        require_attention_check =
          require_attention_check,
        require_manipulation_check =
          require_manipulation_check,
        require_all_five_tasks =
          require_all_five_tasks,
        party_reference =
          party_reference,
        party_levels_use =
          party_levels_use,
        relative_cue_bootstrap_B =
          relative_cue_bootstrap_B,
        relative_cue_bootstrap_seed =
          relative_cue_bootstrap_seed
      ),

      sample_flow = sample_flow,
      n_by_party = n_by_party,
      valid_ids = valid_ids,

      conjoint_all = conjoint_all,
      conjoint_all_m = conjoint_all_m,
      conjoint_all_cov = conjoint_all_cov,

      covar_id = covar_id,

      models_by_party_n_nocov =
        models_by_party_n_nocov,

      models_by_party_n_cov =
        models_by_party_n_cov,

      m_interaction =
        m_interaction,

      m_linear_trend =
        m_linear_trend,

      models_clogit_nocov =
        models_clogit_nocov,

      party_match = list(
        data = conjoint_match,
        models_by_n =
          models_party_match_by_n,
        interaction_model =
          m_party_match_interaction
      ),

      relative_cue = relative_cue_results,

      plots = list(
        amce_cov =
          p_amce_cov,
        amce_nocov =
          p_amce_nocov,
        interaction =
          p_interaction,
        linear_trend =
          p_linear_trend,
        heatmap =
          p_heat_amce,
        clogit_odds_ratio =
          p_clogit_or,
        party_match =
          p_party_match,
        relative_cue_weight =
          figure_relative_weight_jp,
        relative_cue_weight_choice_set_adjusted =
          figure_relative_weight_adjusted_jp
      )
    ),
    file = file.path(
      output_dir,
      "study3_analysis_objects.rds"
    )
  )

  capture.output(
    sessionInfo(),
    file = file.path(
      output_dir,
      "sessionInfo.txt"
    )
  )

  cat(
    "\nStudy 3の分析コードが最後まで完了しました。\n",
    "出力先: ",
    normalizePath(output_dir),
    "\n",
    sep = ""
  )

  environment()
})

A.5 補遺に関する各種の再現コード

# 補遺共通コード
unified_output_dir <- file.path(
  unified_config$output_root,
  "_working",
  "cross_study"
)
dir.create(unified_output_dir, showWarnings = FALSE, recursive = TRUE)

save_plot_both <- function(filename_stub, plot, width, height, dpi = 400) {
  png_file <- file.path(unified_output_dir, paste0(filename_stub, ".png"))
  pdf_file <- file.path(unified_output_dir, paste0(filename_stub, ".pdf"))
  
  ggplot2::ggsave(
    filename = png_file,
    plot = plot,
    width = width,
    height = height,
    dpi = dpi,
    bg = "white"
  )
  
  ggplot2::ggsave(
    filename = pdf_file,
    plot = plot,
    width = width,
    height = height,
    device = grDevices::cairo_pdf,
    bg = "white"
  )
  
  invisible(c(png = png_file, pdf = pdf_file))
}

write_csv_unified <- function(x, filename) {
  readr::write_csv(
    x,
    file.path(unified_output_dir, filename),
    na = ""
  )
}

safe_filename <- function(x) {
  x <- iconv(as.character(x), from = "", to = "ASCII//TRANSLIT")
  x[is.na(x) | x == ""] <- "group"
  x <- tolower(x)
  x <- gsub("[^a-z0-9]+", "_", x)
  x <- gsub("^_+|_+$", "", x)
  ifelse(x == "", "group", x)
}

tidy_fixest_unified <- function(model) {
  ct <- as.data.frame(fixest::coeftable(model))
  ct$term <- rownames(ct)
  
  estimate_col <- intersect(c("Estimate", "estimate"), names(ct))[1]
  se_col <- intersect(c("Std. Error", "Std. error", "std.error"), names(ct))[1]
  statistic_col <- intersect(c("t value", "z value", "statistic"), names(ct))[1]
  p_col <- intersect(c("Pr(>|t|)", "Pr(>|z|)", "p.value"), names(ct))[1]
  
  if (
    is.na(estimate_col) ||
    is.na(se_col) ||
    is.na(statistic_col) ||
    is.na(p_col)
  ) {
    stop("Check data")
  }
  
  tibble::as_tibble(ct) %>%
    dplyr::transmute(
      term = term,
      estimate = .data[[estimate_col]],
      std.error = .data[[se_col]],
      statistic = .data[[statistic_col]],
      p.value = .data[[p_col]],
      conf.low = estimate - 1.96 * std.error,
      conf.high = estimate + 1.96 * std.error
    )
}

study_specs <- list(
  study1 = list(
    study_id = "study1",
    study_label = "Study 1（2023年）",
    condition_label = "政党数",
    env = study1_env
  ),
  study2 = list(
    study_id = "study2",
    study_label = "Study 2（2026年）",
    condition_label = "政党数",
    env = study2_env
  ),
  study3 = list(
    study_id = "study3",
    study_label = "Study 3（2026年）",
    condition_label = "選択肢数",
    env = study3_env
  )
)

excluded_support_categories <- c(
  "その他",
  "わからない",
  "答えない",
  "答えたくない",
  "欠損・無回答"
)


# 補遺C関連コード
balance_variable_labels <- c(
  female_imp = "女性",
  female_miss = "性別：欠損",
  age_imp = "年齢",
  age_miss = "年齢：欠損",
  college_grad_imp = "4年制大学以上",
  college_grad_miss = "学歴：欠損",
  income_gross_log_imp = "世帯年収（対数）",
  income_gross_log_miss = "世帯年収：欠損",
  self_ideology_imp = "左右自己位置づけ",
  self_ideology_miss = "左右自己位置づけ：欠損"
)

make_balance_design <- function(study_spec) {
  env <- study_spec$env
  
  assignment <- env$conjoint_all %>%
    dplyr::distinct(ID, party_n) %>%
    dplyr::mutate(
      ID = as.character(ID),
      party_n = as.integer(as.character(party_n))
    )
  
  respondent <- env$covar_id %>%
    dplyr::mutate(ID = as.character(ID))
  
  dat <- assignment %>%
    dplyr::left_join(respondent, by = "ID")
  
  numeric_candidates <- c(
    "female_imp",
    "female_miss",
    "age_imp",
    "age_miss",
    "college_grad_imp",
    "college_grad_miss",
    "income_gross_log_imp",
    "income_gross_log_miss",
    "self_ideology_imp",
    "self_ideology_miss"
  )
  
  factor_candidates <- c(
    "party_support_f",
    "region"
  )
  
  numeric_use <- intersect(numeric_candidates, names(dat))
  factor_use <- intersect(factor_candidates, names(dat))
  
  design_source <- dat %>%
    dplyr::select(dplyr::all_of(c(numeric_use, factor_use)))
  
  if (length(factor_use) > 0) {
    design_source <- design_source %>%
      dplyr::mutate(
        dplyr::across(
          dplyr::all_of(factor_use),
          ~ forcats::fct_na_value_to_level(as.factor(.x), level = "欠損・無回答")
        )
      )
  }
  
  mm <- stats::model.matrix(
    stats::as.formula(
      paste0(
        "~ 0 + ",
        paste(names(design_source), collapse = " + ")
      )
    ),
    data = design_source
  )
  
  mm <- as.data.frame(mm, check.names = FALSE)
  
  keep <- vapply(
    mm,
    function(x) {
      x <- as.numeric(x)
      is.finite(stats::sd(x, na.rm = TRUE)) && stats::sd(x, na.rm = TRUE) > 0
    },
    logical(1)
  )
  
  mm <- mm[, keep, drop = FALSE]
  
  mm <- mm %>%
    dplyr::mutate(
      ID = dat$ID,
      party_n = dat$party_n,
      .before = 1
    )
  
  long <- mm %>%
    tidyr::pivot_longer(
      cols = -c(ID, party_n),
      names_to = "variable",
      values_to = "value"
    ) %>%
    dplyr::mutate(
      label = dplyr::case_when(
        variable %in% names(balance_variable_labels) ~
          unname(balance_variable_labels[variable]),
        stringr::str_detect(variable, "^party_support_f") ~
          paste0(
            "支持政党：",
            stringr::str_remove(variable, "^party_support_f")
          ),
        stringr::str_detect(variable, "^region") ~
          paste0(
            "地域：",
            stringr::str_remove(variable, "^region")
          ),
        TRUE ~ variable
      ),
      study_id = study_spec$study_id,
      study_label = study_spec$study_label
    )
  
  list(
    respondent = dat,
    matrix = mm,
    long = long,
    numeric_use = numeric_use,
    factor_use = factor_use
  )
}

pairwise_smd_multiarm <- function(balance_long) {
  groups <- sort(unique(balance_long$party_n))
  pairs <- utils::combn(groups, 2, simplify = FALSE)

  purrr::map_dfr(
    pairs,
    function(pair_value) {
      a <- pair_value[1]
      b <- pair_value[2]

      wide <- balance_long %>%
        dplyr::filter(party_n %in% c(a, b)) %>%
        dplyr::group_by(variable, label, party_n) %>%
        dplyr::summarise(
          mean = mean(value, na.rm = TRUE),
          sd = stats::sd(value, na.rm = TRUE),
          n = sum(!is.na(value)),
          .groups = "drop"
        ) %>%
        tidyr::pivot_wider(
          names_from = party_n,
          values_from = c(mean, sd, n),
          names_sep = "_"
        )

      wide %>%
        dplyr::transmute(
          variable = variable,
          label = label,
          condition_a = a,
          condition_b = b,
          comparison = paste0(a, " vs ", b),
          mean_a = .data[[paste0("mean_", a)]],
          mean_b = .data[[paste0("mean_", b)]],
          sd_a = .data[[paste0("sd_", a)]],
          sd_b = .data[[paste0("sd_", b)]],
          n_a = .data[[paste0("n_", a)]],
          n_b = .data[[paste0("n_", b)]],
          pooled_sd = sqrt((sd_a^2 + sd_b^2) / 2),
          smd = dplyr::if_else(
            is.finite(pooled_sd) & pooled_sd > 0,
            (mean_a - mean_b) / pooled_sd,
            NA_real_
          ),
          abs_smd = abs(smd)
        )
    }
  )
}

omnibus_balance_test <- function(balance_long) {
  balance_long %>%
    dplyr::group_by(variable, label) %>%
    dplyr::group_modify(
      ~ {
        dat <- .x %>%
          dplyr::filter(is.finite(value), !is.na(party_n))
        
        p_value <- tryCatch(
          {
            model <- stats::lm(value ~ factor(party_n), data = dat)
            as.numeric(stats::anova(model)[1, "Pr(>F)"])
          },
          error = function(e) NA_real_
        )
        
        tibble::tibble(p_value = p_value)
      }
    ) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(p_holm = stats::p.adjust(p_value, method = "holm"))
}

make_balance_outputs <- function(study_spec) {
  design <- make_balance_design(study_spec)
  long <- design$long
  pairwise <- pairwise_smd_multiarm(long)
  omnibus <- omnibus_balance_test(long)
  
  max_smd <- pairwise %>%
    dplyr::group_by(variable, label) %>%
    dplyr::summarise(
      max_abs_smd = dplyr::if_else(
        all(is.na(abs_smd)),
        NA_real_,
        max(abs_smd, na.rm = TRUE)
      ),
      mean_abs_smd = dplyr::if_else(
        all(is.na(abs_smd)),
        NA_real_,
        mean(abs_smd, na.rm = TRUE)
      ),
      .groups = "drop"
    )
  
  group_summary <- long %>%
    dplyr::group_by(variable, label, party_n) %>%
    dplyr::summarise(
      mean = mean(value, na.rm = TRUE),
      sd = stats::sd(value, na.rm = TRUE),
      n = sum(!is.na(value)),
      .groups = "drop"
    ) %>%
    tidyr::pivot_wider(
      names_from = party_n,
      values_from = c(mean, sd, n),
      names_glue = "{.value}_condition_{party_n}"
    ) %>%
    dplyr::left_join(max_smd, by = c("variable", "label")) %>%
    dplyr::left_join(omnibus, by = c("variable", "label")) %>%
    dplyr::arrange(dplyr::desc(max_abs_smd))
  
  write_csv_unified(
    pairwise,
    paste0(study_spec$study_id, "_assignment_balance_pairwise_smd.csv")
  )
  write_csv_unified(
    group_summary,
    paste0(study_spec$study_id, "_assignment_balance_summary.csv")
  )
  
  love_df <- pairwise %>%
    dplyr::left_join(max_smd, by = c("variable", "label")) %>%
    dplyr::mutate(
      label_ordered = stats::reorder(label, max_abs_smd)
    )
  
  p_love <- ggplot2::ggplot(
    love_df,
    ggplot2::aes(
      x = abs_smd,
      y = label_ordered
    )
  ) +
    ggplot2::geom_vline(
      xintercept = 0.10,
      linetype = "dashed",
      linewidth = 0.55
    ) +
    ggplot2::geom_point(
      alpha = 0.30,
      size = 1.4,
      position = ggplot2::position_jitter(height = 0.10, width = 0)
    ) +
    ggplot2::geom_point(
      data = max_smd %>%
        dplyr::mutate(label_ordered = stats::reorder(label, max_abs_smd)),
      ggplot2::aes(
        x = max_abs_smd,
        y = label_ordered
      ),
      inherit.aes = FALSE,
      shape = 21,
      fill = "white",
      size = 2.5,
      stroke = 0.8
    ) +
    ggplot2::scale_x_continuous(
      breaks = scales::pretty_breaks(n = 6),
      expand = ggplot2::expansion(mult = c(0, 0.05))
    ) +
    ggplot2::labs(
      x = "条件間の絶対標準化平均差（|SMD|）",
      y = NULL,
      subtitle = paste0(
        study_spec$study_label,
        "：各点は条件ペア、白抜き点は最大絶対SMD"
      ),
      caption = "破線は |SMD| = 0.10。多群無作為割付のため、2・3・4・5条件の全6ペアを比較。"
    ) +
    ggplot2::theme_bw(base_size = 11) +
    ggplot2::theme(
      panel.grid.minor = ggplot2::element_blank(),
      axis.text = ggplot2::element_text(color = "black"),
      plot.subtitle = ggplot2::element_text(face = "bold")
    )
  
  save_plot_both(
    paste0(study_spec$study_id, "_assignment_balance_love_plot"),
    p_love,
    width = 9.2,
    height = max(6.5, 0.23 * dplyr::n_distinct(love_df$label) + 2.5)
  )
  
  standardized_means <- long %>%
    dplyr::group_by(variable, label) %>%
    dplyr::mutate(
      overall_mean = mean(value, na.rm = TRUE),
      overall_sd = stats::sd(value, na.rm = TRUE),
      value_z = dplyr::if_else(
        is.finite(overall_sd) & overall_sd > 0,
        (value - overall_mean) / overall_sd,
        NA_real_
      )
    ) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(variable, label, party_n) %>%
    dplyr::summarise(
      mean_z = mean(value_z, na.rm = TRUE),
      .groups = "drop"
    )
  
  groups <- sort(unique(standardized_means$party_n))
  diagonal_df <- purrr::map_dfr(
    utils::combn(groups, 2, simplify = FALSE),
    function(pair_value) {
      a <- pair_value[1]
      b <- pair_value[2]
      
      standardized_means %>%
        dplyr::filter(party_n %in% c(a, b)) %>%
        tidyr::pivot_wider(
          names_from = party_n,
          values_from = mean_z,
          names_prefix = "condition_"
        ) %>%
        dplyr::mutate(
          condition_a = a,
          condition_b = b,
          comparison = paste0(a, " vs ", b),
          x_mean = .data[[paste0("condition_", a)]],
          y_mean = .data[[paste0("condition_", b)]],
          diagonal_deviation = y_mean - x_mean,
          abs_diagonal_deviation = abs(diagonal_deviation)
        )
    }
  )
  
  top_labels <- diagonal_df %>%
    dplyr::group_by(comparison) %>%
    dplyr::slice_max(
      order_by = abs_diagonal_deviation,
      n = 3,
      with_ties = FALSE
    ) %>%
    dplyr::ungroup()
  
  axis_limit <- max(
    abs(c(diagonal_df$x_mean, diagonal_df$y_mean)),
    na.rm = TRUE
  )
  axis_limit <- max(0.10, axis_limit * 1.15)
  
  p_diagonal <- ggplot2::ggplot(
    diagonal_df,
    ggplot2::aes(x = x_mean, y = y_mean)
  ) +
    ggplot2::geom_abline(
      intercept = 0,
      slope = 1,
      linewidth = 0.60,
      linetype = "dashed"
    ) +
    ggplot2::geom_hline(yintercept = 0, linewidth = 0.25) +
    ggplot2::geom_vline(xintercept = 0, linewidth = 0.25) +
    ggplot2::geom_point(shape = 21, fill = "white", size = 2.2) +
    ggplot2::geom_text(
      data = top_labels,
      ggplot2::aes(label = label),
      size = 2.6,
      check_overlap = TRUE,
      vjust = -0.7
    ) +
    ggplot2::facet_wrap(~ comparison, ncol = 3) +
    ggplot2::coord_equal(
      xlim = c(-axis_limit, axis_limit),
      ylim = c(-axis_limit, axis_limit)
    ) +
    ggplot2::labs(
      x = "左側条件の標準化共変量平均",
      y = "右側条件の標準化共変量平均",
      subtitle = paste0(
        study_spec$study_label,
        "：45度線からの乖離による割付バランス診断"
      ),
      caption = "各点は回答者共変量または支持政党・地域のダミー変数。45度線に近いほど条件間の構成が類似。"
    ) +
    ggplot2::theme_bw(base_size = 10.5) +
    ggplot2::theme(
      panel.grid.minor = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(fill = "white"),
      strip.text = ggplot2::element_text(face = "bold"),
      axis.text = ggplot2::element_text(color = "black")
    )
  
  write_csv_unified(
    diagonal_df,
    paste0(study_spec$study_id, "_assignment_balance_diagonal_data.csv")
  )
  
  save_plot_both(
    paste0(study_spec$study_id, "_assignment_balance_diagonal_plot"),
    p_diagonal,
    width = 11.5,
    height = 7.5
  )
  
  list(
    design = design,
    pairwise_smd = pairwise,
    summary = group_summary,
    love_plot = p_love,
    diagonal_data = diagonal_df,
    diagonal_plot = p_diagonal
  )
}

assignment_balance_results <- purrr::map(
  study_specs,
  make_balance_outputs
)


make_profile_randomization_outputs <- function(study_spec) {
  env <- study_spec$env
  attributes <- env$attr_terms
  
  randomization_long <- env$conjoint_all_m %>%
    dplyr::select(
      ID,
      party_n,
      task,
      profile,
      dplyr::all_of(attributes)
    ) %>%
    tidyr::pivot_longer(
      cols = dplyr::all_of(attributes),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    dplyr::mutate(
      level = as.character(level),
      party_n = as.integer(as.character(party_n))
    ) %>%
    dplyr::filter(!is.na(level), level != "")
  
  frequency <- randomization_long %>%
    dplyr::count(party_n, attribute, level, name = "observed_n") %>%
    dplyr::group_by(party_n, attribute) %>%
    dplyr::mutate(
      total_n = sum(observed_n),
      n_levels = dplyr::n(),
      observed_share = observed_n / total_n,
      expected_share = 1 / n_levels,
      deviation = observed_share - expected_share,
      abs_deviation = abs(deviation)
    ) %>%
    dplyr::ungroup()
  
  uniformity_tests <- frequency %>%
    dplyr::group_by(party_n, attribute) %>%
    dplyr::group_modify(
      ~ {
        test <- suppressWarnings(
          stats::chisq.test(
            x = .x$observed_n,
            p = rep(1 / nrow(.x), nrow(.x))
          )
        )
        tibble::tibble(
          chi_square = unname(test$statistic),
          df = unname(test$parameter),
          p_value = test$p.value,
          max_abs_share_deviation = max(.x$abs_deviation)
        )
      }
    ) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(p_holm = stats::p.adjust(p_value, method = "holm"))
  
  write_csv_unified(
    frequency,
    paste0(study_spec$study_id, "_profile_level_randomization_frequency.csv")
  )
  write_csv_unified(
    uniformity_tests,
    paste0(study_spec$study_id, "_profile_level_randomization_tests.csv")
  )
  
  top_frequency_labels <- frequency %>%
    dplyr::group_by(party_n, attribute) %>%
    dplyr::slice_max(abs_deviation, n = 1, with_ties = FALSE) %>%
    dplyr::ungroup()
  
  p_randomization <- ggplot2::ggplot(
    frequency,
    ggplot2::aes(
      x = expected_share,
      y = observed_share
    )
  ) +
    ggplot2::geom_abline(
      intercept = 0,
      slope = 1,
      linetype = "dashed",
      linewidth = 0.65
    ) +
    ggplot2::geom_point(
      ggplot2::aes(shape = factor(party_n)),
      size = 2.2,
      fill = "white"
    ) +
    ggplot2::geom_text(
      data = top_frequency_labels,
      ggplot2::aes(label = level),
      size = 2.4,
      check_overlap = TRUE,
      vjust = -0.7
    ) +
    ggplot2::facet_wrap(~ attribute, ncol = 3) +
    ggplot2::coord_equal() +
    ggplot2::labs(
      x = "設計上の期待比率",
      y = "観測比率",
      shape = study_spec$condition_label,
      subtitle = paste0(
        study_spec$study_label,
        "：属性水準の観測比率と期待比率"
      ),
      caption = "各点は属性水準×条件。45度線に近いほど属性水準の無作為提示が設計どおり。"
    ) +
    ggplot2::theme_bw(base_size = 10.5) +
    ggplot2::theme(
      panel.grid.minor = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(fill = "white"),
      strip.text = ggplot2::element_text(face = "bold"),
      legend.position = "bottom",
      axis.text = ggplot2::element_text(color = "black")
    )
  
  save_plot_both(
    paste0(study_spec$study_id, "_profile_randomization_diagonal_plot"),
    p_randomization,
    width = 11,
    height = ifelse(study_spec$study_id == "study3", 7.5, 8.5)
  )
  
  list(
    frequency = frequency,
    uniformity_tests = uniformity_tests,
    plot = p_randomization
  )
}

profile_randomization_results <- purrr::map(
  study_specs,
  make_profile_randomization_outputs
)


# 補遺H関連コード
make_term_label_table <- function(env) {
  if (exists("term_labels", envir = env, inherits = FALSE)) {
    out <- get("term_labels", envir = env)
    required <- c("term", "attribute", "label")
    if (all(required %in% names(out))) {
      return(out %>% dplyr::select(dplyr::any_of(c(required, "order"))))
    }
  }
  
  tibble::tibble(
    term = character(),
    attribute = character(),
    label = character(),
    order = integer()
  )
}

run_support_amce_heterogeneity <- function(study_spec) {
  env <- study_spec$env
  study_id <- study_spec$study_id
  study_label <- study_spec$study_label
  out_dir <- file.path(unified_output_dir, paste0(study_id, "_party_support"))
  dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
  
  support_id <- env$covar_id %>%
    dplyr::transmute(
      ID = as.character(ID),
      party_support_h = as.character(party_support_f)
    ) %>%
    dplyr::mutate(
      party_support_h = dplyr::na_if(party_support_h, "欠損・無回答")
    )
  
  dat <- env$conjoint_all_m %>%
    dplyr::mutate(
      ID = as.character(ID),
      party_n = as.integer(as.character(party_n))
    ) %>%
    dplyr::left_join(support_id, by = "ID") %>%
    dplyr::filter(
      !is.na(party_support_h),
      party_support_h != "",
      !party_support_h %in% excluded_support_categories
    )
  
  support_counts <- dat %>%
    dplyr::distinct(ID, party_n, party_support_h) %>%
    dplyr::count(party_support_h, party_n, name = "n_condition") %>%
    dplyr::group_by(party_support_h) %>%
    dplyr::mutate(
      n_total = sum(n_condition),
      min_condition_n = min(n_condition),
      conditions_observed = dplyr::n_distinct(party_n)
    ) %>%
    dplyr::ungroup()
  
  support_totals <- dat %>%
    dplyr::distinct(ID, party_support_h) %>%
    dplyr::count(party_support_h, name = "n_total_distinct")
  
  support_counts <- support_counts %>%
    dplyr::left_join(support_totals, by = "party_support_h") %>%
    dplyr::arrange(dplyr::desc(n_total_distinct), party_support_h)
  
  eligible_groups <- support_counts %>%
    dplyr::distinct(
      party_support_h,
      n_total_distinct,
      min_condition_n,
      conditions_observed
    ) %>%
    dplyr::filter(
      n_total_distinct >= unified_config$min_support_total_n,
      conditions_observed == 4
    ) %>%
    dplyr::pull(party_support_h)
  
  readr::write_csv(
    support_counts,
    file.path(out_dir, "party_support_sample_counts.csv"),
    na = ""
  )
  
  formula_subgroup <- stats::as.formula(
    paste(
      "selected ~",
      paste(env$attr_terms, collapse = " + ")
    )
  )
  
  estimate_one_cell <- function(group_value, n_value) {
    dat_cell <- dat %>%
      dplyr::filter(
        party_support_h == group_value,
        party_n == n_value
      )
    
    n_ids <- dplyr::n_distinct(dat_cell$ID)
    
    if (n_ids < unified_config$min_support_cell_n) {
      return(
        tibble::tibble(
          term = NA_character_,
          estimate = NA_real_,
          std.error = NA_real_,
          statistic = NA_real_,
          p.value = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_,
          party_support_h = group_value,
          party_n = n_value,
          n_ids = n_ids,
          status = "insufficient_cell_n"
        )
      )
    }
    
    model <- tryCatch(
      fixest::feols(
        formula_subgroup,
        data = dat_cell,
        vcov = ~ ID
      ),
      error = function(e) e
    )
    
    if (inherits(model, "error")) {
      return(
        tibble::tibble(
          term = NA_character_,
          estimate = NA_real_,
          std.error = NA_real_,
          statistic = NA_real_,
          p.value = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_,
          party_support_h = group_value,
          party_n = n_value,
          n_ids = n_ids,
          status = paste0("model_error: ", conditionMessage(model))
        )
      )
    }
    
    tidy_fixest_unified(model) %>%
      dplyr::mutate(
        party_support_h = group_value,
        party_n = n_value,
        n_ids = n_ids,
        status = "estimated"
      )
  }
  
  subgroup_coefficients <- purrr::map_dfr(
    eligible_groups,
    function(group_value) {
      purrr::map_dfr(
        2:5,
        ~ estimate_one_cell(group_value, .x)
      )
    }
  )
  
  term_label_table <- make_term_label_table(env)
  
  subgroup_coefficients <- subgroup_coefficients %>%
    dplyr::left_join(term_label_table, by = "term") %>%
    dplyr::mutate(
      attribute = dplyr::coalesce(attribute, "その他"),
      label = dplyr::coalesce(label, term),
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      party_n_label = factor(
        party_n,
        levels = 2:5,
        labels = paste0(2:5, ifelse(study_id == "study3", "選択肢", "政党"))
      )
    )
  
  readr::write_csv(
    subgroup_coefficients,
    file.path(out_dir, "party_support_subgroup_amce_coefficients.csv"),
    na = ""
  )
  
  for (group_value in eligible_groups) {
    plot_dat <- subgroup_coefficients %>%
      dplyr::filter(
        party_support_h == group_value,
        status == "estimated",
        !is.na(term)
      )
    
    if (nrow(plot_dat) == 0) next
    
    label_order <- plot_dat %>%
      dplyr::arrange(attribute, dplyr::coalesce(order, 9999), label) %>%
      dplyr::distinct(label) %>%
      dplyr::pull(label)
    
    plot_dat <- plot_dat %>%
      dplyr::mutate(
        label = factor(label, levels = rev(label_order))
      )
    
    n_group <- support_totals %>%
      dplyr::filter(party_support_h == group_value) %>%
      dplyr::pull(n_total_distinct)
    
    p_group <- ggplot2::ggplot(
      plot_dat,
      ggplot2::aes(
        x = estimate_pp,
        y = label,
        shape = party_n_label
      )
    ) +
      ggplot2::geom_vline(xintercept = 0, linewidth = 0.45) +
      ggplot2::geom_errorbarh(
        ggplot2::aes(
          xmin = conf.low_pp,
          xmax = conf.high_pp
        ),
        height = 0.10,
        position = ggplot2::position_dodge(width = 0.55),
        linewidth = 0.55
      ) +
      ggplot2::geom_point(
        position = ggplot2::position_dodge(width = 0.55),
        size = 2.3,
        fill = "white"
      ) +
      ggplot2::facet_grid(
        attribute ~ .,
        scales = "free_y",
        space = "free_y"
      ) +
      ggplot2::labs(
        x = "選択確率への効果（percentage points）",
        y = NULL,
        shape = study_spec$condition_label,
        subtitle = paste0(
          study_label,
          "：",
          group_value,
          "支持者（n = ",
          scales::comma(n_group),
          "）"
        ),
        caption = paste0(
          "回答者IDでクラスタ化した標準誤差。各条件セルn < ",
          unified_config$min_support_cell_n,
          "は推定しない。"
        )
      ) +
      ggplot2::theme_bw(base_size = 10.5) +
      ggplot2::theme(
        panel.grid.minor = ggplot2::element_blank(),
        strip.background = ggplot2::element_rect(fill = "white"),
        strip.text = ggplot2::element_text(face = "bold"),
        legend.position = "bottom",
        axis.text = ggplot2::element_text(color = "black")
      )
    
    group_index <- match(group_value, eligible_groups)
    file_stub <- paste0(
      study_id,
      "_party_support_amce_",
      sprintf("%02d", group_index),
      "_",
      safe_filename(group_value)
    )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, paste0(file_stub, ".png")),
      plot = p_group,
      width = 10.5,
      height = ifelse(study_id == "study3", 11.5, 10.0),
      dpi = 400,
      bg = "white"
    )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, paste0(file_stub, ".pdf")),
      plot = p_group,
      width = 10.5,
      height = ifelse(study_id == "study3", 11.5, 10.0),
      device = grDevices::cairo_pdf,
      bg = "white"
    )
  }
  
  interaction_models <- list()
  interaction_test_text <- character()
  
  dat_interaction <- dat %>%
    dplyr::filter(party_support_h %in% eligible_groups) %>%
    dplyr::mutate(
      party_support_h = factor(party_support_h)
    )
  
  if ("支持政党なし" %in% levels(dat_interaction$party_support_h)) {
    dat_interaction <- dat_interaction %>%
      dplyr::mutate(
        party_support_h = stats::relevel(
          party_support_h,
          ref = "支持政党なし"
        )
      )
  } else if (nrow(support_totals) > 0) {
    largest_group <- support_totals %>%
      dplyr::filter(party_support_h %in% eligible_groups) %>%
      dplyr::slice_max(n_total_distinct, n = 1, with_ties = FALSE) %>%
      dplyr::pull(party_support_h)
    
    if (length(largest_group) == 1) {
      dat_interaction <- dat_interaction %>%
        dplyr::mutate(
          party_support_h = stats::relevel(
            party_support_h,
            ref = largest_group
          )
        )
    }
  }
  
  formula_interaction <- stats::as.formula(
    paste0(
      "selected ~ party_support_h * (",
      paste(env$attr_terms, collapse = " + "),
      ")"
    )
  )
  
  for (n_value in 2:5) {
    dat_n <- dat_interaction %>% dplyr::filter(party_n == n_value)
    
    model_n <- tryCatch(
      fixest::feols(
        formula_interaction,
        data = dat_n,
        vcov = ~ ID
      ),
      error = function(e) e
    )
    
    interaction_models[[as.character(n_value)]] <- model_n
    
    interaction_test_text <- c(
      interaction_test_text,
      paste0("\n===== ", study_label, ": condition ", n_value, " =====\n")
    )
    
    if (inherits(model_n, "error")) {
      interaction_test_text <- c(
        interaction_test_text,
        paste0("Model error: ", conditionMessage(model_n), "\n")
      )
    } else {
      interaction_test_text <- c(
        interaction_test_text,
        capture.output(summary(model_n)),
        "\n--- Joint Wald test for party-support interaction terms ---\n",
        tryCatch(
          capture.output(
            fixest::wald(
              model_n,
              keep = "party_support_h.*:|:party_support_h"
            )
          ),
          error = function(e) paste0("Wald test error: ", conditionMessage(e))
        )
      )
    }
  }
  
  writeLines(
    interaction_test_text,
    con = file.path(out_dir, "party_support_interaction_models_and_wald_tests.txt")
  )
  
  list(
    support_counts = support_counts,
    eligible_groups = eligible_groups,
    subgroup_coefficients = subgroup_coefficients,
    interaction_models = interaction_models,
    data = dat
  )
}

party_support_amce_results <- purrr::map(
  study_specs,
  run_support_amce_heterogeneity
)

run_support_relative_cue <- function(study_spec, amce_result) {
  env <- study_spec$env
  study_id <- study_spec$study_id
  out_dir <- file.path(unified_output_dir, paste0(study_id, "_party_support"))
  
  dat <- amce_result$data
  eligible_groups <- amce_result$eligible_groups
  
  observed_list <- list()
  interval_list <- list()
  slope_list <- list()
  failure_list <- list()
  
  for (group_index in seq_along(eligible_groups)) {
    group_value <- eligible_groups[group_index]
    dat_group <- dat %>%
      dplyr::filter(party_support_h == group_value)
    
    condition_counts <- dat_group %>%
      dplyr::distinct(ID, party_n) %>%
      dplyr::count(party_n, name = "n_ids")
    
    if (
      !identical(sort(condition_counts$party_n), 2:5) ||
      any(condition_counts$n_ids < unified_config$min_support_cell_n)
    ) {
      failure_list[[group_value]] <- tibble::tibble(
        party_support_h = group_value,
        reason = "Not all four conditions meet the minimum cell size"
      )
      next
    }
    
    prepared <- tryCatch(
      env$prepare_relative_cue_analysis(
        data = dat_group,
        cue_map = env$relative_cue_map
      ),
      error = function(e) e
    )
    
    if (inherits(prepared, "error")) {
      failure_list[[group_value]] <- tibble::tibble(
        party_support_h = group_value,
        reason = conditionMessage(prepared)
      )
      next
    }
    
    observed <- env$estimate_relative_cue_indices(prepared)
    observed_slopes <- env$estimate_relative_cue_slopes(
      observed$cue_importance
    )
    
    observed_list[[group_value]] <- observed$cue_importance %>%
      dplyr::mutate(
        party_support_h = group_value,
        .before = 1
      )
    
    slope_list[[group_value]] <- tibble::tibble(
      party_support_h = group_value,
      statistic = names(observed_slopes),
      estimate = as.numeric(observed_slopes)
    )
    
    B <- unified_config$support_bootstrap_B
    
    if (B > 0) {
      cache_file <- file.path(
        out_dir,
        paste0(
          "support_relative_cue_bootstrap_",
          unified_config$cue_importance_metric_version,
          "_",
          sprintf("%02d", group_index),
          "_B",
          B,
          ".rds"
        )
      )
      
      if (
        file.exists(cache_file) &&
        !unified_config$rerun_support_bootstrap
      ) {
        bootstrap_result <- readRDS(cache_file)
      } else {
        bootstrap_result <- env$run_relative_cue_bootstrap(
          prepared = prepared,
          B = B,
          seed = unified_config$support_bootstrap_seed +
            1000 * match(study_id, names(study_specs)) +
            group_index,
          progress_every = max(0, floor(B / 5))
        )
        saveRDS(bootstrap_result, cache_file)
      }
      
      intervals <- env$summarise_condition_intervals(
        observed_cue_importance = observed$cue_importance,
        bootstrap_condition_results = bootstrap_result$condition_estimates
      ) %>%
        dplyr::mutate(
          party_support_h = group_value,
          .before = 1
        )
      
      slope_inference <- env$summarise_slope_inference(
        observed_slopes = observed_slopes,
        bootstrap_slopes = bootstrap_result$slopes
      ) %>%
        dplyr::mutate(
          party_support_h = group_value,
          .before = 1
        )
      
      interval_list[[group_value]] <- intervals
      slope_list[[paste0(group_value, "_inference")]] <- slope_inference
    }
  }
  
  observed_df <- dplyr::bind_rows(observed_list)
  interval_df <- dplyr::bind_rows(interval_list)
  slope_df <- dplyr::bind_rows(slope_list)
  failures_df <- dplyr::bind_rows(failure_list)
  
  readr::write_csv(
    observed_df,
    file.path(out_dir, "party_support_relative_cue_observed.csv"),
    na = ""
  )
  readr::write_csv(
    interval_df,
    file.path(out_dir, "party_support_relative_cue_intervals.csv"),
    na = ""
  )
  readr::write_csv(
    slope_df,
    file.path(out_dir, "party_support_relative_cue_slopes.csv"),
    na = ""
  )
  readr::write_csv(
    failures_df,
    file.path(out_dir, "party_support_relative_cue_failures.csv"),
    na = ""
  )
  
  if (nrow(interval_df) > 0) {
    plot_df <- interval_df %>%
      dplyr::filter(statistic == "relative_party_weight_pairwise") %>%
      dplyr::mutate(
        estimate_pct = estimate * 100,
        conf_low_pct = conf_low * 100,
        conf_high_pct = conf_high * 100
      )
  } else {
    plot_df <- observed_df %>%
      dplyr::transmute(
        party_support_h,
        party_n,
        estimate_pct = relative_party_weight_pairwise * 100,
        conf_low_pct = NA_real_,
        conf_high_pct = NA_real_
      )
  }
  
  if (nrow(plot_df) > 0) {
    p_relative_support <- ggplot2::ggplot(
      plot_df,
      ggplot2::aes(
        x = party_n,
        y = estimate_pct,
        group = 1
      )
    ) +
      ggplot2::geom_hline(yintercept = 50, linetype = "dashed", linewidth = 0.45) +
      ggplot2::geom_line(linewidth = 0.70) +
      ggplot2::geom_errorbar(
        ggplot2::aes(
          ymin = conf_low_pct,
          ymax = conf_high_pct
        ),
        width = 0.08,
        linewidth = 0.55,
        na.rm = TRUE
      ) +
      ggplot2::geom_point(shape = 21, fill = "white", size = 2.5) +
      ggplot2::facet_wrap(~ party_support_h, ncol = 3) +
      ggplot2::scale_x_continuous(
        breaks = 2:5,
        labels = paste0(2:5, ifelse(study_id == "study3", "選択肢", "政党"))
      ) +
      ggplot2::scale_y_continuous(
        labels = function(x) paste0(x, "%"),
        breaks = scales::pretty_breaks(n = 6)
      ) +
      ggplot2::labs(
        x = study_spec$condition_label,
        y = "政党手がかりの相対比重",
        subtitle = paste0(
          study_spec$study_label,
          "：支持政党別の政党手がかり相対比重"
        ),
        caption = paste0(
          "各属性内の限界平均の平均絶対ペア差に基づく。",
          ifelse(
            unified_config$support_bootstrap_B > 0,
            paste0(
              "95%信頼区間は回答者クラスタ・ブートストラップ（B = ",
              unified_config$support_bootstrap_B,
              "）。"
            ),
            "信頼区間は未計算。"
          )
        )
      ) +
      ggplot2::theme_bw(base_size = 10.5) +
      ggplot2::theme(
        panel.grid.minor = ggplot2::element_blank(),
        strip.background = ggplot2::element_rect(fill = "white"),
        strip.text = ggplot2::element_text(face = "bold"),
        axis.text = ggplot2::element_text(color = "black")
      )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, "party_support_relative_cue_weight.png"),
      plot = p_relative_support,
      width = 11.5,
      height = max(7.0, 2.6 * ceiling(dplyr::n_distinct(plot_df$party_support_h) / 3)),
      dpi = 400,
      bg = "white"
    )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, "party_support_relative_cue_weight.pdf"),
      plot = p_relative_support,
      width = 11.5,
      height = max(7.0, 2.6 * ceiling(dplyr::n_distinct(plot_df$party_support_h) / 3)),
      device = grDevices::cairo_pdf,
      bg = "white"
    )
  } else {
    p_relative_support <- NULL
  }
  
  list(
    observed = observed_df,
    intervals = interval_df,
    slopes = slope_df,
    failures = failures_df,
    plot = p_relative_support
  )
}

party_support_relative_cue_results <- purrr::map2(
  study_specs,
  party_support_amce_results,
  run_support_relative_cue
)


# 補遺I関連コード
extract_cue_slope_inference <- function(study_spec) {
  env <- study_spec$env
  
  env$relative_cue_slope_inference %>%
    dplyr::mutate(
      study_id = study_spec$study_id,
      study_label = study_spec$study_label,
      .before = 1
    )
}

cue_slope_inference_all <- purrr::map_dfr(
  study_specs,
  extract_cue_slope_inference
) %>%
  dplyr::mutate(
    statistic_label = dplyr::recode(
      statistic,
      party_importance_pairwise = "政党の手がかりの未調整重要度",
      economic_importance_pairwise = "経済の手がかりの未調整重要度",
      party_importance_pairwise_adjusted =
        "政党の手がかりの選択肢数調整済み重要度",
      economic_importance_pairwise_adjusted =
        "経済の手がかりの選択肢数調整済み重要度",
      relative_party_weight_pairwise = "政党の手がかりの相対比重"
    ),
    metric_scale = dplyr::case_when(
      statistic %in% c(
        "party_importance_pairwise_adjusted",
        "economic_importance_pairwise_adjusted"
      ) ~ "choice_set_adjusted_baseline_relative",
      statistic == "relative_party_weight_pairwise" ~
        "relative_share",
      TRUE ~ "unadjusted_probability_difference"
    ),
    estimate_pp_per_option = estimate * 100,
    conf_low_pp_per_option = conf_low * 100,
    conf_high_pp_per_option = conf_high * 100
  )

write_csv_unified(
  cue_slope_inference_all,
  "cue_importance_linear_slope_all_studies.csv"
)

choice_set_adjusted_slope_summary <- cue_slope_inference_all %>%
  dplyr::filter(
    statistic %in% c(
      "party_importance_pairwise_adjusted",
      "economic_importance_pairwise_adjusted"
    )
  ) %>%
  dplyr::mutate(
    cue_family = dplyr::recode(
      statistic,
      party_importance_pairwise_adjusted =
        "政党・政党名手がかり",
      economic_importance_pairwise_adjusted =
        "経済手がかり"
    ),
    estimate_baseline_pct_per_option = estimate * 100,
    conf_low_baseline_pct_per_option = conf_low * 100,
    conf_high_baseline_pct_per_option = conf_high * 100
  )

write_csv_unified(
  choice_set_adjusted_slope_summary,
  "choice_set_adjusted_importance_linear_slopes.csv"
)

hypothesis_map <- tibble::tribble(
  ~study_id, ~hypothesis, ~statistic, ~expected_direction,
  "study1", "H1a（実験1）", "party_importance_pairwise", "positive",
  "study1", "H1b（実験1）", "economic_importance_pairwise", "negative",
  "study2", "H1a（実験2）", "party_importance_pairwise", "positive",
  "study2", "H1b（実験2）", "economic_importance_pairwise", "negative",
  "study3", "H2a（実験3）", "party_importance_pairwise", "positive",
  "study3", "H2b（実験3）", "economic_importance_pairwise", "negative"
)

hypothesis_test_summary <- hypothesis_map %>%
  dplyr::left_join(
    cue_slope_inference_all %>%
      dplyr::select(
        study_id,
        study_label,
        statistic,
        estimate,
        conf_low,
        conf_high,
        p_value_two_sided
      ),
    by = c("study_id", "statistic")
  ) %>%
  dplyr::mutate(
    estimate_in_expected_direction = dplyr::case_when(
      expected_direction == "positive" ~ estimate > 0,
      expected_direction == "negative" ~ estimate < 0,
      TRUE ~ NA
    ),
    ci_excludes_zero_in_expected_direction = dplyr::case_when(
      expected_direction == "positive" ~ conf_low > 0,
      expected_direction == "negative" ~ conf_high < 0,
      TRUE ~ NA
    ),
    conclusion = dplyr::case_when(
      ci_excludes_zero_in_expected_direction ~
        "予測方向で95%信頼区間が0を含まず、統計的に支持",
      estimate_in_expected_direction ~
        "点推定は予測方向だが、95%信頼区間が0を含む",
      TRUE ~
        "点推定が予測方向と一致しない"
    ),
    estimate_pp_per_option = estimate * 100,
    conf_low_pp_per_option = conf_low * 100,
    conf_high_pp_per_option = conf_high * 100,
    hypothesis = factor(
      hypothesis,
      levels = rev(hypothesis_map$hypothesis)
    )
  )

write_csv_unified(
  hypothesis_test_summary,
  "main_hypothesis_linear_trend_tests.csv"
)

p_hypothesis_slopes <- ggplot2::ggplot(
  hypothesis_test_summary,
  ggplot2::aes(
    x = estimate_pp_per_option,
    y = hypothesis,
    shape = expected_direction
  )
) +
  ggplot2::geom_vline(
    xintercept = 0,
    linewidth = 0.45
  ) +
  ggplot2::geom_errorbarh(
    ggplot2::aes(
      xmin = conf_low_pp_per_option,
      xmax = conf_high_pp_per_option
    ),
    height = 0.12,
    linewidth = 0.60
  ) +
  ggplot2::geom_point(
    size = 2.7,
    fill = "white"
  ) +
  ggplot2::scale_shape_manual(
    values = c(
      positive = 21,
      negative = 24
    ),
    labels = c(
      positive = "正の傾向を予測",
      negative = "負の傾向を予測"
    )
  ) +
  ggplot2::labs(
    x = "選択肢が1つ増えるときの重要度の変化（pp）",
    y = NULL,
    shape = NULL,
    caption = paste0(
      "重要度は、同一属性内の全水準ペアについて限界平均の絶対差を求め、",
      "その平均として算出。横線は回答者クラスタ・ブートストラップ95%信頼区間。"
    )
  ) +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(
    panel.grid.minor = ggplot2::element_blank(),
    legend.position = "bottom",
    axis.text = ggplot2::element_text(color = "black")
  )

save_plot_both(
  "fig_supp_hypothesis_linear_trend_tests",
  p_hypothesis_slopes,
  width = 9.5,
  height = 5.8
)

choice_set_adjusted_slope_summary <- choice_set_adjusted_slope_summary %>%
  dplyr::mutate(
    study_cue_label = paste0(
      study_label,
      "：",
      cue_family
    ),
    study_cue_label = factor(
      study_cue_label,
      levels = rev(
        unique(study_cue_label)
      )
    )
  )

p_choice_set_adjusted_slopes <- ggplot2::ggplot(
  choice_set_adjusted_slope_summary,
  ggplot2::aes(
    x = estimate_baseline_pct_per_option,
    y = study_cue_label,
    shape = cue_family
  )
) +
  ggplot2::geom_vline(
    xintercept = 0,
    linewidth = 0.45
  ) +
  ggplot2::geom_errorbarh(
    ggplot2::aes(
      xmin = conf_low_baseline_pct_per_option,
      xmax = conf_high_baseline_pct_per_option
    ),
    height = 0.12,
    linewidth = 0.60
  ) +
  ggplot2::geom_point(
    size = 2.7,
    fill = "white"
  ) +
  ggplot2::scale_shape_manual(
    values = c(
      "政党・政党名手がかり" = 21,
      "経済手がかり" = 24
    )
  ) +
  ggplot2::labs(
    x = paste0(
      "選択肢が1つ増えるときの調整済み重要度の変化",
      "（平均選択確率に対する割合：pp）"
    ),
    y = NULL,
    shape = NULL,
    caption = paste0(
      "調整済み重要度 = 未調整重要度 ÷（1／選択肢数）。",
      "事前登録済み仮説の判定ではなく、記述的・感度分析として示す。"
    )
  ) +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(
    panel.grid.minor = ggplot2::element_blank(),
    legend.position = "bottom",
    axis.text = ggplot2::element_text(color = "black")
  )

save_plot_both(
  "fig_supp_choice_set_adjusted_importance_slopes",
  p_choice_set_adjusted_slopes,
  width = 10.5,
  height = 6.2
)


# 本文コード
run_study3_all_party_match <- function() {
  env <- study3_env
  out_dir <- file.path(unified_output_dir, "study3_party_match_all_parties")
  dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
  
  dat <- env$conjoint_match %>%
    dplyr::mutate(
      ID = as.character(ID),
      party_n = as.integer(as.character(party_n)),
      support_party_valid = as.character(support_party_valid)
    ) %>%
    dplyr::filter(
      !is.na(support_party_valid),
      support_party_valid != ""
    )
  
  support_cell_counts <- dat %>%
    dplyr::distinct(ID, support_party_valid, party_n) %>%
    dplyr::count(
      support_party_valid,
      party_n,
      name = "n_respondents"
    ) %>%
    tidyr::complete(
      support_party_valid,
      party_n = 2:5,
      fill = list(n_respondents = 0L)
    ) %>%
    dplyr::group_by(support_party_valid) %>%
    dplyr::mutate(
      n_total = sum(n_respondents),
      min_cell_n = min(n_respondents),
      all_four_conditions = all(n_respondents > 0)
    ) %>%
    dplyr::ungroup()
  
  eligible_parties <- support_cell_counts %>%
    dplyr::distinct(
      support_party_valid,
      n_total,
      min_cell_n,
      all_four_conditions
    ) %>%
    dplyr::filter(
      n_total >= unified_config$min_support_total_n,
      min_cell_n >= unified_config$min_support_cell_n,
      all_four_conditions
    ) %>%
    dplyr::arrange(dplyr::desc(n_total)) %>%
    dplyr::pull(support_party_valid)
  
  readr::write_csv(
    support_cell_counts,
    file.path(out_dir, "party_match_all_party_sample_counts.csv"),
    na = ""
  )
  
  formula_cell <- stats::as.formula(
    paste(
      "selected ~",
      paste(
        c(
          "party_match",
          env$economic_attr_terms
        ),
        collapse = " + "
      )
    )
  )
  
  estimate_cell <- function(group_value, n_value) {
    dat_cell <- dat %>%
      dplyr::filter(
        support_party_valid == group_value,
        party_n == n_value
      )
    
    n_ids <- dplyr::n_distinct(dat_cell$ID)
    
    if (n_ids < unified_config$min_support_cell_n) {
      return(
        tibble::tibble(
          support_party_valid = group_value,
          party_n = n_value,
          n_ids = n_ids,
          estimate = NA_real_,
          std.error = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_,
          p.value = NA_real_,
          status = "insufficient_cell_n"
        )
      )
    }
    
    model <- tryCatch(
      fixest::feols(
        formula_cell,
        data = dat_cell,
        vcov = ~ ID
      ),
      error = function(e) e
    )
    
    if (inherits(model, "error")) {
      return(
        tibble::tibble(
          support_party_valid = group_value,
          party_n = n_value,
          n_ids = n_ids,
          estimate = NA_real_,
          std.error = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_,
          p.value = NA_real_,
          status = paste0("model_error: ", conditionMessage(model))
        )
      )
    }
    
    tidy_fixest_unified(model) %>%
      dplyr::filter(term == "party_match") %>%
      dplyr::transmute(
        support_party_valid = group_value,
        party_n = n_value,
        n_ids = n_ids,
        estimate,
        std.error,
        conf.low,
        conf.high,
        p.value,
        status = "estimated"
      )
  }
  
  cell_coefficients <- purrr::map_dfr(
    eligible_parties,
    function(group_value) {
      purrr::map_dfr(
        2:5,
        ~ estimate_cell(group_value, .x)
      )
    }
  ) %>%
    dplyr::mutate(
      estimate_pp = estimate * 100,
      conf.low_pp = conf.low * 100,
      conf.high_pp = conf.high * 100,
      party_n_label = factor(
        party_n,
        levels = 2:5,
        labels = paste0(2:5, "選択肢")
      ),
      main_text_party = support_party_valid %in% c(
        "自由民主党",
        "中道改革連合",
        "立憲民主党",
        "参政党"
      )
    )
  
  readr::write_csv(
    cell_coefficients,
    file.path(out_dir, "party_match_all_party_coefficients.csv"),
    na = ""
  )
  
  estimate_trend <- function(group_value) {
    dat_group <- dat %>%
      dplyr::filter(support_party_valid == group_value) %>%
      dplyr::mutate(
        party_n_f_heterogeneity = factor(
          party_n,
          levels = 2:5
        ),
        party_n_c_heterogeneity = party_n - 2
      )
    
    formula_trend <- stats::as.formula(
      paste(
        "selected ~ party_n_f_heterogeneity + party_match +",
        "party_match:party_n_c_heterogeneity +",
        paste(env$economic_attr_terms, collapse = " + ")
      )
    )
    
    model <- tryCatch(
      fixest::feols(
        formula_trend,
        data = dat_group,
        vcov = ~ ID
      ),
      error = function(e) e
    )
    
    if (inherits(model, "error")) {
      return(
        tibble::tibble(
          support_party_valid = group_value,
          term = "party_match:party_n_c_heterogeneity",
          estimate = NA_real_,
          std.error = NA_real_,
          conf.low = NA_real_,
          conf.high = NA_real_,
          p.value = NA_real_,
          status = paste0("model_error: ", conditionMessage(model))
        )
      )
    }
    
    tidy_fixest_unified(model) %>%
      dplyr::filter(
        stringr::str_detect(
          term,
          "party_match:party_n_c_heterogeneity|party_n_c_heterogeneity:party_match"
        )
      ) %>%
      dplyr::mutate(
        support_party_valid = group_value,
        status = "estimated",
        .before = 1
      )
  }
  
  trend_coefficients <- purrr::map_dfr(
    eligible_parties,
    estimate_trend
  ) %>%
    dplyr::mutate(
      estimate_pp_per_option = estimate * 100,
      conf.low_pp_per_option = conf.low * 100,
      conf.high_pp_per_option = conf.high * 100
    )
  
  readr::write_csv(
    trend_coefficients,
    file.path(out_dir, "party_match_all_party_linear_trends.csv"),
    na = ""
  )
  
  plot_df <- cell_coefficients %>%
    dplyr::filter(
      status == "estimated",
      is.finite(estimate_pp)
    ) %>%
    dplyr::mutate(
      support_party_valid = factor(
        support_party_valid,
        levels = eligible_parties
      )
    )
  
  if (nrow(plot_df) > 0) {
    p_all_party_match <- ggplot2::ggplot(
      plot_df,
      ggplot2::aes(
        x = party_n,
        y = estimate_pp,
        group = 1
      )
    ) +
      ggplot2::geom_hline(
        yintercept = 0,
        linewidth = 0.40
      ) +
      ggplot2::geom_line(
        linewidth = 0.65
      ) +
      ggplot2::geom_errorbar(
        ggplot2::aes(
          ymin = conf.low_pp,
          ymax = conf.high_pp
        ),
        width = 0.08,
        linewidth = 0.55
      ) +
      ggplot2::geom_point(
        shape = 21,
        fill = "white",
        size = 2.4
      ) +
      ggplot2::facet_wrap(
        ~ support_party_valid,
        ncol = 3
      ) +
      ggplot2::scale_x_continuous(
        breaks = 2:5,
        labels = paste0(2:5, "選択肢")
      ) +
      ggplot2::labs(
        x = "提示される選択肢数",
        y = "支持政党と提示政党名の一致効果（pp）",
        caption = paste0(
          "各支持政党サブグループ内で selected ~ party_match + 経済属性を推定。",
          "標準誤差は回答者IDでクラスタ化。"
        )
      ) +
      ggplot2::theme_bw(base_size = 10.5) +
      ggplot2::theme(
        panel.grid.minor = ggplot2::element_blank(),
        strip.background = ggplot2::element_rect(fill = "white"),
        strip.text = ggplot2::element_text(face = "bold"),
        axis.text = ggplot2::element_text(color = "black")
      )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, "party_match_all_parties.png"),
      plot = p_all_party_match,
      width = 11.5,
      height = max(
        7.0,
        2.7 * ceiling(length(eligible_parties) / 3)
      ),
      dpi = 400,
      bg = "white"
    )
    
    ggplot2::ggsave(
      filename = file.path(out_dir, "party_match_all_parties.pdf"),
      plot = p_all_party_match,
      width = 11.5,
      height = max(
        7.0,
        2.7 * ceiling(length(eligible_parties) / 3)
      ),
      device = grDevices::cairo_pdf,
      bg = "white"
    )
  } else {
    p_all_party_match <- NULL
  }
  
  list(
    sample_counts = support_cell_counts,
    eligible_parties = eligible_parties,
    coefficients = cell_coefficients,
    trends = trend_coefficients,
    plot = p_all_party_match
  )
}

study3_all_party_match_results <- run_study3_all_party_match()


extract_cross_study_relative_weight <- function(study_spec) {
  env <- study_spec$env
  
  env$relative_cue_condition_intervals %>%
    dplyr::filter(
      statistic == "relative_party_weight_pairwise"
    ) %>%
    dplyr::transmute(
      study_id = study_spec$study_id,
      study_label = study_spec$study_label,
      party_n,
      estimate,
      conf_low,
      conf_high
    )
}

cross_study_relative_weight <- purrr::map_dfr(
  study_specs,
  extract_cross_study_relative_weight
) %>%
  dplyr::mutate(
    estimate_pct = estimate * 100,
    conf_low_pct = conf_low * 100,
    conf_high_pct = conf_high * 100,
    study_label = factor(
      study_label,
      levels = vapply(
        study_specs,
        `[[`,
        character(1),
        "study_label"
      )
    )
  )

write_csv_unified(
  cross_study_relative_weight,
  "cross_study_relative_party_weight.csv"
)

p_cross_study_relative <- ggplot2::ggplot(
  cross_study_relative_weight,
  ggplot2::aes(
    x = party_n,
    y = estimate_pct,
    linetype = study_label,
    shape = study_label,
    group = study_label
  )
) +
  ggplot2::geom_hline(
    yintercept = 50,
    linetype = "dotted",
    linewidth = 0.45
  ) +
  ggplot2::geom_line(
    linewidth = 0.80
  ) +
  ggplot2::geom_errorbar(
    ggplot2::aes(
      ymin = conf_low_pct,
      ymax = conf_high_pct
    ),
    width = 0.07,
    linewidth = 0.60,
    position = ggplot2::position_dodge(width = 0.08)
  ) +
  ggplot2::geom_point(
    size = 2.7,
    fill = "white",
    position = ggplot2::position_dodge(width = 0.08)
  ) +
  ggplot2::scale_x_continuous(
    breaks = 2:5,
    labels = paste0(2:5, "選択肢")
  ) +
  ggplot2::scale_y_continuous(
    labels = function(x) paste0(x, "%"),
    breaks = scales::pretty_breaks(n = 6)
  ) +
  ggplot2::labs(
    x = "提示される選択肢数",
    y = "政党の手がかりの相対比重",
    linetype = NULL,
    shape = NULL,
    caption = paste0(
      "限界平均の平均絶対ペア差に基づく。",
      "エラーバーは回答者クラスタ・ブートストラップ95%信頼区間。"
    )
  ) +
  ggplot2::theme_bw(base_size = 11.5) +
  ggplot2::theme(
    panel.grid.minor = ggplot2::element_blank(),
    legend.position = "bottom",
    axis.text = ggplot2::element_text(color = "black")
  )

save_plot_both(
  "fig_supp_cross_study_relative_party_weight",
  p_cross_study_relative,
  width = 9.5,
  height = 6.0
)


# 出力整理コード
main_text_figure_manifest <- tibble::tribble(
  ~figure_number, ~study, ~analysis, ~file_png, ~file_pdf,
  "Figure 4", "Study 1", "共変量調整済みAMCE",
  file.path(unified_config$study1$output_dir, "amce_cov_facet_model.png"),
  NA_character_,
  "Figure 5", "Study 1", "政党・経済手がかりの重要度と相対比重",
  file.path(unified_config$study1$output_dir, "fig_study1_relative_cue_weight_jp_bw.png"),
  file.path(unified_config$study1$output_dir, "fig_study1_relative_cue_weight_jp_bw.pdf"),
  "Figure 6", "Study 2", "共変量調整済みAMCE",
  file.path(unified_config$study2$output_dir, "amce_cov_facet_model.png"),
  NA_character_,
  "Figure 7", "Study 2", "政党・経済手がかりの重要度と相対比重",
  file.path(unified_config$study2$output_dir, "fig_study2_relative_cue_weight_jp_bw.png"),
  file.path(unified_config$study2$output_dir, "fig_study2_relative_cue_weight_jp_bw.pdf"),
  "Figure 8", "Study 3", "共変量調整済みAMCE",
  file.path(unified_config$study3$output_dir, "amce_cov_facet_model.png"),
  NA_character_,
  "Figure 9", "Study 3", "政党名・経済手がかりの重要度と相対比重",
  file.path(unified_config$study3$output_dir, "fig_study3_relative_cue_weight_jp_bw.png"),
  file.path(unified_config$study3$output_dir, "fig_study3_relative_cue_weight_jp_bw.pdf"),
  "Figure 10", "Study 3", "支持政党と提示政党名の一致効果",
  file.path(unified_config$study3$output_dir, "party_match_effect_combined.png"),
  NA_character_
)

write_csv_unified(
  main_text_figure_manifest,
  "main_text_figure_reproduction_manifest.csv"
)

supplement_figure_manifest <- tibble::tribble(
  ~section, ~study, ~analysis, ~file_png,
  "B", "Study 1", "回答者割付バランス：Love plot",
  file.path(unified_output_dir, "study1_assignment_balance_love_plot.png"),
  "B", "Study 2", "回答者割付バランス：Love plot",
  file.path(unified_output_dir, "study2_assignment_balance_love_plot.png"),
  "B", "Study 3", "回答者割付バランス：Love plot",
  file.path(unified_output_dir, "study3_assignment_balance_love_plot.png"),
  "B", "Study 1", "回答者割付バランス：45度線診断",
  file.path(unified_output_dir, "study1_assignment_balance_diagonal_plot.png"),
  "B", "Study 2", "回答者割付バランス：45度線診断",
  file.path(unified_output_dir, "study2_assignment_balance_diagonal_plot.png"),
  "B", "Study 3", "回答者割付バランス：45度線診断",
  file.path(unified_output_dir, "study3_assignment_balance_diagonal_plot.png"),
  "B", "Study 1", "属性水準の観測比率対期待比率",
  file.path(unified_output_dir, "study1_profile_randomization_diagonal_plot.png"),
  "B", "Study 2", "属性水準の観測比率対期待比率",
  file.path(unified_output_dir, "study2_profile_randomization_diagonal_plot.png"),
  "B", "Study 3", "属性水準の観測比率対期待比率",
  file.path(unified_output_dir, "study3_profile_randomization_diagonal_plot.png"),
  "C", "Study 1–3", "H1a/H1b/H2a/H2bの線形傾向検定",
  file.path(unified_output_dir, "fig_supp_hypothesis_linear_trend_tests.png"),
  "C", "Study 1–3", "選択肢数調整済み重要度の線形傾向",
  file.path(unified_output_dir, "fig_supp_choice_set_adjusted_importance_slopes.png"),
  "C", "Study 1", "未調整・選択肢数調整済み重要度・相対比重",
  file.path(
    unified_config$study1$output_dir,
    "fig_study1_relative_cue_weight_choice_set_adjusted_jp_bw.png"
  ),
  "C", "Study 2", "未調整・選択肢数調整済み重要度・相対比重",
  file.path(
    unified_config$study2$output_dir,
    "fig_study2_relative_cue_weight_choice_set_adjusted_jp_bw.png"
  ),
  "C", "Study 3", "未調整・選択肢数調整済み重要度・相対比重",
  file.path(
    unified_config$study3$output_dir,
    "fig_study3_relative_cue_weight_choice_set_adjusted_jp_bw.png"
  ),
  "F", "Study 1–3", "政党手がかり相対比重の横断比較",
  file.path(unified_output_dir, "fig_supp_cross_study_relative_party_weight.png"),
  "G", "Study 3", "全ての十分な標本をもつ支持政党の一致効果",
  file.path(
    unified_output_dir,
    "study3_party_match_all_parties",
    "party_match_all_parties.png"
  ),
  "G", "Study 1–3", "支持政党別AMCE・相対比重",
  file.path(unified_output_dir, "<study>_party_support")
)

write_csv_unified(
  supplement_figure_manifest,
  "supplement_figure_manifest.csv"
)

supplement_section_manifest <- tibble::tribble(
  ~section, ~title, ~placement_logic, ~core_outputs,
  "A", "調査設計・質問文・標本構築",
  "読者が3実験の相違と分析対象者の形成を先に確認できるようにする。",
  "調査フロー、属性・水準、質問文、sample_flow、条件別n、欠損集計",
  "B", "無作為割付・属性提示・データ品質の診断",
  "推定結果より前に、処置条件とコンジョイント属性の無作為化が機能したことを示す。",
  "条件別共変量表、全6条件ペアのSMD、Love plot、45度線図、属性水準の観測対期待比率",
  "C", "推定量・相対比重・仮説検定",
  "本文の式(1)(2)とH1a/H1b/H2a/H2bの判定方法を一か所に集約する。",
  paste0(
    "AMCE、限界平均、平均絶対ペア差、選択肢数調整済み重要度、",
    "相対比重、ブートストラップ、線形傾向統合表"
  ),
  "D", "実験1（2023年）の完全な結果",
  "本文図4・5の再現後に、補助分析を同じ実験内でまとめる。",
  "調整済み・未調整AMCE、交互作用、ヒートマップ、条件付きロジット、相対比重傾向",
  "E", "実験2（2026年）と2023–2026年比較",
  "実験1の再現性と時点間変化を連続して読めるようにする。",
  "調整済み・未調整AMCE、交互作用、ヒートマップ、条件付きロジット、相対比重傾向、時点比較",
  "F", "実験3（2026年）の完全な結果",
  "具体的政党名の分析と、本文図8・9・10の追加推定をまとめる。",
  "AMCE、カテゴリカル・線形トレンド、条件付きロジット、相対比重、一致効果",
  "G", "政党支持による異質性",
  "本文の党派性メカニズムに直結するため、頑健性分析から独立させる。",
  "支持政党別AMCE、支持政党×属性Wald検定、支持政党別相対比重、全政党一致効果",
  "H", "除外基準・推定法・標本定義に関する感度分析",
  "主要結論が分析上の選択に依存しないかを最後に確認する。",
  "注意・操作確認、完全5課題、共変量なし、条件付きロジット、代替標本",
  "I", "再現性情報",
  "全ての分析後に、再現に必要な技術情報をまとめる。",
  "ファイル一覧、乱数シード、ブートストラップ回数、パッケージ、sessionInfo"
)

write_csv_unified(
  supplement_section_manifest,
  "supplement_section_manifest.csv"
)

saveRDS(
  list(
    config = unified_config,
    assignment_balance = assignment_balance_results,
    profile_randomization = profile_randomization_results,
    cue_slope_inference = cue_slope_inference_all,
    choice_set_adjusted_slope_summary =
      choice_set_adjusted_slope_summary,
    choice_set_adjusted_slope_plot =
      p_choice_set_adjusted_slopes,
    hypothesis_tests = hypothesis_test_summary,
    party_support_amce = party_support_amce_results,
    party_support_relative_cue = party_support_relative_cue_results,
    study3_all_party_match = study3_all_party_match_results,
    cross_study_relative_weight = cross_study_relative_weight,
    cross_study_relative_plot = p_cross_study_relative,
    main_text_figure_manifest = main_text_figure_manifest,
    supplement_figure_manifest = supplement_figure_manifest,
    supplement_section_manifest = supplement_section_manifest
  ),
  file = file.path(
    unified_output_dir,
    "unified_supplement_objects.rds"
  )
)

capture.output(
  sessionInfo(),
  file = file.path(
    unified_output_dir,
    "sessionInfo_unified.txt"
  )
)

cat(
  "\n3実験の本文図再現・補遺分析・支持政党別異質性分析が完了しました。\n",
  "統合出力先: ",
  normalizePath(unified_output_dir),
  "\n",
  sep = ""
)


final_output_root <- unified_config$output_root

final_dirs <- list(
  main_figures = file.path(final_output_root, "main_text", "figures"),
  main_tables = file.path(final_output_root, "main_text", "tables"),
  supplement_root = file.path(final_output_root, "supplement"),
  supplement_cross = file.path(final_output_root, "supplement", "cross_study"),
  diagnostics_root = file.path(final_output_root, "diagnostics"),
  model_objects_root = file.path(final_output_root, "model_objects"),
  logs = file.path(final_output_root, "logs")
)

invisible(
  lapply(
    final_dirs,
    dir.create,
    showWarnings = FALSE,
    recursive = TRUE
  )
)

for (study_id in names(study_specs)) {
  for (subdir in c("figures", "tables_csv", "tables_tex")) {
    dir.create(
      file.path(final_dirs$supplement_root, study_id, subdir),
      showWarnings = FALSE,
      recursive = TRUE
    )
  }
  for (subdir in c("screening", "balance", "randomization")) {
    dir.create(
      file.path(final_dirs$diagnostics_root, study_id, subdir),
      showWarnings = FALSE,
      recursive = TRUE
    )
  }
  dir.create(
    file.path(final_dirs$model_objects_root, study_id),
    showWarnings = FALSE,
    recursive = TRUE
  )
}

for (subdir in c("figures", "tables_csv", "tables_tex")) {
  dir.create(
    file.path(final_dirs$supplement_cross, subdir),
    showWarnings = FALSE,
    recursive = TRUE
  )
}


copy_file_if_exists <- function(source, destination) {
  if (is.na(source) || !nzchar(source) || !file.exists(source)) {
    return(FALSE)
  }
  dir.create(dirname(destination), showWarnings = FALSE, recursive = TRUE)
  isTRUE(file.copy(source, destination, overwrite = TRUE, copy.mode = TRUE))
}

copy_files_by_pattern <- function(source_dir, destination_dir, pattern) {
  if (!dir.exists(source_dir)) {
    return(character())
  }
  files <- list.files(
    source_dir,
    pattern = pattern,
    full.names = TRUE,
    recursive = TRUE,
    ignore.case = TRUE
  )
  if (length(files) == 0) {
    return(character())
  }
  dir.create(destination_dir, showWarnings = FALSE, recursive = TRUE)
  destinations <- file.path(destination_dir, basename(files))
  copied <- vapply(
    seq_along(files),
    function(i) copy_file_if_exists(files[i], destinations[i]),
    logical(1)
  )
  destinations[copied]
}

latex_escape <- function(x) {
  x <- as.character(x)
  x[is.na(x)] <- ""

  escape_one <- function(s) {
    chars <- strsplit(s, "", fixed = TRUE)[[1]]

    if (length(chars) == 0L) {
      return("")
    }

    replacement <- c(
      "\\" = "\\textbackslash{}",
      "&"  = "\\&",
      "%"  = "\\%",
      "$"  = "\\$",
      "#"  = "\\#",
      "_"  = "\\_",
      "{"  = "\\{",
      "}"  = "\\}",
      "~"  = "\\textasciitilde{}",
      "^"  = "\\textasciicircum{}"
    )

    out <- vapply(
      chars,
      function(ch) {
        if (ch %in% names(replacement)) {
          unname(replacement[[ch]])
        } else {
          ch
        }
      },
      character(1)
    )

    paste0(out, collapse = "")
  }

  vapply(x, escape_one, character(1), USE.NAMES = FALSE)
}

format_number <- function(x, digits = 3) {
  out <- ifelse(
    is.na(x),
    "",
    formatC(x, format = "f", digits = digits)
  )
  as.character(out)
}

format_integer <- function(x) {
  ifelse(is.na(x), "", scales::comma(as.integer(round(x))))
}

format_p_value <- function(x) {
  dplyr::case_when(
    is.na(x) ~ "",
    x < 0.001 ~ "< .001",
    TRUE ~ sub("^0", "", formatC(x, format = "f", digits = 3))
  )
}

write_latex_longtable <- function(
    data,
    file,
    caption,
    label,
    notes = NULL,
    landscape = ncol(data) >= 7) {
  
  data <- as.data.frame(data, stringsAsFactors = FALSE)
  if (ncol(data) == 0) {
    data <- data.frame(note = "該当する推定結果はありません。")
  }
  
  display <- data
  display[] <- lapply(display, function(x) latex_escape(as.character(x)))
  headers <- latex_escape(names(display))
  
  numeric_column <- vapply(data, is.numeric, logical(1))
  alignment <- paste0(ifelse(numeric_column, "r", "l"), collapse = "")
  
  lines <- character()
  lines <- c(lines, "% Generated automatically by the replication script.")
  if (landscape) {
    lines <- c(lines, "\\begin{landscape}")
  }
  lines <- c(
    lines,
    "\\begingroup",
    "\\small",
    paste0("\\begin{longtable}{", alignment, "}"),
    paste0("\\caption{", latex_escape(caption), "}\\label{", label, "}\\\\"),
    "\\toprule",
    paste(headers, collapse = " & "),
    "\\\\",
    "\\midrule",
    "\\endfirsthead",
    paste0("\\multicolumn{", ncol(display), "}{l}{\\tablename~\\thetable{}（続き）}\\\\"),
    "\\toprule",
    paste(headers, collapse = " & "),
    "\\\\",
    "\\midrule",
    "\\endhead",
    paste0("\\midrule\\multicolumn{", ncol(display), "}{r}{次頁に続く}\\\\"),
    "\\endfoot",
    "\\bottomrule",
    "\\endlastfoot"
  )
  
  if (nrow(display) > 0) {
    row_lines <- apply(
      display,
      1,
      function(row) paste0(paste(row, collapse = " & "), " \\\\")
    )
    lines <- c(lines, row_lines)
  }
  
  lines <- c(lines, "\\end{longtable}")
  if (!is.null(notes) && nzchar(notes)) {
    lines <- c(
      lines,
      "\\vspace{-0.5em}",
      "\\begin{minipage}{\\linewidth}",
      "\\footnotesize",
      paste0("\\textit{注：}", latex_escape(notes)),
      "\\end{minipage}"
    )
  }
  lines <- c(lines, "\\endgroup")
  if (landscape) {
    lines <- c(lines, "\\end{landscape}")
  }
  
  dir.create(dirname(file), showWarnings = FALSE, recursive = TRUE)
  writeLines(lines, con = file, useBytes = TRUE)
  invisible(file)
}

write_csv_and_tex <- function(
    data,
    csv_file,
    tex_file,
    caption,
    label,
    notes = NULL,
    landscape = ncol(data) >= 7) {
  dir.create(dirname(csv_file), showWarnings = FALSE, recursive = TRUE)
  readr::write_csv(data, csv_file, na = "")
  write_latex_longtable(
    data = data,
    file = tex_file,
    caption = caption,
    label = label,
    notes = notes,
    landscape = landscape
  )
  invisible(list(csv = csv_file, tex = tex_file))
}

attribute_label_map <- c(
  policy_position = "政策位置",
  government_status = "与野党地位",
  seats = "議席数",
  party_name = "政党名",
  gdp_growth = "GDP成長率",
  nikkei = "日経平均株価",
  cpi = "消費者物価指数（CPI）",
  unemployment = "失業率"
)

cue_family_label <- c(
  party = "政党の手がかり",
  economic = "経済の手がかり"
)


screening_specs <- list(
  study1 = list(
    initial_consent_var = "Q1.1",
    final_consent_var = study1_env$final_consent_var,
    attention_var = NA_character_,
    attention_answer = NA_character_,
    manipulation_available = FALSE,
    intro_map = NULL
  ),
  study2 = list(
    initial_consent_var = "Q1.1",
    final_consent_var = study2_env$final_consent_var,
    attention_var = study2_env$attention_check_var,
    attention_answer = as.character(study2_env$attention_check_correct),
    manipulation_available = TRUE,
    intro_map = NULL
  ),
  study3 = list(
    initial_consent_var = "Q1.1",
    final_consent_var = study3_env$final_consent_var,
    attention_var = study3_env$attention_check_var,
    attention_answer = as.character(study3_env$attention_check_correct),
    manipulation_available = TRUE,
    intro_map = NULL
  )
)

response_present <- function(x) {
  x <- as.character(x)
  !is.na(x) & stringr::str_squish(x) != ""
}

response_is_code <- function(x, code) {
  x <- stringr::str_squish(as.character(x))
  code <- as.character(code)
  out <- x == code | stringr::str_detect(x, paste0("\\(", code, "\\)$"))
  out[is.na(out)] <- FALSE
  out
}

get_mapped_response <- function(data, assigned_n, map, value_column) {
  result <- rep(NA_character_, nrow(data))
  for (n_value in 2:5) {
    row <- map[map$party_n == n_value, , drop = FALSE]
    if (nrow(row) == 0) next
    variable <- as.character(row[[value_column]][1])
    if (!variable %in% names(data)) next
    take <- !is.na(assigned_n) & assigned_n == n_value
    result[take] <- as.character(data[[variable]][take])
  }
  result
}

infer_assigned_condition <- function(data, choice_map, manipulation_map = NULL, intro_map = NULL) {
  candidate <- matrix(FALSE, nrow = nrow(data), ncol = 4)
  colnames(candidate) <- as.character(2:5)
  
  for (n_value in 2:5) {
    variables <- choice_map$choice_var[choice_map$party_n == n_value]
    if (!is.null(manipulation_map) && nrow(manipulation_map) > 0) {
      variables <- c(
        variables,
        manipulation_map$manipulation_var[manipulation_map$party_n == n_value]
      )
    }
    if (!is.null(intro_map) && as.character(n_value) %in% names(intro_map)) {
      variables <- c(variables, unname(intro_map[as.character(n_value)]))
    }
    variables <- intersect(unique(variables), names(data))
    if (length(variables) > 0) {
      candidate[, as.character(n_value)] <- apply(
        data[, variables, drop = FALSE],
        1,
        function(row) any(response_present(row))
      )
    }
  }
  
  n_candidates <- rowSums(candidate)
  assigned <- rep(NA_integer_, nrow(data))
  single <- n_candidates == 1
  assigned[single] <- as.integer(colnames(candidate)[max.col(candidate[single, , drop = FALSE])])
  
  if (any(n_candidates > 1)) {
    warning("Check")
  }
  assigned
}

build_screening_outputs <- function(study_spec) {
  study_id <- study_spec$study_id
  env <- study_spec$env
  spec <- screening_specs[[study_id]]
  raw <- env$df_header_removed %>%
    dplyr::mutate(ID = as.character(ID)) %>%
    dplyr::distinct(ID, .keep_all = TRUE)
  
  manipulation_map <- if (
    spec$manipulation_available &&
    exists("manipulation_map", envir = env, inherits = FALSE)
  ) {
    get("manipulation_map", envir = env, inherits = FALSE)
  } else {
    NULL
  }
  
  assigned_n <- infer_assigned_condition(
    data = raw,
    choice_map = env$choice_map,
    manipulation_map = manipulation_map,
    intro_map = spec$intro_map
  )
  
  if (exists("id_task_check", envir = env, inherits = FALSE)) {
    analysis_assignment <- get("id_task_check", envir = env, inherits = FALSE) %>%
      dplyr::mutate(
        ID = as.character(ID),
        party_n = as.integer(as.character(party_n))
      ) %>%
      dplyr::group_by(ID) %>%
      dplyr::summarise(
        n_condition_candidates = dplyr::n_distinct(party_n),
        assigned_from_analysis = dplyr::if_else(
          n_condition_candidates == 1L,
          dplyr::first(party_n),
          NA_integer_
        ),
        .groups = "drop"
      )
    
    analysis_match <- match(raw$ID, analysis_assignment$ID)
    use_analysis_assignment <- !is.na(analysis_match) &
      !is.na(analysis_assignment$assigned_from_analysis[analysis_match])
    assigned_n[use_analysis_assignment] <-
      analysis_assignment$assigned_from_analysis[analysis_match[use_analysis_assignment]]
  }
  
  if (exists("valid_ids", envir = env, inherits = FALSE)) {
    final_assignment <- get("valid_ids", envir = env, inherits = FALSE) %>%
      dplyr::mutate(
        ID = as.character(ID),
        party_n = as.integer(as.character(party_n))
      ) %>%
      dplyr::distinct(ID, party_n) %>%
      dplyr::group_by(ID) %>%
      dplyr::summarise(
        n_condition_candidates = dplyr::n_distinct(party_n),
        assigned_from_final = dplyr::if_else(
          n_condition_candidates == 1L,
          dplyr::first(party_n),
          NA_integer_
        ),
        .groups = "drop"
      )
    
    final_match <- match(raw$ID, final_assignment$ID)
    use_final_assignment <- !is.na(final_match) &
      !is.na(final_assignment$assigned_from_final[final_match])
    assigned_n[use_final_assignment] <-
      final_assignment$assigned_from_final[final_match[use_final_assignment]]
  }
  
  initial_response <- if (spec$initial_consent_var %in% names(raw)) {
    raw[[spec$initial_consent_var]]
  } else {
    rep(NA_character_, nrow(raw))
  }
  final_response <- if (spec$final_consent_var %in% names(raw)) {
    raw[[spec$final_consent_var]]
  } else {
    rep(NA_character_, nrow(raw))
  }
  
  task_responses <- lapply(
    1:5,
    function(task_value) {
      task_map <- env$choice_map[env$choice_map$task == task_value, , drop = FALSE]
      get_mapped_response(raw, assigned_n, task_map, "choice_var")
    }
  )
  
  task_pass <- lapply(
    task_responses,
    function(response) {
      parsed <- suppressWarnings(readr::parse_number(as.character(response)))
      !is.na(assigned_n) & !is.na(parsed) & parsed >= 1 & parsed <= assigned_n
    }
  )
  
  if (!is.null(manipulation_map)) {
    manipulation_response <- get_mapped_response(
      raw,
      assigned_n,
      manipulation_map,
      "manipulation_var"
    )
    manipulation_answer <- rep(NA_character_, nrow(raw))
    for (n_value in 2:5) {
      answer <- manipulation_map$correct_answer[manipulation_map$party_n == n_value]
      manipulation_answer[!is.na(assigned_n) & assigned_n == n_value] <- answer[1]
    }
    manipulation_pass <- !is.na(assigned_n) & response_is_code(
      manipulation_response,
      manipulation_answer
    )
  } else {
    manipulation_response <- rep(NA_character_, nrow(raw))
    manipulation_pass <- rep(TRUE, nrow(raw))
  }
  
  if (!is.na(spec$attention_var) && spec$attention_var %in% names(raw)) {
    attention_response <- raw[[spec$attention_var]]
    attention_pass <- response_is_code(attention_response, spec$attention_answer)
  } else {
    attention_response <- rep(NA_character_, nrow(raw))
    attention_pass <- rep(TRUE, nrow(raw))
  }
  
  initial_pass <- response_is_code(initial_response, 1) |
    stringr::str_detect(
      stringr::str_squish(as.character(initial_response)),
      "趣旨に同意して.*協力する"
    )
  final_pass <- response_is_code(final_response, 1) |
    stringr::str_detect(
      stringr::str_squish(as.character(final_response)),
      "同意し.*回答結果を送信する"
    )
  
  final_ids <- as.character(env$valid_ids$ID)
  
  audit <- tibble::tibble(
    ID = raw$ID,
    assigned_condition = assigned_n,
    initial_consent_response = as.character(initial_response),
    initial_consent_pass = initial_pass,
    reached_conjoint_block = !is.na(assigned_n),
    task1_response = as.character(task_responses[[1]]),
    task1_complete = task_pass[[1]],
    task2_response = as.character(task_responses[[2]]),
    task2_complete = task_pass[[2]],
    task3_response = as.character(task_responses[[3]]),
    task3_complete = task_pass[[3]],
    task4_response = as.character(task_responses[[4]]),
    task4_complete = task_pass[[4]],
    task5_response = as.character(task_responses[[5]]),
    task5_complete = task_pass[[5]],
    all_five_tasks_complete = Reduce(`&`, task_pass),
    manipulation_response = as.character(manipulation_response),
    manipulation_check_pass = manipulation_pass,
    attention_response = as.character(attention_response),
    attention_check_pass = attention_pass,
    final_consent_response = as.character(final_response),
    final_consent_pass = final_pass,
    included_in_final_analysis = ID %in% final_ids
  )
  
  cumulative <- rep(TRUE, nrow(audit))
  stage_records <- list()
  add_stage <- function(stage, question_variable, criterion) {
    cumulative <<- cumulative & criterion
    stage_records[[length(stage_records) + 1L]] <<- tibble::tibble(
      stage_order = length(stage_records) + 1L,
      stage = stage,
      question_variable = question_variable,
      n_remaining = sum(cumulative, na.rm = TRUE)
    )
  }
  
  add_stage("Qualtricsの質問文・ImportId行を除外", "ResponseId", rep(TRUE, nrow(audit)))
  add_stage("初回同意", spec$initial_consent_var, audit$initial_consent_pass)
  add_stage("割付されたコンジョイント・ブロックに到達", "Q3.1/Q4.1/Q5.1/Q6.1 または最初の選択課題", audit$reached_conjoint_block)
  for (task_value in 1:5) {
    add_stage(
      paste0("選択課題", task_value, "を有効回答"),
      paste0("条件別 choice task ", task_value),
      audit[[paste0("task", task_value, "_complete")]]
    )
  }
  if (spec$manipulation_available) {
    add_stage(
      "提示された選択肢数を正答",
      "条件別に自動検出した選択肢数確認質問",
      audit$manipulation_check_pass
    )
  }
  if (!is.na(spec$attention_var)) {
    add_stage(
      "イデオロギー行列の指示項目に正答",
      spec$attention_var,
      audit$attention_check_pass
    )
  }
  add_stage("最終送信同意", spec$final_consent_var, audit$final_consent_pass)
  add_stage("最終分析標本", "全基準の積集合", audit$included_in_final_analysis)
  
  flow <- dplyr::bind_rows(stage_records) %>%
    dplyr::mutate(
      n_excluded_at_stage = dplyr::lag(n_remaining, default = dplyr::first(n_remaining)) - n_remaining,
      retention_from_previous_pct = dplyr::if_else(
        dplyr::lag(n_remaining, default = dplyr::first(n_remaining)) > 0,
        100 * n_remaining / dplyr::lag(n_remaining, default = dplyr::first(n_remaining)),
        NA_real_
      ),
      retention_from_initial_pct = 100 * n_remaining / dplyr::first(n_remaining)
    )
  
  condition_flow <- purrr::map_dfr(
    2:5,
    function(n_value) {
      subset_audit <- audit %>% dplyr::filter(assigned_condition == n_value)
      if (nrow(subset_audit) == 0) {
        return(tibble::tibble())
      }
      criteria <- list(
        "割付条件を識別" = rep(TRUE, nrow(subset_audit)),
        "選択課題1" = subset_audit$task1_complete,
        "選択課題2" = subset_audit$task2_complete,
        "選択課題3" = subset_audit$task3_complete,
        "選択課題4" = subset_audit$task4_complete,
        "選択課題5" = subset_audit$task5_complete
      )
      if (spec$manipulation_available) {
        criteria[["選択肢数確認"]] <- subset_audit$manipulation_check_pass
      }
      if (!is.na(spec$attention_var)) {
        criteria[["指示項目"]] <- subset_audit$attention_check_pass
      }
      criteria[["最終送信同意"]] <- subset_audit$final_consent_pass
      criteria[["最終分析標本"]] <- subset_audit$included_in_final_analysis
      
      keep <- rep(TRUE, nrow(subset_audit))
      records <- purrr::imap_dfr(
        criteria,
        function(criterion, stage_name) {
          keep <<- keep & criterion
          tibble::tibble(
            assigned_condition = n_value,
            stage_order = which(names(criteria) == stage_name),
            stage = stage_name,
            n_remaining = sum(keep, na.rm = TRUE)
          )
        }
      )
      records %>%
        dplyr::mutate(
          n_excluded_at_stage = dplyr::lag(n_remaining, default = dplyr::first(n_remaining)) - n_remaining,
          retention_from_condition_start_pct = 100 * n_remaining / dplyr::first(n_remaining)
        )
    }
  )
  
  final_audit <- audit %>% dplyr::filter(included_in_final_analysis)
  required_final <- final_audit$initial_consent_pass &
    final_audit$all_five_tasks_complete &
    final_audit$manipulation_check_pass &
    final_audit$attention_check_pass &
    final_audit$final_consent_pass
  if (!all(required_final)) {
    stop("Check")
  }
  if (nrow(final_audit) != dplyr::n_distinct(env$valid_ids$ID)) {
    stop("Check")
  }
  
  list(audit = audit, flow = flow, condition_flow = condition_flow)
}


make_amce_table <- function(env, adjusted = TRUE) {
  source <- if (adjusted) env$amce_plot_cov else env$amce_plot_nocov
  n_table <- env$n_by_party %>%
    dplyr::transmute(
      party_n_numeric = as.integer(as.character(party_n)),
      respondents = n
    )
  
  source %>%
    dplyr::mutate(
      party_n_numeric = suppressWarnings(readr::parse_number(as.character(party_n)))
    ) %>%
    dplyr::left_join(n_table, by = "party_n_numeric") %>%
    dplyr::transmute(
      `条件` = as.character(party_n),
      `属性` = as.character(attribute),
      `水準（基準水準との差）` = as.character(label),
      `推定値（pp）` = format_number(100 * estimate, 2),
      `標準誤差（pp）` = format_number(100 * std.error, 2),
      `95% CI下限（pp）` = format_number(100 * conf.low, 2),
      `95% CI上限（pp）` = format_number(100 * conf.high, 2),
      `p値` = format_p_value(p.value),
      `回答者数` = format_integer(respondents)
    )
}

make_interaction_table <- function(env) {
  source <- env$interaction_plot_df
  condition_column <- intersect(c("party_n_label", "party_n"), names(source))[1]
  if (is.na(condition_column)) {
    source$condition_label <- ""
  } else {
    source$condition_label <- as.character(source[[condition_column]])
  }
  source %>%
    dplyr::transmute(
      `比較条件` = condition_label,
      `属性` = as.character(attribute),
      `水準` = as.character(label),
      `2選択肢条件との差（pp）` = format_number(100 * estimate, 2),
      `標準誤差（pp）` = format_number(100 * std.error, 2),
      `95% CI下限（pp）` = format_number(100 * conf.low, 2),
      `95% CI上限（pp）` = format_number(100 * conf.high, 2),
      `p値` = format_p_value(p.value)
    )
}

clustered_mean_summary <- function(y, cluster) {
  y <- as.numeric(y)
  cluster <- as.character(cluster)
  keep <- is.finite(y) & !is.na(cluster)
  y <- y[keep]
  cluster <- cluster[keep]
  n <- length(y)
  g <- dplyr::n_distinct(cluster)
  if (n == 0) {
    return(c(estimate = NA_real_, se = NA_real_, low = NA_real_, high = NA_real_, n = 0, g = 0))
  }
  estimate <- mean(y)
  if (g <= 1) {
    se <- NA_real_
  } else {
    cluster_score <- tapply(y - estimate, cluster, sum)
    variance <- (g / (g - 1)) * sum(cluster_score^2) / (n^2)
    se <- sqrt(variance)
  }
  c(
    estimate = estimate,
    se = se,
    low = estimate - 1.96 * se,
    high = estimate + 1.96 * se,
    n = n,
    g = g
  )
}

make_mm_table <- function(env) {
  attributes <- names(env$relative_cue_map)
  long <- env$conjoint_all_m %>%
    dplyr::select(ID, party_n, selected, dplyr::all_of(attributes)) %>%
    tidyr::pivot_longer(
      cols = dplyr::all_of(attributes),
      names_to = "attribute",
      values_to = "level"
    ) %>%
    dplyr::filter(!is.na(level), as.character(level) != "") %>%
    dplyr::mutate(level = as.character(level))
  
  summary <- long %>%
    dplyr::group_by(party_n, attribute, level) %>%
    dplyr::group_modify(
      ~ {
        values <- clustered_mean_summary(.x$selected, .x$ID)
        tibble::tibble(
          marginal_mean = values["estimate"],
          cluster_se = values["se"],
          conf_low = values["low"],
          conf_high = values["high"],
          n_profiles = values["n"],
          n_respondents = values["g"]
        )
      }
    ) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(
      cue_family = unname(env$relative_cue_map[attribute]),
      attribute_label = dplyr::coalesce(unname(attribute_label_map[attribute]), attribute),
      cue_label = dplyr::coalesce(unname(cue_family_label[cue_family]), cue_family)
    )
  
  summary %>%
    dplyr::transmute(
      `条件` = paste0(party_n, ifelse("party_name" %in% attributes, "選択肢", "政党")),
      `手がかり群` = cue_label,
      `属性` = attribute_label,
      `水準` = level,
      `限界平均（%）` = format_number(100 * marginal_mean, 2),
      `クラスタSE（pp）` = format_number(100 * cluster_se, 2),
      `95% CI下限（%）` = format_number(100 * conf_low, 2),
      `95% CI上限（%）` = format_number(100 * conf_high, 2),
      `プロファイル数` = format_integer(n_profiles),
      `回答者数` = format_integer(n_respondents)
    )
}

make_attribute_importance_table <- function(env) {
  source <- env$relative_cue_observed$attribute_importance
  adjusted_col <- intersect(
    c("importance_pairwise_adjusted", "choice_set_adjusted_importance_pairwise"),
    names(source)
  )[1]
  adjusted <- if (!is.na(adjusted_col)) source[[adjusted_col]] else source$party_n * source$importance_pairwise
  
  source %>%
    dplyr::mutate(
      adjusted_value = adjusted,
      attribute_label = dplyr::coalesce(unname(attribute_label_map[attribute]), attribute),
      cue_label = dplyr::coalesce(unname(cue_family_label[cue_family]), cue_family)
    ) %>%
    dplyr::transmute(
      `条件` = party_n,
      `手がかり群` = cue_label,
      `属性` = attribute_label,
      `水準数` = n_levels,
      `未調整重要度（pp）` = format_number(100 * importance_pairwise, 2),
      `選択肢数調整済み重要度（%）` = format_number(100 * adjusted_value, 2)
    )
}

make_cue_importance_table <- function(env) {
  source <- env$relative_cue_condition_intervals
  labels <- c(
    party_importance_pairwise = "政党手がかり：未調整重要度",
    economic_importance_pairwise = "経済手がかり：未調整重要度",
    party_importance_pairwise_adjusted = "政党手がかり：選択肢数調整済み重要度",
    economic_importance_pairwise_adjusted = "経済手がかり：選択肢数調整済み重要度",
    relative_party_weight_pairwise = "政党手がかりの相対比重"
  )
  source <- source %>% dplyr::filter(statistic %in% names(labels))
  source %>%
    dplyr::mutate(
      `指標` = unname(labels[statistic]),
      `単位` = dplyr::case_when(
        statistic %in% c("party_importance_pairwise", "economic_importance_pairwise") ~ "pp",
        TRUE ~ "%"
      ),
      multiplier = 100
    ) %>%
    dplyr::transmute(
      `条件` = party_n,
      `指標` = `指標`,
      `単位` = `単位`,
      `推定値` = format_number(multiplier * estimate, 2),
      `95% CI下限` = format_number(multiplier * conf_low, 2),
      `95% CI上限` = format_number(multiplier * conf_high, 2)
    )
}

make_clogit_table <- function(env) {
  env$clogit_plot_df %>%
    dplyr::transmute(
      `条件` = as.character(party_n),
      `属性` = as.character(attribute),
      `水準（基準水準との差）` = as.character(label),
      `log係数` = format_number(estimate, 3),
      `標準誤差` = format_number(std.error, 3),
      `オッズ比` = format_number(odds_ratio, 3),
      `95% CI下限（OR）` = format_number(odds_ratio_low, 3),
      `95% CI上限（OR）` = format_number(odds_ratio_high, 3),
      `p値` = format_p_value(p.value)
    )
}

make_linear_trend_table <- function(env) {
  if (!exists("linear_trend_plot_df", envir = env, inherits = FALSE)) {
    return(tibble::tibble())
  }
  env$linear_trend_plot_df %>%
    dplyr::transmute(
      `属性` = as.character(attribute),
      `水準` = as.character(label),
      `選択肢が1つ増えるときの変化（pp）` = format_number(100 * estimate, 2),
      `標準誤差（pp）` = format_number(100 * std.error, 2),
      `95% CI下限（pp）` = format_number(100 * conf.low, 2),
      `95% CI上限（pp）` = format_number(100 * conf.high, 2),
      `p値` = format_p_value(p.value)
    )
}

make_party_match_table <- function(env) {
  if (!exists("party_match_coef_df", envir = env, inherits = FALSE)) {
    return(tibble::tibble())
  }
  overall <- env$party_match_coef_df
  subgroup <- if (exists("party_match_subgroup_coef_df", envir = env, inherits = FALSE)) {
    env$party_match_subgroup_coef_df
  } else {
    tibble::tibble()
  }
  combined <- dplyr::bind_rows(overall, subgroup)
  if (!"n_ids" %in% names(combined)) combined$n_ids <- NA_real_
  if (!"support_group_label" %in% names(combined)) combined$support_group_label <- "全体"
  combined %>%
    dplyr::mutate(
      support_group_label = dplyr::coalesce(as.character(support_group_label), "全体"),
      n_ids = suppressWarnings(as.numeric(n_ids))
    ) %>%
    dplyr::transmute(
      `対象` = support_group_label,
      `選択肢数` = party_n,
      `一致効果（pp）` = format_number(100 * estimate, 2),
      `標準誤差（pp）` = format_number(100 * std.error, 2),
      `95% CI下限（pp）` = format_number(100 * conf.low, 2),
      `95% CI上限（pp）` = format_number(100 * conf.high, 2),
      `p値` = format_p_value(p.value),
      `回答者数` = format_integer(n_ids)
    )
}


screening_results <- list()
study_table_paths <- list()

for (study_id in names(study_specs)) {
  spec <- study_specs[[study_id]]
  env <- spec$env
  study_label <- spec$study_label
  csv_dir <- file.path(final_dirs$supplement_root, study_id, "tables_csv")
  tex_dir <- file.path(final_dirs$supplement_root, study_id, "tables_tex")
  diag_screen_dir <- file.path(final_dirs$diagnostics_root, study_id, "screening")
  diag_balance_dir <- file.path(final_dirs$diagnostics_root, study_id, "balance")
  diag_random_dir <- file.path(final_dirs$diagnostics_root, study_id, "randomization")
  
  screening <- build_screening_outputs(spec)
  screening_results[[study_id]] <- screening
  
  readr::write_csv(screening$audit, file.path(diag_screen_dir, "respondent_screening_audit.csv"), na = "")
  readr::write_csv(screening$flow, file.path(diag_screen_dir, "sequential_sample_flow.csv"), na = "")
  readr::write_csv(screening$condition_flow, file.path(diag_screen_dir, "sequential_sample_flow_by_condition.csv"), na = "")
  
  attrition_table <- screening$flow %>%
    dplyr::transmute(
      `順序` = stage_order,
      `段階` = stage,
      `質問・変数` = question_variable,
      `残存N` = format_integer(n_remaining),
      `当該段階での除外N` = format_integer(n_excluded_at_stage),
      `前段階からの残存率（%）` = format_number(retention_from_previous_pct, 1),
      `初期標本からの残存率（%）` = format_number(retention_from_initial_pct, 1)
    )
  
  write_csv_and_tex(
    attrition_table,
    file.path(csv_dir, "table_sample_attrition.csv"),
    file.path(tex_dir, "table_sample_attrition.tex"),
    paste0(study_label, "：質問段階ごとの逐次的な標本減少"),
    paste0("tab:", study_id, "-attrition"),
    notes = paste0(
      "各行は直前までの基準を満たした回答者に次の基準を順に適用した残存数を示す。",
      ifelse(
        study_id == "study1",
        "Study 1では選択肢数確認質問および指示項目は調査票に設けられていない。",
        "最終分析は、選択肢数確認とQ25.1_11の指示項目の双方に正答した回答者に限定した。"
      )
    )
  )
  
  condition_attrition_table <- screening$condition_flow %>%
    dplyr::transmute(
      `条件` = assigned_condition,
      `順序` = stage_order,
      `段階` = stage,
      `残存N` = format_integer(n_remaining),
      `当該段階での除外N` = format_integer(n_excluded_at_stage),
      `条件開始時からの残存率（%）` = format_number(retention_from_condition_start_pct, 1)
    )
  write_csv_and_tex(
    condition_attrition_table,
    file.path(csv_dir, "table_sample_attrition_by_condition.csv"),
    file.path(tex_dir, "table_sample_attrition_by_condition.tex"),
    paste0(study_label, "：条件別の逐次的な標本減少"),
    paste0("tab:", study_id, "-attrition-condition"),
    notes = "条件を回答履歴から識別できた回答者について、各条件内で基準を累積的に適用した。"
  )
  
  manipulation_table <- screening$audit %>%
    dplyr::filter(!is.na(assigned_condition)) %>%
    dplyr::count(
      assigned_condition,
      manipulation_response,
      manipulation_check_pass,
      name = "n"
    ) %>%
    dplyr::transmute(
      `条件` = assigned_condition,
      `回答` = dplyr::coalesce(manipulation_response, "未実施・欠損"),
      `正答` = ifelse(manipulation_check_pass, "正答", "不正答・欠損"),
      `N` = format_integer(n)
    )
  if (study_id == "study1") {
    manipulation_table <- tibble::tibble(
      `条件` = "全条件",
      `回答` = "調査票に選択肢数確認質問なし",
      `正答` = "適用外",
      `N` = ""
    )
  }
  write_csv_and_tex(
    manipulation_table,
    file.path(csv_dir, "table_manipulation_check.csv"),
    file.path(tex_dir, "table_manipulation_check.tex"),
    paste0(study_label, "：選択肢数の操作確認"),
    paste0("tab:", study_id, "-manipulation-check"),
    notes = "Study 2・3では、割り当てられた選択肢数と同じ回答を正答とした。"
  )
  
  attention_table <- screening$audit %>%
    dplyr::count(attention_response, attention_check_pass, name = "n") %>%
    dplyr::transmute(
      `回答` = dplyr::coalesce(attention_response, "未実施・欠損"),
      `判定` = ifelse(attention_check_pass, "正答", "不正答・欠損"),
      `N` = format_integer(n)
    )
  if (study_id == "study1") {
    attention_table <- tibble::tibble(
      `回答` = "調査票に指示項目なし",
      `判定` = "適用外",
      `N` = ""
    )
  }
  write_csv_and_tex(
    attention_table,
    file.path(csv_dir, "table_attention_check.csv"),
    file.path(tex_dir, "table_attention_check.tex"),
    paste0(study_label, "：イデオロギー行列の指示項目"),
    paste0("tab:", study_id, "-attention-check"),
    notes = "Study 2・3では、調査画面上の指示項目で「3」を選択した回答者を正答とした。Qualtricsの保存コードが表示値と異なる場合は、本分析で自動検出された保存コードを用いた。"
  )
  
  amce_cov <- make_amce_table(env, adjusted = TRUE)
  amce_nocov <- make_amce_table(env, adjusted = FALSE)
  interaction <- make_interaction_table(env)
  mm_table <- make_mm_table(env)
  attr_importance <- make_attribute_importance_table(env)
  cue_importance <- make_cue_importance_table(env)
  clogit_table <- make_clogit_table(env)
  linear_trend_table <- make_linear_trend_table(env)
  party_match_table <- make_party_match_table(env)
  
  write_csv_and_tex(
    amce_cov,
    file.path(csv_dir, "table_amce_covariate_adjusted.csv"),
    file.path(tex_dir, "table_amce_covariate_adjusted.tex"),
    paste0(study_label, "：共変量調整済みAMCE"),
    paste0("tab:", study_id, "-amce-adjusted"),
    notes = "推定値の単位はパーセントポイント。標準誤差は回答者単位でクラスタ化した。"
  )
  write_csv_and_tex(
    amce_nocov,
    file.path(csv_dir, "table_amce_unadjusted.csv"),
    file.path(tex_dir, "table_amce_unadjusted.tex"),
    paste0(study_label, "：共変量を含めないAMCE"),
    paste0("tab:", study_id, "-amce-unadjusted"),
    notes = "推定値の単位はパーセントポイント。標準誤差は回答者単位でクラスタ化した。"
  )
  write_csv_and_tex(
    interaction,
    file.path(csv_dir, "table_amce_interaction.csv"),
    file.path(tex_dir, "table_amce_interaction.tex"),
    paste0(study_label, "：2選択肢条件との差を表すAMCE交互作用"),
    paste0("tab:", study_id, "-amce-interaction"),
    notes = "正の値は、当該条件におけるAMCEが2選択肢条件より大きいことを示す。"
  )
  write_csv_and_tex(
    mm_table,
    file.path(csv_dir, "table_marginal_means.csv"),
    file.path(tex_dir, "table_marginal_means.tex"),
    paste0(study_label, "：属性水準別の限界平均（MM）"),
    paste0("tab:", study_id, "-marginal-means"),
    notes = "限界平均は当該水準をもつプロファイルの平均選択確率。SEと信頼区間は回答者クラスタに対応した切片のみの線形確率モデルと同値の計算による。"
  )
  write_csv_and_tex(
    attr_importance,
    file.path(csv_dir, "table_attribute_importance.csv"),
    file.path(tex_dir, "table_attribute_importance.tex"),
    paste0(study_label, "：属性別の未調整・選択肢数調整済み重要度"),
    paste0("tab:", study_id, "-attribute-importance"),
    notes = "未調整重要度は限界平均の全水準ペアの絶対差の平均。調整済み重要度は未調整重要度を1／選択肢数で除した。"
  )
  write_csv_and_tex(
    cue_importance,
    file.path(csv_dir, "table_cue_importance.csv"),
    file.path(tex_dir, "table_cue_importance.tex"),
    paste0(study_label, "：政党・経済手がかりの重要度と相対比重"),
    paste0("tab:", study_id, "-cue-importance"),
    notes = "95%信頼区間は条件内で回答者を復元抽出するクラスタ・ブートストラップによる。"
  )
  write_csv_and_tex(
    clogit_table,
    file.path(csv_dir, "table_conditional_logit.csv"),
    file.path(tex_dir, "table_conditional_logit.tex"),
    paste0(study_label, "：条件付きロジット推定"),
    paste0("tab:", study_id, "-conditional-logit"),
    notes = "各選択課題をstratumとするMcFadden型条件付きロジット。標準誤差は回答者単位でクラスタ化した。"
  )
  
  if (nrow(linear_trend_table) > 0) {
    write_csv_and_tex(
      linear_trend_table,
      file.path(csv_dir, "table_amce_linear_trend.csv"),
      file.path(tex_dir, "table_amce_linear_trend.tex"),
      paste0(study_label, "：選択肢数に対するAMCEの線形トレンド"),
      paste0("tab:", study_id, "-amce-linear-trend"),
      notes = "係数は選択肢数が1つ増えたときのAMCEの変化をパーセントポイントで示す。"
    )
  }
  
  if (nrow(party_match_table) > 0) {
    write_csv_and_tex(
      party_match_table,
      file.path(csv_dir, "table_party_match.csv"),
      file.path(tex_dir, "table_party_match.tex"),
      paste0(study_label, "：支持政党と提示政党名の一致効果"),
      paste0("tab:", study_id, "-party-match"),
      notes = "一致効果は、回答者の支持政党と提示された政党名が一致することによる選択確率差。"
    )
  }
  
  balance <- assignment_balance_results[[study_id]]
  balance_summary <- balance$summary %>%
    dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 3)))
  balance_pairwise <- balance$pairwise_smd %>%
    dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 3)))
  
  write_csv_and_tex(
    balance_summary,
    file.path(csv_dir, "table_assignment_balance_summary.csv"),
    file.path(tex_dir, "table_assignment_balance_summary.tex"),
    paste0(study_label, "：条件別の回答者属性"),
    paste0("tab:", study_id, "-balance-summary"),
    notes = "Love plotおよび45度線診断に対応する条件別集計。"
  )
  write_csv_and_tex(
    balance_pairwise,
    file.path(csv_dir, "table_assignment_balance_pairwise_smd.csv"),
    file.path(tex_dir, "table_assignment_balance_pairwise_smd.tex"),
    paste0(study_label, "：全条件ペアの標準化平均差"),
    paste0("tab:", study_id, "-balance-smd"),
    notes = "絶対SMDが0.10未満であれば、通常は実質的に小さい不均衡と解釈される。"
  )
  readr::write_csv(balance$summary, file.path(diag_balance_dir, "assignment_balance_summary.csv"), na = "")
  readr::write_csv(balance$pairwise_smd, file.path(diag_balance_dir, "assignment_balance_pairwise_smd.csv"), na = "")
  readr::write_csv(balance$diagonal_data, file.path(diag_balance_dir, "assignment_balance_diagonal_data.csv"), na = "")
  
  randomization <- profile_randomization_results[[study_id]]
  random_tests <- randomization$uniformity_tests %>%
    dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 4)))
  random_frequency <- randomization$frequency %>%
    dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 4)))
  write_csv_and_tex(
    random_tests,
    file.path(csv_dir, "table_profile_randomization_tests.csv"),
    file.path(tex_dir, "table_profile_randomization_tests.tex"),
    paste0(study_label, "：属性水準提示の一様性検定"),
    paste0("tab:", study_id, "-profile-randomization-tests"),
    notes = "属性×条件ごとのカイ二乗検定。p値はHolm法でも補正した。"
  )
  write_csv_and_tex(
    random_frequency,
    file.path(csv_dir, "table_profile_randomization_frequency.csv"),
    file.path(tex_dir, "table_profile_randomization_frequency.tex"),
    paste0(study_label, "：属性水準の観測比率と設計上の期待比率"),
    paste0("tab:", study_id, "-profile-randomization-frequency"),
    notes = "属性提示の45度線図に対応する数値表。"
  )
  readr::write_csv(randomization$uniformity_tests, file.path(diag_random_dir, "profile_randomization_tests.csv"), na = "")
  readr::write_csv(randomization$frequency, file.path(diag_random_dir, "profile_randomization_frequency.csv"), na = "")
  
  support_amce <- party_support_amce_results[[study_id]]
  if (!is.null(support_amce$subgroup_coefficients)) {
    support_amce_table <- support_amce$subgroup_coefficients %>%
      dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 3)))
    write_csv_and_tex(
      support_amce_table,
      file.path(csv_dir, "table_party_support_amce.csv"),
      file.path(tex_dir, "table_party_support_amce.tex"),
      paste0(study_label, "：支持政党別AMCE"),
      paste0("tab:", study_id, "-party-support-amce"),
      notes = "支持政党別AMCE図に対応する推定値。"
    )
  }
  support_relative <- party_support_relative_cue_results[[study_id]]
  if (!is.null(support_relative$intervals)) {
    support_relative_table <- support_relative$intervals %>%
      dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 3)))
    write_csv_and_tex(
      support_relative_table,
      file.path(csv_dir, "table_party_support_relative_cue.csv"),
      file.path(tex_dir, "table_party_support_relative_cue.tex"),
      paste0(study_label, "：支持政党別の手がかり重要度と相対比重"),
      paste0("tab:", study_id, "-party-support-relative"),
      notes = "支持政党別の相対比重図に対応する回答者クラスタ・ブートストラップ推定。"
    )
  }
  
  study_table_paths[[study_id]] <- list(csv_dir = csv_dir, tex_dir = tex_dir)
}


cross_csv_dir <- file.path(final_dirs$supplement_cross, "tables_csv")
cross_tex_dir <- file.path(final_dirs$supplement_cross, "tables_tex")

cross_tables <- list(
  hypothesis = hypothesis_test_summary,
  adjusted_slopes = choice_set_adjusted_slope_summary,
  cross_relative = cross_study_relative_weight,
  all_party_match_coefficients = study3_all_party_match_results$coefficients,
  all_party_match_trends = study3_all_party_match_results$trends
)

cross_caption <- c(
  hypothesis = "3実験の主要仮説に対応する線形傾向検定",
  adjusted_slopes = "3実験の選択肢数調整済み重要度の線形傾向",
  cross_relative = "3実験横断の政党手がかり相対比重",
  all_party_match_coefficients = "Study 3：すべての対象支持政党における一致効果",
  all_party_match_trends = "Study 3：一致効果の選択肢数トレンド"
)

for (table_name in names(cross_tables)) {
  table_data <- cross_tables[[table_name]]
  if (is.null(table_data)) next
  table_data <- as.data.frame(table_data) %>%
    dplyr::mutate(dplyr::across(where(is.numeric), ~ format_number(.x, 4)))
  write_csv_and_tex(
    table_data,
    file.path(cross_csv_dir, paste0("table_", table_name, ".csv")),
    file.path(cross_tex_dir, paste0("table_", table_name, ".tex")),
    unname(cross_caption[table_name]),
    paste0("tab:cross-", gsub("_", "-", table_name)),
    notes = "対応する補遺図の数値を表形式で再掲した。"
  )
}


for (study_id in names(study_specs)) {
  working_dir <- unified_config[[study_id]]$output_dir
  supplement_fig_dir <- file.path(final_dirs$supplement_root, study_id, "figures")
  copy_files_by_pattern(working_dir, supplement_fig_dir, "\\.(png|pdf)$")
  copy_files_by_pattern(
    working_dir,
    file.path(final_dirs$model_objects_root, study_id),
    "\\.(rds|RDS)$"
  )
  copy_files_by_pattern(working_dir, final_dirs$logs, "(sessionInfo|\\.txt$)")
  
  support_dir <- file.path(unified_output_dir, paste0(study_id, "_party_support"))
  copy_files_by_pattern(support_dir, supplement_fig_dir, "\\.(png|pdf)$")
}

copy_files_by_pattern(
  unified_output_dir,
  file.path(final_dirs$supplement_cross, "figures"),
  "\\.(png|pdf)$"
)
copy_files_by_pattern(unified_output_dir, final_dirs$logs, "(sessionInfo|\\.txt$)")
copy_files_by_pattern(
  unified_output_dir,
  file.path(final_dirs$model_objects_root, "cross_study"),
  "\\.(rds|RDS)$"
)

for (study_id in names(study_specs)) {
  for (kind in c("assignment_balance_love_plot", "assignment_balance_diagonal_plot")) {
    for (extension in c("png", "pdf")) {
      source <- file.path(unified_output_dir, paste0(study_id, "_", kind, ".", extension))
      destination <- file.path(final_dirs$diagnostics_root, study_id, "balance", basename(source))
      copy_file_if_exists(source, destination)
    }
  }
  for (extension in c("png", "pdf")) {
    source <- file.path(unified_output_dir, paste0(study_id, "_profile_randomization_diagonal_plot.", extension))
    destination <- file.path(final_dirs$diagnostics_root, study_id, "randomization", basename(source))
    copy_file_if_exists(source, destination)
  }
}

if (exists("main_text_figure_manifest")) {
  purrr::pwalk(
    main_text_figure_manifest,
    function(figure_number, study, analysis, file_png, file_pdf) {
      prefix <- gsub("[^A-Za-z0-9]+", "_", figure_number)
      if (!is.na(file_png)) {
        copy_file_if_exists(
          file_png,
          file.path(final_dirs$main_figures, paste0(prefix, "_", basename(file_png)))
        )
      }
      if (!is.na(file_pdf)) {
        copy_file_if_exists(
          file_pdf,
          file.path(final_dirs$main_figures, paste0(prefix, "_", basename(file_pdf)))
        )
      }
    }
  )
}

main_table_map <- list(
  study1 = c("table_amce_covariate_adjusted.tex", "table_cue_importance.tex"),
  study2 = c("table_amce_covariate_adjusted.tex", "table_cue_importance.tex"),
  study3 = c("table_amce_covariate_adjusted.tex", "table_cue_importance.tex", "table_party_match.tex")
)
for (study_id in names(main_table_map)) {
  for (table_file in main_table_map[[study_id]]) {
    source <- file.path(final_dirs$supplement_root, study_id, "tables_tex", table_file)
    copy_file_if_exists(
      source,
      file.path(final_dirs$main_tables, paste0(study_id, "_", table_file))
    )
  }
}


pair_manifest <- tibble::tribble(
  ~study_id, ~section_title, ~figure_file, ~table_files,
  "study1", "共変量調整済みAMCE", "amce_cov_facet_model.png", "table_amce_covariate_adjusted.tex",
  "study1", "AMCEヒートマップ", "amce_heatmap_mixed_rank_colored_labels.png", "table_amce_covariate_adjusted.tex",
  "study1", "共変量を含めないAMCE", "amce_facet_nocov.png", "table_amce_unadjusted.tex",
  "study1", "AMCEの条件差", "amce_interaction_difference_from_2party.png", "table_amce_interaction.tex",
  "study1", "条件付きロジット", "clogit_oddsratio_nocov.png", "table_conditional_logit.tex",
  "study1", "手がかり重要度と相対比重", "fig_study1_relative_cue_weight_choice_set_adjusted_jp_bw.png", "table_marginal_means.tex;table_attribute_importance.tex;table_cue_importance.tex",
  "study2", "共変量調整済みAMCE", "amce_cov_facet_model.png", "table_amce_covariate_adjusted.tex",
  "study2", "AMCEヒートマップ", "amce_heatmap_mixed_rank_colored_labels.png", "table_amce_covariate_adjusted.tex",
  "study2", "共変量を含めないAMCE", "amce_facet_nocov.png", "table_amce_unadjusted.tex",
  "study2", "AMCEの条件差", "amce_interaction_difference_from_2party.png", "table_amce_interaction.tex",
  "study2", "条件付きロジット", "clogit_oddsratio_nocov.png", "table_conditional_logit.tex",
  "study2", "手がかり重要度と相対比重", "fig_study2_relative_cue_weight_choice_set_adjusted_jp_bw.png", "table_marginal_means.tex;table_attribute_importance.tex;table_cue_importance.tex",
  "study3", "共変量調整済みAMCE", "amce_cov_facet_model.png", "table_amce_covariate_adjusted.tex",
  "study3", "共変量を含めないAMCE", "amce_nocov_facet_model.png", "table_amce_unadjusted.tex",
  "study3", "AMCEの条件差", "amce_interaction_difference_from_2choice.png", "table_amce_interaction.tex",
  "study3", "AMCEの線形トレンド", "amce_linear_trend.png", "table_amce_linear_trend.tex",
  "study3", "AMCEヒートマップ", "amce_cov_heatmap.png", "table_amce_covariate_adjusted.tex",
  "study3", "条件付きロジット", "clogit_oddsratio_nocov.png", "table_conditional_logit.tex",
  "study3", "支持政党と提示政党名の一致効果", "party_match_effect_combined.png", "table_party_match.tex",
  "study3", "手がかり重要度と相対比重", "fig_study3_relative_cue_weight_choice_set_adjusted_jp_bw.png", "table_marginal_means.tex;table_attribute_importance.tex;table_cue_importance.tex"
)

for (study_id in names(study_specs)) {
  support_figures <- list.files(
    file.path(final_dirs$supplement_root, study_id, "figures"),
    pattern = "party_support_amce_.*\\.png$",
    full.names = FALSE
  )
  if (length(support_figures) > 0) {
    pair_manifest <- dplyr::bind_rows(
      pair_manifest,
      tibble::tibble(
        study_id = study_id,
        section_title = paste0("支持政党別AMCE：", support_figures),
        figure_file = support_figures,
        table_files = "table_party_support_amce.tex"
      )
    )
  }
  if (file.exists(file.path(final_dirs$supplement_root, study_id, "figures", "party_support_relative_cue_weight.png"))) {
    pair_manifest <- dplyr::bind_rows(
      pair_manifest,
      tibble::tibble(
        study_id = study_id,
        section_title = "支持政党別の手がかり相対比重",
        figure_file = "party_support_relative_cue_weight.png",
        table_files = "table_party_support_relative_cue.tex"
      )
    )
  }
}

readr::write_csv(
  pair_manifest,
  file.path(final_dirs$supplement_root, "figure_table_pair_manifest.csv"),
  na = ""
)

pair_tex_lines <- c(
  "% Generated automatically. Run LuaLaTeX from the supplement directory.",
  "\\providecommand{\\ConjointSupplementRoot}{.}",
  "\\section{標本構築・データ品質・分析結果}"
)

for (study_id in names(study_specs)) {
  study_label <- study_specs[[study_id]]$study_label
  pair_tex_lines <- c(
    pair_tex_lines,
    paste0("\\section{", latex_escape(study_label), "}"),
    "\\subsection{標本構築とスクリーニング}",
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_sample_attrition.tex}"),
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_sample_attrition_by_condition.tex}"),
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_manipulation_check.tex}"),
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_attention_check.tex}"),
    "\\clearpage",
    "\\subsection{回答者割付のバランス}",
    "\\begin{figure}[p]",
    "\\centering",
    paste0(
      "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/../diagnostics/",
      study_id,
      "/balance/",
      study_id,
      "_assignment_balance_love_plot.png}"
    ),
    paste0("\\caption{", latex_escape(study_label), "：回答者割付のLove plot}"),
    "\\end{figure}",
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_assignment_balance_pairwise_smd.tex}"),
    "\\begin{figure}[p]",
    "\\centering",
    paste0(
      "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/../diagnostics/",
      study_id,
      "/balance/",
      study_id,
      "_assignment_balance_diagonal_plot.png}"
    ),
    paste0("\\caption{", latex_escape(study_label), "：条件別共変量平均の45度線診断}"),
    "\\end{figure}",
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_assignment_balance_summary.tex}"),
    "\\clearpage",
    "\\subsection{コンジョイント属性提示の無作為化診断}",
    "\\begin{figure}[p]",
    "\\centering",
    paste0(
      "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/../diagnostics/",
      study_id,
      "/randomization/",
      study_id,
      "_profile_randomization_diagonal_plot.png}"
    ),
    paste0("\\caption{", latex_escape(study_label), "：属性水準の観測比率と期待比率}"),
    "\\end{figure}",
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_profile_randomization_tests.tex}"),
    paste0("\\input{\\ConjointSupplementRoot/", study_id, "/tables_tex/table_profile_randomization_frequency.tex}"),
    "\\clearpage",
    "\\subsection{推定結果：図と対応する表}"
  )
  
  study_pairs <- pair_manifest %>% dplyr::filter(.data$study_id == study_id)
  for (i in seq_len(nrow(study_pairs))) {
    row <- study_pairs[i, ]
    figure_path <- file.path(row$study_id, "figures", row$figure_file)
    tables <- unlist(strsplit(row$table_files, ";", fixed = TRUE))
    pair_tex_lines <- c(
      pair_tex_lines,
      paste0("\\subsubsection{", latex_escape(row$section_title), "}"),
      "\\begin{figure}[p]",
      "\\centering",
      paste0("\\includegraphics[width=0.96\\linewidth]{\\ConjointSupplementRoot/", gsub("\\\\", "/", figure_path), "}"),
      paste0("\\caption{", latex_escape(row$section_title), "}"),
      "\\end{figure}"
    )
    for (table_file in tables) {
      table_path <- file.path(row$study_id, "tables_tex", table_file)
      if (file.exists(file.path(final_dirs$supplement_root, table_path))) {
        pair_tex_lines <- c(
          pair_tex_lines,
          paste0("\\input{\\ConjointSupplementRoot/", gsub("\\\\", "/", table_path), "}")
        )
      }
    }
    pair_tex_lines <- c(pair_tex_lines, "\\clearpage")
  }
}

pair_tex_lines <- c(
  pair_tex_lines,
  "\\section{3実験横断の分析}",
  "\\subsection{主要仮説の線形傾向検定}",
  "\\begin{figure}[p]",
  "\\centering",
  "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/cross_study/figures/fig_supp_hypothesis_linear_trend_tests.png}",
  "\\caption{3実験の主要仮説に対応する線形傾向検定}",
  "\\end{figure}",
  "\\input{\\ConjointSupplementRoot/cross_study/tables_tex/table_hypothesis.tex}",
  "\\clearpage",
  "\\subsection{選択肢数調整済み重要度の線形傾向}",
  "\\begin{figure}[p]",
  "\\centering",
  "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/cross_study/figures/fig_supp_choice_set_adjusted_importance_slopes.png}",
  "\\caption{3実験の選択肢数調整済み重要度の線形傾向}",
  "\\end{figure}",
  "\\input{\\ConjointSupplementRoot/cross_study/tables_tex/table_adjusted_slopes.tex}",
  "\\clearpage",
  "\\subsection{3実験横断の政党手がかり相対比重}",
  "\\begin{figure}[p]",
  "\\centering",
  "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/cross_study/figures/fig_supp_cross_study_relative_party_weight.png}",
  "\\caption{3実験横断の政党手がかり相対比重}",
  "\\end{figure}",
  "\\input{\\ConjointSupplementRoot/cross_study/tables_tex/table_cross_relative.tex}",
  "\\clearpage"
)

if (file.exists(file.path(final_dirs$supplement_cross, "figures", "party_match_all_parties.png"))) {
  pair_tex_lines <- c(
    pair_tex_lines,
    "\\subsection{Study 3：すべての対象支持政党における一致効果}",
    "\\begin{figure}[p]",
    "\\centering",
    "\\includegraphics[width=0.92\\linewidth]{\\ConjointSupplementRoot/cross_study/figures/party_match_all_parties.png}",
    "\\caption{すべての対象支持政党における支持政党名一致効果}",
    "\\end{figure}",
    "\\input{\\ConjointSupplementRoot/cross_study/tables_tex/table_all_party_match_coefficients.tex}",
    "\\input{\\ConjointSupplementRoot/cross_study/tables_tex/table_all_party_match_trends.tex}",
    "\\clearpage"
  )
}

writeLines(
  pair_tex_lines,
  con = file.path(final_dirs$supplement_root, "all_studies_figure_table_pairs.tex"),
  useBytes = TRUE
)

preamble_lines <- c(
  "% Add these packages to the preamble of appendix.tex.",
  "\\usepackage{graphicx}",
  "\\usepackage{booktabs}",
  "\\usepackage{longtable}",
  "\\usepackage{array}",
  "\\usepackage{pdflscape}",
  "\\usepackage{caption}",
  "% Compile with LuaLaTeX because the generated captions and tables contain Japanese."
)
writeLines(
  preamble_lines,
  con = file.path(final_dirs$supplement_root, "latex_preamble_snippet.tex"),
  useBytes = TRUE
)

standalone_lines <- c(
  "% !TeX program = lualatex",
  "\\documentclass[a4paper,11pt]{ltjsarticle}",
  "\\usepackage[margin=22mm]{geometry}",
  "\\usepackage{graphicx}",
  "\\usepackage{booktabs}",
  "\\usepackage{longtable}",
  "\\usepackage{array}",
  "\\usepackage{pdflscape}",
  "\\usepackage{caption}",
  "\\begin{document}",
  "\\tableofcontents",
  "\\clearpage",
  "\\input{all_studies_figure_table_pairs.tex}",
  "\\end{document}"
)
writeLines(
  standalone_lines,
  con = file.path(final_dirs$supplement_root, "supplement_tables_figures_master.tex"),
  useBytes = TRUE
)

layout_lines <- c(
  "OUTPUT DIRECTORY STRUCTURE",
  "==========================",
  "main_text/figures      : manuscript figures",
  "main_text/tables       : LaTeX tables corresponding to manuscript figures",
  "supplement/study1-3    : per-study figures, CSV tables, and LaTeX tables",
  "supplement/cross_study : cross-study figures and tables",
  "diagnostics/study1-3   : respondent screening, balance, and randomization diagnostics",
  "model_objects          : RDS model and analysis objects",
  "logs                   : text model summaries and session information",
  "_working               : original intermediate outputs produced by each analysis module",
  "",
  "LATEX",
  "-----",
  "Add the packages in supplement/latex_preamble_snippet.tex to appendix.tex.",
  "Then input supplement/all_studies_figure_table_pairs.tex, or compile",
  "supplement/supplement_tables_figures_master.tex with LuaLaTeX."
)
writeLines(
  layout_lines,
  con = file.path(final_output_root, "OUTPUT_STRUCTURE_AND_LATEX_README.txt"),
  useBytes = TRUE
)

saveRDS(
  list(
    screening = screening_results,
    pair_manifest = pair_manifest,
    final_dirs = final_dirs
  ),
  file = file.path(final_dirs$model_objects_root, "screening_and_latex_export_objects.rds")
)

cat(
  "\nScreened-sample audit, LaTeX tables, figure-table pairs, and final output organization completed.\n",
  "Final output root: ", normalizePath(final_output_root), "\n",
  "LaTeX master: ",
  normalizePath(file.path(final_dirs$supplement_root, "supplement_tables_figures_master.tex")),
  "\n",
  sep = ""
)

B. 推定方法と分析標本の定義

B.1 分析標本

各回答者は2、3、4、5のいずれかの選択肢数条件に割り当てられ、5つの選択課題に回答した。従属変数は、各課題に提示されたプロフィールが選択された場合に1、選択されなかった場合に0をとる二値変数である。

実験1では、初回同意、最終送信同意、および割り当てられた条件における5課題の有効回答を満たす回答者を分析対象とした。実験2・3では、これらに加えて、イデオロギー行列中の指示項目と選択肢数の操作確認質問に正答した回答者に限定した。

B.2 AMCE

回答者を \(i\)、選択課題を \(t\)、プロフィールを \(j\)、選択肢数条件を \(n\in\{2,3,4,5\}\) とする。従属変数を

\[ Y_{itj} = \mathbf{1}\{\text{プロフィール }j\text{ が選択された}\} \]

と定義する。各選択肢数条件について、線形確率モデルを別々に推定する。

\[ Y_{itj} = \alpha_n + \sum_{a} \sum_{\ell\neq \ell_{a0}} \beta_{n,a\ell}D_{itj,a\ell} + \boldsymbol{\gamma}_{n}^{\prime}\boldsymbol{Z}_{i} + \varepsilon_{itj}. \]

\(\beta_{n,a\ell}\) は、属性 \(a\) を基準水準 \(\ell_{a0}\) から水準 \(\ell\) に変更したときの平均限界要素効果（AMCE）である。標準誤差は回答者単位でクラスタ化した。

実験1・2では、政策位置の基準を中道、与野党地位の基準を野党、議席数の基準を10以下とし、GDP成長率、日経平均株価、CPI、失業率はいずれも変化なしを基準とした。実験3では政党名の基準を自由民主党とした。

B.3 限界平均と属性重要度

選択肢数条件 \(n\) における属性 \(a\) の水準 \(\ell\) の限界平均を、

\[ \widehat{\mu}_{n,a\ell} = \frac{ \sum_{i,t,j} \mathbf{1}\{X_{itj,a}=\ell\}Y_{itj} }{ \sum_{i,t,j} \mathbf{1}\{X_{itj,a}=\ell\} } \]

とする。

属性 \(a\) が \(L_a\) 個の水準をもつとき、属性重要度を全水準ペアの限界平均差の絶対値の平均として、

\[ \widehat{I}_{n,a} = \binom{L_a}{2}^{-1} \sum_{\ell<\ell'} \left| \widehat{\mu}_{n,a\ell} - \widehat{\mu}_{n,a\ell'} \right| \]

と定義した。

実験1・2の政党手がかりの重要度は、政策位置、与野党地位、議席数の3属性の重要度を等しい加重で平均した。実験3では政党名属性の重要度を政党手がかりの重要度とした。経済手がかりは、3実験ともGDP成長率、日経平均株価、CPI、失業率の4属性の重要度を等しい加重で平均した。

B.4 選択肢数調整済み重要度と相対比重

\(k\) 個のプロフィールから必ず1つを選択するため、プロフィール1件あたりの平均選択確率は \(1/k\) となる。条件間比較のため、選択肢数調整済み重要度を、

\[ \widehat{I}^{\mathrm{adj}}_{k,a} = \frac{\widehat{I}_{k,a}}{1/k} = k\widehat{I}_{k,a} \]

とした。

政党手がかりの重要度を \(\widehat{P}_{k}\)、経済手がかりの重要度を \(\widehat{E}_{k}\) とすると、政党手がかりの相対比重は、

\[ \widehat{W}_{k} = \frac{\widehat{P}_{k}} {\widehat{P}_{k}+\widehat{E}_{k}} \]

である。政党・経済の両重要度に同じ \(k\) を乗じても相対比重は変化しない。

B.5 ブートストラップと線形トレンド

重要度と相対比重の95%信頼区間は、各選択肢数条件内で回答者を単位として復元抽出し、各回答者の5課題・全プロフィールに欠損のない回答者クラスター・ブートストラップから算出した。主要分析では2,000回反復させた。

各指標 \(Q_n\) の選択肢数に対する線形傾向は、

\[ Q_n=\eta+\delta n+u_n \]

として4条件の点推定値にOLSを当てはめ、傾き \(\delta\) を求めた。各ブートストラップ反復でも同じ傾きを再推定し、95%信頼区間と両側ブートストラップ \(p\) 値を算出した。H1a、H1b、H2a、H2bの判定には選択肢数調整済み重要度を用いた。

B.6 条件付きロジット

強制選択課題の構造を考慮する頑健性分析として、各選択肢数条件について条件付きロジットを推定した。

\[ \Pr(Y_{itj}=1\mid \mathcal{C}_{it}) = \frac{\exp(\boldsymbol{X}_{itj}^{\prime}\boldsymbol{\beta})} {\sum_{k\in\mathcal{C}_{it}}\exp(\boldsymbol{X}_{itk}^{\prime}\boldsymbol{\beta})}. \]

課題を層（stratum）とし、回答者単位でクラスタ化した。回答者レベル共変量は同一選択課題内で一定であるため、条件付きロジットにはプロフィール属性のみを投入した。

B.7 支持政党名との一致効果

実験3では、

\[ M_{itj} = \mathbf{1}\{\text{提示政党名}_{itj}=\text{支持政党}_{i}\} \]

を作成した。全体モデルでは、支持政党名一致、提示政党名、4つの経済属性を投入し、選択肢数条件ごとに推定した。なお、支持政党別の分析では、政党名と一致指標が完全に対応してしまうため、政党名主効果を除き、一致指標と経済属性を用いた。

B.8 バランスと無作為化診断

回答者割付のバランスは、2、3、4、5条件の全条件ペアについて標準化平均差を算出した。用いた回答者属性は、各実験で利用可能な性別、年齢、4年制大学以上、対数世帯年収、自己イデオロギー、およびそれらの欠損指標と支持政党である。地域・都道府県はこの割付バランス診断には用いていない。Love plot は全6条件ペアの絶対SMDを示し、対角線図は同じ回答者共変量について各条件平均を標準化し、二条件ずつ45度線と比較する補助的な可視化である。

\[ \mathrm{SMD}_{ab} = \frac{\overline{x}_a-\overline{x}_b} {\sqrt{(s_a^2+s_b^2)/2}}. \]

プロフィール属性の提示については、選択肢数条件×属性×水準ごとに観測比率を求め、水準数を \(L_a\) とした設計上の期待比率 \(1/L_a\) と比較した。属性×条件ごとに一様分布を帰無仮説とするカイ二乗検定を行い、Holm法による補正値も報告した。

C. 無作為化についての各種検討

以下で、回答者レベルの割付バランスとプロフィール属性の無作為提示は別々に確認する。回答者レベルではLove plotと45度線診断を併用し、プロフィールレベルでは各属性水準の観測比率を設計上の期待比率と比較する。

B.1 実験1（2023年）

図C1：回答者割付のLove plot

実験1仕様 <- study_specs$study1
実験1割付設計 <- make_balance_design(実験1仕様)
実験1SMD <- pairwise_smd_multiarm(実験1割付設計$long)
実験1最大SMD <- 実験1SMD %>%
  dplyr::group_by(variable, label) %>%
  dplyr::summarise(max_abs_smd = max(abs_smd, na.rm = TRUE), .groups = "drop")

Loveデータ <- 実験1SMD %>%
  dplyr::left_join(実験1最大SMD, by = c("variable", "label")) %>%
  dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd))

図C1 <- ggplot2::ggplot(Loveデータ, ggplot2::aes(x = abs_smd, y = 表示名)) +
  ggplot2::geom_vline(xintercept = 0.10, linetype = "dashed", linewidth = 0.55) +
  ggplot2::geom_point(alpha = 0.30, size = 1.4, position = ggplot2::position_jitter(height = 0.10, width = 0)) +
  ggplot2::geom_point(
    data = 実験1最大SMD %>% dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd)),
    ggplot2::aes(x = max_abs_smd, y = 表示名),
    inherit.aes = FALSE, shape = 21, fill = "white", size = 2.5, stroke = 0.8
  ) +
  ggplot2::labs(x = "条件間の絶対標準化平均差（|SMD|）", y = NULL,
                subtitle = "実験1（2023年）：各点は条件ペア、白抜き点は最大絶対SMD") +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C1

表C1には図C1の各点に対応する。各行には比較する2条件の平均とSMDを示す。

表C1 <- 実験1SMD %>%
  dplyr::transmute(
    変数 = label,
    比較 = paste0(condition_a, "政党条件－", condition_b, "政党条件"),
    `前者の平均` = round(mean_a, 3),
    `後者の平均` = round(mean_b, 3),
    `前者N` = n_a,
    `後者N` = n_b,
    SMD = round(smd, 3),
    `|SMD|` = round(abs_smd, 3)
  )
knitr::kable(表日本語(表C1), format = "html", row.names = FALSE)

変数	比較	前者の平均	後者の平均	前者N	後者N	SMD	|SMD|
年齢	2政党条件－3政党条件	35.374	34.896	815	843	0.049	0.049
女性	2政党条件－3政党条件	0.297	0.305	815	843	-0.017	0.017
性別：欠損	2政党条件－3政党条件	0.021	0.017	815	843	0.031	0.031
世帯年収（対数）	2政党条件－3政党条件	5.890	6.068	815	843	-0.133	0.133
支持政党：公明党	2政党条件－3政党条件	0.189	0.168	815	843	0.054	0.054
支持政党：国民民主党	2政党条件－3政党条件	0.000	0.002	815	843	-0.069	0.069
支持政党：日本共産党	2政党条件－3政党条件	0.055	0.058	815	843	-0.013	0.013
支持政党：日本維新の会	2政党条件－3政党条件	0.499	0.509	815	843	-0.019	0.019
支持政党：社会民主党	2政党条件－3政党条件	0.009	0.013	815	843	-0.043	0.043
支持政党：立憲民主党	2政党条件－3政党条件	0.240	0.238	815	843	0.005	0.005
支持政党：自由民主党	2政党条件－3政党条件	0.007	0.011	815	843	-0.035	0.035
年齢	2政党条件－4政党条件	35.374	35.760	815	882	-0.040	0.040
女性	2政党条件－4政党条件	0.297	0.296	815	882	0.002	0.002
性別：欠損	2政党条件－4政党条件	0.021	0.018	815	882	0.020	0.020
世帯年収（対数）	2政党条件－4政党条件	5.890	6.007	815	882	-0.084	0.084
支持政党：公明党	2政党条件－4政党条件	0.189	0.202	815	882	-0.032	0.032
支持政党：国民民主党	2政党条件－4政党条件	0.000	0.002	815	882	-0.067	0.067
支持政党：日本共産党	2政党条件－4政党条件	0.055	0.084	815	882	-0.113	0.113
支持政党：日本維新の会	2政党条件－4政党条件	0.499	0.456	815	882	0.087	0.087
支持政党：社会民主党	2政党条件－4政党条件	0.009	0.015	815	882	-0.057	0.057
支持政党：立憲民主党	2政党条件－4政党条件	0.240	0.240	815	882	0.000	0.000
支持政党：自由民主党	2政党条件－4政党条件	0.007	0.001	815	882	0.096	0.096
年齢	2政党条件－5政党条件	35.374	34.901	815	842	0.048	0.048
女性	2政党条件－5政党条件	0.297	0.293	815	842	0.008	0.008
性別：欠損	2政党条件－5政党条件	0.021	0.018	815	842	0.022	0.022
世帯年収（対数）	2政党条件－5政党条件	5.890	6.033	815	842	-0.105	0.105
支持政党：公明党	2政党条件－5政党条件	0.189	0.185	815	842	0.009	0.009
支持政党：国民民主党	2政党条件－5政党条件	0.000	0.002	815	842	-0.069	0.069
支持政党：日本共産党	2政党条件－5政党条件	0.055	0.065	815	842	-0.042	0.042
支持政党：日本維新の会	2政党条件－5政党条件	0.499	0.458	815	842	0.082	0.082
支持政党：社会民主党	2政党条件－5政党条件	0.009	0.010	815	842	-0.010	0.010
支持政党：立憲民主党	2政党条件－5政党条件	0.240	0.278	815	842	-0.085	0.085
支持政党：自由民主党	2政党条件－5政党条件	0.007	0.001	815	842	0.095	0.095
年齢	3政党条件－4政党条件	34.896	35.760	843	882	-0.090	0.090
女性	3政党条件－4政党条件	0.305	0.296	843	882	0.020	0.020
性別：欠損	3政党条件－4政党条件	0.017	0.018	843	882	-0.012	0.012
世帯年収（対数）	3政党条件－4政党条件	6.068	6.007	843	882	0.049	0.049
支持政党：公明党	3政党条件－4政党条件	0.168	0.202	843	882	-0.086	0.086
支持政党：国民民主党	3政党条件－4政党条件	0.002	0.002	843	882	0.002	0.002
支持政党：日本共産党	3政党条件－4政党条件	0.058	0.084	843	882	-0.100	0.100
支持政党：日本維新の会	3政党条件－4政党条件	0.509	0.456	843	882	0.106	0.106
支持政党：社会民主党	3政党条件－4政党条件	0.013	0.015	843	882	-0.014	0.014
支持政党：立憲民主党	3政党条件－4政党条件	0.238	0.240	843	882	-0.005	0.005
支持政党：自由民主党	3政党条件－4政党条件	0.011	0.001	843	882	0.125	0.125
年齢	3政党条件－5政党条件	34.896	34.901	843	842	-0.001	0.001
女性	3政党条件－5政党条件	0.305	0.293	843	842	0.025	0.025
性別：欠損	3政党条件－5政党条件	0.017	0.018	843	842	-0.009	0.009
世帯年収（対数）	3政党条件－5政党条件	6.068	6.033	843	842	0.029	0.029
支持政党：公明党	3政党条件－5政党条件	0.168	0.185	843	842	-0.044	0.044
支持政党：国民民主党	3政党条件－5政党条件	0.002	0.002	843	842	0.000	0.000
支持政党：日本共産党	3政党条件－5政党条件	0.058	0.065	843	842	-0.030	0.030
支持政党：日本維新の会	3政党条件－5政党条件	0.509	0.458	843	842	0.101	0.101
支持政党：社会民主党	3政党条件－5政党条件	0.013	0.010	843	842	0.034	0.034
支持政党：立憲民主党	3政党条件－5政党条件	0.238	0.278	843	842	-0.090	0.090
支持政党：自由民主党	3政党条件－5政党条件	0.011	0.001	843	842	0.124	0.124
年齢	4政党条件－5政党条件	35.760	34.901	882	842	0.089	0.089
女性	4政党条件－5政党条件	0.296	0.293	882	842	0.006	0.006
性別：欠損	4政党条件－5政党条件	0.018	0.018	882	842	0.002	0.002
世帯年収（対数）	4政党条件－5政党条件	6.007	6.033	882	842	-0.020	0.020
支持政党：公明党	4政党条件－5政党条件	0.202	0.185	882	842	0.042	0.042
支持政党：国民民主党	4政党条件－5政党条件	0.002	0.002	882	842	-0.002	0.002
支持政党：日本共産党	4政党条件－5政党条件	0.084	0.065	882	842	0.071	0.071
支持政党：日本維新の会	4政党条件－5政党条件	0.456	0.458	882	842	-0.005	0.005
支持政党：社会民主党	4政党条件－5政党条件	0.015	0.010	882	842	0.048	0.048
支持政党：立憲民主党	4政党条件－5政党条件	0.240	0.278	882	842	-0.086	0.086
支持政党：自由民主党	4政党条件－5政党条件	0.001	0.001	882	842	-0.002	0.002

図C2：条件平均の45度線診断

図C2は図C1と同じ回答者レベルの割付バランスを、各共変量の条件平均を標準化したうえで二条件ずつ45度線と比較したものである。

対角線データ <- assignment_balance_results$study1$diagonal_data %>%
  dplyr::mutate(
    比較 = paste0(condition_a, "政党条件－", condition_b, "政党条件")
  )

ラベル対象 <- 対角線データ %>%
  dplyr::group_by(比較) %>%
  dplyr::slice_max(abs_diagonal_deviation, n = 3, with_ties = FALSE) %>%
  dplyr::ungroup()

軸範囲 <- max(abs(c(対角線データ$x_mean, 対角線データ$y_mean)), na.rm = TRUE)
軸範囲 <- max(0.10, 軸範囲 * 1.15)

図C2 <- ggplot2::ggplot(対角線データ, ggplot2::aes(x = x_mean, y = y_mean)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.60) +
  ggplot2::geom_hline(yintercept = 0, linewidth = 0.25) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.25) +
  ggplot2::geom_point(shape = 21, fill = "white", size = 2.2) +
  ggplot2::geom_text(data = ラベル対象, ggplot2::aes(label = label), size = 2.6, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 比較, ncol = 3) +
  ggplot2::coord_equal(xlim = c(-軸範囲, 軸範囲), ylim = c(-軸範囲, 軸範囲)) +
  ggplot2::labs(x = "左側条件の標準化共変量平均", y = "右側条件の標準化共変量平均") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C2

表C2 <- assignment_balance_results$study1$summary %>%
  dplyr::transmute(
    変数 = label,
    `2政党条件の平均` = round(mean_condition_2, 3),
    `3政党条件の平均` = round(mean_condition_3, 3),
    `4政党条件の平均` = round(mean_condition_4, 3),
    `5政党条件の平均` = round(mean_condition_5, 3),
    `最大|SMD|` = round(max_abs_smd, 3),
    `Holm補正p値` = signif(p_holm, 3)
  )
knitr::kable(表日本語(表C2), format = "html", row.names = FALSE)

変数	2政党条件の平均	3政党条件の平均	4政党条件の平均	5政党条件の平均	最大|SMD|	Holm補正p値
世帯年収（対数）	5.890	6.068	6.007	6.033	0.133	0.336
支持政党：自由民主党	0.007	0.011	0.001	0.001	0.125	0.106
支持政党：日本共産党	0.055	0.058	0.084	0.065	0.113	0.580
支持政党：日本維新の会	0.499	0.509	0.456	0.458	0.106	0.476
年齢	35.374	34.896	35.760	34.901	0.090	1.000
支持政党：立憲民主党	0.240	0.238	0.240	0.278	0.090	1.000
支持政党：公明党	0.189	0.168	0.202	0.185	0.086	1.000
支持政党：国民民主党	0.000	0.002	0.002	0.002	0.069	1.000
支持政党：社会民主党	0.009	0.013	0.015	0.010	0.057	1.000
性別：欠損	0.021	0.017	0.018	0.018	0.031	1.000
女性	0.297	0.305	0.296	0.293	0.025	1.000

図C3：プロフィール属性水準の無作為提示

図C3は回答者の条件割付ではなく、各コンジョイント課題内で属性水準が設計どおり一様に提示されているかを確認したものである。

属性頻度 <- profile_randomization_results$study1$frequency %>%
  dplyr::mutate(
    属性 = 属性日本語(attribute),
    条件 = 条件日本語(party_n, "study1")
  )

表示ラベル <- 属性頻度 %>%
  dplyr::group_by(属性, 条件) %>%
  dplyr::slice_max(abs_deviation, n = 2, with_ties = FALSE) %>%
  dplyr::ungroup()

図C3 <- ggplot2::ggplot(属性頻度, ggplot2::aes(x = expected_share, y = observed_share, shape = 条件)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.65) +
  ggplot2::geom_point(size = 2.2, fill = "white") +
  ggplot2::geom_text(data = 表示ラベル, ggplot2::aes(label = level), size = 2.4, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 属性, ncol = 3) +
  ggplot2::coord_equal() +
  ggplot2::labs(x = "設計上の期待比率", y = "観測比率", shape = "条件") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), legend.position = "bottom")
図C3

表C3 <- profile_randomization_results$study1$uniformity_tests %>%
  dplyr::transmute(
    条件 = 条件日本語(party_n, "study1"),
    属性 = 属性日本語(attribute),
    `カイ二乗値` = round(chi_square, 3),
    自由度 = df,
    p値 = signif(p_value, 3),
    `Holm補正p値` = signif(p_holm, 3),
    `最大絶対比率差` = round(max_abs_share_deviation, 4)
  )
knitr::kable(表日本語(表C3), format = "html", row.names = FALSE)

条件	属性	カイ二乗値	自由度	p値	Holm補正p値	最大絶対比率差
2政党条件	消費者物価指数（CPI）	2.339	2	3.110000e-01	1.000000e+00	0.0078
2政党条件	GDP成長率	4.032	2	1.330000e-01	1.000000e+00	0.0091
2政党条件	与野党地位	2.474	1	1.160000e-01	1.000000e+00	0.0087
2政党条件	日経平均株価	0.108	2	9.480000e-01	1.000000e+00	0.0017
2政党条件	政策位置	0.022	2	9.890000e-01	1.000000e+00	0.0007
2政党条件	衆議院議席数	6.683	4	1.540000e-01	1.000000e+00	0.0080
2政党条件	失業率	1.851	2	3.960000e-01	1.000000e+00	0.0071
3政党条件	消費者物価指数（CPI）	1.489	2	4.750000e-01	1.000000e+00	0.0049
3政党条件	GDP成長率	7.043	2	2.950000e-02	6.500000e-01	0.0111
3政党条件	与野党地位	1476.555	1	4.940656e-323	1.240105e-321	0.1709
3政党条件	日経平均株価	1.700	2	4.270000e-01	1.000000e+00	0.0055
3政党条件	政策位置	4.462	2	1.070000e-01	1.000000e+00	0.0081
3政党条件	衆議院議席数	209.363	4	3.640000e-44	8.380000e-43	0.0335
3政党条件	失業率	1.219	2	5.440000e-01	1.000000e+00	0.0042
4政党条件	消費者物価指数（CPI）	4.270	2	1.180000e-01	1.000000e+00	0.0073
4政党条件	GDP成長率	0.127	2	9.390000e-01	1.000000e+00	0.0012
4政党条件	与野党地位	4587.756	1	0.000000e+00	0.000000e+00	0.2550
4政党条件	日経平均株価	1.221	2	5.430000e-01	1.000000e+00	0.0037
4政党条件	政策位置	4.136	2	1.260000e-01	1.000000e+00	0.0070
4政党条件	衆議院議席数	896.584	4	9.160000e-193	2.200000e-191	0.0739
4政党条件	失業率	0.551	2	7.590000e-01	1.000000e+00	0.0025
5政党条件	消費者物価指数（CPI）	2.511	2	2.850000e-01	1.000000e+00	0.0051
5政党条件	GDP成長率	3.062	2	2.160000e-01	1.000000e+00	0.0056
5政党条件	与野党地位	7618.855	1	0.000000e+00	0.000000e+00	0.3008
5政党条件	日経平均株価	1.781	2	4.100000e-01	1.000000e+00	0.0041
5政党条件	政策位置	0.632	2	7.290000e-01	1.000000e+00	0.0025
5政党条件	衆議院議席数	3958.393	4	0.000000e+00	0.000000e+00	0.1051
5政党条件	失業率	6.864	2	3.230000e-02	6.790000e-01	0.0079

表C4 <- 属性頻度 %>%
  dplyr::transmute(
    条件,
    属性,
    水準 = level,
    観測数 = observed_n,
    総数 = total_n,
    観測比率 = round(observed_share, 4),
    期待比率 = round(expected_share, 4),
    差 = round(deviation, 4)
  )
knitr::kable(表日本語(表C4), format = "html", row.names = FALSE)

条件	属性	水準	観測数	総数	観測比率	期待比率	差
2政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	2672	8150	0.3279	0.3333	-0.0055
2政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	2780	8150	0.3411	0.3333	0.0078
2政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	2698	8150	0.3310	0.3333	-0.0023
2政党条件	GDP成長率	GDP成長率±0％	2716	8150	0.3333	0.3333	-0.0001
2政党条件	GDP成長率	GDP成長率プラス1％	2791	8150	0.3425	0.3333	0.0091
2政党条件	GDP成長率	GDP成長率マイナス1％	2643	8150	0.3243	0.3333	-0.0090
2政党条件	与野党地位	与党	4146	8150	0.5087	0.5000	0.0087
2政党条件	与野党地位	野党	4004	8150	0.4913	0.5000	-0.0087
2政党条件	日経平均株価	日経平均前月同期比プラス1000円	2721	8150	0.3339	0.3333	0.0005
2政党条件	日経平均株価	日経平均前月同期比マイナス1000円	2726	8150	0.3345	0.3333	0.0011
2政党条件	日経平均株価	日経平均前月同期比変わらず	2703	8150	0.3317	0.3333	-0.0017
2政党条件	政策位置	中道	2717	8150	0.3334	0.3333	0.0000
2政党条件	政策位置	右派・保守的	2711	8150	0.3326	0.3333	-0.0007
2政党条件	政策位置	左派・革新的	2722	8150	0.3340	0.3333	0.0007
2政党条件	衆議院議席数	100~199	1662	8150	0.2039	0.2000	0.0039
2政党条件	衆議院議席数	10~49	1565	8150	0.1920	0.2000	-0.0080
2政党条件	衆議院議席数	10以下	1686	8150	0.2069	0.2000	0.0069
2政党条件	衆議院議席数	200以上	1652	8150	0.2027	0.2000	0.0027
2政党条件	衆議院議席数	50~99	1585	8150	0.1945	0.2000	-0.0055
2政党条件	失業率	失業率前期比±0％	2750	8150	0.3374	0.3333	0.0041
2政党条件	失業率	失業率前期比プラス1％	2741	8150	0.3363	0.3333	0.0030
2政党条件	失業率	失業率前期比マイナス1％	2659	8150	0.3263	0.3333	-0.0071
3政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	4168	12645	0.3296	0.3333	-0.0037
3政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	4277	12645	0.3382	0.3333	0.0049
3政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	4200	12645	0.3321	0.3333	-0.0012
3政党条件	GDP成長率	GDP成長率±0％	4297	12645	0.3398	0.3333	0.0065
3政党条件	GDP成長率	GDP成長率プラス1％	4075	12645	0.3223	0.3333	-0.0111
3政党条件	GDP成長率	GDP成長率マイナス1％	4273	12645	0.3379	0.3333	0.0046
3政党条件	与野党地位	与党	4162	12645	0.3291	0.5000	-0.1709
3政党条件	与野党地位	野党	8483	12645	0.6709	0.5000	0.1709
3政党条件	日経平均株価	日経平均前月同期比プラス1000円	4177	12645	0.3303	0.3333	-0.0030
3政党条件	日経平均株価	日経平均前月同期比マイナス1000円	4284	12645	0.3388	0.3333	0.0055
3政党条件	日経平均株価	日経平均前月同期比変わらず	4184	12645	0.3309	0.3333	-0.0025
3政党条件	政策位置	中道	4113	12645	0.3253	0.3333	-0.0081
3政党条件	政策位置	右派・保守的	4306	12645	0.3405	0.3333	0.0072
3政党条件	政策位置	左派・革新的	4226	12645	0.3342	0.3333	0.0009
3政党条件	衆議院議席数	100~199	2105	12645	0.1665	0.2000	-0.0335
3政党条件	衆議院議席数	10~49	2802	12645	0.2216	0.2000	0.0216
3政党条件	衆議院議席数	10以下	2794	12645	0.2210	0.2000	0.0210
3政党条件	衆議院議席数	200以上	2157	12645	0.1706	0.2000	-0.0294
3政党条件	衆議院議席数	50~99	2787	12645	0.2204	0.2000	0.0204
3政党条件	失業率	失業率前期比±0％	4268	12645	0.3375	0.3333	0.0042
3政党条件	失業率	失業率前期比プラス1％	4167	12645	0.3295	0.3333	-0.0038
3政党条件	失業率	失業率前期比マイナス1％	4210	12645	0.3329	0.3333	-0.0004
4政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	6009	17640	0.3406	0.3333	0.0073
4政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	5824	17640	0.3302	0.3333	-0.0032
4政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	5807	17640	0.3292	0.3333	-0.0041
4政党条件	GDP成長率	GDP成長率±0％	5894	17640	0.3341	0.3333	0.0008
4政党条件	GDP成長率	GDP成長率プラス1％	5858	17640	0.3321	0.3333	-0.0012
4政党条件	GDP成長率	GDP成長率マイナス1％	5888	17640	0.3338	0.3333	0.0005
4政党条件	与野党地位	与党	4322	17640	0.2450	0.5000	-0.2550
4政党条件	与野党地位	野党	13318	17640	0.7550	0.5000	0.2550
4政党条件	日経平均株価	日経平均前月同期比プラス1000円	5814	17640	0.3296	0.3333	-0.0037
4政党条件	日経平均株価	日経平均前月同期比マイナス1000円	5931	17640	0.3362	0.3333	0.0029
4政党条件	日経平均株価	日経平均前月同期比変わらず	5895	17640	0.3342	0.3333	0.0009
4政党条件	政策位置	中道	5913	17640	0.3352	0.3333	0.0019
4政党条件	政策位置	右派・保守的	5757	17640	0.3264	0.3333	-0.0070
4政党条件	政策位置	左派・革新的	5970	17640	0.3384	0.3333	0.0051
4政党条件	衆議院議席数	100~199	2977	17640	0.1688	0.2000	-0.0312
4政党条件	衆議院議席数	10~49	4205	17640	0.2384	0.2000	0.0384
4政党条件	衆議院議席数	10以下	4058	17640	0.2300	0.2000	0.0300
4政党条件	衆議院議席数	200以上	2224	17640	0.1261	0.2000	-0.0739
4政党条件	衆議院議席数	50~99	4176	17640	0.2367	0.2000	0.0367
4政党条件	失業率	失業率前期比±0％	5889	17640	0.3338	0.3333	0.0005
4政党条件	失業率	失業率前期比プラス1％	5915	17640	0.3353	0.3333	0.0020
4政党条件	失業率	失業率前期比マイナス1％	5836	17640	0.3308	0.3333	-0.0025
5政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	6965	21050	0.3309	0.3333	-0.0025
5政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	6960	21050	0.3306	0.3333	-0.0027
5政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	7125	21050	0.3385	0.3333	0.0051
5政党条件	GDP成長率	GDP成長率±0％	7135	21050	0.3390	0.3333	0.0056
5政党条件	GDP成長率	GDP成長率プラス1％	6973	21050	0.3313	0.3333	-0.0021
5政党条件	GDP成長率	GDP成長率マイナス1％	6942	21050	0.3298	0.3333	-0.0035
5政党条件	与野党地位	与党	4193	21050	0.1992	0.5000	-0.3008
5政党条件	与野党地位	野党	16857	21050	0.8008	0.5000	0.3008
5政党条件	日経平均株価	日経平均前月同期比プラス1000円	6996	21050	0.3324	0.3333	-0.0010
5政党条件	日経平均株価	日経平均前月同期比マイナス1000円	6950	21050	0.3302	0.3333	-0.0032
5政党条件	日経平均株価	日経平均前月同期比変わらず	7104	21050	0.3375	0.3333	0.0041
5政党条件	政策位置	中道	7051	21050	0.3350	0.3333	0.0016
5政党条件	政策位置	右派・保守的	6963	21050	0.3308	0.3333	-0.0025
5政党条件	政策位置	左派・革新的	7036	21050	0.3343	0.3333	0.0009
5政党条件	衆議院議席数	100~199	2615	21050	0.1242	0.2000	-0.0758
5政党条件	衆議院議席数	10~49	6423	21050	0.3051	0.2000	0.1051
5政党条件	衆議院議席数	10以下	6338	21050	0.3011	0.2000	0.1011
5政党条件	衆議院議席数	200以上	2157	21050	0.1025	0.2000	-0.0975
5政党条件	衆議院議席数	50~99	3517	21050	0.1671	0.2000	-0.0329
5政党条件	失業率	失業率前期比±0％	6850	21050	0.3254	0.3333	-0.0079
5政党条件	失業率	失業率前期比プラス1％	7157	21050	0.3400	0.3333	0.0067
5政党条件	失業率	失業率前期比マイナス1％	7043	21050	0.3346	0.3333	0.0013

B.2 実験2（2026年）

図C4：回答者割付のLove plot

実験2仕様 <- study_specs$study2
実験2割付設計 <- make_balance_design(実験2仕様)
実験2SMD <- pairwise_smd_multiarm(実験2割付設計$long)
実験2最大SMD <- 実験2SMD %>%
  dplyr::group_by(variable, label) %>%
  dplyr::summarise(max_abs_smd = max(abs_smd, na.rm = TRUE), .groups = "drop")

Loveデータ <- 実験2SMD %>%
  dplyr::left_join(実験2最大SMD, by = c("variable", "label")) %>%
  dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd))

図C4 <- ggplot2::ggplot(Loveデータ, ggplot2::aes(x = abs_smd, y = 表示名)) +
  ggplot2::geom_vline(xintercept = 0.10, linetype = "dashed", linewidth = 0.55) +
  ggplot2::geom_point(alpha = 0.30, size = 1.4, position = ggplot2::position_jitter(height = 0.10, width = 0)) +
  ggplot2::geom_point(
    data = 実験2最大SMD %>% dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd)),
    ggplot2::aes(x = max_abs_smd, y = 表示名),
    inherit.aes = FALSE, shape = 21, fill = "white", size = 2.5, stroke = 0.8
  ) +
  ggplot2::labs(x = "条件間の絶対標準化平均差（|SMD|）", y = NULL,
                subtitle = "実験2（2026年）：各点は条件ペア、白抜き点は最大絶対SMD") +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C4

表C5は図C4の各点に対応する。各行には比較する2条件の平均とSMDだけを残し、他条件に由来する構造的な欠損値は表示しない。

表C5 <- 実験2SMD %>%
  dplyr::transmute(
    変数 = label,
    比較 = paste0(condition_a, "政党条件－", condition_b, "政党条件"),
    `前者の平均` = round(mean_a, 3),
    `後者の平均` = round(mean_b, 3),
    `前者N` = n_a,
    `後者N` = n_b,
    SMD = round(smd, 3),
    `|SMD|` = round(abs_smd, 3)
  )
knitr::kable(表日本語(表C5), format = "html", row.names = FALSE)

変数	比較	前者の平均	後者の平均	前者N	後者N	SMD	|SMD|
年齢	2政党条件－3政党条件	42.000	41.814	711	1062	0.016	0.016
年齢：欠損	2政党条件－3政党条件	0.052	0.044	711	1062	0.036	0.036
4年制大学以上	2政党条件－3政党条件	0.591	0.571	711	1062	0.041	0.041
学歴：欠損	2政党条件－3政党条件	0.007	0.008	711	1062	-0.006	0.006
女性	2政党条件－3政党条件	0.308	0.298	711	1062	0.023	0.023
性別：欠損	2政党条件－3政党条件	0.010	0.011	711	1062	-0.014	0.014
世帯年収（対数）	2政党条件－3政党条件	5.956	6.018	711	1062	-0.044	0.044
支持政党：その他	2政党条件－3政党条件	0.003	0.001	711	1062	0.043	0.043
支持政党：れいわ新選組	2政党条件－3政党条件	0.013	0.021	711	1062	-0.063	0.063
支持政党：わからない	2政党条件－3政党条件	0.028	0.038	711	1062	-0.053	0.053
支持政党：チームみらい	2政党条件－3政党条件	0.059	0.047	711	1062	0.053	0.053
支持政党：中道改革連合	2政党条件－3政党条件	0.028	0.024	711	1062	0.029	0.029
支持政党：公明党	2政党条件－3政党条件	0.024	0.023	711	1062	0.009	0.009
支持政党：参政党	2政党条件－3政党条件	0.051	0.039	711	1062	0.058	0.058
支持政党：国民民主党	2政党条件－3政党条件	0.059	0.069	711	1062	-0.040	0.040
支持政党：支持政党なし	2政党条件－3政党条件	0.360	0.358	711	1062	0.005	0.005
支持政党：日本保守党	2政党条件－3政党条件	0.023	0.022	711	1062	0.006	0.006
支持政党：日本共産党	2政党条件－3政党条件	0.017	0.025	711	1062	-0.059	0.059
支持政党：日本維新の会	2政党条件－3政党条件	0.063	0.062	711	1062	0.005	0.005
支持政党：社会民主党	2政党条件－3政党条件	0.004	0.001	711	1062	0.065	0.065
支持政党：立憲民主党	2政党条件－3政党条件	0.045	0.040	711	1062	0.027	0.027
支持政党：答えたくない	2政党条件－3政党条件	0.020	0.017	711	1062	0.020	0.020
支持政党：自由民主党	2政党条件－3政党条件	0.204	0.216	711	1062	-0.029	0.029
年齢	2政党条件－4政党条件	42.000	42.459	711	1097	-0.041	0.041
年齢：欠損	2政党条件－4政党条件	0.052	0.055	711	1097	-0.012	0.012
4年制大学以上	2政党条件－4政党条件	0.591	0.599	711	1097	-0.017	0.017
学歴：欠損	2政党条件－4政党条件	0.007	0.011	711	1097	-0.041	0.041
女性	2政党条件－4政党条件	0.308	0.315	711	1097	-0.016	0.016
性別：欠損	2政党条件－4政党条件	0.010	0.004	711	1097	0.076	0.076
世帯年収（対数）	2政党条件－4政党条件	5.956	5.955	711	1097	0.001	0.001
支持政党：その他	2政党条件－4政党条件	0.003	0.003	711	1097	0.001	0.001
支持政党：れいわ新選組	2政党条件－4政党条件	0.013	0.016	711	1097	-0.031	0.031
支持政党：わからない	2政党条件－4政党条件	0.028	0.041	711	1097	-0.071	0.071
支持政党：チームみらい	2政党条件－4政党条件	0.059	0.056	711	1097	0.015	0.015
支持政党：中道改革連合	2政党条件－4政党条件	0.028	0.020	711	1097	0.053	0.053
支持政党：公明党	2政党条件－4政党条件	0.024	0.021	711	1097	0.020	0.020
支持政党：参政党	2政党条件－4政党条件	0.051	0.043	711	1097	0.037	0.037
支持政党：国民民主党	2政党条件－4政党条件	0.059	0.057	711	1097	0.011	0.011
支持政党：支持政党なし	2政党条件－4政党条件	0.360	0.356	711	1097	0.008	0.008
支持政党：日本保守党	2政党条件－4政党条件	0.023	0.027	711	1097	-0.031	0.031
支持政党：日本共産党	2政党条件－4政党条件	0.017	0.028	711	1097	-0.077	0.077
支持政党：日本維新の会	2政党条件－4政党条件	0.063	0.053	711	1097	0.045	0.045
支持政党：社会民主党	2政党条件－4政党条件	0.004	0.002	711	1097	0.044	0.044
支持政党：立憲民主党	2政党条件－4政党条件	0.045	0.040	711	1097	0.024	0.024
支持政党：答えたくない	2政党条件－4政党条件	0.020	0.014	711	1097	0.047	0.047
支持政党：自由民主党	2政党条件－4政党条件	0.204	0.223	711	1097	-0.047	0.047
年齢	2政党条件－5政党条件	42.000	42.447	711	1322	-0.039	0.039
年齢：欠損	2政党条件－5政党条件	0.052	0.047	711	1322	0.024	0.024
4年制大学以上	2政党条件－5政党条件	0.591	0.581	711	1322	0.020	0.020
学歴：欠損	2政党条件－5政党条件	0.007	0.008	711	1322	-0.015	0.015
女性	2政党条件－5政党条件	0.308	0.293	711	1322	0.033	0.033
性別：欠損	2政党条件－5政党条件	0.010	0.014	711	1322	-0.035	0.035
世帯年収（対数）	2政党条件－5政党条件	5.956	6.076	711	1322	-0.088	0.088
支持政党：その他	2政党条件－5政党条件	0.003	0.005	711	1322	-0.029	0.029
支持政党：れいわ新選組	2政党条件－5政党条件	0.013	0.016	711	1322	-0.027	0.027
支持政党：わからない	2政党条件－5政党条件	0.028	0.050	711	1322	-0.113	0.113
支持政党：チームみらい	2政党条件－5政党条件	0.059	0.057	711	1322	0.007	0.007
支持政党：中道改革連合	2政党条件－5政党条件	0.028	0.021	711	1322	0.045	0.045
支持政党：公明党	2政党条件－5政党条件	0.024	0.020	711	1322	0.029	0.029
支持政党：参政党	2政党条件－5政党条件	0.051	0.048	711	1322	0.014	0.014
支持政党：国民民主党	2政党条件－5政党条件	0.059	0.057	711	1322	0.007	0.007
支持政党：支持政党なし	2政党条件－5政党条件	0.360	0.328	711	1322	0.067	0.067
支持政党：日本保守党	2政党条件－5政党条件	0.023	0.030	711	1322	-0.048	0.048
支持政党：日本共産党	2政党条件－5政党条件	0.017	0.025	711	1322	-0.056	0.056
支持政党：日本維新の会	2政党条件－5政党条件	0.063	0.051	711	1322	0.054	0.054
支持政党：社会民主党	2政党条件－5政党条件	0.004	0.002	711	1322	0.034	0.034
支持政党：立憲民主党	2政党条件－5政党条件	0.045	0.045	711	1322	0.002	0.002
支持政党：答えたくない	2政党条件－5政党条件	0.020	0.024	711	1322	-0.031	0.031
支持政党：自由民主党	2政党条件－5政党条件	0.204	0.221	711	1322	-0.041	0.041
年齢	3政党条件－4政党条件	41.814	42.459	1062	1097	-0.057	0.057
年齢：欠損	3政党条件－4政党条件	0.044	0.055	1062	1097	-0.048	0.048
4年制大学以上	3政党条件－4政党条件	0.571	0.599	1062	1097	-0.057	0.057
学歴：欠損	3政党条件－4政党条件	0.008	0.011	1062	1097	-0.036	0.036
女性	3政党条件－4政党条件	0.298	0.315	1062	1097	-0.039	0.039
性別：欠損	3政党条件－4政党条件	0.011	0.004	1062	1097	0.089	0.089
世帯年収（対数）	3政党条件－4政党条件	6.018	5.955	1062	1097	0.044	0.044
支持政党：その他	3政党条件－4政党条件	0.001	0.003	1062	1097	-0.042	0.042
支持政党：れいわ新選組	3政党条件－4政党条件	0.021	0.016	1062	1097	0.032	0.032
支持政党：わからない	3政党条件－4政党条件	0.038	0.041	1062	1097	-0.017	0.017
支持政党：チームみらい	3政党条件－4政党条件	0.047	0.056	1062	1097	-0.039	0.039
支持政党：中道改革連合	3政党条件－4政党条件	0.024	0.020	1062	1097	0.024	0.024
支持政党：公明党	3政党条件－4政党条件	0.023	0.021	1062	1097	0.011	0.011
支持政党：参政党	3政党条件－4政党条件	0.039	0.043	1062	1097	-0.021	0.021
支持政党：国民民主党	3政党条件－4政党条件	0.069	0.057	1062	1097	0.050	0.050
支持政党：支持政党なし	3政党条件－4政党条件	0.358	0.356	1062	1097	0.003	0.003
支持政党：日本保守党	3政党条件－4政党条件	0.022	0.027	1062	1097	-0.037	0.037
支持政党：日本共産党	3政党条件－4政党条件	0.025	0.028	1062	1097	-0.018	0.018
支持政党：日本維新の会	3政党条件－4政党条件	0.062	0.053	1062	1097	0.040	0.040
支持政党：社会民主党	3政党条件－4政党条件	0.001	0.002	1062	1097	-0.024	0.024
支持政党：立憲民主党	3政党条件－4政党条件	0.040	0.040	1062	1097	-0.003	0.003
支持政党：答えたくない	3政党条件－4政党条件	0.017	0.014	1062	1097	0.027	0.027
支持政党：自由民主党	3政党条件－4政党条件	0.216	0.223	1062	1097	-0.019	0.019
年齢	3政党条件－5政党条件	41.814	42.447	1062	1322	-0.055	0.055
年齢：欠損	3政党条件－5政党条件	0.044	0.047	1062	1322	-0.013	0.013
4年制大学以上	3政党条件－5政党条件	0.571	0.581	1062	1322	-0.021	0.021
学歴：欠損	3政党条件－5政党条件	0.008	0.008	1062	1322	-0.009	0.009
女性	3政党条件－5政党条件	0.298	0.293	1062	1322	0.011	0.011
性別：欠損	3政党条件－5政党条件	0.011	0.014	1062	1322	-0.021	0.021
世帯年収（対数）	3政党条件－5政党条件	6.018	6.076	1062	1322	-0.045	0.045
支持政党：その他	3政党条件－5政党条件	0.001	0.005	1062	1322	-0.069	0.069
支持政党：れいわ新選組	3政党条件－5政党条件	0.021	0.016	1062	1322	0.036	0.036
支持政党：わからない	3政党条件－5政党条件	0.038	0.050	1062	1322	-0.060	0.060
支持政党：チームみらい	3政党条件－5政党条件	0.047	0.057	1062	1322	-0.047	0.047
支持政党：中道改革連合	3政党条件－5政党条件	0.024	0.021	1062	1322	0.016	0.016
支持政党：公明党	3政党条件－5政党条件	0.023	0.020	1062	1322	0.020	0.020
支持政党：参政党	3政党条件－5政党条件	0.039	0.048	1062	1322	-0.045	0.045
支持政党：国民民主党	3政党条件－5政党条件	0.069	0.057	1062	1322	0.046	0.046
支持政党：支持政党なし	3政党条件－5政党条件	0.358	0.328	1062	1322	0.062	0.062
支持政党：日本保守党	3政党条件－5政党条件	0.022	0.030	1062	1322	-0.054	0.054
支持政党：日本共産党	3政党条件－5政党条件	0.025	0.025	1062	1322	0.003	0.003
支持政党：日本維新の会	3政党条件－5政党条件	0.062	0.051	1062	1322	0.050	0.050
支持政党：社会民主党	3政党条件－5政党条件	0.001	0.002	1062	1322	-0.033	0.033
支持政党：立憲民主党	3政党条件－5政党条件	0.040	0.045	1062	1322	-0.025	0.025
支持政党：答えたくない	3政党条件－5政党条件	0.017	0.024	1062	1322	-0.051	0.051
支持政党：自由民主党	3政党条件－5政党条件	0.216	0.221	1062	1322	-0.013	0.013
年齢	4政党条件－5政党条件	42.459	42.447	1097	1322	0.001	0.001
年齢：欠損	4政党条件－5政党条件	0.055	0.047	1097	1322	0.035	0.035
4年制大学以上	4政党条件－5政党条件	0.599	0.581	1097	1322	0.037	0.037
学歴：欠損	4政党条件－5政党条件	0.011	0.008	1097	1322	0.027	0.027
女性	4政党条件－5政党条件	0.315	0.293	1097	1322	0.049	0.049
性別：欠損	4政党条件－5政党条件	0.004	0.014	1097	1322	-0.108	0.108
世帯年収（対数）	4政党条件－5政党条件	5.955	6.076	1097	1322	-0.086	0.086
支持政党：その他	4政党条件－5政党条件	0.003	0.005	1097	1322	-0.030	0.030
支持政党：れいわ新選組	4政党条件－5政党条件	0.016	0.016	1097	1322	0.004	0.004
支持政党：わからない	4政党条件－5政党条件	0.041	0.050	1097	1322	-0.043	0.043
支持政党：チームみらい	4政党条件－5政党条件	0.056	0.057	1097	1322	-0.008	0.008
支持政党：中道改革連合	4政党条件－5政党条件	0.020	0.021	1097	1322	-0.008	0.008
支持政党：公明党	4政党条件－5政党条件	0.021	0.020	1097	1322	0.009	0.009
支持政党：参政党	4政党条件－5政党条件	0.043	0.048	1097	1322	-0.023	0.023
支持政党：国民民主党	4政党条件－5政党条件	0.057	0.057	1097	1322	-0.004	0.004
支持政党：支持政党なし	4政党条件－5政党条件	0.356	0.328	1097	1322	0.059	0.059
支持政党：日本保守党	4政党条件－5政党条件	0.027	0.030	1097	1322	-0.017	0.017
支持政党：日本共産党	4政党条件－5政党条件	0.028	0.025	1097	1322	0.020	0.020
支持政党：日本維新の会	4政党条件－5政党条件	0.053	0.051	1097	1322	0.010	0.010
支持政党：社会民主党	4政党条件－5政党条件	0.002	0.002	1097	1322	-0.010	0.010
支持政党：立憲民主党	4政党条件－5政党条件	0.040	0.045	1097	1322	-0.022	0.022
支持政党：答えたくない	4政党条件－5政党条件	0.014	0.024	1097	1322	-0.077	0.077
支持政党：自由民主党	4政党条件－5政党条件	0.223	0.221	1097	1322	0.006	0.006

図C5：条件平均の45度線診断

図C5は図C4と同じ回答者レベルの割付バランスを、各共変量の条件平均を標準化したうえで2条件ずつ45度線と比較したものである。

対角線データ <- assignment_balance_results$study2$diagonal_data %>%
  dplyr::mutate(
    比較 = paste0(condition_a, "政党条件－", condition_b, "政党条件")
  )

ラベル対象 <- 対角線データ %>%
  dplyr::group_by(比較) %>%
  dplyr::slice_max(abs_diagonal_deviation, n = 3, with_ties = FALSE) %>%
  dplyr::ungroup()

軸範囲 <- max(abs(c(対角線データ$x_mean, 対角線データ$y_mean)), na.rm = TRUE)
軸範囲 <- max(0.10, 軸範囲 * 1.15)

図C5 <- ggplot2::ggplot(対角線データ, ggplot2::aes(x = x_mean, y = y_mean)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.60) +
  ggplot2::geom_hline(yintercept = 0, linewidth = 0.25) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.25) +
  ggplot2::geom_point(shape = 21, fill = "white", size = 2.2) +
  ggplot2::geom_text(data = ラベル対象, ggplot2::aes(label = label), size = 2.6, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 比較, ncol = 3) +
  ggplot2::coord_equal(xlim = c(-軸範囲, 軸範囲), ylim = c(-軸範囲, 軸範囲)) +
  ggplot2::labs(x = "左側条件の標準化共変量平均", y = "右側条件の標準化共変量平均") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C5

表C6 <- assignment_balance_results$study2$summary %>%
  dplyr::transmute(
    変数 = label,
    `2政党条件の平均` = round(mean_condition_2, 3),
    `3政党条件の平均` = round(mean_condition_3, 3),
    `4政党条件の平均` = round(mean_condition_4, 3),
    `5政党条件の平均` = round(mean_condition_5, 3),
    `最大|SMD|` = round(max_abs_smd, 3),
    `Holm補正p値` = signif(p_holm, 3)
  )
knitr::kable(表日本語(表C6), format = "html", row.names = FALSE)

変数	2政党条件の平均	3政党条件の平均	4政党条件の平均	5政党条件の平均	最大|SMD|	Holm補正p値
支持政党：わからない	0.028	0.038	0.041	0.050	0.113	1
性別：欠損	0.010	0.011	0.004	0.014	0.108	1
世帯年収（対数）	5.956	6.018	5.955	6.076	0.088	1
支持政党：答えたくない	0.020	0.017	0.014	0.024	0.077	1
支持政党：日本共産党	0.017	0.025	0.028	0.025	0.077	1
支持政党：その他	0.003	0.001	0.003	0.005	0.069	1
支持政党：支持政党なし	0.360	0.358	0.356	0.328	0.067	1
支持政党：社会民主党	0.004	0.001	0.002	0.002	0.065	1
支持政党：れいわ新選組	0.013	0.021	0.016	0.016	0.063	1
支持政党：参政党	0.051	0.039	0.043	0.048	0.058	1
4年制大学以上	0.591	0.571	0.599	0.581	0.057	1
年齢	42.000	41.814	42.459	42.447	0.057	1
支持政党：日本維新の会	0.063	0.062	0.053	0.051	0.054	1
支持政党：日本保守党	0.023	0.022	0.027	0.030	0.054	1
支持政党：チームみらい	0.059	0.047	0.056	0.057	0.053	1
支持政党：中道改革連合	0.028	0.024	0.020	0.021	0.053	1
支持政党：国民民主党	0.059	0.069	0.057	0.057	0.050	1
女性	0.308	0.298	0.315	0.293	0.049	1
年齢：欠損	0.052	0.044	0.055	0.047	0.048	1
支持政党：自由民主党	0.204	0.216	0.223	0.221	0.047	1
学歴：欠損	0.007	0.008	0.011	0.008	0.041	1
支持政党：公明党	0.024	0.023	0.021	0.020	0.029	1
支持政党：立憲民主党	0.045	0.040	0.040	0.045	0.027	1

図C6：プロフィール属性水準の無作為提示

図C6以降は回答者の条件割付ではなく、各コンジョイント課題内で属性水準が設計どおり一様に提示されているかを確認するものである。

属性頻度 <- profile_randomization_results$study2$frequency %>%
  dplyr::mutate(
    属性 = 属性日本語(attribute),
    条件 = 条件日本語(party_n, "study2")
  )

表示ラベル <- 属性頻度 %>%
  dplyr::group_by(属性, 条件) %>%
  dplyr::slice_max(abs_deviation, n = 2, with_ties = FALSE) %>%
  dplyr::ungroup()

図C6 <- ggplot2::ggplot(属性頻度, ggplot2::aes(x = expected_share, y = observed_share, shape = 条件)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.65) +
  ggplot2::geom_point(size = 2.2, fill = "white") +
  ggplot2::geom_text(data = 表示ラベル, ggplot2::aes(label = level), size = 2.4, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 属性, ncol = 3) +
  ggplot2::coord_equal() +
  ggplot2::labs(x = "設計上の期待比率", y = "観測比率", shape = "条件") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), legend.position = "bottom")
図C6

表C7 <- profile_randomization_results$study2$uniformity_tests %>%
  dplyr::transmute(
    条件 = 条件日本語(party_n, "study2"),
    属性 = 属性日本語(attribute),
    `カイ二乗値` = round(chi_square, 3),
    自由度 = df,
    p値 = signif(p_value, 3),
    `Holm補正p値` = signif(p_holm, 3),
    `最大絶対比率差` = round(max_abs_share_deviation, 4)
  )
knitr::kable(表日本語(表C7), format = "html", row.names = FALSE)

条件	属性	カイ二乗値	自由度	p値	Holm補正p値	最大絶対比率差
2政党条件	消費者物価指数（CPI）	1.667	2	0.43500	1.000	0.0070
2政党条件	GDP成長率	0.740	2	0.69100	1.000	0.0044
2政党条件	与野党地位	2.601	1	0.10700	1.000	0.0096
2政党条件	日経平均株価	9.289	2	0.00961	0.260	0.0158
2政党条件	政策位置	2.624	2	0.26900	1.000	0.0089
2政党条件	衆議院議席数	9.259	4	0.05490	1.000	0.0100
2政党条件	失業率	0.276	2	0.87100	1.000	0.0027
3政党条件	消費者物価指数（CPI）	0.285	2	0.86700	1.000	0.0018
3政党条件	GDP成長率	3.260	2	0.19600	1.000	0.0063
3政党条件	与野党地位	0.081	1	0.77500	1.000	0.0011
3政党条件	日経平均株価	0.390	2	0.82300	1.000	0.0023
3政党条件	政策位置	1.996	2	0.36900	1.000	0.0051
3政党条件	衆議院議席数	2.861	4	0.58100	1.000	0.0038
3政党条件	失業率	2.895	2	0.23500	1.000	0.0062
4政党条件	消費者物価指数（CPI）	1.732	2	0.42100	1.000	0.0041
4政党条件	GDP成長率	0.239	2	0.88700	1.000	0.0015
4政党条件	与野党地位	0.164	1	0.68500	1.000	0.0014
4政党条件	日経平均株価	9.409	2	0.00906	0.254	0.0097
4政党条件	政策位置	1.147	2	0.56400	1.000	0.0033
4政党条件	衆議院議席数	2.153	4	0.70800	1.000	0.0038
4政党条件	失業率	2.351	2	0.30900	1.000	0.0045
5政党条件	消費者物価指数（CPI）	0.564	2	0.75400	1.000	0.0018
5政党条件	GDP成長率	0.215	2	0.89800	1.000	0.0012
5政党条件	与野党地位	0.327	1	0.56700	1.000	0.0016
5政党条件	日経平均株価	2.328	2	0.31200	1.000	0.0039
5政党条件	政策位置	1.792	2	0.40800	1.000	0.0034
5政党条件	衆議院議席数	1.764	4	0.77900	1.000	0.0026
5政党条件	失業率	4.171	2	0.12400	1.000	0.0053

表C8 <- 属性頻度 %>%
  dplyr::transmute(
    条件,
    属性,
    水準 = level,
    観測数 = observed_n,
    総数 = total_n,
    観測比率 = round(observed_share, 4),
    期待比率 = round(expected_share, 4),
    差 = round(deviation, 4)
  )
knitr::kable(表日本語(表C8), format = "html", row.names = FALSE)

条件	属性	水準	観測数	総数	観測比率	期待比率	差
2政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	2335	7110	0.3284	0.3333	-0.0049
2政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	2355	7110	0.3312	0.3333	-0.0021
2政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	2420	7110	0.3404	0.3333	0.0070
2政党条件	GDP成長率	GDP成長率±0％	2342	7110	0.3294	0.3333	-0.0039
2政党条件	GDP成長率	GDP成長率プラス1％	2401	7110	0.3377	0.3333	0.0044
2政党条件	GDP成長率	GDP成長率マイナス1％	2367	7110	0.3329	0.3333	-0.0004
2政党条件	与野党地位	与党	3623	7110	0.5096	0.5000	0.0096
2政党条件	与野党地位	野党	3487	7110	0.4904	0.5000	-0.0096
2政党条件	日経平均株価	日経平均前月同期比プラス1000円	2354	7110	0.3311	0.3333	-0.0023
2政党条件	日経平均株価	日経平均前月同期比マイナス1000円	2274	7110	0.3198	0.3333	-0.0135
2政党条件	日経平均株価	日経平均前月同期比変わらず	2482	7110	0.3491	0.3333	0.0158
2政党条件	政策位置	中道	2413	7110	0.3394	0.3333	0.0060
2政党条件	政策位置	右派・保守的	2390	7110	0.3361	0.3333	0.0028
2政党条件	政策位置	左派・革新的	2307	7110	0.3245	0.3333	-0.0089
2政党条件	衆議院議席数	100~199	1400	7110	0.1969	0.2000	-0.0031
2政党条件	衆議院議席数	10~49	1351	7110	0.1900	0.2000	-0.0100
2政党条件	衆議院議席数	10以下	1491	7110	0.2097	0.2000	0.0097
2政党条件	衆議院議席数	200以上	1398	7110	0.1966	0.2000	-0.0034
2政党条件	衆議院議席数	50~99	1470	7110	0.2068	0.2000	0.0068
2政党条件	失業率	失業率前期比±0％	2389	7110	0.3360	0.3333	0.0027
2政党条件	失業率	失業率前期比プラス1％	2353	7110	0.3309	0.3333	-0.0024
2政党条件	失業率	失業率前期比マイナス1％	2368	7110	0.3331	0.3333	-0.0003
3政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	5282	15930	0.3316	0.3333	-0.0018
3政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	5311	15930	0.3334	0.3333	0.0001
3政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	5337	15930	0.3350	0.3333	0.0017
3政党条件	GDP成長率	GDP成長率±0％	5394	15930	0.3386	0.3333	0.0053
3政党条件	GDP成長率	GDP成長率プラス1％	5210	15930	0.3271	0.3333	-0.0063
3政党条件	GDP成長率	GDP成長率マイナス1％	5326	15930	0.3343	0.3333	0.0010
3政党条件	与野党地位	与党	7947	15930	0.4989	0.5000	-0.0011
3政党条件	与野党地位	野党	7983	15930	0.5011	0.5000	0.0011
3政党条件	日経平均株価	日経平均前月同期比プラス1000円	5336	15930	0.3350	0.3333	0.0016
3政党条件	日経平均株価	日経平均前月同期比マイナス1000円	5320	15930	0.3340	0.3333	0.0006
3政党条件	日経平均株価	日経平均前月同期比変わらず	5274	15930	0.3311	0.3333	-0.0023
3政党条件	政策位置	中道	5392	15930	0.3385	0.3333	0.0051
3政党条件	政策位置	右派・保守的	5285	15930	0.3318	0.3333	-0.0016
3政党条件	政策位置	左派・革新的	5253	15930	0.3298	0.3333	-0.0036
3政党条件	衆議院議席数	100~199	3246	15930	0.2038	0.2000	0.0038
3政党条件	衆議院議席数	10~49	3149	15930	0.1977	0.2000	-0.0023
3政党条件	衆議院議席数	10以下	3201	15930	0.2009	0.2000	0.0009
3政党条件	衆議院議席数	200以上	3207	15930	0.2013	0.2000	0.0013
3政党条件	衆議院議席数	50~99	3127	15930	0.1963	0.2000	-0.0037
3政党条件	失業率	失業率前期比±0％	5212	15930	0.3272	0.3333	-0.0062
3政党条件	失業率	失業率前期比プラス1％	5381	15930	0.3378	0.3333	0.0045
3政党条件	失業率	失業率前期比マイナス1％	5337	15930	0.3350	0.3333	0.0017
4政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	7255	21940	0.3307	0.3333	-0.0027
4政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	7404	21940	0.3375	0.3333	0.0041
4政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	7281	21940	0.3319	0.3333	-0.0015
4政党条件	GDP成長率	GDP成長率±0％	7281	21940	0.3319	0.3333	-0.0015
4政党条件	GDP成長率	GDP成長率プラス1％	7339	21940	0.3345	0.3333	0.0012
4政党条件	GDP成長率	GDP成長率マイナス1％	7320	21940	0.3336	0.3333	0.0003
4政党条件	与野党地位	与党	11000	21940	0.5014	0.5000	0.0014
4政党条件	与野党地位	野党	10940	21940	0.4986	0.5000	-0.0014
4政党条件	日経平均株価	日経平均前月同期比プラス1000円	7229	21940	0.3295	0.3333	-0.0038
4政党条件	日経平均株価	日経平均前月同期比マイナス1000円	7185	21940	0.3275	0.3333	-0.0058
4政党条件	日経平均株価	日経平均前月同期比変わらず	7526	21940	0.3430	0.3333	0.0097
4政党条件	政策位置	中道	7296	21940	0.3325	0.3333	-0.0008
4政党条件	政策位置	右派・保守的	7259	21940	0.3309	0.3333	-0.0025
4政党条件	政策位置	左派・革新的	7385	21940	0.3366	0.3333	0.0033
4政党条件	衆議院議席数	100~199	4471	21940	0.2038	0.2000	0.0038
4政党条件	衆議院議席数	10~49	4371	21940	0.1992	0.2000	-0.0008
4政党条件	衆議院議席数	10以下	4389	21940	0.2000	0.2000	0.0000
4政党条件	衆議院議席数	200以上	4358	21940	0.1986	0.2000	-0.0014
4政党条件	衆議院議席数	50~99	4351	21940	0.1983	0.2000	-0.0017
4政党条件	失業率	失業率前期比±0％	7412	21940	0.3378	0.3333	0.0045
4政党条件	失業率	失業率前期比プラス1％	7228	21940	0.3294	0.3333	-0.0039
4政党条件	失業率	失業率前期比マイナス1％	7300	21940	0.3327	0.3333	-0.0006
5政党条件	消費者物価指数（CPI）	CPI前期比±0ポイント	11075	33050	0.3351	0.3333	0.0018
5政党条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	11011	33050	0.3332	0.3333	-0.0002
5政党条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	10964	33050	0.3317	0.3333	-0.0016
5政党条件	GDP成長率	GDP成長率±0％	11038	33050	0.3340	0.3333	0.0006
5政党条件	GDP成長率	GDP成長率プラス1％	10977	33050	0.3321	0.3333	-0.0012
5政党条件	GDP成長率	GDP成長率マイナス1％	11035	33050	0.3339	0.3333	0.0006
5政党条件	与野党地位	与党	16473	33050	0.4984	0.5000	-0.0016
5政党条件	与野党地位	野党	16577	33050	0.5016	0.5000	0.0016
5政党条件	日経平均株価	日経平均前月同期比プラス1000円	11056	33050	0.3345	0.3333	0.0012
5政党条件	日経平均株価	日経平均前月同期比マイナス1000円	11105	33050	0.3360	0.3333	0.0027
5政党条件	日経平均株価	日経平均前月同期比変わらず	10889	33050	0.3295	0.3333	-0.0039
5政党条件	政策位置	中道	10985	33050	0.3324	0.3333	-0.0010
5政党条件	政策位置	右派・保守的	11128	33050	0.3367	0.3333	0.0034
5政党条件	政策位置	左派・革新的	10937	33050	0.3309	0.3333	-0.0024
5政党条件	衆議院議席数	100~199	6589	33050	0.1994	0.2000	-0.0006
5政党条件	衆議院議席数	10~49	6697	33050	0.2026	0.2000	0.0026
5政党条件	衆議院議席数	10以下	6550	33050	0.1982	0.2000	-0.0018
5政党条件	衆議院議席数	200以上	6611	33050	0.2000	0.2000	0.0000
5政党条件	衆議院議席数	50~99	6603	33050	0.1998	0.2000	-0.0002
5政党条件	失業率	失業率前期比±0％	11191	33050	0.3386	0.3333	0.0053
5政党条件	失業率	失業率前期比プラス1％	10916	33050	0.3303	0.3333	-0.0030
5政党条件	失業率	失業率前期比マイナス1％	10943	33050	0.3311	0.3333	-0.0022

B.3 実験3（2026年）

図C7：回答者割付のLove plot

実験3仕様 <- study_specs$study3
実験3割付設計 <- make_balance_design(実験3仕様)
実験3SMD <- pairwise_smd_multiarm(実験3割付設計$long)
実験3最大SMD <- 実験3SMD %>%
  dplyr::group_by(variable, label) %>%
  dplyr::summarise(max_abs_smd = max(abs_smd, na.rm = TRUE), .groups = "drop")

Loveデータ <- 実験3SMD %>%
  dplyr::left_join(実験3最大SMD, by = c("variable", "label")) %>%
  dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd))

図C7 <- ggplot2::ggplot(Loveデータ, ggplot2::aes(x = abs_smd, y = 表示名)) +
  ggplot2::geom_vline(xintercept = 0.10, linetype = "dashed", linewidth = 0.55) +
  ggplot2::geom_point(alpha = 0.30, size = 1.4, position = ggplot2::position_jitter(height = 0.10, width = 0)) +
  ggplot2::geom_point(
    data = 実験3最大SMD %>% dplyr::mutate(表示名 = stats::reorder(label, max_abs_smd)),
    ggplot2::aes(x = max_abs_smd, y = 表示名),
    inherit.aes = FALSE, shape = 21, fill = "white", size = 2.5, stroke = 0.8
  ) +
  ggplot2::labs(x = "条件間の絶対標準化平均差（|SMD|）", y = NULL,
                subtitle = "実験3（2026年）：各点は条件ペア、白抜き点は最大絶対SMD") +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C7

表C9は図C7の各点に対応する。

表C9 <- 実験3SMD %>%
  dplyr::transmute(
    変数 = label,
    比較 = paste0(condition_a, "選択肢条件－", condition_b, "選択肢条件"),
    `前者の平均` = round(mean_a, 3),
    `後者の平均` = round(mean_b, 3),
    `前者N` = n_a,
    `後者N` = n_b,
    SMD = round(smd, 3),
    `|SMD|` = round(abs_smd, 3)
  )
knitr::kable(表日本語(表C9), format = "html", row.names = FALSE)

変数	比較	前者の平均	後者の平均	前者N	後者N	SMD	|SMD|
年齢	2選択肢条件－3選択肢条件	41.246	42.353	716	939	-0.097	0.097
年齢：欠損	2選択肢条件－3選択肢条件	0.052	0.052	716	939	-0.002	0.002
4年制大学以上	2選択肢条件－3選択肢条件	0.609	0.600	716	939	0.019	0.019
学歴：欠損	2選択肢条件－3選択肢条件	0.007	0.009	716	939	-0.018	0.018
女性	2選択肢条件－3選択肢条件	0.246	0.298	716	939	-0.118	0.118
性別：欠損	2選択肢条件－3選択肢条件	0.020	0.012	716	939	0.063	0.063
世帯年収（対数）	2選択肢条件－3選択肢条件	5.919	6.034	716	939	-0.079	0.079
支持政党：その他	2選択肢条件－3選択肢条件	0.003	0.002	716	939	0.013	0.013
支持政党：れいわ新選組	2選択肢条件－3選択肢条件	0.015	0.013	716	939	0.022	0.022
支持政党：わからない	2選択肢条件－3選択肢条件	0.038	0.049	716	939	-0.055	0.055
支持政党：チームみらい	2選択肢条件－3選択肢条件	0.042	0.040	716	939	0.007	0.007
支持政党：中道改革連合	2選択肢条件－3選択肢条件	0.032	0.024	716	939	0.046	0.046
支持政党：公明党	2選択肢条件－3選択肢条件	0.011	0.011	716	939	0.005	0.005
支持政党：参政党	2選択肢条件－3選択肢条件	0.042	0.049	716	939	-0.034	0.034
支持政党：国民民主党	2選択肢条件－3選択肢条件	0.068	0.081	716	939	-0.048	0.048
支持政党：支持政党なし	2選択肢条件－3選択肢条件	0.365	0.357	716	939	0.016	0.016
支持政党：日本保守党	2選択肢条件－3選択肢条件	0.025	0.015	716	939	0.073	0.073
支持政党：日本共産党	2選択肢条件－3選択肢条件	0.022	0.014	716	939	0.064	0.064
支持政党：日本維新の会	2選択肢条件－3選択肢条件	0.053	0.049	716	939	0.019	0.019
支持政党：社会民主党	2選択肢条件－3選択肢条件	0.003	0.003	716	939	-0.007	0.007
支持政党：立憲民主党	2選択肢条件－3選択肢条件	0.036	0.040	716	939	-0.022	0.022
支持政党：答えたくない	2選択肢条件－3選択肢条件	0.017	0.019	716	939	-0.018	0.018
支持政党：自由民主党	2選択肢条件－3選択肢条件	0.228	0.233	716	939	-0.013	0.013
地域：17	2選択肢条件－3選択肢条件	0.145	0.153	716	939	-0.023	0.023
地域：27	2選択肢条件－3選択肢条件	0.214	0.201	716	939	0.031	0.031
地域：35	2選択肢条件－3選択肢条件	0.085	0.085	716	939	0.000	0.000
地域：45	2選択肢条件－3選択肢条件	0.087	0.081	716	939	0.020	0.020
地域：9	2選択肢条件－3選択肢条件	0.383	0.396	716	939	-0.028	0.028
左右自己位置づけ	2選択肢条件－3選択肢条件	5.430	5.384	716	939	0.025	0.025
左右自己位置づけ：欠損	2選択肢条件－3選択肢条件	0.080	0.096	716	939	-0.057	0.057
年齢	2選択肢条件－4選択肢条件	41.246	42.935	716	1063	-0.145	0.145
年齢：欠損	2選択肢条件－4選択肢条件	0.052	0.047	716	1063	0.021	0.021
4年制大学以上	2選択肢条件－4選択肢条件	0.609	0.583	716	1063	0.052	0.052
学歴：欠損	2選択肢条件－4選択肢条件	0.007	0.008	716	1063	-0.006	0.006
女性	2選択肢条件－4選択肢条件	0.246	0.285	716	1063	-0.089	0.089
性別：欠損	2選択肢条件－4選択肢条件	0.020	0.014	716	1063	0.042	0.042
世帯年収（対数）	2選択肢条件－4選択肢条件	5.919	5.964	716	1063	-0.030	0.030
支持政党：その他	2選択肢条件－4選択肢条件	0.003	0.001	716	1063	0.043	0.043
支持政党：れいわ新選組	2選択肢条件－4選択肢条件	0.015	0.014	716	1063	0.010	0.010
支持政党：わからない	2選択肢条件－4選択肢条件	0.038	0.040	716	1063	-0.014	0.014
支持政党：チームみらい	2選択肢条件－4選択肢条件	0.042	0.048	716	1063	-0.029	0.029
支持政党：中道改革連合	2選択肢条件－4選択肢条件	0.032	0.032	716	1063	0.001	0.001
支持政党：公明党	2選択肢条件－4選択肢条件	0.011	0.009	716	1063	0.017	0.017
支持政党：参政党	2選択肢条件－4選択肢条件	0.042	0.040	716	1063	0.012	0.012
支持政党：国民民主党	2選択肢条件－4選択肢条件	0.068	0.066	716	1063	0.010	0.010
支持政党：支持政党なし	2選択肢条件－4選択肢条件	0.365	0.348	716	1063	0.034	0.034
支持政党：日本保守党	2選択肢条件－4選択肢条件	0.025	0.024	716	1063	0.011	0.011
支持政党：日本共産党	2選択肢条件－4選択肢条件	0.022	0.021	716	1063	0.011	0.011
支持政党：日本維新の会	2選択肢条件－4選択肢条件	0.053	0.060	716	1063	-0.031	0.031
支持政党：社会民主党	2選択肢条件－4選択肢条件	0.003	0.004	716	1063	-0.017	0.017
支持政党：立憲民主党	2選択肢条件－4選択肢条件	0.036	0.035	716	1063	0.008	0.008
支持政党：答えたくない	2選択肢条件－4選択肢条件	0.017	0.020	716	1063	-0.022	0.022
支持政党：自由民主党	2選択肢条件－4選択肢条件	0.228	0.239	716	1063	-0.027	0.027
地域：17	2選択肢条件－4選択肢条件	0.145	0.165	716	1063	-0.054	0.054
地域：27	2選択肢条件－4選択肢条件	0.214	0.200	716	1063	0.033	0.033
地域：35	2選択肢条件－4選択肢条件	0.085	0.092	716	1063	-0.025	0.025
地域：45	2選択肢条件－4選択肢条件	0.087	0.073	716	1063	0.049	0.049
地域：9	2選択肢条件－4選択肢条件	0.383	0.365	716	1063	0.037	0.037
左右自己位置づけ	2選択肢条件－4選択肢条件	5.430	5.373	716	1063	0.031	0.031
左右自己位置づけ：欠損	2選択肢条件－4選択肢条件	0.080	0.076	716	1063	0.013	0.013
年齢	2選択肢条件－5選択肢条件	41.246	43.582	716	1314	-0.203	0.203
年齢：欠損	2選択肢条件－5選択肢条件	0.052	0.042	716	1314	0.046	0.046
4年制大学以上	2選択肢条件－5選択肢条件	0.609	0.561	716	1314	0.098	0.098
学歴：欠損	2選択肢条件－5選択肢条件	0.007	0.010	716	1314	-0.032	0.032
女性	2選択肢条件－5選択肢条件	0.246	0.271	716	1314	-0.057	0.057
性別：欠損	2選択肢条件－5選択肢条件	0.020	0.015	716	1314	0.033	0.033
世帯年収（対数）	2選択肢条件－5選択肢条件	5.919	5.990	716	1314	-0.050	0.050
支持政党：その他	2選択肢条件－5選択肢条件	0.003	0.003	716	1314	-0.005	0.005
支持政党：れいわ新選組	2選択肢条件－5選択肢条件	0.015	0.018	716	1314	-0.023	0.023
支持政党：わからない	2選択肢条件－5選択肢条件	0.038	0.036	716	1314	0.010	0.010
支持政党：チームみらい	2選択肢条件－5選択肢条件	0.042	0.051	716	1314	-0.043	0.043
支持政党：中道改革連合	2選択肢条件－5選択肢条件	0.032	0.030	716	1314	0.010	0.010
支持政党：公明党	2選択肢条件－5選択肢条件	0.011	0.012	716	1314	-0.009	0.009
支持政党：参政党	2選択肢条件－5選択肢条件	0.042	0.040	716	1314	0.012	0.012
支持政党：国民民主党	2選択肢条件－5選択肢条件	0.068	0.069	716	1314	-0.003	0.003
支持政党：支持政党なし	2選択肢条件－5選択肢条件	0.365	0.340	716	1314	0.051	0.051
支持政党：日本保守党	2選択肢条件－5選択肢条件	0.025	0.024	716	1314	0.005	0.005
支持政党：日本共産党	2選択肢条件－5選択肢条件	0.022	0.021	716	1314	0.012	0.012
支持政党：日本維新の会	2選択肢条件－5選択肢条件	0.053	0.046	716	1314	0.034	0.034
支持政党：社会民主党	2選択肢条件－5選択肢条件	0.003	0.005	716	1314	-0.029	0.029
支持政党：立憲民主党	2選択肢条件－5選択肢条件	0.036	0.048	716	1314	-0.058	0.058
支持政党：答えたくない	2選択肢条件－5選択肢条件	0.017	0.021	716	1314	-0.028	0.028
支持政党：自由民主党	2選択肢条件－5選択肢条件	0.228	0.237	716	1314	-0.021	0.021
地域：17	2選択肢条件－5選択肢条件	0.145	0.170	716	1314	-0.067	0.067
地域：27	2選択肢条件－5選択肢条件	0.214	0.196	716	1314	0.043	0.043
地域：35	2選択肢条件－5選択肢条件	0.085	0.074	716	1314	0.042	0.042
地域：45	2選択肢条件－5選択肢条件	0.087	0.091	716	1314	-0.014	0.014
地域：9	2選択肢条件－5選択肢条件	0.383	0.364	716	1314	0.039	0.039
左右自己位置づけ	2選択肢条件－5選択肢条件	5.430	5.414	716	1314	0.009	0.009
左右自己位置づけ：欠損	2選択肢条件－5選択肢条件	0.080	0.088	716	1314	-0.029	0.029
年齢	3選択肢条件－4選択肢条件	42.353	42.935	939	1063	-0.051	0.051
年齢：欠損	3選択肢条件－4選択肢条件	0.052	0.047	939	1063	0.024	0.024
4年制大学以上	3選択肢条件－4選択肢条件	0.600	0.583	939	1063	0.033	0.033
学歴：欠損	3選択肢条件－4選択肢条件	0.009	0.008	939	1063	0.011	0.011
女性	3選択肢条件－4選択肢条件	0.298	0.285	939	1063	0.029	0.029
性別：欠損	3選択肢条件－4選択肢条件	0.012	0.014	939	1063	-0.021	0.021
世帯年収（対数）	3選択肢条件－4選択肢条件	6.034	5.964	939	1063	0.049	0.049
支持政党：その他	3選択肢条件－4選択肢条件	0.002	0.001	939	1063	0.030	0.030
支持政党：れいわ新選組	3選択肢条件－4選択肢条件	0.013	0.014	939	1063	-0.012	0.012
支持政党：わからない	3選択肢条件－4選択肢条件	0.049	0.040	939	1063	0.041	0.041
支持政党：チームみらい	3選択肢条件－4選択肢条件	0.040	0.048	939	1063	-0.037	0.037
支持政党：中道改革連合	3選択肢条件－4選択肢条件	0.024	0.032	939	1063	-0.045	0.045
支持政党：公明党	3選択肢条件－4選択肢条件	0.011	0.009	939	1063	0.012	0.012
支持政党：参政党	3選択肢条件－4選択肢条件	0.049	0.040	939	1063	0.046	0.046
支持政党：国民民主党	3選択肢条件－4選択肢条件	0.081	0.066	939	1063	0.058	0.058
支持政党：支持政党なし	3選択肢条件－4選択肢条件	0.357	0.348	939	1063	0.018	0.018
支持政党：日本保守党	3選択肢条件－4選択肢条件	0.015	0.024	939	1063	-0.063	0.063
支持政党：日本共産党	3選択肢条件－4選択肢条件	0.014	0.021	939	1063	-0.053	0.053
支持政党：日本維新の会	3選択肢条件－4選択肢条件	0.049	0.060	939	1063	-0.049	0.049
支持政党：社会民主党	3選択肢条件－4選択肢条件	0.003	0.004	939	1063	-0.010	0.010
支持政党：立憲民主党	3選択肢条件－4選択肢条件	0.040	0.035	939	1063	0.030	0.030
支持政党：答えたくない	3選択肢条件－4選択肢条件	0.019	0.020	939	1063	-0.004	0.004
支持政党：自由民主党	3選択肢条件－4選択肢条件	0.233	0.239	939	1063	-0.013	0.013
地域：17	3選択肢条件－4選択肢条件	0.153	0.165	939	1063	-0.031	0.031
地域：27	3選択肢条件－4選択肢条件	0.201	0.200	939	1063	0.002	0.002
地域：35	3選択肢条件－4選択肢条件	0.085	0.092	939	1063	-0.025	0.025
地域：45	3選択肢条件－4選択肢条件	0.081	0.073	939	1063	0.028	0.028
地域：9	3選択肢条件－4選択肢条件	0.396	0.365	939	1063	0.064	0.064
左右自己位置づけ	3選択肢条件－4選択肢条件	5.384	5.373	939	1063	0.006	0.006
左右自己位置づけ：欠損	3選択肢条件－4選択肢条件	0.096	0.076	939	1063	0.070	0.070
年齢	3選択肢条件－5選択肢条件	42.353	43.582	939	1314	-0.108	0.108
年齢：欠損	3選択肢条件－5選択肢条件	0.052	0.042	939	1314	0.049	0.049
4年制大学以上	3選択肢条件－5選択肢条件	0.600	0.561	939	1314	0.078	0.078
学歴：欠損	3選択肢条件－5選択肢条件	0.009	0.010	939	1314	-0.014	0.014
女性	3選択肢条件－5選択肢条件	0.298	0.271	939	1314	0.060	0.060
性別：欠損	3選択肢条件－5選択肢条件	0.012	0.015	939	1314	-0.030	0.030
世帯年収（対数）	3選択肢条件－5選択肢条件	6.034	5.990	939	1314	0.031	0.031
支持政党：その他	3選択肢条件－5選択肢条件	0.002	0.003	939	1314	-0.018	0.018
支持政党：れいわ新選組	3選択肢条件－5選択肢条件	0.013	0.018	939	1314	-0.044	0.044
支持政党：わからない	3選択肢条件－5選択肢条件	0.049	0.036	939	1314	0.066	0.066
支持政党：チームみらい	3選択肢条件－5選択肢条件	0.040	0.051	939	1314	-0.050	0.050
支持政党：中道改革連合	3選択肢条件－5選択肢条件	0.024	0.030	939	1314	-0.036	0.036
支持政党：公明党	3選択肢条件－5選択肢条件	0.011	0.012	939	1314	-0.014	0.014
支持政党：参政党	3選択肢条件－5選択肢条件	0.049	0.040	939	1314	0.046	0.046
支持政党：国民民主党	3選択肢条件－5選択肢条件	0.081	0.069	939	1314	0.044	0.044
支持政党：支持政党なし	3選択肢条件－5選択肢条件	0.357	0.340	939	1314	0.035	0.035
支持政党：日本保守党	3選択肢条件－5選択肢条件	0.015	0.024	939	1314	-0.068	0.068
支持政党：日本共産党	3選択肢条件－5選択肢条件	0.014	0.021	939	1314	-0.052	0.052
支持政党：日本維新の会	3選択肢条件－5選択肢条件	0.049	0.046	939	1314	0.016	0.016
支持政党：社会民主党	3選択肢条件－5選択肢条件	0.003	0.005	939	1314	-0.022	0.022
支持政党：立憲民主党	3選択肢条件－5選択肢条件	0.040	0.048	939	1314	-0.036	0.036
支持政党：答えたくない	3選択肢条件－5選択肢条件	0.019	0.021	939	1314	-0.010	0.010
支持政党：自由民主党	3選択肢条件－5選択肢条件	0.233	0.237	939	1314	-0.008	0.008
地域：17	3選択肢条件－5選択肢条件	0.153	0.170	939	1314	-0.044	0.044
地域：27	3選択肢条件－5選択肢条件	0.201	0.196	939	1314	0.012	0.012
地域：35	3選択肢条件－5選択肢条件	0.085	0.074	939	1314	0.042	0.042
地域：45	3選択肢条件－5選択肢条件	0.081	0.091	939	1314	-0.034	0.034
地域：9	3選択肢条件－5選択肢条件	0.396	0.364	939	1314	0.067	0.067
左右自己位置づけ	3選択肢条件－5選択肢条件	5.384	5.414	939	1314	-0.017	0.017
左右自己位置づけ：欠損	3選択肢条件－5選択肢条件	0.096	0.088	939	1314	0.029	0.029
年齢	4選択肢条件－5選択肢条件	42.935	43.582	1063	1314	-0.056	0.056
年齢：欠損	4選択肢条件－5選択肢条件	0.047	0.042	1063	1314	0.025	0.025
4年制大学以上	4選択肢条件－5選択肢条件	0.583	0.561	1063	1314	0.045	0.045
学歴：欠損	4選択肢条件－5選択肢条件	0.008	0.010	1063	1314	-0.025	0.025
女性	4選択肢条件－5選択肢条件	0.285	0.271	1063	1314	0.031	0.031
性別：欠損	4選択肢条件－5選択肢条件	0.014	0.015	1063	1314	-0.009	0.009
世帯年収（対数）	4選択肢条件－5選択肢条件	5.964	5.990	1063	1314	-0.019	0.019
支持政党：その他	4選択肢条件－5選択肢条件	0.001	0.003	1063	1314	-0.047	0.047
支持政党：れいわ新選組	4選択肢条件－5選択肢条件	0.014	0.018	1063	1314	-0.033	0.033
支持政党：わからない	4選択肢条件－5選択肢条件	0.040	0.036	1063	1314	0.024	0.024
支持政党：チームみらい	4選択肢条件－5選択肢条件	0.048	0.051	1063	1314	-0.014	0.014
支持政党：中道改革連合	4選択肢条件－5選択肢条件	0.032	0.030	1063	1314	0.009	0.009
支持政党：公明党	4選択肢条件－5選択肢条件	0.009	0.012	1063	1314	-0.027	0.027
支持政党：参政党	4選択肢条件－5選択肢条件	0.040	0.040	1063	1314	0.000	0.000
支持政党：国民民主党	4選択肢条件－5選択肢条件	0.066	0.069	1063	1314	-0.014	0.014
支持政党：支持政党なし	4選択肢条件－5選択肢条件	0.348	0.340	1063	1314	0.017	0.017
支持政党：日本保守党	4選択肢条件－5選択肢条件	0.024	0.024	1063	1314	-0.005	0.005
支持政党：日本共産党	4選択肢条件－5選択肢条件	0.021	0.021	1063	1314	0.001	0.001
支持政党：日本維新の会	4選択肢条件－5選択肢条件	0.060	0.046	1063	1314	0.065	0.065
支持政党：社会民主党	4選択肢条件－5選択肢条件	0.004	0.005	1063	1314	-0.012	0.012
支持政党：立憲民主党	4選択肢条件－5選択肢条件	0.035	0.048	1063	1314	-0.066	0.066
支持政党：答えたくない	4選択肢条件－5選択肢条件	0.020	0.021	1063	1314	-0.006	0.006
支持政党：自由民主党	4選択肢条件－5選択肢条件	0.239	0.237	1063	1314	0.005	0.005
地域：17	4選択肢条件－5選択肢条件	0.165	0.170	1063	1314	-0.014	0.014
地域：27	4選択肢条件－5選択肢条件	0.200	0.196	1063	1314	0.010	0.010
地域：35	4選択肢条件－5選択肢条件	0.092	0.074	1063	1314	0.067	0.067
地域：45	4選択肢条件－5選択肢条件	0.073	0.091	1063	1314	-0.063	0.063
地域：9	4選択肢条件－5選択肢条件	0.365	0.364	1063	1314	0.003	0.003
左右自己位置づけ	4選択肢条件－5選択肢条件	5.373	5.414	1063	1314	-0.022	0.022
左右自己位置づけ：欠損	4選択肢条件－5選択肢条件	0.076	0.088	1063	1314	-0.041	0.041

図C8：条件平均の45度線診断

図C8は図C7と同じ回答者レベルの割付バランスを、各共変量の条件平均を標準化したうえで2条件ずつ45度線と比較したものである。

対角線データ <- assignment_balance_results$study3$diagonal_data %>%
  dplyr::mutate(
    比較 = paste0(condition_a, "選択肢条件－", condition_b, "選択肢条件")
  )

ラベル対象 <- 対角線データ %>%
  dplyr::group_by(比較) %>%
  dplyr::slice_max(abs_diagonal_deviation, n = 3, with_ties = FALSE) %>%
  dplyr::ungroup()

軸範囲 <- max(abs(c(対角線データ$x_mean, 対角線データ$y_mean)), na.rm = TRUE)
軸範囲 <- max(0.10, 軸範囲 * 1.15)

図C8 <- ggplot2::ggplot(対角線データ, ggplot2::aes(x = x_mean, y = y_mean)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.60) +
  ggplot2::geom_hline(yintercept = 0, linewidth = 0.25) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.25) +
  ggplot2::geom_point(shape = 21, fill = "white", size = 2.2) +
  ggplot2::geom_text(data = ラベル対象, ggplot2::aes(label = label), size = 2.6, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 比較, ncol = 3) +
  ggplot2::coord_equal(xlim = c(-軸範囲, 軸範囲), ylim = c(-軸範囲, 軸範囲)) +
  ggplot2::labs(x = "左側条件の標準化共変量平均", y = "右側条件の標準化共変量平均") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
図C8

表C10 <- assignment_balance_results$study3$summary %>%
  dplyr::transmute(
    変数 = label,
    `2選択肢条件の平均` = round(mean_condition_2, 3),
    `3選択肢条件の平均` = round(mean_condition_3, 3),
    `4選択肢条件の平均` = round(mean_condition_4, 3),
    `5選択肢条件の平均` = round(mean_condition_5, 3),
    `最大|SMD|` = round(max_abs_smd, 3),
    `Holm補正p値` = signif(p_holm, 3)
  )
knitr::kable(表日本語(表C10), format = "html", row.names = FALSE)

変数	2選択肢条件の平均	3選択肢条件の平均	4選択肢条件の平均	5選択肢条件の平均	最大|SMD|	Holm補正p値
年齢	41.246	42.353	42.935	43.582	0.203	0.00415
女性	0.246	0.298	0.285	0.271	0.118	1.00000
4年制大学以上	0.609	0.600	0.583	0.561	0.098	1.00000
世帯年収（対数）	5.919	6.034	5.964	5.990	0.079	1.00000
支持政党：日本保守党	0.025	0.015	0.024	0.024	0.073	1.00000
左右自己位置づけ：欠損	0.080	0.096	0.076	0.088	0.070	1.00000
地域：17	0.145	0.153	0.165	0.170	0.067	1.00000
地域：9	0.383	0.396	0.365	0.364	0.067	1.00000
地域：35	0.085	0.085	0.092	0.074	0.067	1.00000
支持政党：立憲民主党	0.036	0.040	0.035	0.048	0.066	1.00000
支持政党：わからない	0.038	0.049	0.040	0.036	0.066	1.00000
支持政党：日本維新の会	0.053	0.049	0.060	0.046	0.065	1.00000
支持政党：日本共産党	0.022	0.014	0.021	0.021	0.064	1.00000
性別：欠損	0.020	0.012	0.014	0.015	0.063	1.00000
地域：45	0.087	0.081	0.073	0.091	0.063	1.00000
支持政党：国民民主党	0.068	0.081	0.066	0.069	0.058	1.00000
支持政党：支持政党なし	0.365	0.357	0.348	0.340	0.051	1.00000
支持政党：チームみらい	0.042	0.040	0.048	0.051	0.050	1.00000
年齢：欠損	0.052	0.052	0.047	0.042	0.049	1.00000
支持政党：その他	0.003	0.002	0.001	0.003	0.047	1.00000
支持政党：参政党	0.042	0.049	0.040	0.040	0.046	1.00000
支持政党：中道改革連合	0.032	0.024	0.032	0.030	0.046	1.00000
支持政党：れいわ新選組	0.015	0.013	0.014	0.018	0.044	1.00000
地域：27	0.214	0.201	0.200	0.196	0.043	1.00000
学歴：欠損	0.007	0.009	0.008	0.010	0.032	1.00000
左右自己位置づけ	5.430	5.384	5.373	5.414	0.031	1.00000
支持政党：社会民主党	0.003	0.003	0.004	0.005	0.029	1.00000
支持政党：答えたくない	0.017	0.019	0.020	0.021	0.028	1.00000
支持政党：公明党	0.011	0.011	0.009	0.012	0.027	1.00000
支持政党：自由民主党	0.228	0.233	0.239	0.237	0.027	1.00000

図C9：プロフィール属性水準の無作為提示

図C9は回答者の条件割付ではなく、各コンジョイント課題内で属性水準が設計どおり一様に提示されているかを確認するものである。

属性頻度 <- profile_randomization_results$study3$frequency %>%
  dplyr::mutate(
    属性 = 属性日本語(attribute),
    条件 = 条件日本語(party_n, "study3")
  )

表示ラベル <- 属性頻度 %>%
  dplyr::group_by(属性, 条件) %>%
  dplyr::slice_max(abs_deviation, n = 2, with_ties = FALSE) %>%
  dplyr::ungroup()

図C9 <- ggplot2::ggplot(属性頻度, ggplot2::aes(x = expected_share, y = observed_share, shape = 条件)) +
  ggplot2::geom_abline(intercept = 0, slope = 1, linetype = "dashed", linewidth = 0.65) +
  ggplot2::geom_point(size = 2.2, fill = "white") +
  ggplot2::geom_text(data = 表示ラベル, ggplot2::aes(label = level), size = 2.4, check_overlap = TRUE, vjust = -0.7) +
  ggplot2::facet_wrap(~ 属性, ncol = 3) +
  ggplot2::coord_equal() +
  ggplot2::labs(x = "設計上の期待比率", y = "観測比率", shape = "条件") +
  ggplot2::theme_bw(base_size = 10.5) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), legend.position = "bottom")
図C9

表C11 <- profile_randomization_results$study3$uniformity_tests %>%
  dplyr::transmute(
    条件 = 条件日本語(party_n, "study3"),
    属性 = 属性日本語(attribute),
    `カイ二乗値` = round(chi_square, 3),
    自由度 = df,
    p値 = signif(p_value, 3),
    `Holm補正p値` = signif(p_holm, 3),
    `最大絶対比率差` = round(max_abs_share_deviation, 4)
  )
knitr::kable(表日本語(表C11), format = "html", row.names = FALSE)

条件	属性	カイ二乗値	自由度	p値	Holm補正p値	最大絶対比率差
2選択肢条件	消費者物価指数（CPI）	0.000	2	1.000	1	0.0001
2選択肢条件	GDP成長率	1.386	2	0.500	1	0.0060
2選択肢条件	日経平均株価	0.555	2	0.758	1	0.0041
2選択肢条件	政党名	5.126	9	0.823	1	0.0056
2選択肢条件	失業率	1.668	2	0.434	1	0.0065
3選択肢条件	消費者物価指数（CPI）	0.545	2	0.762	1	0.0027
3選択肢条件	GDP成長率	0.073	2	0.964	1	0.0011
3選択肢条件	日経平均株価	0.833	2	0.659	1	0.0035
3選択肢条件	政党名	6.035	9	0.736	1	0.0031
3選択肢条件	失業率	2.016	2	0.365	1	0.0054
4選択肢条件	消費者物価指数（CPI）	2.607	2	0.272	1	0.0046
4選択肢条件	GDP成長率	0.104	2	0.949	1	0.0010
4選択肢条件	日経平均株価	3.268	2	0.195	1	0.0056
4選択肢条件	政党名	5.990	9	0.741	1	0.0031
4選択肢条件	失業率	0.107	2	0.948	1	0.0009
5選択肢条件	消費者物価指数（CPI）	0.879	2	0.644	1	0.0024
5選択肢条件	GDP成長率	0.107	2	0.948	1	0.0008
5選択肢条件	日経平均株価	2.946	2	0.229	1	0.0044
5選択肢条件	政党名	3.828	9	0.922	1	0.0020
5選択肢条件	失業率	5.593	2	0.061	1	0.0055

表C12 <- 属性頻度 %>%
  dplyr::transmute(
    条件,
    属性,
    水準 = level,
    観測数 = observed_n,
    総数 = total_n,
    観測比率 = round(observed_share, 4),
    期待比率 = round(expected_share, 4),
    差 = round(deviation, 4)
  )
knitr::kable(表日本語(表C12), format = "html", row.names = FALSE)

条件	属性	水準	観測数	総数	観測比率	期待比率	差
2選択肢条件	消費者物価指数（CPI）	CPI前期比±0ポイント	2387	7160	0.3334	0.3333	0.0000
2選択肢条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	2387	7160	0.3334	0.3333	0.0000
2選択肢条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	2386	7160	0.3332	0.3333	-0.0001
2選択肢条件	GDP成長率	GDP成長率±0％	2344	7160	0.3274	0.3333	-0.0060
2選択肢条件	GDP成長率	GDP成長率プラス1％	2425	7160	0.3387	0.3333	0.0054
2選択肢条件	GDP成長率	GDP成長率マイナス1％	2391	7160	0.3339	0.3333	0.0006
2選択肢条件	日経平均株価	日経平均前月同期比プラス1000円	2357	7160	0.3292	0.3333	-0.0041
2選択肢条件	日経平均株価	日経平均前月同期比マイナス1000円	2400	7160	0.3352	0.3333	0.0019
2選択肢条件	日経平均株価	日経平均前月同期比変わらず	2403	7160	0.3356	0.3333	0.0023
2選択肢条件	政党名	れいわ新選組	676	7160	0.0944	0.1000	-0.0056
2選択肢条件	政党名	チームみらい	730	7160	0.1020	0.1000	0.0020
2選択肢条件	政党名	中道改革連合	728	7160	0.1017	0.1000	0.0017
2選択肢条件	政党名	公明党	700	7160	0.0978	0.1000	-0.0022
2選択肢条件	政党名	参政党	746	7160	0.1042	0.1000	0.0042
2選択肢条件	政党名	国民民主党	703	7160	0.0982	0.1000	-0.0018
2選択肢条件	政党名	日本共産党	708	7160	0.0989	0.1000	-0.0011
2選択肢条件	政党名	日本維新の会	734	7160	0.1025	0.1000	0.0025
2選択肢条件	政党名	立憲民主党	720	7160	0.1006	0.1000	0.0006
2選択肢条件	政党名	自由民主党	715	7160	0.0999	0.1000	-0.0001
2選択肢条件	失業率	失業率前期比±0％	2433	7160	0.3398	0.3333	0.0065
2選択肢条件	失業率	失業率前期比プラス1％	2383	7160	0.3328	0.3333	-0.0005
2選択肢条件	失業率	失業率前期比マイナス1％	2344	7160	0.3274	0.3333	-0.0060
3選択肢条件	消費者物価指数（CPI）	CPI前期比±0ポイント	4728	14085	0.3357	0.3333	0.0023
3選択肢条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	4700	14085	0.3337	0.3333	0.0004
3選択肢条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	4657	14085	0.3306	0.3333	-0.0027
3選択肢条件	GDP成長率	GDP成長率±0％	4704	14085	0.3340	0.3333	0.0006
3選択肢条件	GDP成長率	GDP成長率プラス1％	4701	14085	0.3338	0.3333	0.0004
3選択肢条件	GDP成長率	GDP成長率マイナス1％	4680	14085	0.3323	0.3333	-0.0011
3選択肢条件	日経平均株価	日経平均前月同期比プラス1000円	4661	14085	0.3309	0.3333	-0.0024
3選択肢条件	日経平均株価	日経平均前月同期比マイナス1000円	4679	14085	0.3322	0.3333	-0.0011
3選択肢条件	日経平均株価	日経平均前月同期比変わらず	4745	14085	0.3369	0.3333	0.0035
3選択肢条件	政党名	れいわ新選組	1388	14085	0.0985	0.1000	-0.0015
3選択肢条件	政党名	チームみらい	1403	14085	0.0996	0.1000	-0.0004
3選択肢条件	政党名	中道改革連合	1451	14085	0.1030	0.1000	0.0030
3選択肢条件	政党名	公明党	1382	14085	0.0981	0.1000	-0.0019
3選択肢条件	政党名	参政党	1376	14085	0.0977	0.1000	-0.0023
3選択肢条件	政党名	国民民主党	1446	14085	0.1027	0.1000	0.0027
3選択肢条件	政党名	日本共産党	1452	14085	0.1031	0.1000	0.0031
3選択肢条件	政党名	日本維新の会	1413	14085	0.1003	0.1000	0.0003
3選択肢条件	政党名	立憲民主党	1376	14085	0.0977	0.1000	-0.0023
3選択肢条件	政党名	自由民主党	1398	14085	0.0993	0.1000	-0.0007
3選択肢条件	失業率	失業率前期比±0％	4771	14085	0.3387	0.3333	0.0054
3選択肢条件	失業率	失業率前期比プラス1％	4677	14085	0.3321	0.3333	-0.0013
3選択肢条件	失業率	失業率前期比マイナス1％	4637	14085	0.3292	0.3333	-0.0041
4選択肢条件	消費者物価指数（CPI）	CPI前期比±0ポイント	7180	21260	0.3377	0.3333	0.0044
4選択肢条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	6988	21260	0.3287	0.3333	-0.0046
4選択肢条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	7092	21260	0.3336	0.3333	0.0003
4選択肢条件	GDP成長率	GDP成長率±0％	7090	21260	0.3335	0.3333	0.0002
4選択肢条件	GDP成長率	GDP成長率プラス1％	7104	21260	0.3341	0.3333	0.0008
4選択肢条件	GDP成長率	GDP成長率マイナス1％	7066	21260	0.3324	0.3333	-0.0010
4選択肢条件	日経平均株価	日経平均前月同期比プラス1000円	7057	21260	0.3319	0.3333	-0.0014
4選択肢条件	日経平均株価	日経平均前月同期比マイナス1000円	7206	21260	0.3389	0.3333	0.0056
4選択肢条件	日経平均株価	日経平均前月同期比変わらず	6997	21260	0.3291	0.3333	-0.0042
4選択肢条件	政党名	れいわ新選組	2164	21260	0.1018	0.1000	0.0018
4選択肢条件	政党名	チームみらい	2144	21260	0.1008	0.1000	0.0008
4選択肢条件	政党名	中道改革連合	2079	21260	0.0978	0.1000	-0.0022
4選択肢条件	政党名	公明党	2150	21260	0.1011	0.1000	0.0011
4選択肢条件	政党名	参政党	2126	21260	0.1000	0.1000	0.0000
4選択肢条件	政党名	国民民主党	2115	21260	0.0995	0.1000	-0.0005
4選択肢条件	政党名	日本共産党	2184	21260	0.1027	0.1000	0.0027
4選択肢条件	政党名	日本維新の会	2108	21260	0.0992	0.1000	-0.0008
4選択肢条件	政党名	立憲民主党	2060	21260	0.0969	0.1000	-0.0031
4選択肢条件	政党名	自由民主党	2130	21260	0.1002	0.1000	0.0002
4選択肢条件	失業率	失業率前期比±0％	7067	21260	0.3324	0.3333	-0.0009
4選択肢条件	失業率	失業率前期比プラス1％	7087	21260	0.3333	0.3333	0.0000
4選択肢条件	失業率	失業率前期比マイナス1％	7106	21260	0.3342	0.3333	0.0009
5選択肢条件	消費者物価指数（CPI）	CPI前期比±0ポイント	10978	32850	0.3342	0.3333	0.0009
5選択肢条件	消費者物価指数（CPI）	CPI前期比プラス1ポイント	11001	32850	0.3349	0.3333	0.0016
5選択肢条件	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	10871	32850	0.3309	0.3333	-0.0024
5選択肢条件	GDP成長率	GDP成長率±0％	10924	32850	0.3325	0.3333	-0.0008
5選択肢条件	GDP成長率	GDP成長率プラス1％	10954	32850	0.3335	0.3333	0.0001
5選択肢条件	GDP成長率	GDP成長率マイナス1％	10972	32850	0.3340	0.3333	0.0007
5選択肢条件	日経平均株価	日経平均前月同期比プラス1000円	11046	32850	0.3363	0.3333	0.0029
5選択肢条件	日経平均株価	日経平均前月同期比マイナス1000円	10806	32850	0.3289	0.3333	-0.0044
5選択肢条件	日経平均株価	日経平均前月同期比変わらず	10998	32850	0.3348	0.3333	0.0015
5選択肢条件	政党名	れいわ新選組	3277	32850	0.0998	0.1000	-0.0002
5選択肢条件	政党名	チームみらい	3351	32850	0.1020	0.1000	0.0020
5選択肢条件	政党名	中道改革連合	3311	32850	0.1008	0.1000	0.0008
5選択肢条件	政党名	公明党	3243	32850	0.0987	0.1000	-0.0013
5選択肢条件	政党名	参政党	3280	32850	0.0998	0.1000	-0.0002
5選択肢条件	政党名	国民民主党	3315	32850	0.1009	0.1000	0.0009
5選択肢条件	政党名	日本共産党	3271	32850	0.0996	0.1000	-0.0004
5選択肢条件	政党名	日本維新の会	3218	32850	0.0980	0.1000	-0.0020
5選択肢条件	政党名	立憲民主党	3290	32850	0.1002	0.1000	0.0002
5選択肢条件	政党名	自由民主党	3294	32850	0.1003	0.1000	0.0003
5選択肢条件	失業率	失業率前期比±0％	10965	32850	0.3338	0.3333	0.0005
5選択肢条件	失業率	失業率前期比プラス1％	10768	32850	0.3278	0.3333	-0.0055
5選択肢条件	失業率	失業率前期比マイナス1％	11117	32850	0.3384	0.3333	0.0051

C.4 標本減少とスクリーニング

実験1（2023年）

実験1標本減少 <- readr::read_csv(study_csv("study1", "table_sample_attrition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(
    段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))
  ) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験1標本減少, format = "html", row.names = FALSE, caption = "表C13：実験1の標本減少")

表C13：実験1の標本減少

順序	段階	質問・変数	残存N	当該段階での除外N	前段階からの残存率（%）	初期標本からの残存率（%）
1	Qualtricsの質問文・ImportId行を除外	ResponseId	3826	0	100	100
2	初回同意	Q1.1	3730	96	97.5	97.5
3	割付されたコンジョイント・ブロックに到達	Q3.1/Q4.1/Q5.1/Q6.1 または最初の選択課題	3426	304	91.8	89.5
4	選択課題1を有効回答	条件別 choice task 1	3426	0	100	89.5
5	選択課題2を有効回答	条件別 choice task 2	3417	9	99.7	89.3
6	選択課題3を有効回答	条件別 choice task 3	3412	5	99.9	89.2
7	選択課題4を有効回答	条件別 choice task 4	3410	2	99.9	89.1
8	選択課題5を有効回答	条件別 choice task 5	3407	3	99.9	89
9	最終送信同意	Q10.1	3382	25	99.3	88.4
10	最終分析標本	全基準の積集合	3382	0	100	88.4

実験1条件別標本 <- readr::read_csv(study_csv("study1", "table_sample_attrition_by_condition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(
    条件 = 条件日本語(条件, "study1"),
    段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))
  ) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験1条件別標本, format = "html", row.names = FALSE, caption = "表C14：実験1の条件別標本減少")

表C14：実験1の条件別標本減少

条件	順序	段階	残存N	当該段階での除外N	条件開始時からの残存率（%）
2政党条件	1	割付条件を識別	821	0	100
2政党条件	2	選択課題1	821	0	100
2政党条件	3	選択課題2	821	0	100
2政党条件	4	選択課題3	820	1	99.9
2政党条件	5	選択課題4	820	0	99.9
2政党条件	6	選択課題5	820	0	99.9
2政党条件	7	最終送信同意	815	5	99.3
2政党条件	8	最終分析標本	815	0	99.3
3政党条件	1	割付条件を識別	855	0	100
3政党条件	2	選択課題1	855	0	100
3政党条件	3	選択課題2	852	3	99.6
3政党条件	4	選択課題3	851	1	99.5
3政党条件	5	選択課題4	850	1	99.4
3政党条件	6	選択課題5	849	1	99.3
3政党条件	7	最終送信同意	843	6	98.6
3政党条件	8	最終分析標本	843	0	98.6
4政党条件	1	割付条件を識別	894	0	100
4政党条件	2	選択課題1	894	0	100
4政党条件	3	選択課題2	891	3	99.7
4政党条件	4	選択課題3	889	2	99.4
4政党条件	5	選択課題4	889	0	99.4
4政党条件	6	選択課題5	888	1	99.3
4政党条件	7	最終送信同意	882	6	98.7
4政党条件	8	最終分析標本	882	0	98.7
5政党条件	1	割付条件を識別	856	0	100
5政党条件	2	選択課題1	856	0	100
5政党条件	3	選択課題2	853	3	99.6
5政党条件	4	選択課題3	852	1	99.5
5政党条件	5	選択課題4	851	1	99.4
5政党条件	6	選択課題5	850	1	99.3
5政党条件	7	最終送信同意	842	8	98.4
5政党条件	8	最終分析標本	842	0	98.4

実験2（2026年）

実験2標本減少 <- readr::read_csv(study_csv("study2", "table_sample_attrition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験2標本減少, format = "html", row.names = FALSE, caption = "表C17：実験2の標本減少")

表C17：実験2の標本減少

順序	段階	質問・変数	残存N	当該段階での除外N	前段階からの残存率（%）	初期標本からの残存率（%）
1	Qualtricsの質問文・ImportId行を除外	ResponseId	7365	0	100	100
2	初回同意	Q1.1	7114	251	96.6	96.6
3	割付されたコンジョイント・ブロックに到達	Q3.1/Q4.1/Q5.1/Q6.1 または最初の選択課題	7113	1	100	96.6
4	選択課題1を有効回答	条件別 choice task 1	7113	0	100	96.6
5	選択課題2を有効回答	条件別 choice task 2	7113	0	100	96.6
6	選択課題3を有効回答	条件別 choice task 3	7113	0	100	96.6
7	選択課題4を有効回答	条件別 choice task 4	7113	0	100	96.6
8	選択課題5を有効回答	条件別 choice task 5	7113	0	100	96.6
9	提示された選択肢数を正答	条件別に自動検出した選択肢数確認質問	4350	2763	61.2	59.1
10	イデオロギー行列の指示項目に正答	Q25.1_10	4241	109	97.5	57.6
11	最終送信同意	Q9.1	4192	49	98.8	56.9
12	最終分析標本	全基準の積集合	4192	0	100	56.9

実験2条件別標本 <- readr::read_csv(study_csv("study2", "table_sample_attrition_by_condition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), 段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験2条件別標本, format = "html", row.names = FALSE, caption = "表C18：実験2の条件別標本減少")

表C18：実験2の条件別標本減少

条件	順序	段階	残存N	当該段階での除外N	条件開始時からの残存率（%）
2政党条件	1	割付条件を識別	1785	0	100
2政党条件	2	選択課題1	1785	0	100
2政党条件	3	選択課題2	1785	0	100
2政党条件	4	選択課題3	1785	0	100
2政党条件	5	選択課題4	1785	0	100
2政党条件	6	選択課題5	1785	0	100
2政党条件	7	選択肢数確認	734	1051	41.1
2政党条件	8	指示項目	716	18	40.1
2政党条件	9	最終送信同意	711	5	39.8
2政党条件	10	最終分析標本	711	0	39.8
3政党条件	1	割付条件を識別	1791	0	100
3政党条件	2	選択課題1	1791	0	100
3政党条件	3	選択課題2	1791	0	100
3政党条件	4	選択課題3	1791	0	100
3政党条件	5	選択課題4	1791	0	100
3政党条件	6	選択課題5	1791	0	100
3政党条件	7	選択肢数確認	1098	693	61.3
3政党条件	8	指示項目	1069	29	59.7
3政党条件	9	最終送信同意	1062	7	59.3
3政党条件	10	最終分析標本	1062	0	59.3
4政党条件	1	割付条件を識別	1741	0	100
4政党条件	2	選択課題1	1741	0	100
4政党条件	3	選択課題2	1741	0	100
4政党条件	4	選択課題3	1741	0	100
4政党条件	5	選択課題4	1741	0	100
4政党条件	6	選択課題5	1741	0	100
4政党条件	7	選択肢数確認	1141	600	65.5
4政党条件	8	指示項目	1113	28	63.9
4政党条件	9	最終送信同意	1097	16	63
4政党条件	10	最終分析標本	1097	0	63
5政党条件	1	割付条件を識別	1796	0	100
5政党条件	2	選択課題1	1796	0	100
5政党条件	3	選択課題2	1796	0	100
5政党条件	4	選択課題3	1796	0	100
5政党条件	5	選択課題4	1796	0	100
5政党条件	6	選択課題5	1796	0	100
5政党条件	7	選択肢数確認	1377	419	76.7
5政党条件	8	指示項目	1343	34	74.8
5政党条件	9	最終送信同意	1322	21	73.6
5政党条件	10	最終分析標本	1322	0	73.6

実験2操作確認 <- readr::read_csv(study_csv("study2", "table_manipulation_check.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", response = "回答", status = "判定", n = "N")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験2操作確認, format = "html", row.names = FALSE, caption = "表C19：実験2の選択肢数操作確認")

表C19：実験2の選択肢数操作確認

条件	回答	正答	N
2政党条件	1	不正答・欠損	29
2政党条件	2	正答	734
2政党条件	3	不正答・欠損	91
2政党条件	4	不正答・欠損	124
2政党条件	5	不正答・欠損	559
2政党条件	6	不正答・欠損	248
3政党条件	1	不正答・欠損	25
3政党条件	2	不正答・欠損	64
3政党条件	3	正答	1098
3政党条件	4	不正答・欠損	66
3政党条件	5	不正答・欠損	329
3政党条件	6	不正答・欠損	209
4政党条件	1	不正答・欠損	30
4政党条件	2	不正答・欠損	46
4政党条件	3	不正答・欠損	49
4政党条件	4	正答	1141
4政党条件	5	不正答・欠損	289
4政党条件	6	不正答・欠損	186
5政党条件	1	不正答・欠損	37
5政党条件	2	不正答・欠損	53
5政党条件	3	不正答・欠損	76
5政党条件	4	不正答・欠損	90
5政党条件	5	正答	1377
5政党条件	6	不正答・欠損	163

実験2指示項目 <- readr::read_csv(study_csv("study2", "table_attention_check.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, response = "回答コード", status = "判定", n = "N")) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験2指示項目, format = "html", row.names = FALSE, caption = "表C20：実験2の指示項目")

表C20：実験2の指示項目

回答	判定	N
1	不正答・欠損	12
12	不正答・欠損	7
13	不正答・欠損	6
14	不正答・欠損	7
15	不正答・欠損	70
16	不正答・欠損	26
2	不正答・欠損	8
3	正答	6842
4	不正答・欠損	24
5	不正答・欠損	12
6	不正答・欠損	83
7	不正答・欠損	12
8	不正答・欠損	6
未実施・欠損	不正答・欠損	250

実験3（2026年）

実験3標本減少 <- readr::read_csv(study_csv("study3", "table_sample_attrition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験3標本減少, format = "html", row.names = FALSE, caption = "表C21：実験3の標本減少")

表C21：実験3の標本減少

順序	段階	質問・変数	残存N	当該段階での除外N	前段階からの残存率（%）	初期標本からの残存率（%）
1	Qualtricsの質問文・ImportId行を除外	ResponseId	7012	0	100	100
2	初回同意	Q1.1	6852	160	97.7	97.7
3	割付されたコンジョイント・ブロックに到達	Q3.1/Q4.1/Q5.1/Q6.1 または最初の選択課題	6852	0	100	97.7
4	選択課題1を有効回答	条件別 choice task 1	6852	0	100	97.7
5	選択課題2を有効回答	条件別 choice task 2	6852	0	100	97.7
6	選択課題3を有効回答	条件別 choice task 3	6852	0	100	97.7
7	選択課題4を有効回答	条件別 choice task 4	6852	0	100	97.7
8	選択課題5を有効回答	条件別 choice task 5	6852	0	100	97.7
9	提示された選択肢数を正答	条件別に自動検出した選択肢数確認質問	4184	2668	61.1	59.7
10	イデオロギー行列の指示項目に正答	Q25.1_10	4053	131	96.9	57.8
11	最終送信同意	Q8.1	4032	21	99.5	57.5
12	最終分析標本	全基準の積集合	4032	0	100	57.5

実験3条件別標本 <- readr::read_csv(study_csv("study3", "table_sample_attrition_by_condition.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), 段階 = stringr::str_replace_all(段階, c("choice_task([1-5])" = "選択課題\\1", "Choice task ([1-5])" = "選択課題\\1"))) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験3条件別標本, format = "html", row.names = FALSE, caption = "表C22：実験3の条件別標本減少")

表C22：実験3の条件別標本減少

条件	順序	段階	残存N	当該段階での除外N	条件開始時からの残存率（%）
2選択肢条件	1	割付条件を識別	1684	0	100
2選択肢条件	2	選択課題1	1684	0	100
2選択肢条件	3	選択課題2	1684	0	100
2選択肢条件	4	選択課題3	1684	0	100
2選択肢条件	5	選択課題4	1684	0	100
2選択肢条件	6	選択課題5	1684	0	100
2選択肢条件	7	選択肢数確認	741	943	44
2選択肢条件	8	指示項目	721	20	42.8
2選択肢条件	9	最終送信同意	716	5	42.5
2選択肢条件	10	最終分析標本	716	0	42.5
3選択肢条件	1	割付条件を識別	1769	0	100
3選択肢条件	2	選択課題1	1769	0	100
3選択肢条件	3	選択課題2	1769	0	100
3選択肢条件	4	選択課題3	1769	0	100
3選択肢条件	5	選択課題4	1769	0	100
3選択肢条件	6	選択課題5	1769	0	100
3選択肢条件	7	選択肢数確認	982	787	55.5
3選択肢条件	8	指示項目	944	38	53.4
3選択肢条件	9	最終送信同意	939	5	53.1
3選択肢条件	10	最終分析標本	939	0	53.1
4選択肢条件	1	割付条件を識別	1722	0	100
4選択肢条件	2	選択課題1	1722	0	100
4選択肢条件	3	選択課題2	1722	0	100
4選択肢条件	4	選択課題3	1722	0	100
4選択肢条件	5	選択課題4	1722	0	100
4選択肢条件	6	選択課題5	1722	0	100
4選択肢条件	7	選択肢数確認	1099	623	63.8
4選択肢条件	8	指示項目	1064	35	61.8
4選択肢条件	9	最終送信同意	1063	1	61.7
4選択肢条件	10	最終分析標本	1063	0	61.7
5選択肢条件	1	割付条件を識別	1677	0	100
5選択肢条件	2	選択課題1	1677	0	100
5選択肢条件	3	選択課題2	1677	0	100
5選択肢条件	4	選択課題3	1677	0	100
5選択肢条件	5	選択課題4	1677	0	100
5選択肢条件	6	選択課題5	1677	0	100
5選択肢条件	7	選択肢数確認	1362	315	81.2
5選択肢条件	8	指示項目	1324	38	79
5選択肢条件	9	最終送信同意	1314	10	78.4
5選択肢条件	10	最終分析標本	1314	0	78.4

実験3操作確認 <- readr::read_csv(study_csv("study3", "table_manipulation_check.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", response = "回答", status = "判定", n = "N")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験3操作確認, format = "html", row.names = FALSE, caption = "表C23：実験3の選択肢数操作確認")

表C23：実験3の選択肢数操作確認

条件	回答	正答	N
2選択肢条件	1	不正答・欠損	15
2選択肢条件	2	正答	741
2選択肢条件	3	不正答・欠損	47
2選択肢条件	4	不正答・欠損	121
2選択肢条件	5	不正答・欠損	603
2選択肢条件	6	不正答・欠損	157
3選択肢条件	1	不正答・欠損	19
3選択肢条件	2	不正答・欠損	27
3選択肢条件	3	正答	982
3選択肢条件	4	不正答・欠損	93
3選択肢条件	5	不正答・欠損	490
3選択肢条件	6	不正答・欠損	158
4選択肢条件	1	不正答・欠損	16
4選択肢条件	2	不正答・欠損	18
4選択肢条件	3	不正答・欠損	38
4選択肢条件	4	正答	1099
4選択肢条件	5	不正答・欠損	415
4選択肢条件	6	不正答・欠損	135
4選択肢条件	未実施・欠損	不正答・欠損	1
5選択肢条件	1	不正答・欠損	20
5選択肢条件	2	不正答・欠損	27
5選択肢条件	3	不正答・欠損	36
5選択肢条件	4	不正答・欠損	89
5選択肢条件	5	正答	1362
5選択肢条件	6	不正答・欠損	143

実験3指示項目 <- readr::read_csv(study_csv("study3", "table_attention_check.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, response = "回答コード", status = "判定", n = "N")) %>%
  dplyr::mutate(dplyr::across(dplyr::everything(), ~ tidyr::replace_na(as.character(.x), "—")))
knitr::kable(実験3指示項目, format = "html", row.names = FALSE, caption = "表C24：実験3の指示項目")

表C24：実験3の指示項目

回答	判定	N
1	不正答・欠損	8
12	不正答・欠損	9
13	不正答・欠損	4
14	不正答・欠損	7
15	不正答・欠損	94
16	不正答・欠損	11
2	不正答・欠損	11
3	正答	6545
4	不正答・欠損	35
5	不正答・欠損	14
6	不正答・欠損	89
7	不正答・欠損	17
8	不正答・欠損	7
未実施・欠損	不正答・欠損	161

D. 本文図の再現

この節の図（表）番号は本文と一致したものである。本文の分析結果で用いる図は図4から図9までであり、実験2のAMCEは本文図には表示せず、補遺Eに掲示されている。

図4：実験1（2023年）の共変量調整済みAMCE

図4データ <- study1_env$amce_plot_df_cov_facet
図4 <- ggplot2::ggplot(
  図4データ,
  ggplot2::aes(x = estimate_pp, y = label, shape = party_n, linetype = party_n, group = party_n)
) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.45, color = "grey35") +
  ggplot2::geom_errorbarh(
    ggplot2::aes(xmin = conf.low_pp, xmax = conf.high_pp),
    position = ggplot2::position_dodge(width = 0.65), height = 0.16, linewidth = 0.55
  ) +
  ggplot2::geom_point(position = ggplot2::position_dodge(width = 0.65), size = 2.5, fill = "white", stroke = 0.8) +
  ggplot2::facet_grid(attribute_facet ~ ., scales = "free_y", space = "free_y", switch = "y") +
  ggplot2::scale_shape_manual(values = c("2政党" = 16, "3政党" = 17, "4政党" = 15, "5政党" = 1)) +
  ggplot2::scale_linetype_manual(values = c("2政党" = "solid", "3政党" = "dashed", "4政党" = "dotted", "5政党" = "dotdash")) +
  ggplot2::labs(x = "選択確率の変化", y = NULL, shape = "政党数条件", linetype = "政党数条件") +
  ggplot2::theme_bw(base_size = 12) +
  ggplot2::theme(legend.position = "top", panel.grid.major.y = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank())
図4

表D1 <- readr::read_csv(study_csv("study1", "table_amce_covariate_adjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表D1), format = "html", row.names = FALSE, caption = "表D1：図4に対応する共変量調整済みAMCE")

表D1：図4に対応する共変量調整済みAMCE

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2政党条件	政策位置	右派・保守的	-2.51	1.44	-5.33	0.32	.082	815
2政党条件	政策位置	左派・革新的	-8.04	1.43	-10.85	-5.23	< .001	815
2政党条件	与党／野党	与党	4.78	1.21	2.41	7.15	< .001	815
2政党条件	GDP成長率	GDP：プラス1％	7.73	1.40	4.99	10.47	< .001	815
2政党条件	GDP成長率	GDP：マイナス1％	-2.75	1.38	-5.45	-0.05	.046	815
2政党条件	日経平均	日経平均：プラス1000円	6.35	1.39	3.63	9.07	< .001	815
2政党条件	日経平均	日経平均：マイナス1000円	-5.44	1.34	-8.07	-2.81	< .001	815
2政党条件	議席数	議席数：10～49	2.16	1.74	-1.25	5.57	.214	815
2政党条件	議席数	議席数：50～99	7.55	1.76	4.09	11.01	< .001	815
2政党条件	議席数	議席数：100～199	8.90	1.78	5.41	12.40	< .001	815
2政党条件	議席数	議席数：200以上	10.73	1.84	7.13	14.34	< .001	815
2政党条件	CPI	CPI：プラス1ポイント	-0.14	1.38	-2.85	2.57	.918	815
2政党条件	CPI	CPI：マイナス1ポイント	-1.13	1.38	-3.83	1.57	.413	815
2政党条件	失業率	失業率：プラス1％	-4.50	1.38	-7.22	-1.79	.001	815
2政党条件	失業率	失業率：マイナス1％	-2.83	1.39	-5.55	-0.10	.042	815
3政党条件	政策位置	右派・保守的	-4.79	1.22	-7.18	-2.40	< .001	843
3政党条件	政策位置	左派・革新的	-8.99	1.22	-11.39	-6.60	< .001	843
3政党条件	与党／野党	与党	3.50	1.10	1.35	5.65	.001	843
3政党条件	GDP成長率	GDP：プラス1％	8.05	1.02	6.05	10.06	< .001	843
3政党条件	GDP成長率	GDP：マイナス1％	-2.67	0.96	-4.55	-0.80	.005	843
3政党条件	日経平均	日経平均：プラス1000円	6.07	1.06	3.99	8.14	< .001	843
3政党条件	日経平均	日経平均：マイナス1000円	-4.23	1.04	-6.28	-2.19	< .001	843
3政党条件	議席数	議席数：10～49	3.66	1.24	1.23	6.09	.003	843
3政党条件	議席数	議席数：50～99	8.36	1.28	5.86	10.86	< .001	843
3政党条件	議席数	議席数：100～199	11.70	1.48	8.79	14.61	< .001	843
3政党条件	議席数	議席数：200以上	11.28	1.52	8.29	14.26	< .001	843
3政党条件	CPI	CPI：プラス1ポイント	1.15	1.01	-0.82	3.13	.253	843
3政党条件	CPI	CPI：マイナス1ポイント	0.14	1.01	-1.84	2.12	.892	843
3政党条件	失業率	失業率：プラス1％	-3.40	1.05	-5.47	-1.34	.001	843
3政党条件	失業率	失業率：マイナス1％	-2.05	1.06	-4.12	0.03	.053	843
4政党条件	政策位置	右派・保守的	-5.27	1.00	-7.22	-3.32	< .001	882
4政党条件	政策位置	左派・革新的	-8.28	0.99	-10.22	-6.34	< .001	882
4政党条件	与党／野党	与党	4.27	0.95	2.40	6.14	< .001	882
4政党条件	GDP成長率	GDP：プラス1％	7.39	0.88	5.67	9.11	< .001	882
4政党条件	GDP成長率	GDP：マイナス1％	-3.46	0.78	-4.98	-1.94	< .001	882
4政党条件	日経平均	日経平均：プラス1000円	3.24	0.86	1.55	4.93	< .001	882
4政党条件	日経平均	日経平均：マイナス1000円	-5.21	0.77	-6.71	-3.70	< .001	882
4政党条件	議席数	議席数：10～49	3.79	0.89	2.05	5.54	< .001	882
4政党条件	議席数	議席数：50～99	6.69	0.99	4.74	8.63	< .001	882
4政党条件	議席数	議席数：100～199	10.17	1.14	7.93	12.41	< .001	882
4政党条件	議席数	議席数：200以上	9.91	1.30	7.36	12.47	< .001	882
4政党条件	CPI	CPI：プラス1ポイント	2.79	0.81	1.21	4.38	< .001	882
4政党条件	CPI	CPI：マイナス1ポイント	0.05	0.81	-1.53	1.62	.955	882
4政党条件	失業率	失業率：プラス1％	-3.58	0.84	-5.23	-1.93	< .001	882
4政党条件	失業率	失業率：マイナス1％	-0.44	0.82	-2.05	1.17	.589	882
5政党条件	政策位置	右派・保守的	-4.37	0.85	-6.04	-2.70	< .001	842
5政党条件	政策位置	左派・革新的	-6.56	0.85	-8.23	-4.89	< .001	842
5政党条件	与党／野党	与党	4.94	0.87	3.23	6.65	< .001	842
5政党条件	GDP成長率	GDP：プラス1％	6.42	0.77	4.91	7.93	< .001	842
5政党条件	GDP成長率	GDP：マイナス1％	-3.26	0.67	-4.58	-1.94	< .001	842
5政党条件	日経平均	日経平均：プラス1000円	3.79	0.72	2.38	5.20	< .001	842
5政党条件	日経平均	日経平均：マイナス1000円	-4.52	0.65	-5.79	-3.25	< .001	842
5政党条件	議席数	議席数：10～49	3.80	0.71	2.41	5.18	< .001	842
5政党条件	議席数	議席数：50～99	8.22	0.93	6.40	10.04	< .001	842
5政党条件	議席数	議席数：100～199	9.81	1.09	7.68	11.94	< .001	842
5政党条件	議席数	議席数：200以上	10.13	1.14	7.90	12.36	< .001	842
5政党条件	CPI	CPI：プラス1ポイント	0.89	0.69	-0.45	2.23	.194	842
5政党条件	CPI	CPI：マイナス1ポイント	-1.16	0.67	-2.48	0.16	.086	842
5政党条件	失業率	失業率：プラス1％	-2.97	0.71	-4.36	-1.58	< .001	842
5政党条件	失業率	失業率：マイナス1％	-0.07	0.72	-1.48	1.34	.924	842

図5：実験1（2023年）の政党・経済手がかりの重要度と相対比重

図5重要度データ <- study1_env$relative_panel_adjusted_data
図5相対比重データ <- study1_env$relative_panel_b_data
図5パネルA <- study1_env$relative_panel_adjusted
図5パネルB <- study1_env$relative_panel_c
図5 <- (図5パネルA | 図5パネルB) + patchwork::plot_layout(widths = c(1, 1))
図5

表D2 <- readr::read_csv(study_csv("study1", "table_marginal_means.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", level = "水準")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study1"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D2), format = "html", row.names = FALSE, caption = "表D2：限界平均")

表D2：限界平均

条件	手がかり群	属性	水準	限界平均（%）	クラスタSE（pp）	95% CI下限（%）	95% CI上限（%）	プロファイル数	回答者数
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	50.37	0.80	48.81	51.94	2672	799
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	50.36	0.82	48.76	51.96	2780	804
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	49.26	0.82	47.64	50.88	2698	800
2政党	経済の手がかり	GDP成長率	GDP成長率±0％	48.09	0.81	46.50	49.67	2716	797
2政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	56.04	0.82	54.44	57.64	2791	801
2政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	45.59	0.83	43.97	47.21	2643	800
2政党	政党の手がかり	与野党地位	与党	52.41	0.61	51.22	53.61	4146	815
2政党	政党の手がかり	与野党地位	野党	47.50	0.63	46.27	48.74	4004	814
2政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	56.27	0.82	54.65	57.88	2721	802
2政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	44.13	0.79	42.58	45.68	2726	798
2政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	49.61	0.79	48.07	51.16	2703	792
2政党	政党の手がかり	政策位置	中道	53.44	0.81	51.86	55.02	2717	800
2政党	政党の手がかり	政策位置	右派・保守的	51.09	0.91	49.31	52.87	2711	801
2政党	政党の手がかり	政策位置	左派・革新的	45.48	0.89	43.73	47.23	2722	802
2政党	政党の手がかり	議席数	100~199	53.13	1.13	50.92	55.34	1662	744
2政党	政党の手がかり	議席数	10~49	46.26	1.15	44.01	48.51	1565	721
2政党	政党の手がかり	議席数	10以下	44.13	1.11	41.96	46.30	1686	725
2政党	政党の手がかり	議席数	200以上	54.84	1.17	52.55	57.13	1652	730
2政党	政党の手がかり	議席数	50~99	51.61	1.16	49.34	53.88	1585	721
2政党	経済の手がかり	失業率	失業率前期比±0％	52.47	0.81	50.88	54.07	2750	796
2政党	経済の手がかり	失業率	失業率前期比プラス1％	48.08	0.81	46.50	49.67	2741	806
2政党	経済の手がかり	失業率	失業率前期比マイナス1％	49.42	0.83	47.80	51.04	2659	802
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	32.89	0.59	31.73	34.06	4168	841
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	33.95	0.60	32.77	35.12	4277	842
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	33.14	0.61	31.95	34.33	4200	839
3政党	経済の手がかり	GDP成長率	GDP成長率±0％	31.77	0.56	30.68	32.85	4297	842
3政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	39.75	0.66	38.46	41.05	4075	839
3政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	28.79	0.61	27.60	29.97	4273	843
3政党	政党の手がかり	与野党地位	与党	35.46	0.74	34.01	36.92	4162	842
3政党	政党の手がかり	与野党地位	野党	32.29	0.36	31.58	33.00	8483	843
3政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	38.95	0.63	37.71	40.19	4177	842
3政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	28.55	0.62	27.33	29.77	4284	842
3政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	32.62	0.61	31.43	33.82	4184	843
3政党	政党の手がかり	政策位置	中道	38.05	0.71	36.65	39.45	4113	841
3政党	政党の手がかり	政策位置	右派・保守的	33.14	0.72	31.73	34.55	4306	841
3政党	政党の手がかり	政策位置	左派・革新的	28.94	0.72	27.52	30.36	4226	841
3政党	政党の手がかり	議席数	100~199	38.67	1.01	36.70	40.64	2105	793
3政党	政党の手がかり	議席数	10~49	30.41	0.79	28.86	31.95	2802	826
3政党	政党の手がかり	議席数	10以下	26.84	0.84	25.20	28.49	2794	828
3政党	政党の手がかり	議席数	200以上	38.06	1.03	36.05	40.07	2157	796
3政党	政党の手がかり	議席数	50~99	35.09	0.81	33.49	36.69	2787	825
3政党	経済の手がかり	失業率	失業率前期比±0％	35.07	0.61	33.88	36.27	4268	842
3政党	経済の手がかり	失業率	失業率前期比プラス1％	31.85	0.64	30.58	33.11	4167	839
3政党	経済の手がかり	失業率	失業率前期比マイナス1％	33.04	0.64	31.79	34.29	4210	839
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	24.15	0.47	23.23	25.06	6009	882
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	26.61	0.48	25.68	27.55	5824	882
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	24.26	0.48	23.33	25.20	5807	882
4政党	経済の手がかり	GDP成長率	GDP成長率±0％	23.80	0.47	22.89	24.72	5894	881
4政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	31.10	0.55	30.03	32.18	5858	882
4政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	20.13	0.48	19.18	21.07	5888	882
4政党	政党の手がかり	与野党地位	与党	28.30	0.72	26.88	29.71	4322	878
4政党	政党の手がかり	与野党地位	野党	23.93	0.23	23.47	24.39	13318	882
4政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	28.93	0.53	27.89	29.97	5814	881
4政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	20.62	0.47	19.70	21.54	5931	882
4政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	25.53	0.47	24.61	26.45	5895	881
4政党	政党の手がかり	政策位置	中道	29.38	0.57	28.26	30.49	5913	882
4政党	政党の手がかり	政策位置	右派・保守的	24.23	0.60	23.06	25.40	5757	882
4政党	政党の手がかり	政策位置	左派・革新的	21.41	0.58	20.28	22.54	5970	882
4政党	政党の手がかり	議席数	100~199	29.83	0.80	28.27	31.39	2977	859
4政党	政党の手がかり	議席数	10~49	23.26	0.58	22.11	24.40	4205	879
4政党	政党の手がかり	議席数	10以下	19.49	0.62	18.28	20.70	4058	875
4政党	政党の手がかり	議席数	200以上	29.36	0.99	27.42	31.30	2224	828
4政党	政党の手がかり	議席数	50~99	26.34	0.62	25.12	27.56	4176	879
4政党	経済の手がかり	失業率	失業率前期比±0％	26.30	0.48	25.36	27.25	5889	882
4政党	経済の手がかり	失業率	失業率前期比プラス1％	22.79	0.50	21.81	23.76	5915	882
4政党	経済の手がかり	失業率	失業率前期比マイナス1％	25.93	0.48	24.98	26.87	5836	881
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	20.10	0.40	19.33	20.87	6965	842
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	21.08	0.42	20.26	21.90	6960	842
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	18.85	0.40	18.06	19.64	7125	842
5政党	経済の手がかり	GDP成長率	GDP成長率±0％	18.96	0.41	18.17	19.76	7135	842
5政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	25.37	0.48	24.44	26.30	6973	842
5政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	15.67	0.42	14.85	16.50	6942	842
5政党	政党の手がかり	与野党地位	与党	24.06	0.70	22.69	25.44	4193	839
5政党	政党の手がかり	与野党地位	野党	18.99	0.17	18.65	19.33	16857	842
5政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	24.07	0.44	23.21	24.93	6996	841
5政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	15.67	0.40	14.89	16.45	6950	842
5政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	20.23	0.39	19.47	20.99	7104	842
5政党	政党の手がかり	政策位置	中道	23.66	0.50	22.68	24.63	7051	842
5政党	政党の手がかり	政策位置	右派・保守的	19.22	0.50	18.23	20.20	6963	842
5政党	政党の手がかり	政策位置	左派・革新的	17.11	0.49	16.15	18.08	7036	842
5政党	政党の手がかり	議席数	100~199	24.93	0.86	23.25	26.62	2615	813
5政党	政党の手がかり	議席数	10~49	19.03	0.44	18.15	19.90	6423	842
5政党	政党の手がかり	議席数	10以下	15.13	0.46	14.24	16.02	6338	842
5政党	政党の手がかり	議席数	200以上	25.36	0.94	23.51	27.21	2157	789
5政党	政党の手がかり	議席数	50~99	23.60	0.67	22.28	24.92	3517	837
5政党	経済の手がかり	失業率	失業率前期比±0％	21.11	0.42	20.29	21.93	6850	842
5政党	経済の手がかり	失業率	失業率前期比プラス1％	17.91	0.42	17.09	18.74	7157	842
5政党	経済の手がかり	失業率	失業率前期比マイナス1％	21.04	0.44	20.18	21.90	7043	841

表D3 <- readr::read_csv(study_csv("study1", "table_attribute_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study1"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D3), format = "html", row.names = FALSE, caption = "表D3：属性重要度")

表D3：属性重要度

条件	手がかり群	属性	水準数	未調整重要度（pp）	選択肢数調整済み重要度（%）
2政党条件	経済の手がかり	消費者物価指数（CPI）	3	0.74	1.49
2政党条件	経済の手がかり	GDP成長率	3	6.96	13.93
2政党条件	政党の手がかり	与野党地位	2	4.91	9.82
2政党条件	経済の手がかり	日経平均株価	3	8.09	16.18
2政党条件	政党の手がかり	政策位置	3	5.31	10.61
2政党条件	政党の手がかり	議席数	5	5.66	11.32
2政党条件	経済の手がかり	失業率	3	2.93	5.85
3政党条件	経済の手がかり	消費者物価指数（CPI）	3	0.70	2.11
3政党条件	経済の手がかり	GDP成長率	3	7.31	21.94
3政党条件	政党の手がかり	与野党地位	2	3.18	9.53
3政党条件	経済の手がかり	日経平均株価	3	6.94	20.81
3政党条件	政党の手がかり	政策位置	3	6.07	18.22
3政党条件	政党の手がかり	議席数	5	6.26	18.79
3政党条件	経済の手がかり	失業率	3	2.15	6.46
4政党条件	経済の手がかり	消費者物価指数（CPI）	3	1.64	6.58
4政党条件	経済の手がかり	GDP成長率	3	7.32	29.27
4政党条件	政党の手がかり	与野党地位	2	4.37	17.47
4政党条件	経済の手がかり	日経平均株価	3	5.54	22.16
4政党条件	政党の手がかり	政策位置	3	5.31	21.25
4政党条件	政党の手がかり	議席数	5	5.36	21.42
4政党条件	経済の手がかり	失業率	3	2.34	9.37
5政党条件	経済の手がかり	消費者物価指数（CPI）	3	1.49	7.43
5政党条件	経済の手がかり	GDP成長率	3	6.46	32.32
5政党条件	政党の手がかり	与野党地位	2	5.07	25.37
5政党条件	経済の手がかり	日経平均株価	3	5.60	28.01
5政党条件	政党の手がかり	政策位置	3	4.36	21.81
5政党条件	政党の手がかり	議席数	5	5.27	26.36
5政党条件	経済の手がかり	失業率	3	2.13	10.66

表D4 <- readr::read_csv(study_csv("study1", "table_cue_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", statistic = "指標")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study1"), 指標 = 統計量日本語(指標, "study1"))
knitr::kable(表日本語(表D4), format = "html", row.names = FALSE, caption = "表D4：政党・経済手がかりの重要度と相対比重")

表D4：政党・経済手がかりの重要度と相対比重

条件	指標	単位	推定値	95% CI下限	95% CI上限
2政党条件	政党手がかり：未調整重要度	pp	5.29	4.20	6.51
2政党条件	経済手がかり：未調整重要度	pp	4.68	4.03	5.72
2政党条件	政党手がかり：選択肢数調整済み重要度	%	10.58	8.40	13.02
2政党条件	経済手がかり：選択肢数調整済み重要度	%	9.36	8.06	11.44
2政党条件	政党手がかりの相対比重	%	53.06	44.85	59.61
3政党条件	政党手がかり：未調整重要度	pp	5.17	4.16	6.23
3政党条件	経済手がかり：未調整重要度	pp	4.28	3.73	5.04
3政党条件	政党手がかり：選択肢数調整済み重要度	%	15.51	12.47	18.68
3政党条件	経済手がかり：選択肢数調整済み重要度	%	12.83	11.20	15.11
3政党条件	政党手がかりの相対比重	%	54.73	47.38	60.49
4政党条件	政党手がかり：未調整重要度	pp	5.01	4.22	5.94
4政党条件	経済手がかり：未調整重要度	pp	4.21	3.73	4.84
4政党条件	政党手がかり：選択肢数調整済み重要度	%	20.05	16.88	23.76
4政党条件	経済手がかり：選択肢数調整済み重要度	%	16.84	14.90	19.34
4政党条件	政党手がかりの相対比重	%	54.34	48.53	59.45
5政党条件	政党手がかり：未調整重要度	pp	4.90	4.12	5.76
5政党条件	経済手がかり：未調整重要度	pp	3.92	3.49	4.50
5政党条件	政党手がかり：選択肢数調整済み重要度	%	24.52	20.58	28.81
5政党条件	経済手がかり：選択肢数調整済み重要度	%	19.60	17.47	22.52
5政党条件	政党手がかりの相対比重	%	55.57	49.63	60.52

図6：実験2（2026年）の政党・経済手がかりの重要度と相対比重

図6重要度データ <- study2_env$relative_panel_adjusted_data
図6相対比重データ <- study2_env$relative_panel_b_data
図6パネルA <- study2_env$relative_panel_adjusted
図6パネルB <- study2_env$relative_panel_c
図6 <- (図6パネルA | 図6パネルB) + patchwork::plot_layout(widths = c(1, 1))
図6

表D5 <- readr::read_csv(study_csv("study2", "table_marginal_means.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", level = "水準")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D5), format = "html", row.names = FALSE, caption = "表D5：限界平均")

表D5：限界平均

条件	手がかり群	属性	水準	限界平均（%）	クラスタSE（pp）	95% CI下限（%）	95% CI上限（%）	プロファイル数	回答者数
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	48.57	0.82	46.95	50.18	2335	696
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	50.74	0.86	49.06	52.43	2355	700
2政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	50.66	0.83	49.04	52.28	2420	699
2政党	経済の手がかり	GDP成長率	GDP成長率±0％	48.98	0.90	47.21	50.74	2342	701
2政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	57.31	0.90	55.54	59.08	2401	704
2政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	43.60	0.89	41.86	45.34	2367	702
2政党	政党の手がかり	与野党地位	与党	51.78	0.65	50.51	53.05	3623	711
2政党	政党の手がかり	与野党地位	野党	48.15	0.67	46.83	49.47	3487	709
2政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	55.23	0.90	53.47	56.98	2354	697
2政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	43.71	0.92	41.91	45.52	2274	695
2政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	50.81	0.84	49.15	52.46	2482	699
2政党	政党の手がかり	政策位置	中道	53.58	0.89	51.84	55.33	2413	703
2政党	政党の手がかり	政策位置	右派・保守的	51.80	0.98	49.89	53.71	2390	698
2政党	政党の手がかり	政策位置	左派・革新的	44.39	0.99	42.45	46.33	2307	698
2政党	政党の手がかり	議席数	100~199	54.21	1.26	51.75	56.67	1400	622
2政党	政党の手がかり	議席数	10~49	46.04	1.19	43.70	48.38	1351	624
2政党	政党の手がかり	議席数	10以下	45.27	1.20	42.92	47.62	1491	632
2政党	政党の手がかり	議席数	200以上	53.93	1.28	51.42	56.45	1398	634
2政党	政党の手がかり	議席数	50~99	50.68	1.12	48.48	52.88	1470	641
2政党	経済の手がかり	失業率	失業率前期比±0％	52.49	0.88	50.76	54.22	2389	700
2政党	経済の手がかり	失業率	失業率前期比プラス1％	47.90	0.87	46.18	49.61	2353	696
2政党	経済の手がかり	失業率	失業率前期比マイナス1％	49.58	0.87	47.88	51.28	2368	700
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	33.81	0.54	32.75	34.87	5282	1058
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	35.00	0.56	33.91	36.10	5311	1061
3政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	31.20	0.57	30.08	32.32	5337	1061
3政党	経済の手がかり	GDP成長率	GDP成長率±0％	33.50	0.52	32.48	34.52	5394	1059
3政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	39.44	0.60	38.26	40.62	5210	1061
3政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	27.19	0.55	26.11	28.26	5326	1059
3政党	政党の手がかり	与野党地位	与党	34.20	0.45	33.31	35.09	7947	1062
3政党	政党の手がかり	与野党地位	野党	32.47	0.45	31.59	33.35	7983	1062
3政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	38.36	0.57	37.25	39.48	5336	1060
3政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	28.59	0.55	27.50	29.68	5320	1059
3政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	33.03	0.56	31.94	34.12	5274	1061
3政党	政党の手がかり	政策位置	中道	36.48	0.62	35.26	37.70	5392	1061
3政党	政党の手がかり	政策位置	右派・保守的	36.06	0.72	34.65	37.47	5285	1059
3政党	政党の手がかり	政策位置	左派・革新的	27.36	0.64	26.09	28.62	5253	1056
3政党	政党の手がかり	議席数	100~199	37.71	0.76	36.23	39.19	3246	1031
3政党	政党の手がかり	議席数	10~49	30.52	0.78	28.99	32.04	3149	1016
3政党	政党の手がかり	議席数	10以下	26.93	0.76	25.43	28.43	3201	1028
3政党	政党の手がかり	議席数	200以上	37.11	0.82	35.50	38.71	3207	1027
3政党	政党の手がかり	議席数	50~99	34.31	0.79	32.77	35.85	3127	1019
3政党	経済の手がかり	失業率	失業率前期比±0％	35.23	0.57	34.11	36.34	5212	1059
3政党	経済の手がかり	失業率	失業率前期比プラス1％	30.91	0.55	29.82	31.99	5381	1059
3政党	経済の手がかり	失業率	失業率前期比マイナス1％	33.93	0.56	32.84	35.03	5337	1059
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	24.56	0.43	23.72	25.40	7255	1097
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	26.38	0.44	25.51	27.25	7404	1097
4政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	24.04	0.44	23.18	24.89	7281	1097
4政党	経済の手がかり	GDP成長率	GDP成長率±0％	24.42	0.42	23.60	25.24	7281	1097
4政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	30.85	0.45	29.96	31.74	7339	1097
4政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	19.71	0.41	18.90	20.53	7320	1097
4政党	政党の手がかり	与野党地位	与党	25.95	0.36	25.23	26.66	11000	1097
4政党	政党の手がかり	与野党地位	野党	24.05	0.37	23.33	24.77	10940	1097
4政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	28.33	0.48	27.40	29.26	7229	1097
4政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	20.81	0.44	19.94	21.67	7185	1097
4政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	25.80	0.42	24.99	26.62	7526	1097
4政党	政党の手がかり	政策位置	中道	27.52	0.53	26.48	28.57	7296	1096
4政党	政党の手がかり	政策位置	右派・保守的	28.59	0.59	27.43	29.74	7259	1097
4政党	政党の手がかり	政策位置	左派・革新的	18.98	0.51	17.98	19.99	7385	1097
4政党	政党の手がかり	議席数	100~199	28.92	0.61	27.73	30.11	4471	1077
4政党	政党の手がかり	議席数	10~49	22.83	0.59	21.68	23.99	4371	1077
4政党	政党の手がかり	議席数	10以下	17.95	0.60	16.79	19.12	4389	1079
4政党	政党の手がかり	議席数	200以上	29.28	0.66	27.99	30.57	4358	1086
4政党	政党の手がかり	議席数	50~99	25.97	0.62	24.75	27.19	4351	1081
4政党	経済の手がかり	失業率	失業率前期比±0％	26.71	0.45	25.83	27.60	7412	1097
4政党	経済の手がかり	失業率	失業率前期比プラス1％	22.57	0.44	21.69	23.44	7228	1097
4政党	経済の手がかり	失業率	失業率前期比マイナス1％	25.67	0.47	24.76	26.58	7300	1097
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	20.07	0.32	19.45	20.69	11075	1322
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	20.33	0.31	19.72	20.95	11011	1322
5政党	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	19.59	0.32	18.97	20.21	10964	1322
5政党	経済の手がかり	GDP成長率	GDP成長率±0％	19.23	0.32	18.61	19.86	11038	1322
5政党	経済の手がかり	GDP成長率	GDP成長率プラス1％	24.41	0.36	23.70	25.12	10977	1322
5政党	経済の手がかり	GDP成長率	GDP成長率マイナス1％	16.38	0.32	15.76	17.01	11035	1322
5政党	政党の手がかり	与野党地位	与党	21.36	0.28	20.82	21.91	16473	1322
5政党	政党の手がかり	与野党地位	野党	18.65	0.28	18.11	19.19	16577	1322
5政党	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	23.67	0.36	22.97	24.37	11056	1322
5政党	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	16.60	0.34	15.94	17.26	11105	1322
5政党	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	19.74	0.32	19.12	20.37	10889	1322
5政党	政党の手がかり	政策位置	中道	21.66	0.42	20.83	22.48	10985	1322
5政党	政党の手がかり	政策位置	右派・保守的	22.72	0.46	21.82	23.62	11128	1322
5政党	政党の手がかり	政策位置	左派・革新的	15.57	0.41	14.77	16.37	10937	1322
5政党	政党の手がかり	議席数	100~199	23.74	0.49	22.77	24.70	6589	1316
5政党	政党の手がかり	議席数	10~49	16.37	0.42	15.54	17.19	6697	1317
5政党	政党の手がかり	議席数	10以下	14.15	0.44	13.29	15.01	6550	1316
5政党	政党の手がかり	議席数	200以上	24.75	0.52	23.72	25.77	6611	1318
5政党	政党の手がかり	議席数	50~99	21.01	0.48	20.07	21.94	6603	1321
5政党	経済の手がかり	失業率	失業率前期比±0％	20.78	0.33	20.14	21.42	11191	1322
5政党	経済の手がかり	失業率	失業率前期比プラス1％	18.57	0.33	17.92	19.22	10916	1322
5政党	経済の手がかり	失業率	失業率前期比マイナス1％	20.63	0.36	19.93	21.32	10943	1322

表D6 <- readr::read_csv(study_csv("study2", "table_attribute_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D6), format = "html", row.names = FALSE, caption = "表D6：属性重要度")

表D6：属性重要度

条件	手がかり群	属性	水準数	未調整重要度（pp）	選択肢数調整済み重要度（%）
2政党条件	経済の手がかり	消費者物価指数（CPI）	3	1.45	2.90
2政党条件	経済の手がかり	GDP成長率	3	9.14	18.28
2政党条件	政党の手がかり	与野党地位	2	3.63	7.26
2政党条件	経済の手がかり	日経平均株価	3	7.68	15.35
2政党条件	政党の手がかり	政策位置	3	6.13	12.26
2政党条件	政党の手がかり	議席数	5	5.16	10.31
2政党条件	経済の手がかり	失業率	3	3.06	6.13
3政党条件	経済の手がかり	消費者物価指数（CPI）	3	2.54	7.61
3政党条件	経済の手がかり	GDP成長率	3	8.17	24.51
3政党条件	政党の手がかり	与野党地位	2	1.73	5.20
3政党条件	経済の手がかり	日経平均株価	3	6.51	19.54
3政党条件	政党の手がかり	政策位置	3	6.08	18.25
3政党条件	政党の手がかり	議席数	5	5.63	16.89
3政党条件	経済の手がかり	失業率	3	2.88	8.64
4政党条件	経済の手がかり	消費者物価指数（CPI）	3	1.56	6.25
4政党条件	経済の手がかり	GDP成長率	3	7.42	29.70
4政党条件	政党の手がかり	与野党地位	2	1.90	7.58
4政党条件	経済の手がかり	日経平均株価	3	5.02	20.06
4政党条件	政党の手がかり	政策位置	3	6.40	25.60
4政党条件	政党の手がかり	議席数	5	5.75	22.99
4政党条件	経済の手がかり	失業率	3	2.77	11.06
5政党条件	経済の手がかり	消費者物価指数（CPI）	3	0.50	2.48
5政党条件	経済の手がかり	GDP成長率	3	5.35	26.74
5政党条件	政党の手がかり	与野党地位	2	2.72	13.58
5政党条件	経済の手がかり	日経平均株価	3	4.72	23.58
5政党条件	政党の手がかり	政策位置	3	4.76	23.82
5政党条件	政党の手がかり	議席数	5	5.71	28.56
5政党条件	経済の手がかり	失業率	3	1.48	7.38

表D7 <- readr::read_csv(study_csv("study2", "table_cue_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", statistic = "指標")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), 指標 = 統計量日本語(指標, "study2"))
knitr::kable(表日本語(表D7), format = "html", row.names = FALSE, caption = "表D7：政党・経済手がかりの重要度と相対比重")

表D7：政党・経済手がかりの重要度と相対比重

条件	指標	単位	推定値	95% CI下限	95% CI上限
2政党条件	政党手がかり：未調整重要度	pp	4.97	3.74	6.35
2政党条件	経済手がかり：未調整重要度	pp	5.33	4.53	6.42
2政党条件	政党手がかり：選択肢数調整済み重要度	%	9.95	7.48	12.70
2政党条件	経済手がかり：選択肢数調整済み重要度	%	10.67	9.06	12.85
2政党条件	政党手がかりの相対比重	%	48.25	39.91	55.66
3政党条件	政党手がかり：未調整重要度	pp	4.48	3.77	5.40
3政党条件	経済手がかり：未調整重要度	pp	5.03	4.39	5.66
3政党条件	政党手がかり：選択肢数調整済み重要度	%	13.44	11.31	16.20
3政党条件	経済手がかり：選択肢数調整済み重要度	%	15.08	13.18	16.99
3政党条件	政党手がかりの相対比重	%	47.14	42.11	53.05
4政党条件	政党手がかり：未調整重要度	pp	4.68	3.98	5.46
4政党条件	経済手がかり：未調整重要度	pp	4.19	3.72	4.76
4政党条件	政党手がかり：選択肢数調整済み重要度	%	18.73	15.93	21.84
4政党条件	経済手がかり：選択肢数調整済み重要度	%	16.77	14.90	19.06
4政党条件	政党手がかりの相対比重	%	52.76	47.46	57.72
5政党条件	政党手がかり：未調整重要度	pp	4.40	3.86	4.98
5政党条件	経済手がかり：未調整重要度	pp	3.01	2.70	3.45
5政党条件	政党手がかり：選択肢数調整済み重要度	%	21.99	19.31	24.88
5政党条件	経済手がかり：選択肢数調整済み重要度	%	15.04	13.50	17.26
5政党条件	政党手がかりの相対比重	%	59.37	54.43	63.34

図7：実験3（2026年）の共変量調整済みAMCE

図7データ <- study3_env$amce_plot_cov
図7 <- ggplot2::ggplot(
  図7データ,
  ggplot2::aes(x = estimate_pp, y = label, shape = party_n, linetype = party_n, group = party_n)
) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.45, color = "grey35") +
  ggplot2::geom_errorbarh(
    ggplot2::aes(xmin = conf.low_pp, xmax = conf.high_pp),
    position = ggplot2::position_dodge(width = 0.65), height = 0.16, linewidth = 0.55
  ) +
  ggplot2::geom_point(position = ggplot2::position_dodge(width = 0.65), size = 2.5, fill = "white", stroke = 0.8) +
  ggplot2::facet_grid(attribute ~ ., scales = "free_y", space = "free_y", switch = "y") +
  ggplot2::scale_shape_manual(values = c("2選択肢" = 16, "3選択肢" = 17, "4選択肢" = 15, "5選択肢" = 1)) +
  ggplot2::scale_linetype_manual(values = c("2選択肢" = "solid", "3選択肢" = "dashed", "4選択肢" = "dotted", "5選択肢" = "dotdash")) +
  ggplot2::labs(x = "選択確率の変化", y = NULL, shape = "選択肢数", linetype = "選択肢数") +
  ggplot2::theme_bw(base_size = 12) +
  ggplot2::theme(legend.position = "top", panel.grid.major.y = ggplot2::element_blank(), panel.grid.minor = ggplot2::element_blank())
図7

表D8 <- readr::read_csv(study_csv("study3", "table_amce_covariate_adjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表D8), format = "html", row.names = FALSE, caption = "表D8：図7に対応する共変量調整済みAMCE")

表D8：図7に対応する共変量調整済みAMCE

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2選択肢条件	政権与党の政党名	立憲民主党	-8.88	3.12	-15.00	-2.76	.005	716
2選択肢条件	政権与党の政党名	日本維新の会	-5.97	2.78	-11.42	-0.53	.032	716
2選択肢条件	政権与党の政党名	公明党	-23.60	2.91	-29.30	-17.89	< .001	716
2選択肢条件	政権与党の政党名	国民民主党	-1.29	2.81	-6.80	4.21	.645	716
2選択肢条件	政権与党の政党名	れいわ新選組	-28.42	3.04	-34.39	-22.45	< .001	716
2選択肢条件	政権与党の政党名	参政党	-14.98	2.78	-20.42	-9.53	< .001	716
2選択肢条件	政権与党の政党名	日本共産党	-33.71	2.91	-39.41	-28.01	< .001	716
2選択肢条件	政権与党の政党名	中道改革連合	-12.57	2.92	-18.30	-6.84	< .001	716
2選択肢条件	政権与党の政党名	チームみらい	-5.19	2.82	-10.72	0.34	.066	716
2選択肢条件	GDP成長率	GDP：プラス1％	7.64	1.44	4.82	10.46	< .001	716
2選択肢条件	GDP成長率	GDP：マイナス1％	-5.92	1.44	-8.75	-3.09	< .001	716
2選択肢条件	日経平均	日経平均：プラス1000円	2.84	1.42	0.06	5.62	.046	716
2選択肢条件	日経平均	日経平均：マイナス1000円	-5.27	1.43	-8.08	-2.46	< .001	716
2選択肢条件	CPI	CPI：プラス1ポイント	-0.48	1.43	-3.28	2.31	.735	716
2選択肢条件	CPI	CPI：マイナス1ポイント	-2.25	1.43	-5.06	0.56	.117	716
2選択肢条件	失業率	失業率：プラス1％	-6.05	1.43	-8.85	-3.24	< .001	716
2選択肢条件	失業率	失業率：マイナス1％	-1.47	1.42	-4.26	1.32	.301	716
3選択肢条件	政権与党の政党名	立憲民主党	-13.89	2.26	-18.32	-9.46	< .001	939
3選択肢条件	政権与党の政党名	日本維新の会	-9.02	2.05	-13.04	-4.99	< .001	939
3選択肢条件	政権与党の政党名	公明党	-25.32	2.00	-29.24	-21.39	< .001	939
3選択肢条件	政権与党の政党名	国民民主党	-2.57	2.15	-6.79	1.65	.233	939
3選択肢条件	政権与党の政党名	れいわ新選組	-26.05	2.19	-30.35	-21.76	< .001	939
3選択肢条件	政権与党の政党名	参政党	-12.46	2.16	-16.69	-8.22	< .001	939
3選択肢条件	政権与党の政党名	日本共産党	-28.06	2.16	-32.29	-23.84	< .001	939
3選択肢条件	政権与党の政党名	中道改革連合	-18.38	2.26	-22.81	-13.95	< .001	939
3選択肢条件	政権与党の政党名	チームみらい	-8.31	2.16	-12.54	-4.07	< .001	939
3選択肢条件	GDP成長率	GDP：プラス1％	7.10	1.00	5.14	9.06	< .001	939
3選択肢条件	GDP成長率	GDP：マイナス1％	-4.80	0.97	-6.71	-2.89	< .001	939
3選択肢条件	日経平均	日経平均：プラス1000円	3.38	1.02	1.37	5.39	.001	939
3選択肢条件	日経平均	日経平均：マイナス1000円	-5.27	0.95	-7.13	-3.42	< .001	939
3選択肢条件	CPI	CPI：プラス1ポイント	-0.44	0.96	-2.33	1.44	.645	939
3選択肢条件	CPI	CPI：マイナス1ポイント	-1.38	0.94	-3.22	0.46	.142	939
3選択肢条件	失業率	失業率：プラス1％	-4.47	0.96	-6.36	-2.58	< .001	939
3選択肢条件	失業率	失業率：マイナス1％	-1.96	0.97	-3.87	-0.05	.044	939
4選択肢条件	政権与党の政党名	立憲民主党	-16.35	1.88	-20.03	-12.66	< .001	1063
4選択肢条件	政権与党の政党名	日本維新の会	-9.35	1.73	-12.74	-5.96	< .001	1063
4選択肢条件	政権与党の政党名	公明党	-24.45	1.67	-27.73	-21.17	< .001	1063
4選択肢条件	政権与党の政党名	国民民主党	-4.97	1.80	-8.50	-1.43	.006	1063
4選択肢条件	政権与党の政党名	れいわ新選組	-25.32	1.76	-28.77	-21.88	< .001	1063
4選択肢条件	政権与党の政党名	参政党	-12.38	1.81	-15.93	-8.83	< .001	1063
4選択肢条件	政権与党の政党名	日本共産党	-25.68	1.80	-29.21	-22.15	< .001	1063
4選択肢条件	政権与党の政党名	中道改革連合	-17.95	1.93	-21.72	-14.17	< .001	1063
4選択肢条件	政権与党の政党名	チームみらい	-11.30	1.89	-15.01	-7.59	< .001	1063
4選択肢条件	GDP成長率	GDP：プラス1％	5.04	0.76	3.55	6.53	< .001	1063
4選択肢条件	GDP成長率	GDP：マイナス1％	-3.49	0.72	-4.91	-2.08	< .001	1063
4選択肢条件	日経平均	日経平均：プラス1000円	3.87	0.80	2.31	5.43	< .001	1063
4選択肢条件	日経平均	日経平均：マイナス1000円	-3.33	0.72	-4.75	-1.91	< .001	1063
4選択肢条件	CPI	CPI：プラス1ポイント	0.54	0.73	-0.89	1.98	.459	1063
4選択肢条件	CPI	CPI：マイナス1ポイント	-1.26	0.73	-2.70	0.18	.087	1063
4選択肢条件	失業率	失業率：プラス1％	-3.73	0.71	-5.12	-2.33	< .001	1063
4選択肢条件	失業率	失業率：マイナス1％	-2.02	0.73	-3.45	-0.59	.006	1063
5選択肢条件	政権与党の政党名	立憲民主党	-12.98	1.59	-16.11	-9.86	< .001	1314
5選択肢条件	政権与党の政党名	日本維新の会	-8.62	1.42	-11.41	-5.84	< .001	1314
5選択肢条件	政権与党の政党名	公明党	-21.75	1.38	-24.46	-19.04	< .001	1314
5選択肢条件	政権与党の政党名	国民民主党	-5.06	1.49	-7.99	-2.14	< .001	1314
5選択肢条件	政権与党の政党名	れいわ新選組	-21.60	1.41	-24.38	-18.83	< .001	1314
5選択肢条件	政権与党の政党名	参政党	-13.08	1.49	-16.00	-10.15	< .001	1314
5選択肢条件	政権与党の政党名	日本共産党	-21.88	1.42	-24.66	-19.09	< .001	1314
5選択肢条件	政権与党の政党名	中道改革連合	-16.65	1.50	-19.60	-13.70	< .001	1314
5選択肢条件	政権与党の政党名	チームみらい	-12.21	1.51	-15.17	-9.26	< .001	1314
5選択肢条件	GDP成長率	GDP：プラス1％	5.49	0.59	4.33	6.64	< .001	1314
5選択肢条件	GDP成長率	GDP：マイナス1％	-2.10	0.52	-3.13	-1.08	< .001	1314
5選択肢条件	日経平均	日経平均：プラス1000円	3.78	0.55	2.70	4.86	< .001	1314
5選択肢条件	日経平均	日経平均：マイナス1000円	-2.15	0.53	-3.19	-1.12	< .001	1314
5選択肢条件	CPI	CPI：プラス1ポイント	0.42	0.53	-0.62	1.47	.428	1314
5選択肢条件	CPI	CPI：マイナス1ポイント	-0.10	0.55	-1.18	0.99	.863	1314
5選択肢条件	失業率	失業率：プラス1％	-2.85	0.56	-3.93	-1.76	< .001	1314
5選択肢条件	失業率	失業率：マイナス1％	-0.89	0.56	-1.98	0.20	.108	1314

図8：実験3（2026年）の政党名・経済手がかりの重要度と相対比重

図8重要度データ <- study3_env$relative_panel_adjusted_data
図8相対比重データ <- study3_env$relative_panel_b_data
図8パネルA <- study3_env$relative_panel_adjusted
図8パネルB <- study3_env$relative_panel_c
図8 <- (図8パネルA | 図8パネルB) + patchwork::plot_layout(widths = c(1, 1))
図8

表D9 <- readr::read_csv(study_csv("study3", "table_marginal_means.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", level = "水準")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D9), format = "html", row.names = FALSE, caption = "表D9：限界平均")

表D9：限界平均

条件	手がかり群	属性	水準	限界平均（%）	クラスタSE（pp）	95% CI下限（%）	95% CI上限（%）	プロファイル数	回答者数
2選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	50.82	0.85	49.15	52.48	2387	706
2選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	50.27	0.85	48.62	51.93	2387	697
2選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	48.91	0.86	47.23	50.59	2386	707
2選択肢	経済の手がかり	GDP成長率	GDP成長率±0％	49.53	0.85	47.87	51.19	2344	705
2選択肢	経済の手がかり	GDP成長率	GDP成長率プラス1％	57.15	0.84	55.50	58.80	2425	708
2選択肢	経済の手がかり	GDP成長率	GDP成長率マイナス1％	43.20	0.87	41.51	44.90	2391	701
2選択肢	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	53.29	0.86	51.60	54.98	2357	709
2選択肢	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	45.62	0.85	43.96	47.29	2400	706
2選択肢	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	51.14	0.84	49.50	52.79	2403	707
2選択肢	政党の手がかり	政党名	れいわ新選組	35.36	2.01	31.41	39.30	676	465
2選択肢	政党の手がかり	政党名	チームみらい	58.49	1.93	54.71	62.28	730	475
2選択肢	政党の手がかり	政党名	中道改革連合	50.41	1.90	46.68	54.14	728	471
2選択肢	政党の手がかり	政党名	公明党	39.29	1.95	35.46	43.11	700	479
2選択肢	政党の手がかり	政党名	参政党	48.53	1.95	44.70	52.36	746	512
2選択肢	政党の手がかり	政党名	国民民主党	62.16	1.94	58.37	65.96	703	468
2選択肢	政党の手がかり	政党名	日本共産党	29.52	1.90	25.80	33.24	708	484
2選択肢	政党の手がかり	政党名	日本維新の会	57.49	2.03	53.51	61.47	734	476
2選択肢	政党の手がかり	政党名	立憲民主党	54.44	2.07	50.39	58.49	720	466
2選択肢	政党の手がかり	政党名	自由民主党	62.94	1.94	59.14	66.74	715	481
2選択肢	経済の手がかり	失業率	失業率前期比±0％	52.94	0.83	51.31	54.56	2433	708
2選択肢	経済の手がかり	失業率	失業率前期比プラス1％	46.41	0.84	44.76	48.07	2383	705
2選択肢	経済の手がかり	失業率	失業率前期比マイナス1％	50.60	0.86	48.91	52.29	2344	709
3選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	33.86	0.56	32.77	34.96	4728	937
3選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	33.51	0.57	32.39	34.63	4700	934
3選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	32.62	0.56	31.51	33.72	4657	935
3選択肢	経済の手がかり	GDP成長率	GDP成長率±0％	32.55	0.57	31.43	33.66	4704	937
3選択肢	経済の手がかり	GDP成長率	GDP成長率プラス1％	39.61	0.61	38.41	40.81	4701	936
3選択肢	経済の手がかり	GDP成長率	GDP成長率マイナス1％	27.82	0.59	26.66	28.98	4680	935
3選択肢	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	37.31	0.61	36.11	38.51	4661	938
3選択肢	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	28.75	0.57	27.63	29.86	4679	937
3選択肢	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	33.95	0.58	32.82	35.08	4745	935
3選択肢	政党の手がかり	政党名	れいわ新選組	21.61	1.26	19.15	24.08	1388	808
3選択肢	政党の手がかり	政党名	チームみらい	39.42	1.41	36.65	42.18	1403	779
3選択肢	政党の手がかり	政党名	中道改革連合	29.22	1.36	26.55	31.89	1451	800
3選択肢	政党の手がかり	政党名	公明党	22.58	1.19	20.25	24.90	1382	778
3選択肢	政党の手がかり	政党名	参政党	35.54	1.48	32.63	38.44	1376	776
3選択肢	政党の手がかり	政党名	国民民主党	45.02	1.43	42.21	47.83	1446	791
3選択肢	政党の手がかり	政党名	日本共産党	19.49	1.24	17.06	21.92	1452	782
3選択肢	政党の手がかり	政党名	日本維新の会	38.85	1.48	35.95	41.76	1413	771
3選択肢	政党の手がかり	政党名	立憲民主党	33.87	1.39	31.14	36.59	1376	778
3選択肢	政党の手がかり	政党名	自由民主党	47.78	1.53	44.78	50.79	1398	791
3選択肢	経済の手がかり	失業率	失業率前期比±0％	35.76	0.56	34.67	36.85	4771	936
3選択肢	経済の手がかり	失業率	失業率前期比プラス1％	30.77	0.59	29.61	31.92	4677	936
3選択肢	経済の手がかり	失業率	失業率前期比マイナス1％	33.43	0.60	32.25	34.61	4637	937
4選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	25.18	0.42	24.35	26.01	7180	1062
4選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	25.83	0.46	24.94	26.72	6988	1063
4選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	24.00	0.45	23.11	24.89	7092	1063
4選択肢	経済の手がかり	GDP成長率	GDP成長率±0％	24.43	0.43	23.59	25.27	7090	1063
4選択肢	経済の手がかり	GDP成長率	GDP成長率プラス1％	29.52	0.46	28.61	30.43	7104	1060
4選択肢	経済の手がかり	GDP成長率	GDP成長率マイナス1％	21.03	0.44	20.17	21.89	7066	1063
4選択肢	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	28.78	0.47	27.85	29.71	7057	1063
4選択肢	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	21.55	0.43	20.71	22.39	7206	1063
4選択肢	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	24.74	0.44	23.87	25.61	6997	1063
4選択肢	政党の手がかり	政党名	れいわ新選組	14.42	0.89	12.67	16.16	2164	978
4選択肢	政党の手がかり	政党名	チームみらい	28.40	1.13	26.19	30.62	2144	977
4選択肢	政党の手がかり	政党名	中道改革連合	21.79	1.10	19.64	23.94	2079	970
4選択肢	政党の手がかり	政党名	公明党	15.49	0.90	13.72	17.25	2150	992
4選択肢	政党の手がかり	政党名	参政党	27.28	1.14	25.04	29.52	2126	975
4選択肢	政党の手がかり	政党名	国民民主党	34.80	1.18	32.49	37.11	2115	982
4選択肢	政党の手がかり	政党名	日本共産党	14.24	0.90	12.48	16.00	2184	988
4選択肢	政党の手がかり	政党名	日本維新の会	30.69	1.15	28.44	32.95	2108	987
4選択肢	政党の手がかり	政党名	立憲民主党	23.50	1.07	21.40	25.59	2060	978
4選択肢	政党の手がかり	政党名	自由民主党	39.91	1.34	37.29	42.52	2130	976
4選択肢	経済の手がかり	失業率	失業率前期比±0％	27.07	0.42	26.25	27.89	7067	1063
4選択肢	経済の手がかり	失業率	失業率前期比プラス1％	23.14	0.42	22.31	23.97	7087	1062
4選択肢	経済の手がかり	失業率	失業率前期比マイナス1％	24.80	0.43	23.94	25.65	7106	1062
5選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比±0ポイント	19.78	0.31	19.16	20.39	10978	1314
5選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比プラス1ポイント	20.43	0.32	19.80	21.07	11001	1314
5選択肢	経済の手がかり	消費者物価指数（CPI）	CPI前期比マイナス1ポイント	19.79	0.34	19.13	20.45	10871	1314
5選択肢	経済の手がかり	GDP成長率	GDP成長率±0％	18.91	0.32	18.29	19.54	10924	1314
5選択肢	経済の手がかり	GDP成長率	GDP成長率プラス1％	24.36	0.36	23.64	25.07	10954	1314
5選択肢	経済の手がかり	GDP成長率	GDP成長率マイナス1％	16.73	0.33	16.09	17.38	10972	1314
5選択肢	経済の手がかり	日経平均株価	日経平均前月同期比プラス1000円	23.22	0.33	22.57	23.87	11046	1314
5選択肢	経済の手がかり	日経平均株価	日経平均前月同期比マイナス1000円	17.33	0.33	16.69	17.97	10806	1314
5選択肢	経済の手がかり	日経平均株価	日経平均前月同期比変わらず	19.39	0.31	18.78	19.99	10998	1314
5選択肢	政党の手がかり	政党名	れいわ新選組	11.66	0.67	10.34	12.97	3277	1281
5選択肢	政党の手がかり	政党名	チームみらい	21.13	0.87	19.43	22.83	3351	1281
5選択肢	政党の手がかり	政党名	中道改革連合	16.82	0.80	15.26	18.39	3311	1275
5選択肢	政党の手がかり	政党名	公明党	11.63	0.67	10.31	12.94	3243	1262
5選択肢	政党の手がかり	政党名	参政党	20.21	0.89	18.47	21.96	3280	1270
5選択肢	政党の手がかり	政党名	国民民主党	28.33	0.92	26.51	30.14	3315	1274
5選択肢	政党の手がかり	政党名	日本共産党	11.49	0.67	10.18	12.81	3271	1276
5選択肢	政党の手がかり	政党名	日本維新の会	24.77	0.93	22.93	26.60	3218	1275
5選択肢	政党の手がかり	政党名	立憲民主党	20.46	0.88	18.73	22.18	3290	1277
5選択肢	政党の手がかり	政党名	自由民主党	33.33	1.11	31.16	35.51	3294	1278
5選択肢	経済の手がかり	失業率	失業率前期比±0％	21.24	0.32	20.60	21.88	10965	1314
5選択肢	経済の手がかり	失業率	失業率前期比プラス1％	18.51	0.33	17.86	19.16	10768	1313
5選択肢	経済の手がかり	失業率	失業率前期比マイナス1％	20.22	0.32	19.59	20.85	11117	1314

表D10 <- readr::read_csv(study_csv("study3", "table_attribute_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), 属性 = 属性日本語(属性))
knitr::kable(表日本語(表D10), format = "html", row.names = FALSE, caption = "表D10：属性重要度")

表D10：属性重要度

条件	手がかり群	属性	水準数	未調整重要度（pp）	選択肢数調整済み重要度（%）
2選択肢条件	経済の手がかり	消費者物価指数（CPI）	3	1.27	2.54
2選択肢条件	経済の手がかり	GDP成長率	3	9.30	18.60
2選択肢条件	経済の手がかり	日経平均株価	3	5.11	10.22
2選択肢条件	政党の手がかり	政党名	10	13.68	27.35
2選択肢条件	経済の手がかり	失業率	3	4.35	8.70
3選択肢条件	経済の手がかり	消費者物価指数（CPI）	3	0.83	2.49
3選択肢条件	経済の手がかり	GDP成長率	3	7.86	23.58
3選択肢条件	経済の手がかり	日経平均株価	3	5.71	17.13
3選択肢条件	政党の手がかり	政党名	10	11.85	35.55
3選択肢条件	経済の手がかり	失業率	3	3.33	9.98
4選択肢条件	経済の手がかり	消費者物価指数（CPI）	3	1.22	4.88
4選択肢条件	経済の手がかり	GDP成長率	3	5.66	22.64
4選択肢条件	経済の手がかり	日経平均株価	3	4.82	19.28
4選択肢条件	政党の手がかり	政党名	10	10.52	42.07
4選択肢条件	経済の手がかり	失業率	3	2.62	10.48
5選択肢条件	経済の手がかり	消費者物価指数（CPI）	3	0.44	2.20
5選択肢条件	経済の手がかり	GDP成長率	3	5.08	25.41
5選択肢条件	経済の手がかり	日経平均株価	3	3.93	19.63
5選択肢条件	政党の手がかり	政党名	10	8.71	43.57
5選択肢条件	経済の手がかり	失業率	3	1.82	9.11

表D11 <- readr::read_csv(study_csv("study3", "table_cue_importance.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", statistic = "指標")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), 指標 = 統計量日本語(指標, "study3"))
knitr::kable(表日本語(表D11), format = "html", row.names = FALSE, caption = "表D11：政党名・経済手がかりの重要度と相対比重")

表D11：政党名・経済手がかりの重要度と相対比重

条件	指標	単位	推定値	95% CI下限	95% CI上限
2選択肢条件	政党手がかり：未調整重要度	pp	13.68	12.04	15.55
2選択肢条件	経済手がかり：未調整重要度	pp	5.01	4.18	6.05
2選択肢条件	政党手がかり：選択肢数調整済み重要度	%	27.35	24.08	31.09
2選択肢条件	経済手がかり：選択肢数調整済み重要度	%	10.02	8.36	12.09
2選択肢条件	政党手がかりの相対比重	%	73.20	68.24	77.40
3選択肢条件	政党手がかり：未調整重要度	pp	11.85	10.54	13.20
3選択肢条件	経済手がかり：未調整重要度	pp	4.43	3.85	5.10
3選択肢条件	政党手がかり：選択肢数調整済み重要度	%	35.55	31.61	39.59
3選択肢条件	経済手がかり：選択肢数調整済み重要度	%	13.29	11.55	15.31
3選択肢条件	政党手がかりの相対比重	%	72.78	68.90	76.46
4選択肢条件	政党手がかり：未調整重要度	pp	10.52	9.54	11.69
4選択肢条件	経済手がかり：未調整重要度	pp	3.58	3.05	4.09
4選択肢条件	政党手がかり：選択肢数調整済み重要度	%	42.07	38.15	46.76
4選択肢条件	経済手がかり：選択肢数調整済み重要度	%	14.32	12.21	16.37
4選択肢条件	政党手がかりの相対比重	%	74.61	71.03	78.20
5選択肢条件	政党手がかり：未調整重要度	pp	8.71	8.04	9.57
5選択肢条件	経済手がかり：未調整重要度	pp	2.82	2.46	3.26
5選択肢条件	政党手がかり：選択肢数調整済み重要度	%	43.57	40.22	47.87
5選択肢条件	経済手がかり：選択肢数調整済み重要度	%	14.08	12.31	16.30
5選択肢条件	政党手がかりの相対比重	%	75.57	72.24	78.63

図9：実験3（2026年）の支持政党と提示政党名の一致効果

図9 <- study3_env$p_party_match
図9

表D12元 <- readr::read_csv(study_csv("study3", "table_party_match.csv"), show_col_types = FALSE)

表D12条件列 <- intersect(c("選択肢数", "条件", "party_n"), names(表D12元))
if (length(表D12条件列) == 0) stop("Check condition column")
表D12条件列 <- 表D12条件列[[1]]

if (!"回答者数" %in% names(表D12元)) {
  表D12元$回答者数 <- NA_character_
}

実験3条件人数 <- study3_env$conjoint_all_m %>%
  dplyr::distinct(ID, party_n) %>%
  dplyr::count(party_n, name = "回答者数補完")

表D12 <- 表D12元 %>%
  dplyr::mutate(条件数 = 数値列(.data[[表D12条件列]])) %>%
  dplyr::select(-dplyr::all_of(表D12条件列)) %>%
  dplyr::left_join(実験3条件人数, by = c("条件数" = "party_n")) %>%
  dplyr::mutate(
    回答者数 = dplyr::coalesce(数値列(回答者数), 回答者数補完),
    条件 = 条件日本語(条件数, "study3")
  ) %>%
  dplyr::select(-条件数, -回答者数補完) %>%
  dplyr::relocate(条件, .after = 対象)

knitr::kable(
  表日本語(表D12),
  format = "html",
  row.names = FALSE,
  caption = "表D12：支持政党と提示政党名の一致効果"
)

表D12：支持政党と提示政党名の一致効果

対象	条件	一致効果（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
全体	2選択肢条件	28.82	2.86	23.21	34.43	< .001	716
全体	3選択肢条件	38.91	2.17	34.66	43.16	< .001	939
全体	4選択肢条件	44.35	1.99	40.44	48.25	< .001	1063
全体	5選択肢条件	44.83	1.82	41.25	48.41	< .001	1314
自民党支持者	2選択肢条件	34.77	3.43	28.06	41.49	< .001	163
自民党支持者	3選択肢条件	42.74	3.13	36.61	48.87	< .001	219
自民党支持者	4選択肢条件	47.62	2.88	41.97	53.28	< .001	254
自民党支持者	5選択肢条件	49.55	2.70	44.26	54.84	< .001	311
中道改革支持者	2選択肢条件	27.10	13.17	1.30	52.91	.052	23
中道改革支持者	3選択肢条件	35.16	9.34	16.85	53.48	.001	23
中道改革支持者	4選択肢条件	36.97	7.47	22.33	51.60	< .001	34
中道改革支持者	5選択肢条件	46.37	7.16	32.33	60.40	< .001	40
立憲支持者	2選択肢条件	18.12	12.01	-5.41	41.66	.144	26
立憲支持者	3選択肢条件	46.89	7.00	33.16	60.61	< .001	38
立憲支持者	4選択肢条件	41.34	5.79	30.00	52.69	< .001	37
立憲支持者	5選択肢条件	40.03	6.09	28.09	51.97	< .001	63
参政党支持者	2選択肢条件	39.23	7.32	24.88	53.59	< .001	30
参政党支持者	3選択肢条件	53.61	6.14	41.57	65.65	< .001	46
参政党支持者	4選択肢条件	62.99	5.48	52.25	73.72	< .001	42
参政党支持者	5選択肢条件	61.03	5.53	50.20	71.86	< .001	52

E. 実験1（2023年）の補足分析

補図E1：共変量を含めないAMCE

補図E1データ <- study1_env$amce_plot_df_nocov_facet
補図E1 <- study1_env$p_amce_facet_nocov
補図E1

表E1 <- readr::read_csv(study_csv("study1", "table_amce_unadjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表E1), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2政党条件	政策位置	右派・保守的	-2.50	1.44	-5.32	0.32	.082	815
2政党条件	政策位置	左派・革新的	-8.04	1.43	-10.85	-5.23	< .001	815
2政党条件	与党／野党	与党	4.77	1.21	2.40	7.14	< .001	815
2政党条件	GDP成長率	GDP：プラス1％	7.72	1.40	4.99	10.46	< .001	815
2政党条件	GDP成長率	GDP：マイナス1％	-2.74	1.37	-5.44	-0.05	.046	815
2政党条件	日経平均	日経平均：プラス1000円	6.33	1.39	3.62	9.05	< .001	815
2政党条件	日経平均	日経平均：マイナス1000円	-5.45	1.34	-8.08	-2.82	< .001	815
2政党条件	議席数	議席数：10～49	2.14	1.74	-1.26	5.55	.218	815
2政党条件	議席数	議席数：50～99	7.52	1.76	4.08	10.97	< .001	815
2政党条件	議席数	議席数：100～199	8.89	1.78	5.40	12.39	< .001	815
2政党条件	議席数	議席数：200以上	10.72	1.83	7.12	14.31	< .001	815
2政党条件	CPI	CPI：プラス1ポイント	-0.14	1.38	-2.85	2.56	.918	815
2政党条件	CPI	CPI：マイナス1ポイント	-1.13	1.38	-3.83	1.56	.410	815
2政党条件	失業率	失業率：プラス1％	-4.50	1.38	-7.21	-1.79	.001	815
2政党条件	失業率	失業率：マイナス1％	-2.82	1.39	-5.54	-0.10	.042	815
3政党条件	政策位置	右派・保守的	-4.78	1.22	-7.17	-2.40	< .001	843
3政党条件	政策位置	左派・革新的	-8.99	1.22	-11.39	-6.59	< .001	843
3政党条件	与党／野党	与党	3.50	1.10	1.35	5.65	.001	843
3政党条件	GDP成長率	GDP：プラス1％	8.04	1.02	6.04	10.05	< .001	843
3政党条件	GDP成長率	GDP：マイナス1％	-2.67	0.96	-4.55	-0.80	.005	843
3政党条件	日経平均	日経平均：プラス1000円	6.05	1.06	3.99	8.12	< .001	843
3政党条件	日経平均	日経平均：マイナス1000円	-4.23	1.04	-6.27	-2.19	< .001	843
3政党条件	議席数	議席数：10～49	3.67	1.24	1.24	6.09	.003	843
3政党条件	議席数	議席数：50～99	8.36	1.28	5.86	10.86	< .001	843
3政党条件	議席数	議席数：100～199	11.70	1.48	8.79	14.60	< .001	843
3政党条件	議席数	議席数：200以上	11.27	1.52	8.29	14.25	< .001	843
3政党条件	CPI	CPI：プラス1ポイント	1.16	1.01	-0.82	3.13	.252	843
3政党条件	CPI	CPI：マイナス1ポイント	0.15	1.01	-1.83	2.12	.885	843
3政党条件	失業率	失業率：プラス1％	-3.40	1.05	-5.47	-1.34	.001	843
3政党条件	失業率	失業率：マイナス1％	-2.05	1.06	-4.12	0.03	.054	843
4政党条件	政策位置	右派・保守的	-5.27	0.99	-7.22	-3.32	< .001	882
4政党条件	政策位置	左派・革新的	-8.27	0.99	-10.21	-6.33	< .001	882
4政党条件	与党／野党	与党	4.26	0.95	2.40	6.13	< .001	882
4政党条件	GDP成長率	GDP：プラス1％	7.38	0.88	5.66	9.11	< .001	882
4政党条件	GDP成長率	GDP：マイナス1％	-3.46	0.78	-4.98	-1.94	< .001	882
4政党条件	日経平均	日経平均：プラス1000円	3.24	0.86	1.55	4.93	< .001	882
4政党条件	日経平均	日経平均：マイナス1000円	-5.21	0.77	-6.71	-3.71	< .001	882
4政党条件	議席数	議席数：10～49	3.79	0.89	2.05	5.53	< .001	882
4政党条件	議席数	議席数：50～99	6.68	0.99	4.74	8.62	< .001	882
4政党条件	議席数	議席数：100～199	10.16	1.14	7.93	12.40	< .001	882
4政党条件	議席数	議席数：200以上	9.90	1.30	7.35	12.45	< .001	882
4政党条件	CPI	CPI：プラス1ポイント	2.79	0.81	1.21	4.38	< .001	882
4政党条件	CPI	CPI：マイナス1ポイント	0.05	0.80	-1.53	1.63	.952	882
4政党条件	失業率	失業率：プラス1％	-3.58	0.84	-5.23	-1.94	< .001	882
4政党条件	失業率	失業率：マイナス1％	-0.45	0.82	-2.05	1.16	.586	882
5政党条件	政策位置	右派・保守的	-4.37	0.85	-6.04	-2.70	< .001	842
5政党条件	政策位置	左派・革新的	-6.56	0.85	-8.23	-4.89	< .001	842
5政党条件	与党／野党	与党	4.94	0.87	3.23	6.65	< .001	842
5政党条件	GDP成長率	GDP：プラス1％	6.41	0.77	4.91	7.92	< .001	842
5政党条件	GDP成長率	GDP：マイナス1％	-3.27	0.67	-4.59	-1.95	< .001	842
5政党条件	日経平均	日経平均：プラス1000円	3.79	0.72	2.38	5.19	< .001	842
5政党条件	日経平均	日経平均：マイナス1000円	-4.52	0.65	-5.79	-3.25	< .001	842
5政党条件	議席数	議席数：10～49	3.79	0.71	2.41	5.18	< .001	842
5政党条件	議席数	議席数：50～99	8.21	0.93	6.39	10.03	< .001	842
5政党条件	議席数	議席数：100～199	9.80	1.09	7.67	11.93	< .001	842
5政党条件	議席数	議席数：200以上	10.12	1.14	7.89	12.35	< .001	842
5政党条件	CPI	CPI：プラス1ポイント	0.89	0.68	-0.45	2.23	.195	842
5政党条件	CPI	CPI：マイナス1ポイント	-1.16	0.67	-2.47	0.16	.087	842
5政党条件	失業率	失業率：プラス1％	-2.97	0.71	-4.36	-1.59	< .001	842
5政党条件	失業率	失業率：マイナス1％	-0.07	0.72	-1.47	1.34	.927	842

補図E2：2政党条件との差

補図E2データ <- study1_env$interaction_plot_df
補図E2 <- study1_env$p_interaction
補図E2

表E2 <- readr::read_csv(study_csv("study1", "table_amce_interaction.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, attribute = "属性")) %>%
  dplyr::mutate(dplyr::across(dplyr::any_of("属性"), 属性日本語))
knitr::kable(表日本語(表E2), format = "html", row.names = FALSE)

比較条件	属性	水準	2選択肢条件との差（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値
3政党	政策位置	右派・保守的	-2.28	1.88	-5.97	1.41	0.226
4政党	政策位置	右派・保守的	-2.77	1.75	-6.19	0.66	0.114
5政党	政策位置	右派・保守的	-1.87	1.67	-5.14	1.41	0.264
3政党	政策位置	左派・革新的	-0.95	1.88	-4.64	2.74	0.613
4政党	政策位置	左派・革新的	-0.23	1.74	-3.64	3.18	0.893
5政党	政策位置	左派・革新的	1.48	1.66	-1.78	4.74	0.374
3政党	与党／野党	与党	-1.27	1.63	-4.47	1.92	0.435
4政党	与党／野党	与党	-0.51	1.54	-3.52	2.50	0.740
5政党	与党／野党	与党	0.17	1.49	-2.75	3.09	0.910
3政党	GDP成長率	GDP：プラス1％	0.32	1.73	-3.07	3.71	0.852
4政党	GDP成長率	GDP：プラス1％	-0.34	1.65	-3.57	2.89	0.838
5政党	GDP成長率	GDP：プラス1％	-1.31	1.59	-4.43	1.81	0.412
3政党	GDP成長率	GDP：マイナス1％	0.07	1.67	-3.21	3.35	0.967
4政党	GDP成長率	GDP：マイナス1％	-0.72	1.58	-3.81	2.38	0.650
5政党	GDP成長率	GDP：マイナス1％	-0.53	1.53	-3.53	2.47	0.730
3政党	日経平均	日経平均：プラス1000円	-0.28	1.74	-3.69	3.13	0.873
4政党	日経平均	日経平均：プラス1000円	-3.10	1.63	-6.29	0.10	0.058
5政党	日経平均	日経平均：プラス1000円	-2.55	1.56	-5.60	0.51	0.102
3政党	日経平均	日経平均：マイナス1000円	1.22	1.70	-2.10	4.55	0.471
4政党	日経平均	日経平均：マイナス1000円	0.24	1.54	-2.78	3.27	0.875
5政党	日経平均	日経平均：マイナス1000円	0.93	1.49	-1.99	3.85	0.532
3政党	議席数	議席数：10～49	1.52	2.13	-2.66	5.70	0.475
4政党	議席数	議席数：10～49	1.65	1.95	-2.18	5.47	0.398
5政党	議席数	議席数：10～49	1.65	1.87	-2.02	5.33	0.379
3政党	議席数	議席数：50～99	0.84	2.17	-3.42	5.09	0.700
4政党	議席数	議席数：50～99	-0.84	2.02	-4.80	3.11	0.676
5政党	議席数	議席数：50～99	0.69	1.99	-3.21	4.58	0.729
3政党	議席数	議席数：100～199	2.80	2.32	-1.74	7.35	0.226
4政党	議席数	議席数：100～199	1.27	2.12	-2.87	5.42	0.548
5政党	議席数	議席数：100～199	0.91	2.09	-3.18	4.99	0.664
3政党	議席数	議席数：200以上	0.55	2.38	-4.12	5.22	0.817
4政党	議席数	議席数：200以上	-0.82	2.25	-5.22	3.59	0.717
5政党	議席数	議席数：200以上	-0.60	2.16	-4.82	3.63	0.781
3政党	CPI	CPI：プラス1ポイント	1.30	1.71	-2.05	4.65	0.447
4政党	CPI	CPI：プラス1ポイント	2.93	1.60	-0.20	6.07	0.066
5政党	CPI	CPI：プラス1ポイント	1.03	1.54	-1.99	4.05	0.504
3政党	CPI	CPI：マイナス1ポイント	1.28	1.70	-2.06	4.62	0.453
4政党	CPI	CPI：マイナス1ポイント	1.18	1.59	-1.94	4.30	0.458
5政党	CPI	CPI：マイナス1ポイント	-0.02	1.53	-3.02	2.98	0.988
3政党	失業率	失業率：プラス1％	1.10	1.74	-2.30	4.50	0.527
4政党	失業率	失業率：プラス1％	0.92	1.62	-2.25	4.08	0.571
5政党	失業率	失業率：プラス1％	1.53	1.55	-1.52	4.57	0.325
3政党	失業率	失業率：マイナス1％	0.78	1.74	-2.64	4.19	0.657
4政党	失業率	失業率：マイナス1％	2.37	1.61	-0.78	5.53	0.141
5政党	失業率	失業率：マイナス1％	2.76	1.56	-0.31	5.82	0.078

補図E3：条件付きロジット

補図E3 <- study1_env$p_clogit_or
補図E3

表E3 <- readr::read_csv(study_csv("study1", "table_conditional_logit.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", label = "水準")) %>%
  dplyr::mutate(
    条件 = 条件日本語(条件, "study1"),
    属性 = 属性日本語(属性)
  ) %>%
  dplyr::select(-dplyr::any_of(c("term", "variable", "policy_position", "government_status")))
knitr::kable(表日本語(表E3), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	log係数	標準誤差	オッズ比	95% CI下限（OR）	95% CI上限（OR）	p値
2政党	政策位置	右派・保守的	-0.115	0.060	0.891	0.792	1.003	.055
2政党	政策位置	左派・革新的	-0.350	0.060	0.705	0.627	0.793	< .001
2政党	与党／野党	与党	0.207	0.051	1.229	1.112	1.359	< .001
2政党	GDP成長率	GDP：プラス1％	0.309	0.058	1.362	1.215	1.526	< .001
2政党	GDP成長率	GDP：マイナス1％	-0.133	0.058	0.876	0.782	0.980	.021
2政党	日経平均	日経平均：プラス1000円	0.261	0.059	1.298	1.156	1.457	< .001
2政党	日経平均	日経平均：マイナス1000円	-0.246	0.058	0.782	0.698	0.876	< .001
2政党	議席数	議席数：10～49	0.112	0.074	1.118	0.968	1.291	.130
2政党	議席数	議席数：50～99	0.331	0.074	1.392	1.205	1.608	< .001
2政党	議席数	議席数：100～199	0.378	0.077	1.459	1.255	1.696	< .001
2政党	議席数	議席数：200以上	0.442	0.077	1.555	1.337	1.810	< .001
2政党	CPI	CPI：プラス1ポイント	0.020	0.057	1.020	0.911	1.142	.728
2政党	CPI	CPI：マイナス1ポイント	-0.047	0.058	0.954	0.852	1.068	.414
2政党	失業率	失業率：プラス1％	-0.201	0.059	0.818	0.728	0.918	< .001
2政党	失業率	失業率：マイナス1％	-0.136	0.058	0.873	0.779	0.978	.019
3政党	政策位置	右派・保守的	-0.225	0.056	0.798	0.716	0.891	< .001
3政党	政策位置	左派・革新的	-0.435	0.059	0.647	0.576	0.726	< .001
3政党	与党／野党	与党	0.177	0.051	1.193	1.080	1.318	< .001
3政党	GDP成長率	GDP：プラス1％	0.373	0.047	1.451	1.323	1.592	< .001
3政党	GDP成長率	GDP：マイナス1％	-0.136	0.048	0.872	0.794	0.959	.005
3政党	日経平均	日経平均：プラス1000円	0.283	0.049	1.328	1.207	1.460	< .001
3政党	日経平均	日経平均：マイナス1000円	-0.201	0.051	0.818	0.741	0.903	< .001
3政党	議席数	議席数：10～49	0.197	0.063	1.218	1.076	1.379	.002
3政党	議席数	議席数：50～99	0.410	0.063	1.506	1.330	1.706	< .001
3政党	議席数	議席数：100～199	0.574	0.072	1.776	1.542	2.045	< .001
3政党	議席数	議席数：200以上	0.544	0.073	1.723	1.492	1.989	< .001
3政党	CPI	CPI：プラス1ポイント	0.053	0.048	1.054	0.959	1.159	.273
3政党	CPI	CPI：マイナス1ポイント	-0.001	0.047	0.999	0.911	1.096	.989
3政党	失業率	失業率：プラス1％	-0.167	0.049	0.846	0.768	0.932	< .001
3政党	失業率	失業率：マイナス1％	-0.103	0.049	0.902	0.819	0.994	.037
4政党	政策位置	右派・保守的	-0.286	0.054	0.752	0.676	0.835	< .001
4政党	政策位置	左派・革新的	-0.468	0.057	0.626	0.560	0.700	< .001
4政党	与党／野党	与党	0.241	0.051	1.273	1.153	1.405	< .001
4政党	GDP成長率	GDP：プラス1％	0.384	0.046	1.468	1.342	1.605	< .001
4政党	GDP成長率	GDP：マイナス1％	-0.207	0.047	0.813	0.741	0.891	< .001
4政党	日経平均	日経平均：プラス1000円	0.168	0.045	1.183	1.083	1.293	< .001
4政党	日経平均	日経平均：マイナス1000円	-0.301	0.045	0.740	0.677	0.809	< .001
4政党	議席数	議席数：10～49	0.232	0.056	1.261	1.130	1.406	< .001
4政党	議席数	議席数：50～99	0.399	0.060	1.491	1.326	1.676	< .001
4政党	議席数	議席数：100～199	0.585	0.065	1.795	1.579	2.040	< .001
4政党	議席数	議席数：200以上	0.567	0.073	1.762	1.527	2.033	< .001
4政党	CPI	CPI：プラス1ポイント	0.150	0.045	1.161	1.063	1.269	< .001
4政党	CPI	CPI：マイナス1ポイント	-0.001	0.046	0.999	0.912	1.094	.983
4政党	失業率	失業率：プラス1％	-0.204	0.048	0.815	0.742	0.895	< .001
4政党	失業率	失業率：マイナス1％	-0.020	0.044	0.981	0.900	1.069	.656
5政党	政策位置	右派・保守的	-0.271	0.054	0.763	0.686	0.848	< .001
5政党	政策位置	左派・革新的	-0.419	0.056	0.657	0.589	0.734	< .001
5政党	与党／野党	与党	0.306	0.052	1.358	1.226	1.504	< .001
5政党	GDP成長率	GDP：プラス1％	0.389	0.046	1.475	1.348	1.615	< .001
5政党	GDP成長率	GDP：マイナス1％	-0.228	0.048	0.796	0.725	0.874	< .001
5政党	日経平均	日経平均：プラス1000円	0.231	0.044	1.260	1.157	1.373	< .001
5政党	日経平均	日経平均：マイナス1000円	-0.323	0.046	0.724	0.662	0.792	< .001
5政党	議席数	議席数：10～49	0.275	0.052	1.317	1.190	1.457	< .001
5政党	議席数	議席数：50～99	0.544	0.060	1.722	1.530	1.938	< .001
5政党	議席数	議席数：100～199	0.643	0.068	1.902	1.665	2.172	< .001
5政党	議席数	議席数：200以上	0.651	0.070	1.917	1.671	2.199	< .001
5政党	CPI	CPI：プラス1ポイント	0.054	0.044	1.055	0.969	1.149	.216
5政党	CPI	CPI：マイナス1ポイント	-0.083	0.045	0.920	0.843	1.005	.065
5政党	失業率	失業率：プラス1％	-0.190	0.047	0.827	0.754	0.907	< .001
5政党	失業率	失業率：マイナス1％	-0.005	0.045	0.995	0.911	1.087	.912

F. 実験2（2026年）の補足分析

本文では実験2のAMCEの方向性を記述し、詳細を補遺に回しているため、共変量調整済みAMCEを補図F1として最初に示す。

補図F1：共変量調整済みAMCE

補図F1データ <- study2_env$amce_plot_df_cov_facet
補図F1 <- study2_env$p_amce_cov_facet
補図F1

表F1 <- readr::read_csv(study_csv("study2", "table_amce_covariate_adjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表F1), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2政党条件	政策位置	右派・保守的	-1.96	1.61	-5.11	1.19	.223	711
2政党条件	政策位置	左派・革新的	-9.43	1.58	-12.53	-6.34	< .001	711
2政党条件	与党／野党	与党	3.43	1.31	0.87	5.99	.009	711
2政党条件	GDP成長率	GDP：プラス1％	8.29	1.56	5.23	11.35	< .001	711
2政党条件	GDP成長率	GDP：マイナス1％	-5.54	1.52	-8.52	-2.56	< .001	711
2政党条件	日経平均	日経平均：プラス1000円	4.28	1.49	1.35	7.20	.004	711
2政党条件	日経平均	日経平均：マイナス1000円	-7.03	1.52	-10.01	-4.06	< .001	711
2政党条件	議席数	議席数：10～49	1.05	1.85	-2.58	4.67	.572	711
2政党条件	議席数	議席数：50～99	5.40	1.80	1.87	8.93	.003	711
2政党条件	議席数	議席数：100～199	8.38	2.00	4.46	12.30	< .001	711
2政党条件	議席数	議席数：200以上	8.34	1.99	4.43	12.24	< .001	711
2政党条件	CPI	CPI：プラス1ポイント	1.84	1.43	-0.97	4.64	.200	711
2政党条件	CPI	CPI：マイナス1ポイント	1.64	1.41	-1.13	4.40	.246	711
2政党条件	失業率	失業率：プラス1％	-4.71	1.52	-7.69	-1.73	.002	711
2政党条件	失業率	失業率：マイナス1％	-3.02	1.50	-5.96	-0.08	.045	711
3政党条件	政策位置	右派・保守的	-0.29	1.18	-2.59	2.02	.807	1062
3政党条件	政策位置	左派・革新的	-9.14	1.04	-11.19	-7.10	< .001	1062
3政党条件	与党／野党	与党	1.80	0.91	0.02	3.57	.048	1062
3政党条件	GDP成長率	GDP：プラス1％	5.85	0.97	3.95	7.75	< .001	1062
3政党条件	GDP成長率	GDP：マイナス1％	-6.32	0.88	-8.05	-4.58	< .001	1062
3政党条件	日経平均	日経平均：プラス1000円	5.06	0.96	3.18	6.94	< .001	1062
3政党条件	日経平均	日経平均：マイナス1000円	-4.63	0.94	-6.46	-2.79	< .001	1062
3政党条件	議席数	議席数：10～49	3.52	1.17	1.23	5.81	.003	1062
3政党条件	議席数	議席数：50～99	7.32	1.19	4.99	9.65	< .001	1062
3政党条件	議席数	議席数：100～199	10.83	1.21	8.46	13.20	< .001	1062
3政党条件	議席数	議席数：200以上	10.08	1.25	7.63	12.52	< .001	1062
3政党条件	CPI	CPI：プラス1ポイント	1.32	0.92	-0.47	3.12	.149	1062
3政党条件	CPI	CPI：マイナス1ポイント	-2.66	0.94	-4.51	-0.81	.005	1062
3政党条件	失業率	失業率：プラス1％	-4.23	0.95	-6.09	-2.37	< .001	1062
3政党条件	失業率	失業率：マイナス1％	-1.38	0.96	-3.26	0.50	.150	1062
4政党条件	政策位置	右派・保守的	1.11	0.98	-0.82	3.03	.260	1097
4政党条件	政策位置	左派・革新的	-8.64	0.86	-10.32	-6.96	< .001	1097
4政党条件	与党／野党	与党	1.85	0.72	0.43	3.27	.011	1097
4政党条件	GDP成長率	GDP：プラス1％	6.40	0.76	4.92	7.89	< .001	1097
4政党条件	GDP成長率	GDP：マイナス1％	-4.84	0.69	-6.19	-3.50	< .001	1097
4政党条件	日経平均	日経平均：プラス1000円	2.72	0.77	1.20	4.23	< .001	1097
4政党条件	日経平均	日経平均：マイナス1000円	-5.12	0.71	-6.52	-3.73	< .001	1097
4政党条件	議席数	議席数：10～49	5.18	0.87	3.47	6.89	< .001	1097
4政党条件	議席数	議席数：50～99	8.18	0.94	6.34	10.02	< .001	1097
4政党条件	議席数	議席数：100～199	11.17	0.97	9.28	13.07	< .001	1097
4政党条件	議席数	議席数：200以上	11.28	1.02	9.28	13.29	< .001	1097
4政党条件	CPI	CPI：プラス1ポイント	1.67	0.74	0.21	3.12	.025	1097
4政党条件	CPI	CPI：マイナス1ポイント	-0.57	0.73	-2.00	0.86	.433	1097
4政党条件	失業率	失業率：プラス1％	-4.23	0.75	-5.70	-2.76	< .001	1097
4政党条件	失業率	失業率：マイナス1％	-1.18	0.79	-2.73	0.37	.136	1097
5政党条件	政策位置	右派・保守的	1.01	0.78	-0.52	2.55	.195	1322
5政党条件	政策位置	左派・革新的	-6.08	0.68	-7.42	-4.75	< .001	1322
5政党条件	与党／野党	与党	2.76	0.55	1.68	3.83	< .001	1322
5政党条件	GDP成長率	GDP：プラス1％	5.07	0.59	3.91	6.23	< .001	1322
5政党条件	GDP成長率	GDP：マイナス1％	-2.96	0.52	-3.98	-1.94	< .001	1322
5政党条件	日経平均	日経平均：プラス1000円	4.09	0.58	2.97	5.22	< .001	1322
5政党条件	日経平均	日経平均：マイナス1000円	-3.13	0.55	-4.20	-2.07	< .001	1322
5政党条件	議席数	議席数：10～49	2.26	0.63	1.02	3.50	< .001	1322
5政党条件	議席数	議席数：50～99	6.91	0.70	5.54	8.28	< .001	1322
5政党条件	議席数	議席数：100～199	9.65	0.75	8.18	11.12	< .001	1322
5政党条件	議席数	議席数：200以上	10.56	0.77	9.05	12.08	< .001	1322
5政党条件	CPI	CPI：プラス1ポイント	0.28	0.54	-0.78	1.35	.602	1322
5政党条件	CPI	CPI：マイナス1ポイント	-0.43	0.55	-1.50	0.65	.436	1322
5政党条件	失業率	失業率：プラス1％	-2.36	0.55	-3.43	-1.28	< .001	1322
5政党条件	失業率	失業率：マイナス1％	-0.19	0.59	-1.34	0.97	.753	1322

補図F2：共変量を含めないAMCE

補図F2データ <- study2_env$amce_plot_df_nocov_facet
補図F2 <- study2_env$p_amce_facet_nocov
補図F2

表F2 <- readr::read_csv(study_csv("study2", "table_amce_unadjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表F2), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2政党条件	政策位置	右派・保守的	-1.94	1.60	-5.08	1.19	.225	711
2政党条件	政策位置	左派・革新的	-9.40	1.57	-12.48	-6.31	< .001	711
2政党条件	与党／野党	与党	3.43	1.30	0.88	5.98	.009	711
2政党条件	GDP成長率	GDP：プラス1％	8.26	1.56	5.21	11.31	< .001	711
2政党条件	GDP成長率	GDP：マイナス1％	-5.53	1.51	-8.49	-2.56	< .001	711
2政党条件	日経平均	日経平均：プラス1000円	4.27	1.49	1.36	7.18	.004	711
2政党条件	日経平均	日経平均：マイナス1000円	-7.01	1.51	-9.97	-4.05	< .001	711
2政党条件	議席数	議席数：10～49	1.03	1.84	-2.59	4.64	.578	711
2政党条件	議席数	議席数：50～99	5.37	1.79	1.86	8.89	.003	711
2政党条件	議席数	議席数：100～199	8.35	1.99	4.45	12.25	< .001	711
2政党条件	議席数	議席数：200以上	8.33	1.98	4.44	12.21	< .001	711
2政党条件	CPI	CPI：プラス1ポイント	1.85	1.43	-0.95	4.64	.195	711
2政党条件	CPI	CPI：マイナス1ポイント	1.62	1.40	-1.14	4.37	.250	711
2政党条件	失業率	失業率：プラス1％	-4.72	1.51	-7.68	-1.75	.002	711
2政党条件	失業率	失業率：マイナス1％	-3.02	1.49	-5.95	-0.10	.043	711
3政党条件	政策位置	右派・保守的	-0.28	1.17	-2.58	2.02	.810	1062
3政党条件	政策位置	左派・革新的	-9.12	1.04	-11.16	-7.08	< .001	1062
3政党条件	与党／野党	与党	1.79	0.91	0.01	3.56	.049	1062
3政党条件	GDP成長率	GDP：プラス1％	5.85	0.97	3.95	7.74	< .001	1062
3政党条件	GDP成長率	GDP：マイナス1％	-6.31	0.88	-8.03	-4.58	< .001	1062
3政党条件	日経平均	日経平均：プラス1000円	5.05	0.96	3.18	6.93	< .001	1062
3政党条件	日経平均	日経平均：マイナス1000円	-4.62	0.93	-6.46	-2.79	< .001	1062
3政党条件	議席数	議席数：10～49	3.52	1.17	1.23	5.81	.003	1062
3政党条件	議席数	議席数：50～99	7.31	1.19	4.99	9.63	< .001	1062
3政党条件	議席数	議席数：100～199	10.81	1.21	8.45	13.18	< .001	1062
3政党条件	議席数	議席数：200以上	10.06	1.24	7.62	12.50	< .001	1062
3政党条件	CPI	CPI：プラス1ポイント	1.33	0.92	-0.47	3.13	.148	1062
3政党条件	CPI	CPI：マイナス1ポイント	-2.66	0.94	-4.51	-0.81	.005	1062
3政党条件	失業率	失業率：プラス1％	-4.23	0.95	-6.08	-2.37	< .001	1062
3政党条件	失業率	失業率：マイナス1％	-1.39	0.96	-3.26	0.49	.147	1062
4政党条件	政策位置	右派・保守的	1.11	0.98	-0.82	3.03	.260	1097
4政党条件	政策位置	左派・革新的	-8.63	0.86	-10.31	-6.96	< .001	1097
4政党条件	与党／野党	与党	1.85	0.72	0.43	3.27	.011	1097
4政党条件	GDP成長率	GDP：プラス1％	6.40	0.76	4.91	7.88	< .001	1097
4政党条件	GDP成長率	GDP：マイナス1％	-4.84	0.69	-6.18	-3.50	< .001	1097
4政党条件	日経平均	日経平均：プラス1000円	2.72	0.77	1.20	4.23	< .001	1097
4政党条件	日経平均	日経平均：マイナス1000円	-5.12	0.71	-6.51	-3.73	< .001	1097
4政党条件	議席数	議席数：10～49	5.18	0.87	3.47	6.88	< .001	1097
4政党条件	議席数	議席数：50～99	8.17	0.94	6.33	10.01	< .001	1097
4政党条件	議席数	議席数：100～199	11.17	0.96	9.28	13.06	< .001	1097
4政党条件	議席数	議席数：200以上	11.28	1.02	9.28	13.28	< .001	1097
4政党条件	CPI	CPI：プラス1ポイント	1.67	0.74	0.22	3.12	.024	1097
4政党条件	CPI	CPI：マイナス1ポイント	-0.57	0.73	-1.99	0.86	.435	1097
4政党条件	失業率	失業率：プラス1％	-4.22	0.75	-5.69	-2.75	< .001	1097
4政党条件	失業率	失業率：マイナス1％	-1.18	0.79	-2.73	0.37	.137	1097
5政党条件	政策位置	右派・保守的	1.02	0.78	-0.51	2.55	.194	1322
5政党条件	政策位置	左派・革新的	-6.08	0.68	-7.41	-4.75	< .001	1322
5政党条件	与党／野党	与党	2.75	0.55	1.67	3.82	< .001	1322
5政党条件	GDP成長率	GDP：プラス1％	5.07	0.59	3.91	6.23	< .001	1322
5政党条件	GDP成長率	GDP：マイナス1％	-2.96	0.52	-3.97	-1.94	< .001	1322
5政党条件	日経平均	日経平均：プラス1000円	4.09	0.57	2.96	5.22	< .001	1322
5政党条件	日経平均	日経平均：マイナス1000円	-3.13	0.55	-4.20	-2.06	< .001	1322
5政党条件	議席数	議席数：10～49	2.26	0.63	1.02	3.50	< .001	1322
5政党条件	議席数	議席数：50～99	6.91	0.70	5.54	8.27	< .001	1322
5政党条件	議席数	議席数：100～199	9.65	0.75	8.18	11.12	< .001	1322
5政党条件	議席数	議席数：200以上	10.56	0.77	9.05	12.07	< .001	1322
5政党条件	CPI	CPI：プラス1ポイント	0.28	0.54	-0.78	1.35	.602	1322
5政党条件	CPI	CPI：マイナス1ポイント	-0.42	0.55	-1.50	0.65	.438	1322
5政党条件	失業率	失業率：プラス1％	-2.36	0.55	-3.44	-1.28	< .001	1322
5政党条件	失業率	失業率：マイナス1％	-0.19	0.59	-1.34	0.96	.749	1322

補図F3：2政党条件との差

補図F3データ <- study2_env$interaction_plot_df
補図F3 <- study2_env$p_interaction
補図F3

表F3 <- readr::read_csv(study_csv("study2", "table_amce_interaction.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, attribute = "属性")) %>%
  dplyr::mutate(dplyr::across(dplyr::any_of("属性"), 属性日本語))
knitr::kable(表日本語(表F3), format = "html", row.names = FALSE)

比較条件	属性	水準	2選択肢条件との差（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値
3政党	政策位置	右派・保守的	1.66	1.98	-2.22	5.55	0.402
4政党	政策位置	右派・保守的	3.05	1.88	-0.63	6.73	0.104
5政党	政策位置	右派・保守的	2.96	1.78	-0.53	6.45	0.096
3政党	政策位置	左派・革新的	0.28	1.88	-3.42	3.97	0.882
4政党	政策位置	左派・革新的	0.77	1.79	-2.74	4.27	0.668
5政党	政策位置	左派・革新的	3.32	1.71	-0.04	6.68	0.053
3政党	与党／野党	与党	-1.64	1.58	-4.74	1.46	0.300
4政党	与党／野党	与党	-1.58	1.49	-4.49	1.33	0.288
5政党	与党／野党	与党	-0.68	1.41	-3.44	2.08	0.630
3政党	GDP成長率	GDP：プラス1％	-2.42	1.83	-6.00	1.17	0.187
4政党	GDP成長率	GDP：プラス1％	-1.87	1.73	-5.25	1.52	0.280
5政党	GDP成長率	GDP：プラス1％	-3.20	1.66	-6.45	0.06	0.055
3政党	GDP成長率	GDP：マイナス1％	-0.78	1.75	-4.21	2.65	0.656
4政党	GDP成長率	GDP：マイナス1％	0.69	1.66	-2.56	3.93	0.679
5政党	GDP成長率	GDP：マイナス1％	2.57	1.60	-0.56	5.70	0.108
3政党	日経平均	日経平均：プラス1000円	0.78	1.77	-2.68	4.24	0.658
4政党	日経平均	日経平均：プラス1000円	-1.56	1.67	-4.83	1.72	0.353
5政党	日経平均	日経平均：プラス1000円	-0.18	1.59	-3.30	2.94	0.909
3政党	日経平均	日経平均：マイナス1000円	2.39	1.78	-1.09	5.87	0.179
4政党	日経平均	日経平均：マイナス1000円	1.89	1.67	-1.38	5.16	0.257
5政党	日経平均	日経平均：マイナス1000円	3.88	1.60	0.73	7.02	0.016
3政党	議席数	議席数：10～49	2.49	2.18	-1.79	6.76	0.254
4政党	議席数	議席数：10～49	4.15	2.04	0.16	8.14	0.042
5政党	議席数	議席数：10～49	1.23	1.95	-2.58	5.05	0.527
3政党	議席数	議席数：50～99	1.94	2.15	-2.27	6.15	0.367
4政党	議席数	議席数：50～99	2.80	2.02	-1.17	6.76	0.167
5政党	議席数	議席数：50～99	1.53	1.92	-2.24	5.30	0.425
3政党	議席数	議席数：100～199	2.46	2.32	-2.09	7.02	0.289
4政党	議席数	議席数：100～199	2.82	2.21	-1.51	7.15	0.202
5政党	議席数	議席数：100～199	1.30	2.12	-2.87	5.46	0.542
3政党	議席数	議席数：200以上	1.74	2.34	-2.85	6.32	0.458
4政党	議席数	議席数：200以上	2.95	2.23	-1.42	7.32	0.185
5政党	議席数	議席数：200以上	2.23	2.13	-1.93	6.40	0.293
3政党	CPI	CPI：プラス1ポイント	-0.52	1.69	-3.84	2.80	0.759
4政党	CPI	CPI：プラス1ポイント	-0.18	1.61	-3.32	2.97	0.912
5政党	CPI	CPI：プラス1ポイント	-1.56	1.52	-4.55	1.42	0.305
3政党	CPI	CPI：マイナス1ポイント	-4.28	1.69	-7.59	-0.97	0.011
4政党	CPI	CPI：マイナス1ポイント	-2.18	1.58	-5.28	0.91	0.167
5政党	CPI	CPI：マイナス1ポイント	-2.04	1.51	-4.99	0.91	0.175
3政党	失業率	失業率：プラス1％	0.49	1.78	-3.00	3.99	0.782
4政党	失業率	失業率：プラス1％	0.50	1.69	-2.81	3.80	0.769
5政党	失業率	失業率：プラス1％	2.36	1.61	-0.79	5.51	0.142
3政党	失業率	失業率：マイナス1％	1.64	1.77	-1.84	5.11	0.355
4政党	失業率	失業率：マイナス1％	1.85	1.69	-1.46	5.16	0.274
5政党	失業率	失業率：マイナス1％	2.84	1.60	-0.31	5.98	0.077

補図F4：条件付きロジット

補図F4 <- study2_env$p_clogit_or
補図F4

表F4 <- readr::read_csv(study_csv("study2", "table_conditional_logit.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", label = "水準")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study2"), 属性 = 属性日本語(属性)) %>%
  dplyr::select(-dplyr::any_of(c("term", "variable", "policy_position", "government_status")))
knitr::kable(表日本語(表F4), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	log係数	標準誤差	オッズ比	95% CI下限（OR）	95% CI上限（OR）	p値
2政党	政策位置	右派・保守的	-0.086	0.072	0.918	0.797	1.057	.234
2政党	政策位置	左派・革新的	-0.408	0.069	0.665	0.581	0.762	< .001
2政党	与党／野党	与党	0.137	0.054	1.147	1.031	1.276	.012
2政党	GDP成長率	GDP：プラス1％	0.346	0.065	1.413	1.245	1.603	< .001
2政党	GDP成長率	GDP：マイナス1％	-0.224	0.063	0.799	0.706	0.905	< .001
2政党	日経平均	日経平均：プラス1000円	0.187	0.063	1.205	1.066	1.363	.003
2政党	日経平均	日経平均：マイナス1000円	-0.294	0.064	0.745	0.658	0.844	< .001
2政党	議席数	議席数：10～49	0.054	0.076	1.056	0.910	1.225	.474
2政党	議席数	議席数：50～99	0.254	0.079	1.290	1.105	1.505	.001
2政党	議席数	議席数：100～199	0.349	0.084	1.418	1.202	1.672	< .001
2政党	議席数	議席数：200以上	0.351	0.087	1.420	1.199	1.683	< .001
2政党	CPI	CPI：プラス1ポイント	0.099	0.062	1.104	0.977	1.247	.112
2政党	CPI	CPI：マイナス1ポイント	0.087	0.061	1.091	0.968	1.230	.153
2政党	失業率	失業率：プラス1％	-0.190	0.064	0.827	0.729	0.938	.003
2政党	失業率	失業率：マイナス1％	-0.131	0.064	0.877	0.774	0.993	.039
3政党	政策位置	右派・保守的	-0.014	0.053	0.986	0.889	1.093	.791
3政党	政策位置	左派・革新的	-0.444	0.051	0.641	0.580	0.709	< .001
3政党	与党／野党	与党	0.089	0.042	1.093	1.006	1.187	.036
3政党	GDP成長率	GDP：プラス1％	0.263	0.043	1.301	1.196	1.415	< .001
3政党	GDP成長率	GDP：マイナス1％	-0.309	0.043	0.734	0.675	0.798	< .001
3政党	日経平均	日経平均：プラス1000円	0.228	0.044	1.256	1.153	1.369	< .001
3政党	日経平均	日経平均：マイナス1000円	-0.232	0.046	0.793	0.724	0.869	< .001
3政党	議席数	議席数：10～49	0.182	0.060	1.200	1.066	1.350	.003
3政党	議席数	議席数：50～99	0.377	0.060	1.457	1.295	1.640	< .001
3政党	議席数	議席数：100～199	0.536	0.060	1.710	1.519	1.924	< .001
3政党	議席数	議席数：200以上	0.495	0.062	1.640	1.454	1.850	< .001
3政党	CPI	CPI：プラス1ポイント	0.066	0.043	1.068	0.983	1.161	.120
3政党	CPI	CPI：マイナス1ポイント	-0.117	0.045	0.890	0.815	0.971	.009
3政党	失業率	失業率：プラス1％	-0.200	0.044	0.819	0.751	0.893	< .001
3政党	失業率	失業率：マイナス1％	-0.063	0.044	0.939	0.862	1.024	.156
4政党	政策位置	右派・保守的	0.053	0.050	1.055	0.957	1.163	.285
4政党	政策位置	左派・革新的	-0.519	0.052	0.595	0.538	0.659	< .001
4政党	与党／野党	与党	0.099	0.040	1.104	1.020	1.195	.014
4政党	GDP成長率	GDP：プラス1％	0.340	0.040	1.405	1.300	1.518	< .001
4政党	GDP成長率	GDP：マイナス1％	-0.294	0.042	0.745	0.687	0.809	< .001
4政党	日経平均	日経平均：プラス1000円	0.142	0.040	1.152	1.065	1.247	< .001
4政党	日経平均	日経平均：マイナス1000円	-0.300	0.042	0.741	0.683	0.804	< .001
4政党	議席数	議席数：10～49	0.331	0.056	1.392	1.247	1.553	< .001
4政党	議席数	議席数：50～99	0.497	0.058	1.645	1.467	1.844	< .001
4政党	議席数	議席数：100～199	0.656	0.059	1.927	1.716	2.163	< .001
4政党	議席数	議席数：200以上	0.656	0.062	1.928	1.709	2.175	< .001
4政党	CPI	CPI：プラス1ポイント	0.098	0.040	1.103	1.019	1.194	.015
4政党	CPI	CPI：マイナス1ポイント	-0.031	0.041	0.969	0.894	1.051	.447
4政党	失業率	失業率：プラス1％	-0.232	0.042	0.793	0.730	0.862	< .001
4政党	失業率	失業率：マイナス1％	-0.065	0.043	0.937	0.862	1.019	.127
5政党	政策位置	右派・保守的	0.064	0.047	1.066	0.973	1.168	.173
5政党	政策位置	左派・革新的	-0.418	0.047	0.658	0.600	0.722	< .001
5政党	与党／野党	与党	0.185	0.036	1.203	1.121	1.291	< .001
5政党	GDP成長率	GDP：プラス1％	0.311	0.036	1.365	1.272	1.464	< .001
5政党	GDP成長率	GDP：マイナス1％	-0.209	0.037	0.812	0.755	0.873	< .001
5政党	日経平均	日経平均：プラス1000円	0.245	0.035	1.278	1.193	1.369	< .001
5政党	日経平均	日経平均：マイナス1000円	-0.221	0.038	0.802	0.745	0.864	< .001
5政党	議席数	議席数：10～49	0.182	0.050	1.200	1.087	1.324	< .001
5政党	議席数	議席数：50～99	0.493	0.050	1.638	1.484	1.808	< .001
5政党	議席数	議席数：100～199	0.665	0.053	1.945	1.752	2.159	< .001
5政党	議席数	議席数：200以上	0.716	0.054	2.047	1.843	2.274	< .001
5政党	CPI	CPI：プラス1ポイント	0.023	0.035	1.023	0.955	1.096	.513
5政党	CPI	CPI：マイナス1ポイント	-0.027	0.036	0.973	0.907	1.044	.443
5政党	失業率	失業率：プラス1％	-0.160	0.036	0.852	0.794	0.914	< .001
5政党	失業率	失業率：マイナス1％	-0.016	0.037	0.985	0.916	1.058	.674

G. 実験3（2026年）の補足分析

補図G1：共変量を含めないAMCE

補図G1データ <- study3_env$amce_plot_nocov
補図G1 <- study3_env$p_amce_nocov
補図G1

表G1 <- readr::read_csv(study_csv("study3", "table_amce_unadjusted.csv"), show_col_types = FALSE) %>%
  dplyr::mutate(条件 = paste0(stringr::str_remove(条件, "条件$"), "条件"))
knitr::kable(表日本語(表G1), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	推定値（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値	回答者数
2選択肢条件	政権与党の政党名	立憲民主党	-8.81	3.11	-14.91	-2.72	.005	716
2選択肢条件	政権与党の政党名	日本維新の会	-5.98	2.76	-11.39	-0.56	.031	716
2選択肢条件	政権与党の政党名	公明党	-23.50	2.89	-29.17	-17.83	< .001	716
2選択肢条件	政権与党の政党名	国民民主党	-1.24	2.79	-6.71	4.24	.659	716
2選択肢条件	政権与党の政党名	れいわ新選組	-28.29	3.03	-34.23	-22.36	< .001	716
2選択肢条件	政権与党の政党名	参政党	-14.93	2.76	-20.35	-9.52	< .001	716
2選択肢条件	政権与党の政党名	日本共産党	-33.63	2.89	-39.30	-27.95	< .001	716
2選択肢条件	政権与党の政党名	中道改革連合	-12.51	2.91	-18.22	-6.80	< .001	716
2選択肢条件	政権与党の政党名	チームみらい	-5.10	2.81	-10.60	0.40	.070	716
2選択肢条件	GDP成長率	GDP：プラス1％	7.63	1.43	4.82	10.44	< .001	716
2選択肢条件	GDP成長率	GDP：マイナス1％	-5.89	1.44	-8.71	-3.07	< .001	716
2選択肢条件	日経平均	日経平均：プラス1000円	2.84	1.41	0.07	5.61	.045	716
2選択肢条件	日経平均	日経平均：マイナス1000円	-5.26	1.43	-8.06	-2.46	< .001	716
2選択肢条件	CPI	CPI：プラス1ポイント	-0.48	1.42	-3.26	2.30	.733	716
2選択肢条件	CPI	CPI：マイナス1ポイント	-2.27	1.43	-5.07	0.52	.112	716
2選択肢条件	失業率	失業率：プラス1％	-6.06	1.42	-8.85	-3.27	< .001	716
2選択肢条件	失業率	失業率：マイナス1％	-1.49	1.42	-4.26	1.29	.295	716
3選択肢条件	政権与党の政党名	立憲民主党	-13.87	2.26	-18.29	-9.45	< .001	939
3選択肢条件	政権与党の政党名	日本維新の会	-9.01	2.05	-13.02	-5.00	< .001	939
3選択肢条件	政権与党の政党名	公明党	-25.30	2.00	-29.22	-21.38	< .001	939
3選択肢条件	政権与党の政党名	国民民主党	-2.58	2.15	-6.79	1.64	.231	939
3選択肢条件	政権与党の政党名	れいわ新選組	-26.00	2.18	-30.28	-21.73	< .001	939
3選択肢条件	政権与党の政党名	参政党	-12.43	2.15	-16.66	-8.21	< .001	939
3選択肢条件	政権与党の政党名	日本共産党	-28.06	2.15	-32.28	-23.84	< .001	939
3選択肢条件	政権与党の政党名	中道改革連合	-18.36	2.26	-22.78	-13.94	< .001	939
3選択肢条件	政権与党の政党名	チームみらい	-8.30	2.16	-12.53	-4.07	< .001	939
3選択肢条件	GDP成長率	GDP：プラス1％	7.09	1.00	5.14	9.05	< .001	939
3選択肢条件	GDP成長率	GDP：マイナス1％	-4.80	0.97	-6.70	-2.89	< .001	939
3選択肢条件	日経平均	日経平均：プラス1000円	3.37	1.02	1.37	5.38	.001	939
3選択肢条件	日経平均	日経平均：マイナス1000円	-5.28	0.94	-7.13	-3.43	< .001	939
3選択肢条件	CPI	CPI：プラス1ポイント	-0.44	0.96	-2.32	1.44	.645	939
3選択肢条件	CPI	CPI：マイナス1ポイント	-1.37	0.94	-3.21	0.46	.143	939
3選択肢条件	失業率	失業率：プラス1％	-4.46	0.96	-6.34	-2.58	< .001	939
3選択肢条件	失業率	失業率：マイナス1％	-1.96	0.97	-3.86	-0.05	.044	939
4選択肢条件	政権与党の政党名	立憲民主党	-16.33	1.88	-20.01	-12.64	< .001	1063
4選択肢条件	政権与党の政党名	日本維新の会	-9.34	1.73	-12.73	-5.95	< .001	1063
4選択肢条件	政権与党の政党名	公明党	-24.43	1.67	-27.71	-21.16	< .001	1063
4選択肢条件	政権与党の政党名	国民民主党	-4.96	1.80	-8.49	-1.43	.006	1063
4選択肢条件	政権与党の政党名	れいわ新選組	-25.30	1.75	-28.74	-21.86	< .001	1063
4選択肢条件	政権与党の政党名	参政党	-12.36	1.81	-15.91	-8.81	< .001	1063
4選択肢条件	政権与党の政党名	日本共産党	-25.65	1.80	-29.17	-22.13	< .001	1063
4選択肢条件	政権与党の政党名	中道改革連合	-17.92	1.92	-21.69	-14.15	< .001	1063
4選択肢条件	政権与党の政党名	チームみらい	-11.29	1.89	-14.99	-7.58	< .001	1063
4選択肢条件	GDP成長率	GDP：プラス1％	5.03	0.76	3.54	6.52	< .001	1063
4選択肢条件	GDP成長率	GDP：マイナス1％	-3.49	0.72	-4.91	-2.08	< .001	1063
4選択肢条件	日経平均	日経平均：プラス1000円	3.87	0.80	2.31	5.43	< .001	1063
4選択肢条件	日経平均	日経平均：マイナス1000円	-3.32	0.72	-4.74	-1.90	< .001	1063
4選択肢条件	CPI	CPI：プラス1ポイント	0.54	0.73	-0.89	1.98	.457	1063
4選択肢条件	CPI	CPI：マイナス1ポイント	-1.25	0.73	-2.69	0.19	.088	1063
4選択肢条件	失業率	失業率：プラス1％	-3.72	0.71	-5.11	-2.33	< .001	1063
4選択肢条件	失業率	失業率：マイナス1％	-2.01	0.73	-3.44	-0.58	.006	1063
5選択肢条件	政権与党の政党名	立憲民主党	-12.98	1.59	-16.10	-9.86	< .001	1314
5選択肢条件	政権与党の政党名	日本維新の会	-8.62	1.42	-11.40	-5.84	< .001	1314
5選択肢条件	政権与党の政党名	公明党	-21.75	1.38	-24.46	-19.03	< .001	1314
5選択肢条件	政権与党の政党名	国民民主党	-5.06	1.49	-7.98	-2.14	< .001	1314
5選択肢条件	政権与党の政党名	れいわ新選組	-21.60	1.41	-24.37	-18.83	< .001	1314
5選択肢条件	政権与党の政党名	参政党	-13.07	1.49	-16.00	-10.15	< .001	1314
5選択肢条件	政権与党の政党名	日本共産党	-21.87	1.42	-24.65	-19.09	< .001	1314
5選択肢条件	政権与党の政党名	中道改革連合	-16.65	1.50	-19.60	-13.70	< .001	1314
5選択肢条件	政権与党の政党名	チームみらい	-12.21	1.51	-15.16	-9.26	< .001	1314
5選択肢条件	GDP成長率	GDP：プラス1％	5.48	0.59	4.32	6.64	< .001	1314
5選択肢条件	GDP成長率	GDP：マイナス1％	-2.10	0.52	-3.13	-1.08	< .001	1314
5選択肢条件	日経平均	日経平均：プラス1000円	3.78	0.55	2.70	4.86	< .001	1314
5選択肢条件	日経平均	日経平均：マイナス1000円	-2.15	0.53	-3.19	-1.12	< .001	1314
5選択肢条件	CPI	CPI：プラス1ポイント	0.42	0.53	-0.62	1.47	.430	1314
5選択肢条件	CPI	CPI：マイナス1ポイント	-0.10	0.55	-1.18	0.99	.863	1314
5選択肢条件	失業率	失業率：プラス1％	-2.85	0.55	-3.93	-1.76	< .001	1314
5選択肢条件	失業率	失業率：マイナス1％	-0.89	0.55	-1.98	0.19	.107	1314

補図G2：2選択肢条件との差

補図G2 <- study3_env$p_interaction
補図G2

表G2 <- readr::read_csv(study_csv("study3", "table_amce_interaction.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, attribute = "属性")) %>%
  dplyr::mutate(dplyr::across(dplyr::any_of("属性"), 属性日本語))
knitr::kable(表日本語(表G2), format = "html", row.names = FALSE)

比較条件	属性	水準	2選択肢条件との差（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値
3選択肢	政権与党の政党名	立憲民主党	-5.05	3.84	-12.57	2.47	.188
4選択肢	政権与党の政党名	立憲民主党	-7.51	3.63	-14.62	-0.40	.038
5選択肢	政権与党の政党名	立憲民主党	-4.16	3.49	-11.00	2.67	.233
3選択肢	政権与党の政党名	日本維新の会	-3.03	3.43	-9.77	3.70	.377
4選択肢	政権与党の政党名	日本維新の会	-3.36	3.26	-9.74	3.02	.302
5選択肢	政権与党の政党名	日本維新の会	-2.65	3.10	-8.72	3.43	.394
3選択肢	政権与党の政党名	公明党	-1.80	3.51	-8.69	5.08	.608
4選択肢	政権与党の政党名	公明党	-0.93	3.34	-7.48	5.61	.780
5選択肢	政権与党の政党名	公明党	1.75	3.20	-4.53	8.03	.584
3選択肢	政権与党の政党名	国民民主党	-1.34	3.52	-8.24	5.56	.703
4選択肢	政権与党の政党名	国民民主党	-3.72	3.32	-10.24	2.79	.262
5選択肢	政権与党の政党名	国民民主党	-3.83	3.16	-10.03	2.38	.227
3選択肢	政権与党の政党名	れいわ新選組	2.29	3.73	-5.02	9.60	.539
4選択肢	政権与党の政党名	れいわ新選組	2.99	3.50	-3.86	9.84	.392
5選択肢	政権与党の政党名	れいわ新選組	6.69	3.34	0.15	13.24	.045
3選択肢	政権与党の政党名	参政党	2.50	3.50	-4.36	9.36	.475
4選択肢	政権与党の政党名	参政党	2.57	3.30	-3.89	9.04	.436
5選択肢	政権与党の政党名	参政党	1.86	3.14	-4.29	8.01	.553
3選択肢	政権与党の政党名	日本共産党	5.57	3.60	-1.49	12.63	.122
4選択肢	政権与党の政党名	日本共産党	7.98	3.40	1.31	14.65	.019
5選択肢	政権与党の政党名	日本共産党	11.76	3.22	5.44	18.07	< .001
3選択肢	政権与党の政党名	中道改革連合	-5.85	3.68	-13.07	1.36	.112
4選択肢	政権与党の政党名	中道改革連合	-5.41	3.49	-12.25	1.42	.121
5選択肢	政権与党の政党名	中道改革連合	-4.15	3.28	-10.56	2.27	.206
3選択肢	政権与党の政党名	チームみらい	-3.20	3.54	-10.13	3.73	.365
4選択肢	政権与党の政党名	チームみらい	-6.19	3.38	-12.81	0.44	.067
5選択肢	政権与党の政党名	チームみらい	-7.11	3.18	-13.35	-0.87	.026
3選択肢	GDP成長率	GDP：プラス1％	-0.54	1.75	-3.96	2.88	.758
4選択肢	GDP成長率	GDP：プラス1％	-2.60	1.62	-5.78	0.58	.109
5選択肢	GDP成長率	GDP：プラス1％	-2.15	1.55	-5.19	0.89	.165
3選択肢	GDP成長率	GDP：マイナス1％	1.09	1.73	-2.31	4.49	.529
4選択肢	GDP成長率	GDP：マイナス1％	2.39	1.61	-0.76	5.54	.136
5選択肢	GDP成長率	GDP：マイナス1％	3.78	1.53	0.79	6.78	.013
3選択肢	日経平均	日経平均：プラス1000円	0.53	1.74	-2.88	3.95	.759
4選択肢	日経平均	日経平均：プラス1000円	1.03	1.62	-2.14	4.21	.525
5選択肢	日経平均	日経平均：プラス1000円	0.94	1.52	-2.03	3.91	.535
3選択肢	日経平均	日経平均：マイナス1000円	-0.02	1.71	-3.37	3.33	.991
4選択肢	日経平均	日経平均：マイナス1000円	1.94	1.60	-1.20	5.07	.226
5選択肢	日経平均	日経平均：マイナス1000円	3.11	1.52	0.12	6.09	.041
3選択肢	CPI	CPI：プラス1ポイント	0.04	1.71	-3.31	3.40	.980
4選択肢	CPI	CPI：プラス1ポイント	1.03	1.59	-2.10	4.15	.519
5選択肢	CPI	CPI：プラス1ポイント	0.91	1.51	-2.06	3.87	.550
3選択肢	CPI	CPI：マイナス1ポイント	0.90	1.71	-2.44	4.24	.598
4選択肢	CPI	CPI：マイナス1ポイント	1.02	1.60	-2.12	4.16	.525
5選択肢	CPI	CPI：マイナス1ポイント	2.18	1.53	-0.82	5.18	.154
3選択肢	失業率	失業率：プラス1％	1.59	1.72	-1.77	4.96	.353
4選択肢	失業率	失業率：プラス1％	2.34	1.59	-0.78	5.45	.142
5選択肢	失業率	失業率：プラス1％	3.21	1.53	0.22	6.21	.035
3選択肢	失業率	失業率：マイナス1％	-0.47	1.72	-3.84	2.89	.784
4選択肢	失業率	失業率：マイナス1％	-0.53	1.59	-3.65	2.59	.740
5選択肢	失業率	失業率：マイナス1％	0.59	1.52	-2.39	3.57	.697

補図G3：AMCEの線形トレンド

補図G3 <- study3_env$p_linear_trend
補図G3

表G3 <- readr::read_csv(study_csv("study3", "table_amce_linear_trend.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, attribute = "属性", label = "水準")) %>%
  dplyr::mutate(dplyr::across(dplyr::any_of("属性"), 属性日本語)) %>%
  dplyr::select(-dplyr::any_of(c("term", "variable")))
knitr::kable(表日本語(表G3), format = "html", row.names = FALSE)

属性	水準	選択肢が1つ増えるときの変化（pp）	標準誤差（pp）	95% CI下限（pp）	95% CI上限（pp）	p値
政権与党の政党名	立憲民主党	-0.61	1.00	-2.57	1.36	.545
政権与党の政党名	日本維新の会	-0.47	0.89	-2.22	1.28	.599
政権与党の政党名	公明党	1.10	0.90	-0.66	2.85	.221
政権与党の政党名	国民民主党	-1.22	0.93	-3.04	0.60	.189
政権与党の政党名	れいわ新選組	2.28	0.94	0.45	4.12	.015
政権与党の政党名	参政党	0.18	0.92	-1.62	1.99	.844
政権与党の政党名	日本共産党	3.61	0.92	1.81	5.40	< .001
政権与党の政党名	中道改革連合	-0.44	0.96	-2.31	1.43	.644
政権与党の政党名	チームみらい	-2.19	0.93	-4.01	-0.36	.019
GDP成長率	GDP：プラス1％	-0.74	0.42	-1.57	0.09	.079
GDP成長率	GDP：マイナス1％	1.29	0.40	0.50	2.08	.001
日経平均	日経平均：プラス1000円	0.29	0.41	-0.52	1.10	.483
日経平均	日経平均：マイナス1000円	1.24	0.40	0.45	2.03	.002
CPI	CPI：プラス1ポイント	0.36	0.40	-0.43	1.15	.372
CPI	CPI：マイナス1ポイント	0.70	0.40	-0.09	1.49	.083
失業率	失業率：プラス1％	0.97	0.41	0.17	1.77	.018
失業率	失業率：マイナス1％	0.39	0.41	-0.42	1.19	.346

補図G4：条件付きロジット

補図G4 <- study3_env$p_clogit_or
補図G4

表G4 <- readr::read_csv(study_csv("study3", "table_conditional_logit.csv"), show_col_types = FALSE) %>%
  dplyr::rename_with(~ dplyr::recode(.x, party_n = "条件", attribute = "属性", label = "水準")) %>%
  dplyr::mutate(条件 = 条件日本語(条件, "study3"), 属性 = 属性日本語(属性)) %>%
  dplyr::select(-dplyr::any_of(c("term", "variable")))
knitr::kable(表日本語(表G4), format = "html", row.names = FALSE)

条件	属性	水準（基準水準との差）	log係数	標準誤差	オッズ比	95% CI下限（OR）	95% CI上限（OR）	p値
2選択肢	政権与党の政党名	立憲民主党	-0.328	0.123	0.721	0.567	0.916	.008
2選択肢	政権与党の政党名	日本維新の会	-0.248	0.111	0.781	0.628	0.970	.026
2選択肢	政権与党の政党名	公明党	-0.952	0.118	0.386	0.306	0.486	< .001
2選択肢	政権与党の政党名	国民民主党	-0.056	0.114	0.946	0.756	1.183	.625
2選択肢	政権与党の政党名	れいわ新選組	-1.155	0.129	0.315	0.245	0.406	< .001
2選択肢	政権与党の政党名	参政党	-0.598	0.110	0.550	0.443	0.682	< .001
2選択肢	政権与党の政党名	日本共産党	-1.364	0.129	0.256	0.199	0.329	< .001
2選択肢	政権与党の政党名	中道改革連合	-0.524	0.118	0.592	0.470	0.746	< .001
2選択肢	政権与党の政党名	チームみらい	-0.206	0.110	0.814	0.655	1.011	.062
2選択肢	GDP成長率	GDP：プラス1％	0.363	0.066	1.438	1.264	1.635	< .001
2選択肢	GDP成長率	GDP：マイナス1％	-0.266	0.064	0.766	0.676	0.869	< .001
2選択肢	日経平均	日経平均：プラス1000円	0.133	0.063	1.143	1.009	1.294	.035
2選択肢	日経平均	日経平均：マイナス1000円	-0.248	0.064	0.781	0.688	0.886	< .001
2選択肢	CPI	CPI：プラス1ポイント	-0.021	0.063	0.980	0.865	1.109	.746
2選択肢	CPI	CPI：マイナス1ポイント	-0.120	0.063	0.887	0.784	1.003	.055
2選択肢	失業率	失業率：プラス1％	-0.256	0.063	0.774	0.684	0.876	< .001
2選択肢	失業率	失業率：マイナス1％	-0.064	0.065	0.938	0.825	1.066	.327
3選択肢	政権与党の政党名	立憲民主党	-0.543	0.089	0.581	0.488	0.691	< .001
3選択肢	政権与党の政党名	日本維新の会	-0.341	0.077	0.711	0.612	0.826	< .001
3選択肢	政権与党の政党名	公明党	-1.061	0.087	0.346	0.291	0.411	< .001
3選択肢	政権与党の政党名	国民民主党	-0.096	0.079	0.908	0.778	1.061	.224
3選択肢	政権与党の政党名	れいわ新選組	-1.121	0.100	0.326	0.268	0.396	< .001
3選択肢	政権与党の政党名	参政党	-0.487	0.084	0.614	0.521	0.725	< .001
3選択肢	政権与党の政党名	日本共産党	-1.226	0.103	0.293	0.240	0.359	< .001
3選択肢	政権与党の政党名	中道改革連合	-0.738	0.092	0.478	0.399	0.573	< .001
3選択肢	政権与党の政党名	チームみらい	-0.322	0.081	0.725	0.618	0.850	< .001
3選択肢	GDP成長率	GDP：プラス1％	0.331	0.046	1.393	1.273	1.523	< .001
3選択肢	GDP成長率	GDP：マイナス1％	-0.264	0.050	0.768	0.696	0.846	< .001
3選択肢	日経平均	日経平均：プラス1000円	0.157	0.048	1.170	1.066	1.285	< .001
3選択肢	日経平均	日経平均：マイナス1000円	-0.275	0.047	0.760	0.692	0.834	< .001
3選択肢	CPI	CPI：プラス1ポイント	-0.016	0.046	0.984	0.900	1.076	.725
3選択肢	CPI	CPI：マイナス1ポイント	-0.084	0.045	0.920	0.841	1.005	.065
3選択肢	失業率	失業率：プラス1％	-0.224	0.047	0.799	0.729	0.876	< .001
3選択肢	失業率	失業率：マイナス1％	-0.097	0.046	0.907	0.828	0.993	.035
4選択肢	政権与党の政党名	立憲民主党	-0.689	0.081	0.502	0.428	0.589	< .001
4選択肢	政権与党の政党名	日本維新の会	-0.362	0.068	0.696	0.609	0.795	< .001
4選択肢	政権与党の政党名	公明党	-1.181	0.085	0.307	0.260	0.363	< .001
4選択肢	政権与党の政党名	国民民主党	-0.186	0.068	0.830	0.726	0.949	.007
4選択肢	政権与党の政党名	れいわ新選組	-1.257	0.093	0.285	0.237	0.342	< .001
4選択肢	政権与党の政党名	参政党	-0.502	0.074	0.605	0.524	0.700	< .001
4選択肢	政権与党の政党名	日本共産党	-1.270	0.096	0.281	0.233	0.339	< .001
4選択肢	政権与党の政党名	中道改革連合	-0.783	0.086	0.457	0.386	0.542	< .001
4選択肢	政権与党の政党名	チームみらい	-0.452	0.077	0.636	0.547	0.740	< .001
4選択肢	GDP成長率	GDP：プラス1％	0.271	0.041	1.311	1.209	1.421	< .001
4選択肢	GDP成長率	GDP：マイナス1％	-0.205	0.043	0.814	0.748	0.887	< .001
4選択肢	日経平均	日経平均：プラス1000円	0.202	0.043	1.223	1.125	1.330	< .001
4選択肢	日経平均	日経平均：マイナス1000円	-0.211	0.043	0.810	0.744	0.881	< .001
4選択肢	CPI	CPI：プラス1ポイント	0.037	0.041	1.038	0.958	1.124	.366
4選択肢	CPI	CPI：マイナス1ポイント	-0.061	0.042	0.941	0.867	1.021	.145
4選択肢	失業率	失業率：プラス1％	-0.209	0.040	0.811	0.749	0.878	< .001
4選択肢	失業率	失業率：マイナス1％	-0.116	0.041	0.890	0.822	0.964	.004
5選択肢	政権与党の政党名	立憲民主党	-0.598	0.074	0.550	0.476	0.636	< .001
5選択肢	政権与党の政党名	日本維新の会	-0.371	0.061	0.690	0.612	0.778	< .001
5選択肢	政権与党の政党名	公明党	-1.223	0.081	0.294	0.251	0.345	< .001
5選択肢	政権与党の政党名	国民民主党	-0.211	0.061	0.810	0.718	0.913	< .001
5選択肢	政権与党の政党名	れいわ新選組	-1.214	0.083	0.297	0.252	0.349	< .001
5選択肢	政権与党の政党名	参政党	-0.603	0.070	0.547	0.477	0.627	< .001
5選択肢	政権与党の政党名	日本共産党	-1.238	0.084	0.290	0.246	0.342	< .001
5選択肢	政権与党の政党名	中道改革連合	-0.822	0.076	0.439	0.379	0.510	< .001
5選択肢	政権与党の政党名	チームみらい	-0.553	0.069	0.575	0.503	0.658	< .001
5選択肢	GDP成長率	GDP：プラス1％	0.340	0.037	1.404	1.307	1.509	< .001
5選択肢	GDP成長率	GDP：マイナス1％	-0.155	0.037	0.857	0.796	0.922	< .001
5選択肢	日経平均	日経平均：プラス1000円	0.232	0.034	1.262	1.179	1.350	< .001
5選択肢	日経平均	日経平均：マイナス1000円	-0.152	0.037	0.859	0.799	0.923	< .001
5選択肢	CPI	CPI：プラス1ポイント	0.028	0.035	1.028	0.961	1.101	.421
5選択肢	CPI	CPI：マイナス1ポイント	-0.007	0.037	0.993	0.925	1.067	.852
5選択肢	失業率	失業率：プラス1％	-0.188	0.037	0.829	0.771	0.891	< .001
5選択肢	失業率	失業率：マイナス1％	-0.051	0.035	0.951	0.887	1.019	.152

H. 政党支持による異質性

支持政党別AMCEでは、各条件に該当する回答者数が40人未満のセルは推定対象外としている。したがって、以下では insufficient_cell_n をNAのまま表示せず、推定可能であった支持政党×選択肢数条件のみを掲載する。

補図H1：支持政党別AMCE

補図H1は、支持政党によるAMCEの異質性を実験ごとに示す。可読性のため、結果は実験1・2・3に分け、1つのパネルを1つの支持政党に対応させる。縦軸には属性名と水準名を一体として表示し、同一の支持政党について各属性・水準の推定結果を上から順に確認できるようにした。点はAMCE、横線は95%信頼区間を示し、点の形で選択肢数条件を区別する。

対応表も実験ごとに分け、選択肢数条件を列方向に展開する。各セルは AMCE [95% CI]（pp） を示し、回答者数は支持政党×選択肢数条件ごとの小表として別に示す。この形式により、同じ属性・水準について2・3・4・5選択肢条件を横方向に直接比較できる。表示表では情報を点推定値と95%信頼区間に集約し、p値を含む完全な係数表は各実験のCSV出力 table_party_support_amce.csv に保存する。

支持AMCE一覧 <- dplyr::bind_rows(
  party_support_amce_results$study1$subgroup_coefficients %>%
    dplyr::mutate(実験 = "実験1（2023年）", study_id = "study1"),
  party_support_amce_results$study2$subgroup_coefficients %>%
    dplyr::mutate(実験 = "実験2（2026年）", study_id = "study2"),
  party_support_amce_results$study3$subgroup_coefficients %>%
    dplyr::mutate(実験 = "実験3（2026年）", study_id = "study3")
) %>%
  dplyr::filter(
    status == "estimated",
    !is.na(term),
    term != "(Intercept)",
    !is.na(estimate)
  ) %>%
  dplyr::mutate(
    属性表示 = 属性日本語(attribute),
    条件表示 = purrr::map2_chr(party_n, study_id, 条件日本語),
    水準表示 = 水準日本語(term, label, attribute),
    表示項目 = paste0(属性表示, "：", 水準表示)
  )

補図H1作成 <- function(描画データ, 実験名) {
  項目順 <- 描画データ %>%
    dplyr::distinct(属性表示, 水準表示, 表示項目) %>%
    dplyr::pull(表示項目)

  条件順 <- 描画データ %>%
    dplyr::distinct(party_n, 条件表示) %>%
    dplyr::arrange(party_n) %>%
    dplyr::pull(条件表示)

  描画データ <- 描画データ %>%
    dplyr::mutate(
      表示項目 = factor(表示項目, levels = rev(項目順)),
      条件表示 = factor(条件表示, levels = 条件順)
    )

  dodge <- ggplot2::position_dodge(width = 0.52)

  ggplot2::ggplot(
    描画データ,
    ggplot2::aes(
      x = estimate_pp,
      y = 表示項目,
      shape = 条件表示
    )
  ) +
    ggplot2::geom_vline(
      xintercept = 0,
      linewidth = 0.45
    ) +
    ggplot2::geom_errorbarh(
      ggplot2::aes(
        xmin = conf.low_pp,
        xmax = conf.high_pp
      ),
      height = 0.12,
      position = dodge,
      linewidth = 0.55
    ) +
    ggplot2::geom_point(
      position = dodge,
      size = 2.25,
      fill = "white"
    ) +
    ggplot2::facet_wrap(
      ~ party_support_h,
      ncol = 2,
      scales = "free_y"
    ) +
    ggplot2::labs(
      title = 実験名,
      subtitle = "各パネルは支持政党別の推定結果。点はAMCE、横線は95%信頼区間。",
      x = "選択確率への効果（pp）",
      y = NULL,
      shape = "選択肢数条件",
      caption = "回答者数が40人未満の支持政党×選択肢数条件は推定対象外。"
    ) +
    ggplot2::theme_bw(base_size = 10.5) +
    ggplot2::theme(
      legend.position = "top",
      legend.justification = "center",
      panel.grid.minor = ggplot2::element_blank(),
      strip.background = ggplot2::element_rect(fill = "white"),
      strip.text = ggplot2::element_text(face = "bold", size = 10.5),
      axis.text.y = ggplot2::element_text(size = 8.6, color = "black"),
      axis.text.x = ggplot2::element_text(color = "black"),
      plot.title = ggplot2::element_text(face = "bold"),
      plot.subtitle = ggplot2::element_text(size = 9.5),
      plot.caption = ggplot2::element_text(hjust = 0, size = 8.5),
      panel.spacing = grid::unit(1.0, "lines")
    )
}

表H1作成 <- function(表データ) {
  支持順 <- unique(表データ$party_support_h)
  項目順 <- unique(表データ$表示項目)

  表データ %>%
    dplyr::mutate(
      支持政党 = factor(party_support_h, levels = 支持順),
      `属性・水準` = factor(表示項目, levels = 項目順),
      結果 = sprintf(
        "%.2f [%.2f, %.2f]",
        estimate_pp,
        conf.low_pp,
        conf.high_pp
      )
    ) %>%
    dplyr::select(
      支持政党,
      `属性・水準`,
      条件 = 条件表示,
      結果
    ) %>%
    tidyr::pivot_wider(
      names_from = 条件,
      values_from = 結果,
      values_fill = "—"
    ) %>%
    dplyr::arrange(支持政党, `属性・水準`) %>%
    dplyr::mutate(
      支持政党 = as.character(支持政党),
      `属性・水準` = as.character(`属性・水準`)
    )
}

表H1回答者数作成 <- function(表データ) {
  表データ %>%
    dplyr::distinct(
      支持政党 = party_support_h,
      条件 = 条件表示,
      回答者数 = n_ids
    ) %>%
    dplyr::mutate(回答者数 = as.character(回答者数)) %>%
    tidyr::pivot_wider(
      names_from = 条件,
      values_from = 回答者数,
      values_fill = "—"
    ) %>%
    dplyr::arrange(支持政党)
}

補図H1a：実験1（2023年）

実験1について、推定可能であった支持政党別にAMCEを示す。各パネル内では、同一の属性・水準について4つの政党数条件を比較できる。

H1_実験1 <- 支持AMCE一覧 %>%
  dplyr::filter(study_id == "study1")

補図H1a <- 補図H1作成(
  H1_実験1,
  "補図H1a：実験1（2023年）の支持政党別AMCE"
)
補図H1a

対応する回答者数とAMCEを以下に示す。AMCE表では、各条件の点推定値と95%信頼区間を1セルにまとめている。

表H1a回答者数 <- 表H1回答者数作成(H1_実験1)
knitr::kable(
  表H1a回答者数,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1a-1：実験1（2023年）の支持政党別回答者数"
)

表H1a-1：実験1（2023年）の支持政党別回答者数

支持政党	2政党条件	3政党条件	4政党条件	5政党条件
公明党	154	142	178	156
日本共産党	45	49	74	55
日本維新の会	407	429	402	386
立憲民主党	196	201	212	234

表H1a <- 表H1作成(H1_実験1)
knitr::kable(
  表H1a,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1a-2：実験1（2023年）の支持政党別AMCE［点推定値 [95% CI]、pp］"
)

表H1a-2：実験1（2023年）の支持政党別AMCE［点推定値 [95% CI]、pp］

支持政党	属性・水準	2政党条件	3政党条件	4政党条件	5政党条件
日本維新の会	政策位置：右派・保守的	-2.02 [-6.12, 2.09]	-4.21 [-7.71, -0.72]	-4.37 [-7.21, -1.52]	-3.88 [-6.37, -1.39]
日本維新の会	政策位置：左派・革新的	-7.84 [-11.76, -3.91]	-10.14 [-13.58, -6.70]	-8.27 [-11.26, -5.29]	-6.54 [-9.06, -4.01]
日本維新の会	与党／野党：与党	4.29 [1.09, 7.49]	5.53 [2.43, 8.63]	4.98 [2.12, 7.84]	6.28 [3.67, 8.90]
日本維新の会	GDP成長率：GDP：プラス1％	9.39 [5.46, 13.32]	7.02 [4.10, 9.94]	10.53 [7.92, 13.14]	7.61 [5.31, 9.92]
日本維新の会	GDP成長率：GDP：マイナス1％	-2.10 [-5.83, 1.63]	-3.60 [-6.23, -0.98]	-1.39 [-3.60, 0.81]	-2.84 [-4.83, -0.84]
日本維新の会	日経平均：日経平均：プラス1000円	9.57 [5.82, 13.32]	7.44 [4.50, 10.37]	3.01 [0.46, 5.56]	3.72 [1.63, 5.80]
日本維新の会	日経平均：日経平均：マイナス1000円	-2.55 [-6.29, 1.18]	-2.52 [-5.45, 0.42]	-4.61 [-6.85, -2.37]	-4.94 [-6.79, -3.09]
日本維新の会	議席数：議席数：10～49	-0.21 [-4.87, 4.44]	5.13 [1.78, 8.47]	5.04 [2.43, 7.64]	3.23 [1.14, 5.32]
日本維新の会	議席数：議席数：50～99	3.66 [-1.21, 8.54]	9.66 [6.32, 13.00]	8.13 [5.40, 10.85]	7.38 [4.73, 10.03]
日本維新の会	議席数：議席数：100～199	8.60 [3.71, 13.49]	12.47 [8.39, 16.54]	11.98 [8.84, 15.12]	10.64 [7.43, 13.85]
日本維新の会	議席数：議席数：200以上	9.37 [4.45, 14.28]	12.65 [8.56, 16.73]	11.95 [8.28, 15.62]	9.46 [6.33, 12.60]
日本維新の会	CPI：CPI：プラス1ポイント	-1.55 [-5.32, 2.23]	2.12 [-0.57, 4.81]	3.50 [1.04, 5.95]	0.36 [-1.63, 2.34]
日本維新の会	CPI：CPI：マイナス1ポイント	-2.30 [-6.10, 1.50]	1.09 [-1.54, 3.72]	0.24 [-2.18, 2.65]	-2.10 [-4.09, -0.10]
日本維新の会	失業率：失業率：プラス1％	-6.14 [-10.03, -2.25]	-3.68 [-6.55, -0.81]	-3.93 [-6.34, -1.52]	-3.18 [-5.29, -1.06]
日本維新の会	失業率：失業率：マイナス1％	-4.70 [-8.54, -0.86]	-0.08 [-2.96, 2.79]	0.28 [-2.14, 2.70]	0.63 [-1.46, 2.72]
立憲民主党	政策位置：右派・保守的	1.68 [-4.14, 7.50]	-2.04 [-6.81, 2.74]	-7.38 [-11.43, -3.33]	-4.18 [-7.28, -1.07]
立憲民主党	政策位置：左派・革新的	-2.46 [-7.90, 2.97]	-4.68 [-9.39, 0.03]	-10.03 [-14.11, -5.95]	-6.24 [-9.32, -3.16]
立憲民主党	与党／野党：与党	5.90 [0.91, 10.89]	-0.95 [-5.23, 3.33]	4.58 [0.73, 8.43]	4.83 [1.73, 7.93]
立憲民主党	GDP成長率：GDP：プラス1％	4.26 [-1.15, 9.67]	7.79 [3.81, 11.77]	0.87 [-2.46, 4.21]	4.99 [2.25, 7.72]
立憲民主党	GDP成長率：GDP：マイナス1％	-2.43 [-7.98, 3.12]	-1.69 [-5.42, 2.05]	-5.32 [-8.34, -2.31]	-4.11 [-6.62, -1.60]
立憲民主党	日経平均：日経平均：プラス1000円	2.07 [-3.85, 7.99]	4.48 [0.23, 8.73]	6.86 [3.36, 10.36]	3.84 [1.11, 6.58]
立憲民主党	日経平均：日経平均：マイナス1000円	-9.22 [-14.88, -3.55]	-6.24 [-10.44, -2.05]	-4.88 [-8.01, -1.75]	-3.32 [-5.76, -0.89]
立憲民主党	議席数：議席数：10～49	3.77 [-3.44, 10.98]	3.27 [-1.61, 8.14]	2.11 [-1.57, 5.78]	3.34 [0.72, 5.96]
立憲民主党	議席数：議席数：50～99	10.85 [3.95, 17.75]	8.47 [3.09, 13.85]	3.47 [-0.61, 7.55]	7.26 [3.51, 11.02]
立憲民主党	議席数：議席数：100～199	10.32 [3.13, 17.50]	12.99 [6.69, 19.30]	6.38 [1.53, 11.24]	7.71 [3.53, 11.89]
立憲民主党	議席数：議席数：200以上	13.65 [5.86, 21.43]	9.09 [2.89, 15.29]	9.05 [3.35, 14.74]	9.53 [5.05, 14.01]
立憲民主党	CPI：CPI：プラス1ポイント	-1.68 [-7.12, 3.76]	-1.44 [-5.77, 2.90]	1.12 [-2.05, 4.28]	1.41 [-1.22, 4.05]
立憲民主党	CPI：CPI：マイナス1ポイント	-1.08 [-6.68, 4.51]	-1.23 [-5.49, 3.03]	0.57 [-2.84, 3.97]	-1.98 [-4.50, 0.53]
立憲民主党	失業率：失業率：プラス1％	-3.16 [-8.35, 2.02]	-0.91 [-5.22, 3.40]	-1.99 [-5.29, 1.31]	-1.46 [-4.13, 1.21]
立憲民主党	失業率：失業率：マイナス1％	-3.36 [-8.86, 2.14]	-0.88 [-5.27, 3.51]	-1.42 [-4.71, 1.86]	-0.30 [-2.96, 2.36]
公明党	政策位置：右派・保守的	-11.27 [-17.21, -5.32]	-10.45 [-15.76, -5.13]	-5.60 [-9.85, -1.34]	-7.78 [-11.72, -3.85]
公明党	政策位置：左派・革新的	-14.02 [-21.01, -7.02]	-13.15 [-18.79, -7.51]	-6.01 [-10.21, -1.81]	-9.00 [-12.70, -5.29]
公明党	与党／野党：与党	5.22 [-0.79, 11.23]	3.82 [-1.21, 8.85]	2.53 [-1.40, 6.45]	1.82 [-2.01, 5.66]
公明党	GDP成長率：GDP：プラス1％	10.04 [3.83, 16.26]	11.68 [7.20, 16.16]	6.66 [2.77, 10.54]	5.91 [2.47, 9.35]
公明党	GDP成長率：GDP：マイナス1％	-3.03 [-9.39, 3.32]	-1.12 [-5.81, 3.57]	-5.15 [-8.79, -1.52]	-3.67 [-6.41, -0.93]
公明党	日経平均：日経平均：プラス1000円	2.06 [-4.11, 8.23]	8.41 [3.59, 13.24]	1.06 [-2.43, 4.54]	3.17 [0.37, 5.97]
公明党	日経平均：日経平均：マイナス1000円	-8.74 [-14.57, -2.91]	-3.61 [-8.08, 0.85]	-5.31 [-8.66, -1.96]	-5.07 [-8.07, -2.07]
公明党	議席数：議席数：10～49	6.80 [-1.14, 14.74]	2.23 [-3.79, 8.26]	3.24 [-0.67, 7.15]	5.32 [2.20, 8.43]
公明党	議席数：議席数：50～99	14.72 [6.81, 22.63]	6.69 [0.29, 13.10]	7.54 [3.01, 12.07]	9.88 [5.94, 13.83]
公明党	議席数：議席数：100～199	8.74 [0.57, 16.90]	9.11 [1.93, 16.29]	7.68 [2.78, 12.58]	10.58 [5.78, 15.38]
公明党	議席数：議席数：200以上	11.71 [3.24, 20.17]	9.84 [2.38, 17.31]	8.06 [2.60, 13.53]	13.12 [7.50, 18.73]
公明党	CPI：CPI：プラス1ポイント	3.63 [-2.61, 9.87]	-1.42 [-5.87, 3.02]	4.33 [1.07, 7.58]	0.47 [-2.48, 3.43]
公明党	CPI：CPI：マイナス1ポイント	1.00 [-4.76, 6.76]	-1.40 [-6.50, 3.70]	0.14 [-3.20, 3.48]	1.56 [-1.43, 4.56]
公明党	失業率：失業率：プラス1％	-1.56 [-8.11, 5.00]	-5.22 [-10.28, -0.15]	-3.94 [-7.70, -0.18]	-4.48 [-7.39, -1.56]
公明党	失業率：失業率：マイナス1％	-0.09 [-6.46, 6.28]	-8.89 [-13.97, -3.81]	-1.53 [-5.08, 2.02]	-0.34 [-3.66, 2.97]
日本共産党	政策位置：右派・保守的	7.15 [-3.36, 17.66]	-8.37 [-17.89, 1.15]	-4.96 [-11.98, 2.05]	0.84 [-5.37, 7.06]
日本共産党	政策位置：左派・革新的	-8.98 [-20.58, 2.61]	-4.85 [-15.18, 5.48]	-8.90 [-14.23, -3.57]	-2.65 [-9.38, 4.08]
日本共産党	与党／野党：与党	4.30 [-6.01, 14.61]	3.83 [-4.13, 11.78]	4.73 [-1.08, 10.55]	5.33 [-1.85, 12.50]
日本共産党	GDP成長率：GDP：プラス1％	7.02 [-5.08, 19.13]	4.94 [-3.49, 13.38]	12.25 [6.63, 17.87]	6.32 [0.63, 12.00]
日本共産党	GDP成長率：GDP：マイナス1％	-8.82 [-21.36, 3.72]	-10.69 [-17.77, -3.62]	-5.77 [-11.31, -0.24]	-0.52 [-6.47, 5.43]
日本共産党	日経平均：日経平均：プラス1000円	10.03 [-2.67, 22.73]	0.91 [-7.89, 9.71]	1.20 [-4.60, 7.01]	3.33 [-3.10, 9.76]
日本共産党	日経平均：日経平均：マイナス1000円	-4.13 [-13.56, 5.29]	-11.70 [-19.14, -4.26]	-8.69 [-13.57, -3.80]	-5.35 [-10.61, -0.10]
日本共産党	議席数：議席数：10～49	8.41 [-7.24, 24.06]	-5.14 [-15.60, 5.33]	1.20 [-4.69, 7.09]	6.08 [0.91, 11.26]
日本共産党	議席数：議席数：50～99	12.54 [-2.61, 27.68]	6.40 [-3.36, 16.16]	5.10 [-1.82, 12.02]	13.52 [6.70, 20.34]
日本共産党	議席数：議席数：100～199	8.06 [-7.07, 23.20]	10.40 [0.91, 19.89]	13.55 [5.20, 21.90]	11.38 [4.33, 18.43]
日本共産党	議席数：議席数：200以上	4.37 [-10.39, 19.14]	14.57 [2.31, 26.84]	4.59 [-3.69, 12.88]	10.02 [2.10, 17.94]
日本共産党	CPI：CPI：プラス1ポイント	2.37 [-11.47, 16.21]	7.74 [-0.24, 15.73]	0.22 [-5.28, 5.72]	0.24 [-4.98, 5.46]
日本共産党	CPI：CPI：マイナス1ポイント	2.77 [-11.16, 16.70]	0.00 [-7.77, 7.78]	-0.61 [-4.92, 3.70]	-0.48 [-5.00, 4.04]
日本共産党	失業率：失業率：プラス1％	-5.40 [-16.48, 5.67]	0.39 [-7.53, 8.30]	-3.56 [-9.26, 2.14]	-4.99 [-10.87, 0.90]
日本共産党	失業率：失業率：マイナス1％	3.38 [-9.03, 15.79]	-0.21 [-8.41, 8.00]	1.82 [-3.54, 7.17]	-3.39 [-8.66, 1.88]

補図H1b：実験2（2026年）

実験2についても同じ形式で示す。支持政党の種類が実験1より多いため、支持政党を2列のファセットに分け、各パネルで属性・水準を縦方向に追えるようにした。

H1_実験2 <- 支持AMCE一覧 %>%
  dplyr::filter(study_id == "study2")

補図H1b <- 補図H1作成(
  H1_実験2,
  "補図H1b：実験2（2026年）の支持政党別AMCE"
)
補図H1b

表H1b回答者数 <- 表H1回答者数作成(H1_実験2)
knitr::kable(
  表H1b回答者数,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1b-1：実験2（2026年）の支持政党別回答者数"
)

表H1b-1：実験2（2026年）の支持政党別回答者数

支持政党	2政党条件	3政党条件	4政党条件	5政党条件
チームみらい	42	50	61	76
参政党	—	41	47	63
国民民主党	42	73	62	76
支持政党なし	256	380	391	434
日本維新の会	45	66	58	67
立憲民主党	—	42	44	59
自由民主党	145	229	245	292

表H1b <- 表H1作成(H1_実験2)
knitr::kable(
  表H1b,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1b-2：実験2（2026年）の支持政党別AMCE［点推定値 [95% CI]、pp］"
)

表H1b-2：実験2（2026年）の支持政党別AMCE［点推定値 [95% CI]、pp］

支持政党	属性・水準	2政党条件	3政党条件	4政党条件	5政党条件
支持政党なし	政策位置：右派・保守的	-5.32 [-10.45, -0.19]	-5.78 [-9.58, -1.98]	-4.90 [-8.16, -1.63]	-2.86 [-5.42, -0.30]
支持政党なし	政策位置：左派・革新的	-9.73 [-14.90, -4.57]	-10.05 [-13.48, -6.63]	-12.04 [-14.87, -9.22]	-7.02 [-9.36, -4.69]
支持政党なし	与党／野党：与党	0.53 [-3.65, 4.71]	-0.22 [-3.15, 2.70]	0.86 [-1.57, 3.28]	2.22 [0.35, 4.08]
支持政党なし	GDP成長率：GDP：プラス1％	13.04 [8.25, 17.82]	7.34 [4.26, 10.42]	5.63 [3.19, 8.06]	6.25 [4.23, 8.27]
支持政党なし	GDP成長率：GDP：マイナス1％	-4.71 [-9.66, 0.24]	-7.39 [-10.18, -4.60]	-5.53 [-7.72, -3.33]	-3.32 [-5.02, -1.62]
支持政党なし	日経平均：日経平均：プラス1000円	4.47 [-0.53, 9.47]	3.75 [0.47, 7.04]	3.53 [0.82, 6.23]	5.40 [3.39, 7.42]
支持政党なし	日経平均：日経平均：マイナス1000円	-6.79 [-11.90, -1.67]	-5.07 [-8.21, -1.93]	-7.19 [-9.52, -4.85]	-3.53 [-5.42, -1.64]
支持政党なし	議席数：議席数：10～49	5.62 [-0.15, 11.39]	4.94 [1.13, 8.75]	5.15 [2.39, 7.91]	1.60 [-0.54, 3.74]
支持政党なし	議席数：議席数：50～99	3.90 [-1.78, 9.58]	9.72 [5.97, 13.46]	8.92 [5.99, 11.86]	5.34 [2.74, 7.94]
支持政党なし	議席数：議席数：100～199	8.74 [1.90, 15.58]	12.15 [8.13, 16.17]	11.13 [8.01, 14.24]	8.50 [5.92, 11.09]
支持政党なし	議席数：議席数：200以上	8.17 [1.87, 14.48]	11.60 [7.76, 15.43]	10.33 [7.06, 13.59]	8.48 [5.81, 11.15]
支持政党なし	CPI：CPI：プラス1ポイント	2.97 [-1.82, 7.76]	1.71 [-1.24, 4.66]	2.73 [0.26, 5.19]	-1.39 [-3.17, 0.40]
支持政党なし	CPI：CPI：マイナス1ポイント	4.75 [0.14, 9.37]	-1.38 [-4.56, 1.79]	-0.11 [-2.29, 2.07]	-0.66 [-2.60, 1.27]
支持政党なし	失業率：失業率：プラス1％	-5.94 [-10.98, -0.89]	-4.25 [-7.44, -1.05]	-4.78 [-7.25, -2.30]	-3.58 [-5.48, -1.68]
支持政党なし	失業率：失業率：マイナス1％	-0.94 [-6.05, 4.18]	-0.28 [-3.44, 2.87]	0.25 [-2.42, 2.91]	-0.20 [-2.30, 1.90]
自由民主党	政策位置：右派・保守的	8.49 [1.93, 15.04]	10.25 [5.28, 15.22]	10.36 [6.36, 14.35]	11.35 [8.21, 14.50]
自由民主党	政策位置：左派・革新的	-14.32 [-20.62, -8.03]	-10.94 [-15.34, -6.53]	-8.94 [-12.08, -5.81]	-5.16 [-7.53, -2.79]
自由民主党	与党／野党：与党	12.28 [6.77, 17.79]	14.94 [11.42, 18.45]	11.56 [8.79, 14.34]	10.70 [8.59, 12.81]
自由民主党	GDP成長率：GDP：プラス1％	4.20 [-2.37, 10.77]	6.41 [2.59, 10.22]	6.24 [3.11, 9.37]	5.43 [3.13, 7.72]
自由民主党	GDP成長率：GDP：マイナス1％	-3.93 [-9.85, 1.98]	-3.77 [-7.56, 0.01]	-4.71 [-7.51, -1.91]	-1.11 [-3.24, 1.03]
自由民主党	日経平均：日経平均：プラス1000円	5.58 [-0.54, 11.69]	3.74 [-0.07, 7.56]	4.59 [1.52, 7.66]	3.48 [1.18, 5.78]
自由民主党	日経平均：日経平均：マイナス1000円	-4.32 [-10.55, 1.90]	-6.64 [-10.66, -2.62]	-4.25 [-7.06, -1.45]	-1.86 [-4.07, 0.36]
自由民主党	議席数：議席数：10～49	-7.17 [-15.36, 1.02]	1.49 [-3.27, 6.24]	3.28 [0.00, 6.56]	2.94 [0.45, 5.44]
自由民主党	議席数：議席数：50～99	0.90 [-6.68, 8.48]	6.90 [1.74, 12.05]	5.46 [1.82, 9.11]	7.67 [5.11, 10.23]
自由民主党	議席数：議席数：100～199	6.99 [-0.51, 14.49]	13.18 [8.35, 18.02]	14.22 [10.29, 18.14]	12.19 [9.35, 15.04]
自由民主党	議席数：議席数：200以上	9.20 [0.84, 17.56]	12.10 [6.78, 17.42]	15.83 [11.83, 19.83]	18.24 [15.07, 21.42]
自由民主党	CPI：CPI：プラス1ポイント	4.74 [-1.81, 11.28]	2.31 [-1.30, 5.91]	1.73 [-1.38, 4.84]	1.50 [-0.79, 3.79]
自由民主党	CPI：CPI：マイナス1ポイント	2.40 [-3.79, 8.59]	-5.04 [-8.68, -1.41]	-0.44 [-3.54, 2.66]	0.68 [-1.45, 2.81]
自由民主党	失業率：失業率：プラス1％	-4.43 [-11.01, 2.14]	-3.10 [-6.86, 0.66]	-3.21 [-6.13, -0.29]	-1.41 [-3.61, 0.78]
自由民主党	失業率：失業率：マイナス1％	-7.10 [-13.45, -0.76]	-1.47 [-5.37, 2.43]	-0.93 [-4.01, 2.14]	-0.66 [-2.91, 1.58]
国民民主党	政策位置：右派・保守的	-4.67 [-16.44, 7.11]	7.63 [-0.76, 16.02]	1.35 [-4.69, 7.39]	3.76 [-1.81, 9.34]
国民民主党	政策位置：左派・革新的	-7.60 [-22.25, 7.05]	-8.67 [-16.07, -1.27]	-7.07 [-14.65, 0.50]	-4.19 [-9.26, 0.89]
国民民主党	与党／野党：与党	3.08 [-5.91, 12.07]	0.14 [-5.99, 6.27]	0.16 [-5.98, 6.30]	1.79 [-2.77, 6.35]
国民民主党	GDP成長率：GDP：プラス1％	14.78 [1.85, 27.71]	6.71 [-0.54, 13.96]	13.69 [7.15, 20.24]	6.22 [1.46, 10.97]
国民民主党	GDP成長率：GDP：マイナス1％	-17.70 [-30.01, -5.40]	-5.86 [-11.60, -0.12]	-4.51 [-10.34, 1.32]	-3.45 [-7.58, 0.68]
国民民主党	日経平均：日経平均：プラス1000円	1.74 [-9.48, 12.96]	3.55 [-4.53, 11.62]	2.87 [-3.72, 9.46]	8.04 [2.98, 13.09]
国民民主党	日経平均：日経平均：マイナス1000円	-5.52 [-17.80, 6.76]	-11.10 [-18.38, -3.83]	-0.67 [-6.89, 5.56]	-4.12 [-8.28, 0.04]
国民民主党	議席数：議席数：10～49	-1.97 [-15.00, 11.05]	12.16 [4.35, 19.97]	7.31 [-0.05, 14.68]	7.29 [2.31, 12.28]
国民民主党	議席数：議席数：50～99	13.44 [0.04, 26.83]	11.24 [2.12, 20.35]	11.10 [4.23, 17.96]	16.48 [10.52, 22.43]
国民民主党	議席数：議席数：100～199	12.27 [-2.31, 26.85]	15.41 [7.03, 23.79]	12.42 [4.72, 20.12]	13.28 [6.78, 19.78]
国民民主党	議席数：議席数：200以上	-2.29 [-19.03, 14.45]	13.91 [5.64, 22.19]	8.34 [-0.34, 17.02]	8.22 [2.30, 14.14]
国民民主党	CPI：CPI：プラス1ポイント	-1.87 [-13.90, 10.16]	3.97 [-4.22, 12.17]	-1.85 [-7.98, 4.29]	0.55 [-3.70, 4.80]
国民民主党	CPI：CPI：マイナス1ポイント	4.08 [-7.08, 15.24]	-1.03 [-9.02, 6.95]	-2.61 [-9.58, 4.35]	1.46 [-2.75, 5.67]
国民民主党	失業率：失業率：プラス1％	1.08 [-12.09, 14.24]	-4.10 [-11.45, 3.26]	-6.77 [-13.58, 0.04]	-1.00 [-5.42, 3.41]
国民民主党	失業率：失業率：マイナス1％	-0.00 [-11.80, 11.79]	3.28 [-3.64, 10.20]	-8.96 [-14.65, -3.28]	-0.67 [-5.43, 4.09]
日本維新の会	政策位置：右派・保守的	10.02 [-3.12, 23.16]	-5.26 [-13.72, 3.21]	7.51 [-0.56, 15.57]	-0.22 [-6.58, 6.13]
日本維新の会	政策位置：左派・革新的	-0.35 [-12.27, 11.56]	-8.33 [-16.28, -0.37]	1.10 [-6.48, 8.68]	-2.90 [-9.21, 3.42]
日本維新の会	与党／野党：与党	3.60 [-5.19, 12.39]	2.05 [-5.39, 9.48]	5.57 [-0.19, 11.33]	9.28 [5.28, 13.29]
日本維新の会	GDP成長率：GDP：プラス1％	0.86 [-9.29, 11.02]	6.10 [-2.12, 14.32]	10.92 [3.72, 18.12]	0.34 [-4.83, 5.51]
日本維新の会	GDP成長率：GDP：マイナス1％	-1.07 [-12.02, 9.89]	-3.08 [-10.95, 4.78]	-1.32 [-7.54, 4.90]	-5.40 [-10.04, -0.76]
日本維新の会	日経平均：日経平均：プラス1000円	5.31 [-6.01, 16.63]	8.54 [1.06, 16.03]	0.57 [-5.99, 7.12]	-0.42 [-5.54, 4.70]
日本維新の会	日経平均：日経平均：マイナス1000円	-16.57 [-26.80, -6.33]	-7.06 [-13.16, -0.96]	-2.72 [-9.37, 3.94]	-4.23 [-8.92, 0.46]
日本維新の会	議席数：議席数：10～49	-8.42 [-23.38, 6.54]	2.90 [-6.92, 12.72]	3.27 [-4.52, 11.06]	1.30 [-3.85, 6.45]
日本維新の会	議席数：議席数：50～99	3.42 [-11.94, 18.77]	2.25 [-7.39, 11.90]	13.24 [5.10, 21.38]	4.45 [-1.38, 10.28]
日本維新の会	議席数：議席数：100～199	7.12 [-11.10, 25.34]	12.03 [2.19, 21.88]	13.63 [4.86, 22.39]	6.33 [-0.43, 13.09]
日本維新の会	議席数：議席数：200以上	10.35 [-6.59, 27.29]	9.51 [-1.06, 20.09]	13.38 [3.97, 22.79]	7.46 [1.17, 13.74]
日本維新の会	CPI：CPI：プラス1ポイント	-1.17 [-10.32, 7.97]	-0.23 [-7.17, 6.71]	-0.69 [-5.69, 4.32]	1.94 [-2.87, 6.75]
日本維新の会	CPI：CPI：マイナス1ポイント	-5.28 [-16.62, 6.06]	-2.37 [-10.06, 5.32]	-1.81 [-8.00, 4.38]	1.20 [-3.20, 5.61]
日本維新の会	失業率：失業率：プラス1％	-0.40 [-11.05, 10.25]	0.35 [-6.12, 6.81]	-6.22 [-12.37, -0.07]	-3.05 [-8.01, 1.91]
日本維新の会	失業率：失業率：マイナス1％	4.27 [-6.11, 14.66]	-5.57 [-12.45, 1.30]	-2.02 [-9.66, 5.63]	-0.44 [-6.76, 5.88]
チームみらい	政策位置：右派・保守的	-2.83 [-16.96, 11.30]	7.51 [-2.39, 17.41]	-4.17 [-11.01, 2.67]	-5.25 [-10.18, -0.32]
チームみらい	政策位置：左派・革新的	-23.88 [-36.67, -11.09]	1.71 [-7.07, 10.50]	-0.97 [-8.67, 6.73]	-3.89 [-9.49, 1.71]
チームみらい	与党／野党：与党	4.88 [-5.07, 14.83]	2.88 [-3.49, 9.26]	-1.22 [-6.85, 4.41]	-1.70 [-5.89, 2.49]
チームみらい	GDP成長率：GDP：プラス1％	7.65 [-3.71, 19.01]	17.19 [7.90, 26.47]	4.91 [-0.63, 10.45]	7.69 [2.40, 12.97]
チームみらい	GDP成長率：GDP：マイナス1％	0.42 [-10.48, 11.32]	-9.27 [-17.38, -1.15]	-5.31 [-11.66, 1.04]	-3.11 [-7.73, 1.50]
チームみらい	日経平均：日経平均：プラス1000円	12.99 [0.23, 25.75]	7.78 [-1.94, 17.51]	2.96 [-4.00, 9.93]	6.49 [2.04, 10.95]
チームみらい	日経平均：日経平均：マイナス1000円	2.12 [-8.91, 13.16]	-1.88 [-9.42, 5.65]	-4.96 [-10.44, 0.52]	-2.41 [-6.90, 2.07]
チームみらい	議席数：議席数：10～49	-13.36 [-29.33, 2.61]	-2.48 [-11.56, 6.59]	5.08 [-1.67, 11.83]	4.74 [0.04, 9.43]
チームみらい	議席数：議席数：50～99	17.12 [2.17, 32.07]	3.76 [-5.38, 12.90]	14.46 [5.75, 23.17]	4.61 [-0.73, 9.96]
チームみらい	議席数：議席数：100～199	9.78 [-8.67, 28.23]	0.13 [-11.36, 11.61]	13.68 [5.16, 22.20]	11.66 [5.03, 18.28]
チームみらい	議席数：議席数：200以上	22.76 [6.96, 38.56]	7.46 [-4.10, 19.01]	16.06 [7.41, 24.72]	10.21 [3.45, 16.96]
チームみらい	CPI：CPI：プラス1ポイント	-0.44 [-9.71, 8.83]	2.73 [-4.71, 10.16]	1.39 [-4.61, 7.40]	-1.29 [-6.00, 3.42]
チームみらい	CPI：CPI：マイナス1ポイント	-0.01 [-10.26, 10.25]	-3.01 [-11.79, 5.77]	2.10 [-4.30, 8.49]	-2.47 [-7.24, 2.31]
チームみらい	失業率：失業率：プラス1％	-7.32 [-20.30, 5.66]	-7.56 [-16.69, 1.57]	-9.35 [-14.99, -3.71]	-2.77 [-7.71, 2.18]
チームみらい	失業率：失業率：マイナス1％	-3.36 [-16.07, 9.36]	-6.96 [-14.87, 0.95]	-0.71 [-7.99, 6.58]	-2.29 [-6.92, 2.34]
参政党	政策位置：右派・保守的	—	8.98 [-2.54, 20.50]	21.91 [12.61, 31.20]	20.94 [13.55, 28.32]
参政党	政策位置：左派・革新的	—	-7.06 [-17.57, 3.44]	-11.33 [-18.02, -4.63]	-3.70 [-9.44, 2.04]
参政党	与党／野党：与党	—	5.16 [-4.17, 14.49]	-2.06 [-8.23, 4.12]	2.20 [-2.37, 6.77]
参政党	GDP成長率：GDP：プラス1％	—	-0.00 [-10.97, 10.96]	10.22 [4.18, 16.26]	2.38 [-2.88, 7.65]
参政党	GDP成長率：GDP：マイナス1％	—	-11.63 [-20.54, -2.71]	-1.82 [-8.18, 4.53]	-6.06 [-10.65, -1.47]
参政党	日経平均：日経平均：プラス1000円	—	2.68 [-5.22, 10.58]	1.60 [-4.21, 7.40]	5.21 [0.27, 10.15]
参政党	日経平均：日経平均：マイナス1000円	—	-2.13 [-10.56, 6.30]	-0.64 [-7.85, 6.57]	-3.55 [-8.36, 1.25]
参政党	議席数：議席数：10～49	—	8.87 [-3.29, 21.02]	12.68 [3.95, 21.42]	0.35 [-5.18, 5.88]
参政党	議席数：議席数：50～99	—	7.89 [-5.55, 21.34]	2.86 [-7.19, 12.90]	7.64 [1.94, 13.34]
参政党	議席数：議席数：100～199	—	8.37 [-2.80, 19.55]	8.36 [0.40, 16.33]	13.52 [7.32, 19.72]
参政党	議席数：議席数：200以上	—	-1.16 [-11.62, 9.30]	5.56 [-3.43, 14.54]	7.42 [1.48, 13.36]
参政党	CPI：CPI：プラス1ポイント	—	2.03 [-8.17, 12.23]	3.02 [-4.33, 10.37]	0.74 [-3.50, 4.98]
参政党	CPI：CPI：マイナス1ポイント	—	-1.31 [-9.19, 6.57]	-6.90 [-13.39, -0.41]	-1.75 [-5.54, 2.03]
参政党	失業率：失業率：プラス1％	—	-8.95 [-18.92, 1.03]	-6.11 [-12.84, 0.62]	-0.64 [-4.91, 3.63]
参政党	失業率：失業率：マイナス1％	—	-3.20 [-13.56, 7.16]	-3.64 [-10.48, 3.20]	0.72 [-3.92, 5.36]
立憲民主党	政策位置：右派・保守的	—	-25.44 [-35.61, -15.27]	-13.26 [-21.65, -4.86]	-13.47 [-19.20, -7.75]
立憲民主党	政策位置：左派・革新的	—	-9.91 [-20.81, 0.99]	-1.30 [-10.26, 7.66]	-3.82 [-11.59, 3.95]
立憲民主党	与党／野党：与党	—	-21.18 [-30.32, -12.05]	-16.42 [-23.36, -9.48]	-10.36 [-15.77, -4.94]
立憲民主党	GDP成長率：GDP：プラス1％	—	0.55 [-8.17, 9.27]	7.34 [-0.65, 15.33]	3.01 [-3.02, 9.04]
立憲民主党	GDP成長率：GDP：マイナス1％	—	-6.62 [-15.08, 1.84]	-9.22 [-15.77, -2.67]	-3.81 [-9.28, 1.65]
立憲民主党	日経平均：日経平均：プラス1000円	—	13.37 [4.33, 22.41]	5.53 [-1.70, 12.76]	2.26 [-2.21, 6.73]
立憲民主党	日経平均：日経平均：マイナス1000円	—	-1.75 [-11.65, 8.14]	-3.39 [-9.74, 2.97]	-4.68 [-9.05, -0.32]
立憲民主党	議席数：議席数：10～49	—	-0.02 [-13.33, 13.28]	1.61 [-8.16, 11.37]	2.79 [-2.83, 8.40]
立憲民主党	議席数：議席数：50～99	—	-0.54 [-11.64, 10.55]	3.62 [-6.49, 13.73]	15.37 [8.55, 22.20]
立憲民主党	議席数：議席数：100～199	—	-0.12 [-12.37, 12.13]	16.52 [5.89, 27.14]	18.38 [11.88, 24.88]
立憲民主党	議席数：議席数：200以上	—	2.50 [-8.03, 13.03]	15.37 [3.83, 26.91]	14.99 [8.86, 21.12]
立憲民主党	CPI：CPI：プラス1ポイント	—	-1.53 [-10.59, 7.53]	-5.12 [-12.63, 2.39]	-0.85 [-5.52, 3.83]
立憲民主党	CPI：CPI：マイナス1ポイント	—	1.98 [-8.09, 12.04]	-6.33 [-13.37, 0.70]	-1.06 [-6.05, 3.93]
立憲民主党	失業率：失業率：プラス1％	—	-14.23 [-23.21, -5.26]	-2.82 [-10.02, 4.38]	1.73 [-3.15, 6.61]
立憲民主党	失業率：失業率：マイナス1％	—	-1.25 [-11.04, 8.54]	4.26 [-1.50, 10.03]	4.48 [-1.21, 10.17]

補図H1c：実験3（2026年）

実験3では、政党属性が政党名として提示される。図の構成は実験1・2と揃え、支持政党ごとに、政党名および経済属性の各水準に対するAMCEを比較できるようにした。

H1_実験3 <- 支持AMCE一覧 %>%
  dplyr::filter(study_id == "study3")

補図H1c <- 補図H1作成(
  H1_実験3,
  "補図H1c：実験3（2026年）の支持政党別AMCE"
)
補図H1c

表H1c回答者数 <- 表H1回答者数作成(H1_実験3)
knitr::kable(
  表H1c回答者数,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1c-1：実験3（2026年）の支持政党別回答者数"
)

表H1c-1：実験3（2026年）の支持政党別回答者数

支持政党	2選択肢条件	3選択肢条件	4選択肢条件	5選択肢条件
チームみらい	—	—	51	67
参政党	—	46	42	52
国民民主党	49	76	70	91
支持政党なし	261	335	370	447
日本維新の会	—	46	64	60
立憲民主党	—	—	—	63
自由民主党	163	219	254	311

表H1c <- 表H1作成(H1_実験3)
knitr::kable(
  表H1c,
  format = "html",
  row.names = FALSE,
  table.attr = 'class="table table-condensed" style="font-size:90%;"',
  caption = "表H1c-2：実験3（2026年）の支持政党別AMCE［点推定値 [95% CI]、pp］"
)

表H1c-2：実験3（2026年）の支持政党別AMCE［点推定値 [95% CI]、pp］

支持政党	属性・水準	2選択肢条件	3選択肢条件	4選択肢条件	5選択肢条件
支持政党なし	政権与党の政党名：立憲民主党	0.74 [-9.09, 10.58]	-4.79 [-11.87, 2.29]	-9.12 [-15.28, -2.96]	-1.85 [-6.48, 2.78]
支持政党なし	政権与党の政党名：日本維新の会	-10.06 [-19.64, -0.48]	-5.74 [-12.08, 0.59]	-9.50 [-14.98, -4.02]	-3.09 [-7.45, 1.27]
支持政党なし	政権与党の政党名：公明党	-21.56 [-30.97, -12.15]	-18.37 [-24.99, -11.75]	-18.40 [-23.82, -12.98]	-12.61 [-16.50, -8.72]
支持政党なし	政権与党の政党名：国民民主党	1.09 [-7.88, 10.05]	2.36 [-4.42, 9.14]	1.93 [-3.80, 7.65]	4.80 [0.21, 9.39]
支持政党なし	政権与党の政党名：れいわ新選組	-26.73 [-36.50, -16.96]	-17.04 [-24.11, -9.97]	-17.85 [-23.57, -12.12]	-11.85 [-15.95, -7.76]
支持政党なし	政権与党の政党名：参政党	-11.28 [-20.49, -2.07]	-11.58 [-18.31, -4.85]	-10.52 [-16.29, -4.75]	-4.16 [-8.49, 0.17]
支持政党なし	政権与党の政党名：日本共産党	-26.13 [-35.60, -16.65]	-17.25 [-24.46, -10.03]	-17.12 [-22.84, -11.40]	-11.77 [-15.80, -7.75]
支持政党なし	政権与党の政党名：中道改革連合	-7.07 [-16.79, 2.65]	-7.74 [-15.15, -0.34]	-7.72 [-14.12, -1.33]	-5.69 [-10.01, -1.36]
支持政党なし	政権与党の政党名：チームみらい	-0.43 [-9.60, 8.74]	-3.81 [-10.45, 2.83]	-5.40 [-11.52, 0.71]	0.22 [-4.44, 4.89]
支持政党なし	GDP成長率：GDP：プラス1％	12.93 [8.34, 17.53]	6.60 [3.32, 9.89]	6.12 [3.53, 8.71]	7.30 [5.31, 9.30]
支持政党なし	GDP成長率：GDP：マイナス1％	-1.81 [-6.51, 2.89]	-7.01 [-10.16, -3.85]	-3.47 [-5.90, -1.03]	-3.64 [-5.37, -1.91]
支持政党なし	日経平均：日経平均：プラス1000円	2.95 [-1.44, 7.34]	4.26 [0.95, 7.56]	4.92 [2.25, 7.60]	5.75 [3.83, 7.67]
支持政党なし	日経平均：日経平均：マイナス1000円	-5.85 [-10.93, -0.77]	-4.97 [-8.05, -1.89]	-4.75 [-7.25, -2.24]	-2.92 [-4.72, -1.13]
支持政党なし	CPI：CPI：プラス1ポイント	-2.01 [-6.72, 2.70]	-0.30 [-3.52, 2.92]	-0.88 [-3.26, 1.51]	-0.07 [-1.90, 1.76]
支持政党なし	CPI：CPI：マイナス1ポイント	-0.97 [-5.59, 3.65]	-2.28 [-5.45, 0.89]	-4.47 [-6.86, -2.08]	-1.44 [-3.38, 0.50]
支持政党なし	失業率：失業率：プラス1％	-7.45 [-12.32, -2.58]	-6.78 [-9.93, -3.63]	-4.65 [-7.13, -2.16]	-3.04 [-5.04, -1.04]
支持政党なし	失業率：失業率：マイナス1％	-3.03 [-7.81, 1.75]	-1.01 [-4.28, 2.26]	-2.87 [-5.37, -0.36]	-1.22 [-3.22, 0.79]
自由民主党	政権与党の政党名：立憲民主党	-35.30 [-46.48, -24.12]	-46.59 [-54.80, -38.38]	-47.57 [-54.70, -40.43]	-53.57 [-59.43, -47.71]
自由民主党	政権与党の政党名：日本維新の会	-16.83 [-25.95, -7.71]	-24.49 [-32.31, -16.68]	-30.95 [-37.84, -24.06]	-30.79 [-36.94, -24.63]
自由民主党	政権与党の政党名：公明党	-31.29 [-42.09, -20.49]	-50.52 [-57.89, -43.15]	-55.88 [-62.15, -49.61]	-53.05 [-59.05, -47.05]
自由民主党	政権与党の政党名：国民民主党	-17.49 [-27.60, -7.39]	-29.14 [-36.79, -21.48]	-36.79 [-43.25, -30.34]	-41.21 [-47.00, -35.41]
自由民主党	政権与党の政党名：れいわ新選組	-56.09 [-66.06, -46.11]	-54.33 [-62.75, -45.90]	-56.75 [-63.59, -49.91]	-56.38 [-62.21, -50.55]
自由民主党	政権与党の政党名：参政党	-35.62 [-45.83, -25.41]	-33.32 [-41.68, -24.96]	-40.05 [-47.03, -33.06]	-50.66 [-56.69, -44.63]
自由民主党	政権与党の政党名：日本共産党	-58.61 [-68.30, -48.92]	-59.57 [-67.10, -52.05]	-61.82 [-68.02, -55.62]	-57.78 [-63.55, -52.00]
自由民主党	政権与党の政党名：中道改革連合	-38.53 [-49.49, -27.57]	-52.07 [-59.96, -44.17]	-54.80 [-61.67, -47.93]	-55.26 [-61.09, -49.43]
自由民主党	政権与党の政党名：チームみらい	-26.52 [-36.15, -16.89]	-34.90 [-43.04, -26.75]	-44.00 [-51.21, -36.78]	-47.44 [-53.49, -41.39]
自由民主党	GDP成長率：GDP：プラス1％	8.28 [2.69, 13.87]	5.82 [2.38, 9.25]	4.12 [1.26, 6.97]	4.45 [2.32, 6.58]
自由民主党	GDP成長率：GDP：マイナス1％	-3.23 [-8.67, 2.22]	-5.21 [-9.17, -1.26]	-3.47 [-6.25, -0.68]	-0.66 [-2.49, 1.17]
自由民主党	日経平均：日経平均：プラス1000円	7.71 [2.22, 13.20]	3.19 [-0.74, 7.11]	3.35 [0.36, 6.34]	3.04 [0.91, 5.17]
自由民主党	日経平均：日経平均：マイナス1000円	-4.77 [-10.45, 0.91]	-5.98 [-9.57, -2.39]	-1.26 [-3.95, 1.43]	-2.15 [-4.23, -0.07]
自由民主党	CPI：CPI：プラス1ポイント	0.33 [-5.12, 5.78]	1.43 [-2.09, 4.95]	1.08 [-1.79, 3.94]	1.18 [-0.74, 3.10]
自由民主党	CPI：CPI：マイナス1ポイント	-2.90 [-8.42, 2.62]	0.44 [-3.27, 4.15]	0.26 [-2.39, 2.91]	-0.03 [-1.98, 1.93]
自由民主党	失業率：失業率：プラス1％	-6.54 [-12.52, -0.57]	-3.98 [-7.61, -0.34]	-2.52 [-5.13, 0.10]	-0.10 [-2.10, 1.90]
自由民主党	失業率：失業率：マイナス1％	-3.37 [-8.97, 2.24]	-4.23 [-7.62, -0.84]	-0.47 [-3.16, 2.23]	-0.75 [-2.71, 1.22]
国民民主党	政権与党の政党名：立憲民主党	6.08 [-17.38, 29.54]	-12.86 [-27.13, 1.41]	-5.60 [-19.28, 8.07]	-13.60 [-25.01, -2.19]
国民民主党	政権与党の政党名：日本維新の会	9.72 [-12.02, 31.47]	-12.07 [-27.33, 3.19]	4.44 [-9.23, 18.12]	-9.03 [-19.63, 1.56]
国民民主党	政権与党の政党名：公明党	-7.82 [-30.54, 14.90]	-29.46 [-40.25, -18.68]	-9.01 [-19.36, 1.35]	-23.18 [-32.61, -13.75]
国民民主党	政権与党の政党名：国民民主党	25.68 [4.69, 46.68]	28.20 [14.82, 41.57]	40.51 [26.54, 54.48]	27.05 [15.13, 38.97]
国民民主党	政権与党の政党名：れいわ新選組	-21.96 [-46.38, 2.46]	-25.26 [-36.79, -13.73]	-21.76 [-32.24, -11.29]	-21.73 [-31.88, -11.58]
国民民主党	政権与党の政党名：参政党	7.75 [-13.83, 29.32]	-0.67 [-17.07, 15.74]	-2.81 [-15.32, 9.70]	-14.58 [-24.85, -4.31]
国民民主党	政権与党の政党名：日本共産党	-20.58 [-41.93, 0.77]	-19.83 [-33.22, -6.43]	-20.86 [-30.73, -10.99]	-24.39 [-33.49, -15.29]
国民民主党	政権与党の政党名：中道改革連合	6.29 [-12.94, 25.51]	-23.73 [-36.82, -10.65]	-11.83 [-23.78, 0.13]	-17.41 [-28.07, -6.75]
国民民主党	政権与党の政党名：チームみらい	21.97 [2.03, 41.92]	5.68 [-8.86, 20.22]	0.48 [-14.09, 15.05]	-11.79 [-22.39, -1.18]
国民民主党	GDP成長率：GDP：プラス1％	-2.73 [-11.95, 6.49]	10.68 [4.08, 17.28]	6.52 [-0.10, 13.13]	5.54 [0.83, 10.25]
国民民主党	GDP成長率：GDP：マイナス1％	-10.99 [-21.40, -0.57]	-1.80 [-7.92, 4.32]	-5.53 [-10.67, -0.38]	0.41 [-3.24, 4.07]
国民民主党	日経平均：日経平均：プラス1000円	1.02 [-9.64, 11.68]	3.55 [-3.79, 10.89]	1.09 [-4.92, 7.11]	0.98 [-2.68, 4.63]
国民民主党	日経平均：日経平均：マイナス1000円	-5.45 [-16.73, 5.83]	-2.26 [-9.46, 4.94]	-4.25 [-9.30, 0.80]	-3.44 [-6.57, -0.31]
国民民主党	CPI：CPI：プラス1ポイント	-0.60 [-12.81, 11.61]	1.17 [-4.87, 7.21]	0.27 [-4.77, 5.32]	0.68 [-3.48, 4.84]
国民民主党	CPI：CPI：マイナス1ポイント	-1.55 [-12.37, 9.26]	4.04 [-1.60, 9.69]	1.23 [-4.88, 7.35]	4.22 [0.34, 8.10]
国民民主党	失業率：失業率：プラス1％	-3.54 [-13.05, 5.98]	-6.22 [-13.09, 0.65]	-1.05 [-5.89, 3.80]	-2.38 [-5.88, 1.12]
国民民主党	失業率：失業率：マイナス1％	-1.72 [-11.23, 7.80]	-2.08 [-8.92, 4.75]	2.36 [-2.32, 7.04]	0.65 [-3.31, 4.61]
日本維新の会	政権与党の政党名：立憲民主党	—	-23.66 [-43.24, -4.08]	-20.02 [-33.48, -6.57]	-21.64 [-32.04, -11.24]
日本維新の会	政権与党の政党名：日本維新の会	—	18.89 [0.97, 36.80]	21.51 [6.23, 36.79]	35.33 [19.19, 51.48]
日本維新の会	政権与党の政党名：公明党	—	-36.32 [-53.85, -18.79]	-22.15 [-35.20, -9.09]	-22.37 [-32.76, -11.98]
日本維新の会	政権与党の政党名：国民民主党	—	-20.71 [-40.44, -0.98]	-9.87 [-24.34, 4.60]	-6.76 [-18.76, 5.25]
日本維新の会	政権与党の政党名：れいわ新選組	—	-45.42 [-61.49, -29.35]	-22.65 [-35.00, -10.31]	-14.15 [-26.23, -2.06]
日本維新の会	政権与党の政党名：参政党	—	-13.95 [-31.21, 3.31]	-10.22 [-24.83, 4.39]	-16.40 [-26.41, -6.40]
日本維新の会	政権与党の政党名：日本共産党	—	-40.77 [-57.04, -24.49]	-27.21 [-39.61, -14.82]	-21.59 [-31.75, -11.42]
日本維新の会	政権与党の政党名：中道改革連合	—	-34.64 [-54.04, -15.23]	-18.34 [-33.65, -3.04]	-15.87 [-28.04, -3.70]
日本維新の会	政権与党の政党名：チームみらい	—	-8.52 [-29.27, 12.24]	-7.07 [-20.54, 6.39]	-7.28 [-20.35, 5.80]
日本維新の会	GDP成長率：GDP：プラス1％	—	5.13 [-2.27, 12.54]	8.34 [3.24, 13.43]	2.45 [-1.47, 6.37]
日本維新の会	GDP成長率：GDP：マイナス1％	—	-5.35 [-13.02, 2.33]	2.95 [-2.72, 8.62]	-6.55 [-10.87, -2.22]
日本維新の会	日経平均：日経平均：プラス1000円	—	4.91 [-4.27, 14.09]	-3.11 [-10.64, 4.42]	2.14 [-2.61, 6.89]
日本維新の会	日経平均：日経平均：マイナス1000円	—	-7.38 [-15.22, 0.47]	-7.98 [-13.94, -2.01]	-2.23 [-6.47, 2.01]
日本維新の会	CPI：CPI：プラス1ポイント	—	-2.65 [-11.05, 5.75]	-2.66 [-8.07, 2.74]	-0.44 [-4.92, 4.03]
日本維新の会	CPI：CPI：マイナス1ポイント	—	-0.30 [-7.61, 7.01]	0.78 [-4.96, 6.51]	3.72 [-0.75, 8.18]
日本維新の会	失業率：失業率：プラス1％	—	-2.34 [-10.83, 6.14]	-4.58 [-10.19, 1.04]	-0.27 [-5.98, 5.43]
日本維新の会	失業率：失業率：マイナス1％	—	-1.90 [-9.41, 5.61]	1.46 [-4.78, 7.70]	2.56 [-1.60, 6.72]
チームみらい	政権与党の政党名：立憲民主党	—	—	-6.71 [-19.68, 6.26]	0.81 [-11.15, 12.76]
チームみらい	政権与党の政党名：日本維新の会	—	—	9.18 [-4.41, 22.77]	-3.20 [-12.14, 5.75]
チームみらい	政権与党の政党名：公明党	—	—	-16.16 [-26.87, -5.45]	-12.75 [-21.24, -4.27]
チームみらい	政権与党の政党名：国民民主党	—	—	1.21 [-11.62, 14.04]	3.82 [-5.60, 13.24]
チームみらい	政権与党の政党名：れいわ新選組	—	—	-18.02 [-29.24, -6.79]	-13.33 [-22.00, -4.67]
チームみらい	政権与党の政党名：参政党	—	—	4.18 [-10.11, 18.46]	-2.68 [-13.01, 7.64]
チームみらい	政権与党の政党名：日本共産党	—	—	-16.03 [-27.71, -4.36]	-13.93 [-23.34, -4.52]
チームみらい	政権与党の政党名：中道改革連合	—	—	-13.19 [-25.56, -0.81]	-4.76 [-15.38, 5.86]
チームみらい	政権与党の政党名：チームみらい	—	—	48.94 [35.13, 62.74]	37.67 [23.97, 51.37]
チームみらい	GDP成長率：GDP：プラス1％	—	—	8.54 [1.61, 15.47]	9.10 [3.48, 14.71]
チームみらい	GDP成長率：GDP：マイナス1％	—	—	-3.19 [-9.18, 2.81]	-4.16 [-8.90, 0.58]
チームみらい	日経平均：日経平均：プラス1000円	—	—	0.62 [-5.37, 6.62]	2.70 [-1.45, 6.85]
チームみらい	日経平均：日経平均：マイナス1000円	—	—	-3.43 [-9.65, 2.79]	-3.20 [-7.11, 0.72]
チームみらい	CPI：CPI：プラス1ポイント	—	—	2.78 [-3.70, 9.26]	-3.34 [-7.59, 0.90]
チームみらい	CPI：CPI：マイナス1ポイント	—	—	-1.61 [-8.78, 5.55]	-0.56 [-5.33, 4.21]
チームみらい	失業率：失業率：プラス1％	—	—	-0.21 [-5.42, 4.99]	-4.60 [-8.74, -0.46]
チームみらい	失業率：失業率：マイナス1％	—	—	-1.80 [-7.78, 4.17]	-0.08 [-4.33, 4.17]
参政党	政権与党の政党名：立憲民主党	—	-31.17 [-48.83, -13.51]	-23.63 [-33.43, -13.82]	-23.29 [-33.83, -12.76]
参政党	政権与党の政党名：日本維新の会	—	-8.75 [-25.57, 8.06]	-4.13 [-15.54, 7.28]	-11.14 [-21.99, -0.28]
参政党	政権与党の政党名：公明党	—	-29.26 [-45.87, -12.65]	-17.96 [-30.38, -5.55]	-27.02 [-36.77, -17.28]
参政党	政権与党の政党名：国民民主党	—	-14.78 [-34.48, 4.92]	15.24 [-1.44, 31.92]	-6.82 [-19.94, 6.29]
参政党	政権与党の政党名：れいわ新選組	—	-35.49 [-53.20, -17.79]	-18.05 [-31.32, -4.79]	-22.87 [-33.73, -12.01]
参政党	政権与党の政党名：参政党	—	28.82 [14.23, 43.41]	52.99 [40.57, 65.42]	43.77 [29.78, 57.75]
参政党	政権与党の政党名：日本共産党	—	-43.09 [-59.59, -26.59]	-21.44 [-33.47, -9.41]	-23.24 [-34.51, -11.97]
参政党	政権与党の政党名：中道改革連合	—	-41.85 [-57.51, -26.20]	-22.82 [-33.16, -12.48]	-24.34 [-34.61, -14.07]
参政党	政権与党の政党名：チームみらい	—	-17.61 [-35.44, 0.23]	2.83 [-12.16, 17.82]	-15.39 [-27.36, -3.43]
参政党	GDP成長率：GDP：プラス1％	—	8.78 [1.61, 15.96]	4.79 [-3.30, 12.87]	3.01 [-2.78, 8.79]
参政党	GDP成長率：GDP：マイナス1％	—	-6.46 [-13.58, 0.66]	-5.66 [-12.64, 1.32]	-2.31 [-6.76, 2.14]
参政党	日経平均：日経平均：プラス1000円	—	4.40 [-6.02, 14.82]	0.25 [-6.40, 6.91]	3.43 [-1.26, 8.12]
参政党	日経平均：日経平均：マイナス1000円	—	0.20 [-9.41, 9.82]	-4.26 [-9.99, 1.47]	0.22 [-4.17, 4.60]
参政党	CPI：CPI：プラス1ポイント	—	-0.78 [-8.29, 6.74]	3.49 [-2.11, 9.09]	1.40 [-3.09, 5.90]
参政党	CPI：CPI：マイナス1ポイント	—	-4.56 [-10.79, 1.67]	-0.07 [-6.57, 6.42]	-1.81 [-6.65, 3.04]
参政党	失業率：失業率：プラス1％	—	-1.84 [-9.72, 6.04]	-0.63 [-6.03, 4.76]	-0.26 [-5.25, 4.73]
参政党	失業率：失業率：マイナス1％	—	-3.19 [-8.63, 2.24]	-3.86 [-10.66, 2.95]	1.05 [-3.67, 5.77]
立憲民主党	政権与党の政党名：立憲民主党	—	—	—	42.48 [28.96, 56.00]
立憲民主党	政権与党の政党名：日本維新の会	—	—	—	-1.82 [-10.06, 6.41]
立憲民主党	政権与党の政党名：公明党	—	—	—	-4.14 [-11.47, 3.18]
立憲民主党	政権与党の政党名：国民民主党	—	—	—	14.88 [4.04, 25.72]
立憲民主党	政権与党の政党名：れいわ新選組	—	—	—	-2.95 [-10.04, 4.14]
立憲民主党	政権与党の政党名：参政党	—	—	—	-1.03 [-8.16, 6.10]
立憲民主党	政権与党の政党名：日本共産党	—	—	—	1.91 [-6.64, 10.45]
立憲民主党	政権与党の政党名：中道改革連合	—	—	—	15.25 [5.75, 24.75]
立憲民主党	政権与党の政党名：チームみらい	—	—	—	-0.05 [-7.52, 7.43]
立憲民主党	GDP成長率：GDP：プラス1％	—	—	—	7.46 [2.35, 12.56]
立憲民主党	GDP成長率：GDP：マイナス1％	—	—	—	-2.33 [-6.77, 2.12]
立憲民主党	日経平均：日経平均：プラス1000円	—	—	—	2.79 [-2.46, 8.03]
立憲民主党	日経平均：日経平均：マイナス1000円	—	—	—	-0.33 [-5.52, 4.87]
立憲民主党	CPI：CPI：プラス1ポイント	—	—	—	-1.81 [-6.24, 2.62]
立憲民主党	CPI：CPI：マイナス1ポイント	—	—	—	-0.72 [-4.91, 3.47]
立憲民主党	失業率：失業率：プラス1％	—	—	—	-4.70 [-9.93, 0.53]
立憲民主党	失業率：失業率：マイナス1％	—	—	—	-3.89 [-8.39, 0.61]

補図H2：支持政党別の手がかり重要度と相対比重

支持手がかり一覧 <- dplyr::bind_rows(
  party_support_relative_cue_results$study1$intervals %>% dplyr::mutate(実験 = "実験1（2023年）", study_id = "study1"),
  party_support_relative_cue_results$study2$intervals %>% dplyr::mutate(実験 = "実験2（2026年）", study_id = "study2"),
  party_support_relative_cue_results$study3$intervals %>% dplyr::mutate(実験 = "実験3（2026年）", study_id = "study3")
) %>%
  dplyr::mutate(
    条件 = purrr::map2_chr(party_n, study_id, 条件日本語),
    指標 = purrr::map2_chr(statistic, study_id, 統計量日本語),
    表示値 = dplyr::if_else(statistic == "relative_party_weight_pairwise", 100 * estimate, 100 * estimate),
    下限 = 100 * conf_low,
    上限 = 100 * conf_high,
    単位 = dplyr::if_else(statistic == "relative_party_weight_pairwise", "%", "pp")
  )

相対比重データ <- 支持手がかり一覧 %>%
  dplyr::filter(statistic == "relative_party_weight_pairwise") %>%
  dplyr::mutate(数値ラベル = sprintf("%.1f%%", 表示値))

for (実験名 in unique(相対比重データ$実験)) {
  描画データ <- 相対比重データ %>% dplyr::filter(実験 == 実験名)
  図 <- ggplot2::ggplot(描画データ, ggplot2::aes(x = party_n, y = 表示値, group = party_support_h)) +
    ggplot2::geom_hline(yintercept = 50, linetype = "dashed", linewidth = 0.4) +
    ggplot2::geom_line(linewidth = 0.65) +
    ggplot2::geom_errorbar(ggplot2::aes(ymin = 下限, ymax = 上限), width = 0.08, linewidth = 0.45) +
    ggplot2::geom_label(ggplot2::aes(label = 数値ラベル), size = 3.0, label.size = 0, fill = "white") +
    ggplot2::facet_wrap(~ party_support_h, scales = "free_y") +
    ggplot2::scale_x_continuous(breaks = 2:5, labels = 条件日本語(2:5, ifelse(unique(描画データ$study_id) == "study3", "study3", "study1"))) +
    ggplot2::labs(x = NULL, y = "政党手がかり相対比重（%）", subtitle = 実験名) +
    ggplot2::theme_bw(base_size = 10) +
    ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
  print(図)
}

表H2 <- 支持手がかり一覧 %>%
  dplyr::transmute(
    実験,
    支持政党 = party_support_h,
    `条件・指標` = paste0(条件, "：", 指標),
    推定値 = round(表示値, 2),
    `95%CI下限` = round(下限, 2),
    `95%CI上限` = round(上限, 2),
    単位
  )
knitr::kable(表日本語(表H2), format = "html", row.names = FALSE, caption = "表H2：支持政党別の手がかり重要度と相対比重")

表H2：支持政党別の手がかり重要度と相対比重

実験	支持政党	条件・指標	推定値	95%CI下限	95%CI上限	単位
実験1（2023年）	日本維新の会	2政党条件：政党重要度	5.09	3.59	6.78	pp
実験1（2023年）	日本維新の会	2政党条件：経済重要度	5.41	4.47	6.90	pp
実験1（2023年）	日本維新の会	2政党条件：政党重要度（選択肢数調整済み）	10.17	7.18	13.57	pp
実験1（2023年）	日本維新の会	2政党条件：経済重要度（選択肢数調整済み）	10.82	8.93	13.79	pp
実験1（2023年）	日本維新の会	2政党条件：政党手がかり相対比重	48.44	38.23	57.41	%
実験1（2023年）	日本維新の会	3政党条件：政党重要度	6.19	4.83	7.84	pp
実験1（2023年）	日本維新の会	3政党条件：経済重要度	4.38	3.68	5.51	pp
実験1（2023年）	日本維新の会	3政党条件：政党重要度（選択肢数調整済み）	18.58	14.49	23.52	pp
実験1（2023年）	日本維新の会	3政党条件：経済重要度（選択肢数調整済み）	13.15	11.03	16.53	pp
実験1（2023年）	日本維新の会	3政党条件：政党手がかり相対比重	58.56	49.36	65.52	%
実験1（2023年）	日本維新の会	4政党条件：政党重要度	5.52	4.24	6.99	pp
実験1（2023年）	日本維新の会	4政党条件：経済重要度	4.48	3.85	5.42	pp
実験1（2023年）	日本維新の会	4政党条件：政党重要度（選択肢数調整済み）	22.07	16.95	27.95	pp
実験1（2023年）	日本維新の会	4政党条件：経済重要度（選択肢数調整済み）	17.92	15.42	21.66	pp
実験1（2023年）	日本維新の会	4政党条件：政党手がかり相対比重	55.19	47.29	62.14	%
実験1（2023年）	日本維新の会	5政党条件：政党重要度	5.44	4.24	6.68	pp
実験1（2023年）	日本維新の会	5政党条件：経済重要度	4.30	3.64	5.03	pp
実験1（2023年）	日本維新の会	5政党条件：政党重要度（選択肢数調整済み）	27.22	21.22	33.40	pp
実験1（2023年）	日本維新の会	5政党条件：経済重要度（選択肢数調整済み）	21.51	18.22	25.14	pp
実験1（2023年）	日本維新の会	5政党条件：政党手がかり相対比重	55.87	48.23	62.06	%
実験1（2023年）	立憲民主党	2政党条件：政党重要度	5.20	3.31	7.93	pp
実験1（2023年）	立憲民主党	2政党条件：経済重要度	3.83	2.96	6.14	pp
実験1（2023年）	立憲民主党	2政党条件：政党重要度（選択肢数調整済み）	10.41	6.62	15.85	pp
実験1（2023年）	立憲民主党	2政党条件：経済重要度（選択肢数調整済み）	7.66	5.92	12.27	pp
実験1（2023年）	立憲民主党	2政党条件：政党手がかり相対比重	57.60	39.96	67.43	%
実験1（2023年）	立憲民主党	3政党条件：政党重要度	3.40	2.49	5.81	pp
実験1（2023年）	立憲民主党	3政党条件：経済重要度	3.88	3.29	5.75	pp
実験1（2023年）	立憲民主党	3政党条件：政党重要度（選択肢数調整済み）	10.19	7.46	17.42	pp
実験1（2023年）	立憲民主党	3政党条件：経済重要度（選択肢数調整済み）	11.63	9.87	17.25	pp
実験1（2023年）	立憲民主党	3政党条件：政党手がかり相対比重	46.70	33.47	57.85	%
実験1（2023年）	立憲民主党	4政党条件：政党重要度	5.25	3.56	7.11	pp
実験1（2023年）	立憲民主党	4政党条件：経済重要度	3.42	2.92	4.93	pp
実験1（2023年）	立憲民主党	4政党条件：政党重要度（選択肢数調整済み）	21.00	14.25	28.46	pp
実験1（2023年）	立憲民主党	4政党条件：経済重要度（選択肢数調整済み）	13.69	11.70	19.73	pp
実験1（2023年）	立憲民主党	4政党条件：政党手がかり相対比重	60.54	46.06	68.15	%
実験1（2023年）	立憲民主党	5政党条件：政党重要度	4.58	3.37	6.02	pp
実験1（2023年）	立憲民主党	5政党条件：経済重要度	3.58	2.75	4.60	pp
実験1（2023年）	立憲民主党	5政党条件：政党重要度（選択肢数調整済み）	22.91	16.87	30.08	pp
実験1（2023年）	立憲民主党	5政党条件：経済重要度（選択肢数調整済み）	17.88	13.74	22.99	pp
実験1（2023年）	立憲民主党	5政党条件：政党手がかり相対比重	56.17	46.56	65.70	%
実験1（2023年）	公明党	2政党条件：政党重要度	7.42	4.97	10.33	pp
実験1（2023年）	公明党	2政党条件：経済重要度	4.92	4.05	7.50	pp
実験1（2023年）	公明党	2政党条件：政党重要度（選択肢数調整済み）	14.85	9.95	20.66	pp
実験1（2023年）	公明党	2政党条件：経済重要度（選択肢数調整済み）	9.85	8.11	15.00	pp
実験1（2023年）	公明党	2政党条件：政党手がかり相対比重	60.12	46.64	68.04	%
実験1（2023年）	公明党	3政党条件：政党重要度	5.86	4.17	8.22	pp
実験1（2023年）	公明党	3政党条件：経済重要度	5.92	4.96	7.76	pp
実験1（2023年）	公明党	3政党条件：政党重要度（選択肢数調整済み）	17.57	12.52	24.67	pp
実験1（2023年）	公明党	3政党条件：経済重要度（選択肢数調整済み）	17.75	14.87	23.27	pp
実験1（2023年）	公明党	3政党条件：政党手がかり相対比重	49.75	37.47	59.67	%
実験1（2023年）	公明党	4政党条件：政党重要度	3.72	2.51	5.81	pp
実験1（2023年）	公明党	4政党条件：経済重要度	4.23	3.13	5.75	pp
実験1（2023年）	公明党	4政党条件：政党重要度（選択肢数調整済み）	14.86	10.02	23.22	pp
実験1（2023年）	公明党	4政党条件：経済重要度（選択肢数調整済み）	16.91	12.52	22.98	pp
実験1（2023年）	公明党	4政党条件：政党手がかり相対比重	46.78	34.69	60.02	%
実験1（2023年）	公明党	5政党条件：政党重要度	4.60	3.50	6.53	pp
実験1（2023年）	公明党	5政党条件：経済重要度	4.08	3.42	5.36	pp
実験1（2023年）	公明党	5政党条件：政党重要度（選択肢数調整済み）	23.02	17.51	32.64	pp
実験1（2023年）	公明党	5政党条件：経済重要度（選択肢数調整済み）	20.38	17.09	26.80	pp
実験1（2023年）	公明党	5政党条件：政党手がかり相対比重	53.04	42.31	63.34	%
実験1（2023年）	日本共産党	2政党条件：政党重要度	6.39	4.56	11.78	pp
実験1（2023年）	日本共産党	2政党条件：経済重要度	6.23	4.76	11.78	pp
実験1（2023年）	日本共産党	2政党条件：政党重要度（選択肢数調整済み）	12.78	9.11	23.56	pp
実験1（2023年）	日本共産党	2政党条件：経済重要度（選択肢数調整済み）	12.46	9.52	23.57	pp
実験1（2023年）	日本共産党	2政党条件：政党手がかり相対比重	50.64	31.63	66.38	%
実験1（2023年）	日本共産党	3政党条件：政党重要度	6.34	4.27	10.29	pp
実験1（2023年）	日本共産党	3政党条件：経済重要度	6.85	5.14	10.57	pp
実験1（2023年）	日本共産党	3政党条件：政党重要度（選択肢数調整済み）	19.01	12.82	30.87	pp
実験1（2023年）	日本共産党	3政党条件：経済重要度（選択肢数調整済み）	20.55	15.42	31.71	pp
実験1（2023年）	日本共産党	3政党条件：政党手がかり相対比重	48.05	32.82	62.62	%
実験1（2023年）	日本共産党	4政党条件：政党重要度	5.39	3.49	8.70	pp
実験1（2023年）	日本共産党	4政党条件：経済重要度	5.99	4.48	8.79	pp
実験1（2023年）	日本共産党	4政党条件：政党重要度（選択肢数調整済み）	21.57	13.97	34.78	pp
実験1（2023年）	日本共産党	4政党条件：経済重要度（選択肢数調整済み）	23.95	17.93	35.14	pp
実験1（2023年）	日本共産党	4政党条件：政党手がかり相対比重	47.38	34.06	60.47	%
実験1（2023年）	日本共産党	5政党条件：政党重要度	4.81	3.03	8.47	pp
実験1（2023年）	日本共産党	5政党条件：経済重要度	3.57	2.82	5.89	pp
実験1（2023年）	日本共産党	5政党条件：政党重要度（選択肢数調整済み）	24.07	15.17	42.36	pp
実験1（2023年）	日本共産党	5政党条件：経済重要度（選択肢数調整済み）	17.84	14.10	29.45	pp
実験1（2023年）	日本共産党	5政党条件：政党手がかり相対比重	57.44	38.54	71.29	%
実験2（2026年）	支持政党なし	2政党条件：政党重要度	3.83	2.53	6.22	pp
実験2（2026年）	支持政党なし	2政党条件：経済重要度	6.22	5.02	7.93	pp
実験2（2026年）	支持政党なし	2政党条件：政党重要度（選択肢数調整済み）	7.66	5.07	12.44	pp
実験2（2026年）	支持政党なし	2政党条件：経済重要度（選択肢数調整済み）	12.43	10.04	15.86	pp
実験2（2026年）	支持政党なし	2政党条件：政党手がかり相対比重	38.12	27.09	50.95	%
実験2（2026年）	支持政党なし	3政党条件：政党重要度	4.33	3.62	5.92	pp
実験2（2026年）	支持政党なし	3政党条件：経済重要度	5.24	4.35	6.50	pp
実験2（2026年）	支持政党なし	3政党条件：政党重要度（選択肢数調整済み）	13.00	10.87	17.77	pp
実験2（2026年）	支持政党なし	3政党条件：経済重要度（選択肢数調整済み）	15.72	13.05	19.50	pp
実験2（2026年）	支持政党なし	3政党条件：政党手がかり相対比重	45.26	38.89	54.38	%
実験2（2026年）	支持政党なし	4政党条件：政党重要度	4.85	3.96	6.09	pp
実験2（2026年）	支持政党なし	4政党条件：経済重要度	4.84	4.07	5.71	pp
実験2（2026年）	支持政党なし	4政党条件：政党重要度（選択肢数調整済み）	19.42	15.85	24.34	pp
実験2（2026年）	支持政党なし	4政党条件：経済重要度（選択肢数調整済み）	19.37	16.26	22.83	pp
実験2（2026年）	支持政党なし	4政党条件：政党手がかり相対比重	50.06	43.40	57.04	%
実験2（2026年）	支持政党なし	5政党条件：政党重要度	3.91	2.98	4.87	pp
実験2（2026年）	支持政党なし	5政党条件：経済重要度	3.90	3.34	4.73	pp
実験2（2026年）	支持政党なし	5政党条件：政党重要度（選択肢数調整済み）	19.53	14.91	24.35	pp
実験2（2026年）	支持政党なし	5政党条件：経済重要度（選択肢数調整済み）	19.49	16.69	23.64	pp
実験2（2026年）	支持政党なし	5政党条件：政党手がかり相対比重	50.05	41.26	57.35	%
実験2（2026年）	自由民主党	2政党条件：政党重要度	11.95	9.31	14.87	pp
実験2（2026年）	自由民主党	2政党条件：経済重要度	4.99	3.53	7.23	pp
実験2（2026年）	自由民主党	2政党条件：政党重要度（選択肢数調整済み）	23.89	18.62	29.73	pp
実験2（2026年）	自由民主党	2政党条件：経済重要度（選択肢数調整済み）	9.98	7.05	14.46	pp
実験2（2026年）	自由民主党	2政党条件：政党手がかり相対比重	70.53	60.77	78.71	%
実験2（2026年）	自由民主党	3政党条件：政党重要度	11.71	9.95	13.43	pp
実験2（2026年）	自由民主党	3政党条件：経済重要度	5.18	3.88	6.75	pp
実験2（2026年）	自由民主党	3政党条件：政党重要度（選択肢数調整済み）	35.13	29.86	40.30	pp
実験2（2026年）	自由民主党	3政党条件：経済重要度（選択肢数調整済み）	15.53	11.64	20.25	pp
実験2（2026年）	自由民主党	3政党条件：政党手がかり相対比重	69.35	61.89	76.20	%
実験2（2026年）	自由民主党	4政党条件：政党重要度	10.84	9.30	12.34	pp
実験2（2026年）	自由民主党	4政党条件：経済重要度	3.96	3.20	5.18	pp
実験2（2026年）	自由民主党	4政党条件：政党重要度（選択肢数調整済み）	43.36	37.21	49.37	pp
実験2（2026年）	自由民主党	4政党条件：経済重要度（選択肢数調整済み）	15.84	12.80	20.74	pp
実験2（2026年）	自由民主党	4政党条件：政党手がかり相対比重	73.24	65.54	78.08	%
実験2（2026年）	自由民主党	5政党条件：政党重要度	10.62	9.61	11.74	pp
実験2（2026年）	自由民主党	5政党条件：経済重要度	2.40	1.90	3.27	pp
実験2（2026年）	自由民主党	5政党条件：政党重要度（選択肢数調整済み）	53.11	48.05	58.72	pp
実験2（2026年）	自由民主党	5政党条件：経済重要度（選択肢数調整済み）	12.00	9.52	16.35	pp
実験2（2026年）	自由民主党	5政党条件：政党手がかり相対比重	81.57	75.95	85.34	%
実験2（2026年）	国民民主党	2政党条件：政党重要度	5.66	4.06	12.30	pp
実験2（2026年）	国民民主党	2政党条件：経済重要度	8.46	6.45	13.94	pp
実験2（2026年）	国民民主党	2政党条件：政党重要度（選択肢数調整済み）	11.33	8.11	24.60	pp
実験2（2026年）	国民民主党	2政党条件：経済重要度（選択肢数調整済み）	16.93	12.89	27.87	pp
実験2（2026年）	国民民主党	2政党条件：政党手がかり相対比重	40.09	27.47	59.50	%
実験2（2026年）	国民民主党	3政党条件：政党重要度	6.22	4.94	9.76	pp
実験2（2026年）	国民民主党	3政党条件：経済重要度	6.91	5.32	9.75	pp
実験2（2026年）	国民民主党	3政党条件：政党重要度（選択肢数調整済み）	18.65	14.83	29.28	pp
実験2（2026年）	国民民主党	3政党条件：経済重要度（選択肢数調整済み）	20.74	15.96	29.24	pp
実験2（2026年）	国民民主党	3政党条件：政党手がかり相対比重	47.34	38.02	60.40	%
実験2（2026年）	国民民主党	4政党条件：政党重要度	3.98	2.94	7.73	pp
実験2（2026年）	国民民主党	4政党条件：経済重要度	5.50	4.46	8.17	pp
実験2（2026年）	国民民主党	4政党条件：政党重要度（選択肢数調整済み）	15.94	11.76	30.91	pp
実験2（2026年）	国民民主党	4政党条件：経済重要度（選択肢数調整済み）	22.01	17.82	32.68	pp
実験2（2026年）	国民民主党	4政党条件：政党手がかり相対比重	42.00	31.79	58.16	%
実験2（2026年）	国民民主党	5政党条件：政党重要度	5.02	3.68	7.36	pp
実験2（2026年）	国民民主党	5政党条件：経済重要度	4.19	3.36	6.32	pp
実験2（2026年）	国民民主党	5政党条件：政党重要度（選択肢数調整済み）	25.11	18.42	36.81	pp
実験2（2026年）	国民民主党	5政党条件：経済重要度（選択肢数調整済み）	20.95	16.82	31.60	pp
実験2（2026年）	国民民主党	5政党条件：政党手がかり相対比重	54.51	40.84	65.60	%
実験2（2026年）	日本維新の会	2政党条件：政党重要度	6.99	4.19	12.61	pp
実験2（2026年）	日本維新の会	2政党条件：経済重要度	5.86	4.48	10.95	pp
実験2（2026年）	日本維新の会	2政党条件：政党重要度（選択肢数調整済み）	13.98	8.38	25.22	pp
実験2（2026年）	日本維新の会	2政党条件：経済重要度（選択肢数調整済み）	11.73	8.95	21.90	pp
実験2（2026年）	日本維新の会	2政党条件：政党手がかり相対比重	54.38	36.28	65.23	%
実験2（2026年）	日本維新の会	3政党条件：政党重要度	4.58	3.07	8.58	pp
実験2（2026年）	日本維新の会	3政党条件：経済重要度	5.69	4.53	8.49	pp
実験2（2026年）	日本維新の会	3政党条件：政党重要度（選択肢数調整済み）	13.74	9.20	25.75	pp
実験2（2026年）	日本維新の会	3政党条件：経済重要度（選択肢数調整済み）	17.06	13.60	25.48	pp
実験2（2026年）	日本維新の会	3政党条件：政党手がかり相対比重	44.60	30.75	59.88	%
実験2（2026年）	日本維新の会	4政党条件：政党重要度	6.29	4.16	10.00	pp
実験2（2026年）	日本維新の会	4政党条件：経済重要度	4.11	3.14	7.15	pp
実験2（2026年）	日本維新の会	4政党条件：政党重要度（選択肢数調整済み）	25.16	16.64	39.99	pp
実験2（2026年）	日本維新の会	4政党条件：経済重要度（選択肢数調整済み）	16.45	12.58	28.59	pp
実験2（2026年）	日本維新の会	4政党条件：政党手がかり相対比重	60.46	42.10	72.36	%
実験2（2026年）	日本維新の会	5政党条件：政党重要度	5.28	3.88	7.83	pp
実験2（2026年）	日本維新の会	5政党条件：経済重要度	2.56	2.06	4.94	pp
実験2（2026年）	日本維新の会	5政党条件：政党重要度（選択肢数調整済み）	26.39	19.38	39.16	pp
実験2（2026年）	日本維新の会	5政党条件：経済重要度（選択肢数調整済み）	12.79	10.31	24.70	pp
実験2（2026年）	日本維新の会	5政党条件：政党手がかり相対比重	67.36	51.12	76.48	%
実験2（2026年）	チームみらい	2政党条件：政党重要度	12.13	9.48	17.24	pp
実験2（2026年）	チームみらい	2政党条件：経済重要度	5.89	4.43	11.21	pp
実験2（2026年）	チームみらい	2政党条件：政党重要度（選択肢数調整済み）	24.27	18.95	34.47	pp
実験2（2026年）	チームみらい	2政党条件：経済重要度（選択肢数調整済み）	11.78	8.86	22.41	pp
実験2（2026年）	チームみらい	2政党条件：政党手がかり相対比重	67.32	51.58	76.76	%
実験2（2026年）	チームみらい	3政党条件：政党重要度	2.76	2.42	7.43	pp
実験2（2026年）	チームみらい	3政党条件：経済重要度	7.71	5.93	11.02	pp
実験2（2026年）	チームみらい	3政党条件：政党重要度（選択肢数調整済み）	8.28	7.27	22.29	pp
実験2（2026年）	チームみらい	3政党条件：経済重要度（選択肢数調整済み）	23.13	17.78	33.07	pp
実験2（2026年）	チームみらい	3政党条件：政党手がかり相対比重	26.35	20.72	50.97	%
実験2（2026年）	チームみらい	4政党条件：政党重要度	4.06	3.43	7.56	pp
実験2（2026年）	チームみらい	4政党条件：経済重要度	4.97	3.60	7.89	pp
実験2（2026年）	チームみらい	4政党条件：政党重要度（選択肢数調整済み）	16.23	13.74	30.24	pp
実験2（2026年）	チームみらい	4政党条件：経済重要度（選択肢数調整済み）	19.86	14.41	31.56	pp
実験2（2026年）	チームみらい	4政党条件：政党手がかり相対比重	44.96	36.39	63.14	%
実験2（2026年）	チームみらい	5政党条件：政党重要度	3.80	2.63	5.99	pp
実験2（2026年）	チームみらい	5政党条件：経済重要度	3.92	2.86	6.21	pp
実験2（2026年）	チームみらい	5政党条件：政党重要度（選択肢数調整済み）	18.98	13.16	29.96	pp
実験2（2026年）	チームみらい	5政党条件：経済重要度（選択肢数調整済み）	19.62	14.29	31.07	pp
実験2（2026年）	チームみらい	5政党条件：政党手がかり相対比重	49.17	33.67	61.87	%
実験3（2026年）	支持政党なし	2選択肢条件：政党名重要度	12.75	10.83	15.93	pp
実験3（2026年）	支持政党なし	2選択肢条件：経済重要度	5.38	4.23	7.47	pp
実験3（2026年）	支持政党なし	2選択肢条件：政党名重要度（選択肢数調整済み）	25.49	21.66	31.87	pp
実験3（2026年）	支持政党なし	2選択肢条件：経済重要度（選択肢数調整済み）	10.76	8.47	14.93	pp
実験3（2026年）	支持政党なし	2選択肢条件：政党手がかり相対比重	70.32	62.45	77.48	%
実験3（2026年）	支持政党なし	3選択肢条件：政党名重要度	8.88	7.27	11.32	pp
実験3（2026年）	支持政党なし	3選択肢条件：経済重要度	5.34	4.46	6.49	pp
実験3（2026年）	支持政党なし	3選択肢条件：政党名重要度（選択肢数調整済み）	26.63	21.82	33.95	pp
実験3（2026年）	支持政党なし	3選択肢条件：経済重要度（選択肢数調整済み）	16.01	13.38	19.46	pp
実験3（2026年）	支持政党なし	3選択肢条件：政党手がかり相対比重	62.46	55.62	69.13	%
実験3（2026年）	支持政党なし	4選択肢条件：政党名重要度	8.31	7.00	10.19	pp
実験3（2026年）	支持政党なし	4選択肢条件：経済重要度	4.77	3.96	5.78	pp
実験3（2026年）	支持政党なし	4選択肢条件：政党名重要度（選択肢数調整済み）	33.24	27.99	40.76	pp
実験3（2026年）	支持政党なし	4選択肢条件：経済重要度（選択肢数調整済み）	19.09	15.84	23.12	pp
実験3（2026年）	支持政党なし	4選択肢条件：政党手がかり相対比重	63.52	57.46	70.08	%
実験3（2026年）	支持政党なし	5選択肢条件：政党名重要度	7.05	6.04	8.37	pp
実験3（2026年）	支持政党なし	5選択肢条件：経済重要度	4.04	3.47	4.74	pp
実験3（2026年）	支持政党なし	5選択肢条件：政党名重要度（選択肢数調整済み）	35.27	30.22	41.84	pp
実験3（2026年）	支持政党なし	5選択肢条件：経済重要度（選択肢数調整済み）	20.19	17.35	23.71	pp
実験3（2026年）	支持政党なし	5選択肢条件：政党手がかり相対比重	63.60	58.13	69.15	%
実験3（2026年）	自由民主党	2選択肢条件：政党名重要度	20.69	17.88	24.62	pp
実験3（2026年）	自由民主党	2選択肢条件：経済重要度	5.70	4.22	7.54	pp
実験3（2026年）	自由民主党	2選択肢条件：政党名重要度（選択肢数調整済み）	41.38	35.75	49.24	pp
実験3（2026年）	自由民主党	2選択肢条件：経済重要度（選択肢数調整済み）	11.40	8.44	15.08	pp
実験3（2026年）	自由民主党	2選択肢条件：政党手がかり相対比重	78.40	72.05	84.06	%
実験3（2026年）	自由民主党	3選択肢条件：政党名重要度	20.57	17.85	23.03	pp
実験3（2026年）	自由民主党	3選択肢条件：経済重要度	4.48	3.55	6.23	pp
実験3（2026年）	自由民主党	3選択肢条件：政党名重要度（選択肢数調整済み）	61.71	53.54	69.10	pp
実験3（2026年）	自由民主党	3選択肢条件：経済重要度（選択肢数調整済み）	13.44	10.64	18.68	pp
実験3（2026年）	自由民主党	3選択肢条件：政党手がかり相対比重	82.12	75.41	85.88	%
実験3（2026年）	自由民主党	4選択肢条件：政党名重要度	19.66	17.72	21.53	pp
実験3（2026年）	自由民主党	4選択肢条件：経済重要度	2.91	2.30	4.26	pp
実験3（2026年）	自由民主党	4選択肢条件：政党名重要度（選択肢数調整済み）	78.63	70.87	86.13	pp
実験3（2026年）	自由民主党	4選択肢条件：経済重要度（選択肢数調整済み）	11.63	9.20	17.05	pp
実験3（2026年）	自由民主党	4選択肢条件：政党手がかり相対比重	87.11	81.82	89.73	%
実験3（2026年）	自由民主党	5選択肢条件：政党名重要度	17.57	16.08	19.23	pp
実験3（2026年）	自由民主党	5選択肢条件：経済重要度	2.33	1.78	3.22	pp
実験3（2026年）	自由民主党	5選択肢条件：政党名重要度（選択肢数調整済み）	87.87	80.41	96.13	pp
実験3（2026年）	自由民主党	5選択肢条件：経済重要度（選択肢数調整済み）	11.64	8.92	16.08	pp
実験3（2026年）	自由民主党	5選択肢条件：政党手がかり相対比重	88.30	84.32	90.95	%
実験3（2026年）	国民民主党	2選択肢条件：政党名重要度	18.98	14.97	26.31	pp
実験3（2026年）	国民民主党	2選択肢条件：経済重要度	4.32	3.47	9.09	pp
実験3（2026年）	国民民主党	2選択肢条件：政党名重要度（選択肢数調整済み）	37.96	29.93	52.62	pp
実験3（2026年）	国民民主党	2選択肢条件：経済重要度（選択肢数調整済み）	8.64	6.93	18.17	pp
実験3（2026年）	国民民主党	2選択肢条件：政党手がかり相対比重	81.46	67.84	86.08	%
実験3（2026年）	国民民主党	3選択肢条件：政党名重要度	20.20	16.30	24.53	pp
実験3（2026年）	国民民主党	3選択肢条件：経済重要度	4.36	3.16	7.22	pp
実験3（2026年）	国民民主党	3選択肢条件：政党名重要度（選択肢数調整済み）	60.59	48.89	73.59	pp
実験3（2026年）	国民民主党	3選択肢条件：経済重要度（選択肢数調整済み）	13.09	9.49	21.67	pp
実験3（2026年）	国民民主党	3選択肢条件：政党手がかり相対比重	82.23	71.68	87.02	%
実験3（2026年）	国民民主党	4選択肢条件：政党名重要度	18.43	16.01	22.51	pp
実験3（2026年）	国民民主党	4選択肢条件：経済重要度	3.81	2.92	6.42	pp
実験3（2026年）	国民民主党	4選択肢条件：政党名重要度（選択肢数調整済み）	73.73	64.04	90.02	pp
実験3（2026年）	国民民主党	4選択肢条件：経済重要度（選択肢数調整済み）	15.25	11.69	25.66	pp
実験3（2026年）	国民民主党	4選択肢条件：政党手がかり相対比重	82.86	73.39	86.89	%
実験3（2026年）	国民民主党	5選択肢条件：政党名重要度	15.75	13.01	19.17	pp
実験3（2026年）	国民民主党	5選択肢条件：経済重要度	3.05	2.20	4.78	pp
実験3（2026年）	国民民主党	5選択肢条件：政党名重要度（選択肢数調整済み）	78.73	65.05	95.85	pp
実験3（2026年）	国民民主党	5選択肢条件：経済重要度（選択肢数調整済み）	15.27	11.01	23.88	pp
実験3（2026年）	国民民主党	5選択肢条件：政党手がかり相対比重	83.75	75.55	88.48	%

補図H3：対象となる支持政党別の一致効果

一致効果 <- study3_all_party_match_results$coefficients %>%
  dplyr::filter(status == "estimated", !is.na(estimate)) %>%
  dplyr::mutate(
    条件 = 条件日本語(party_n, "study3"),
    数値ラベル = sprintf("%.1f", estimate_pp)
  )

補図H3 <- ggplot2::ggplot(一致効果, ggplot2::aes(x = party_n, y = estimate_pp, group = 1)) +
  ggplot2::geom_hline(yintercept = 0, linewidth = 0.4) +
  ggplot2::geom_line(linewidth = 0.65) +
  ggplot2::geom_errorbar(ggplot2::aes(ymin = conf.low_pp, ymax = conf.high_pp), width = 0.08, linewidth = 0.45) +
  ggplot2::geom_label(ggplot2::aes(label = 数値ラベル), size = 3.0, label.size = 0, fill = "white") +
  ggplot2::facet_wrap(~ support_party_valid) +
  ggplot2::scale_x_continuous(breaks = 2:5, labels = paste0(2:5, "選択肢")) +
  ggplot2::labs(x = "選択肢数", y = "一致効果（pp）") +
  ggplot2::theme_bw(base_size = 10) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
補図H3

表H3 <- 一致効果 %>%
  dplyr::transmute(
    支持政党 = support_party_valid,
    条件,
    回答者数 = n_ids,
    `一致効果（pp）` = round(estimate_pp, 2),
    `95%CI下限` = round(conf.low_pp, 2),
    `95%CI上限` = round(conf.high_pp, 2),
    p値 = signif(p.value, 3)
  )
knitr::kable(表日本語(表H3), format = "html", row.names = FALSE)

支持政党	条件	回答者数	一致効果（pp）	95%CI下限	95%CI上限	p値
自由民主党	2選択肢条件	163	34.77	28.06	41.49	0.00000000000000000048599999999999995625374338281687869
自由民主党	3選択肢条件	219	42.74	36.61	48.87	0.00000000000000000000000000000037699999999999995606639
自由民主党	4選択肢条件	254	47.62	41.97	53.28	0.00000000000000000000000000000000000000000476000000000
自由民主党	5選択肢条件	311	49.55	44.26	54.84	0.00000000000000000000000000000000000000000000000000197
国民民主党	2選択肢条件	49	25.26	8.98	41.53	0.00379999999999999999236721670570204878458753228187561
国民民主党	3選択肢条件	76	41.28	30.79	51.76	0.00000000004140000000000000050619231029003231014939956
国民民主党	4選択肢条件	70	48.40	37.40	59.40	0.00000000000143999999999999992264000658881428762470023
国民民主党	5選択肢条件	91	42.08	32.42	51.74	0.00000000000031500000000000002089040745945069943445560

表H4 <- study3_all_party_match_results$trends %>%
  dplyr::filter(status == "estimated") %>%
  dplyr::transmute(
    支持政党 = support_party_valid,
    `1選択肢増加あたりの変化（pp）` = round(estimate * 100, 2),
    `95%CI下限` = round(conf.low * 100, 2),
    `95%CI上限` = round(conf.high * 100, 2),
    p値 = signif(p.value, 3)
  )
knitr::kable(表日本語(表H4), format = "html", row.names = FALSE)

支持政党	1選択肢増加あたりの変化（pp）	95%CI下限	95%CI上限	p値
自由民主党	4.20	1.37	7.03	0.00372
国民民主党	3.23	-2.26	8.73	0.25000

I. 3実験横断分析

補図I1：主要仮説の線形傾向

主要仮説 <- hypothesis_test_summary %>%
  dplyr::mutate(
    実験 = dplyr::recode(study_id, study1 = "実験1（2023年）", study2 = "実験2（2026年）", study3 = "実験3（2026年）"),
    指標 = dplyr::case_when(
      stringr::str_detect(statistic, "party") ~ "政党手がかり重要度",
      stringr::str_detect(statistic, "economic") ~ "経済手がかり重要度",
      TRUE ~ statistic
    ),
    予測方向 = dplyr::recode(expected_direction, positive = "正", negative = "負")
  )

主要仮説 <- 主要仮説 %>%
  dplyr::mutate(
    傾きpp = 100 * estimate,
    下限pp = 100 * conf_low,
    上限pp = 100 * conf_high,
    表示行 = paste0(hypothesis, "：", 指標),
    数値ラベル = sprintf("%.2f", 傾きpp)
  )

補図I1 <- ggplot2::ggplot(主要仮説, ggplot2::aes(x = 傾きpp, y = stats::reorder(表示行, 傾きpp))) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.45) +
  ggplot2::geom_errorbarh(ggplot2::aes(xmin = 下限pp, xmax = 上限pp), height = 0.12, linewidth = 0.55) +
  ggplot2::geom_label(ggplot2::aes(label = 数値ラベル), size = 3.1, label.size = 0, fill = "white") +
  ggplot2::labs(x = "選択肢が1つ増えるときの重要度の変化（pp）", y = NULL) +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
補図I1

表I1 <- 主要仮説 %>%
  dplyr::transmute(
    実験,
    仮説 = hypothesis,
    指標,
    予測方向,
    傾き = round(estimate, 4),
    `95%CI下限` = round(conf_low, 4),
    `95%CI上限` = round(conf_high, 4),
    p値 = signif(p_value_two_sided, 3),
    判定 = conclusion
  )
knitr::kable(表日本語(表I1), format = "html", row.names = FALSE)

実験	仮説	指標	予測方向	傾き	95%CI下限	95%CI上限	p値	判定
実験1（2023年）	H1a（実験1）	政党手がかり重要度	正	-0.0013	-0.0057	0.0030	0.536	点推定が予測方向と一致しない
実験1（2023年）	H1b（実験1）	経済手がかり重要度	負	-0.0023	-0.0058	0.0002	0.076	点推定は予測方向だが、95%信頼区間が0を含む
実験2（2026年）	H1a（実験2）	政党手がかり重要度	正	-0.0015	-0.0062	0.0025	0.387	点推定が予測方向と一致しない
実験2（2026年）	H1b（実験2）	経済手がかり重要度	負	-0.0078	-0.0113	-0.0046	0.001	予測方向で95%信頼区間が0を含まず、統計的に支持
実験3（2026年）	H2a（実験3）	政党手がかり重要度	正	-0.0162	-0.0223	-0.0103	0.001	点推定が予測方向と一致しない
実験3（2026年）	H2b（実験3）	経済手がかり重要度	負	-0.0074	-0.0106	-0.0045	0.001	予測方向で95%信頼区間が0を含まず、統計的に支持

補図I2：選択肢数調整済み重要度の線形傾向

調整済み傾向 <- choice_set_adjusted_slope_summary %>%
  dplyr::mutate(
    実験 = dplyr::recode(study_id, study1 = "実験1（2023年）", study2 = "実験2（2026年）", study3 = "実験3（2026年）"),
    指標 = dplyr::case_when(
      stringr::str_detect(statistic, "party") ~ "政党手がかり重要度（選択肢数調整済み）",
      stringr::str_detect(statistic, "economic") ~ "経済手がかり重要度（選択肢数調整済み）",
      TRUE ~ statistic
    )
  )

調整済み傾向 <- 調整済み傾向 %>%
  dplyr::mutate(
    傾き表示 = 100 * estimate,
    下限表示 = 100 * conf_low,
    上限表示 = 100 * conf_high,
    表示行 = paste0(実験, "：", 指標),
    数値ラベル = sprintf("%.2f", 傾き表示)
  )

補図I2 <- ggplot2::ggplot(調整済み傾向, ggplot2::aes(x = 傾き表示, y = stats::reorder(表示行, 傾き表示))) +
  ggplot2::geom_vline(xintercept = 0, linewidth = 0.45) +
  ggplot2::geom_errorbarh(ggplot2::aes(xmin = 下限表示, xmax = 上限表示), height = 0.12, linewidth = 0.55) +
  ggplot2::geom_label(ggplot2::aes(label = 数値ラベル), size = 3.1, label.size = 0, fill = "white") +
  ggplot2::labs(x = "選択肢が1つ増えるときの調整済み重要度の変化（%）", y = NULL) +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank())
補図I2

表I2 <- 調整済み傾向 %>%
  dplyr::transmute(
    実験,
    指標,
    傾き = round(estimate, 4),
    `95%CI下限` = round(conf_low, 4),
    `95%CI上限` = round(conf_high, 4),
    p値 = signif(p_value_two_sided, 3)
  )
knitr::kable(表日本語(表I2), format = "html", row.names = FALSE)

実験	指標	傾き	95%CI下限	95%CI上限	p値
実験1（2023年）	政党手がかり重要度（選択肢数調整済み）	0.0463	0.0319	0.0616	0.001
実験1（2023年）	経済手がかり重要度（選択肢数調整済み）	0.0347	0.0253	0.0440	0.001
実験2（2026年）	政党手がかり重要度（選択肢数調整済み）	0.0414	0.0289	0.0528	0.001
実験2（2026年）	経済手がかり重要度（選択肢数調整済み）	0.0148	0.0064	0.0239	0.001
実験3（2026年）	政党手がかり重要度（選択肢数調整済み）	0.0552	0.0394	0.0734	0.001
実験3（2026年）	経済手がかり重要度（選択肢数調整済み）	0.0132	0.0047	0.0216	0.002

補図I3：政党手がかり相対比重の3実験比較

横断相対比重 <- cross_study_relative_weight %>%
  dplyr::mutate(
    実験 = dplyr::recode(study_id, study1 = "実験1（2023年）", study2 = "実験2（2026年）", study3 = "実験3（2026年）"),
    相対比重 = 100 * estimate,
    下限 = 100 * conf_low,
    上限 = 100 * conf_high,
    数値ラベル = sprintf("%.1f%%", 相対比重)
  )

補図I3 <- ggplot2::ggplot(横断相対比重, ggplot2::aes(x = party_n, y = 相対比重, group = 実験, linetype = 実験)) +
  ggplot2::geom_hline(yintercept = 50, linetype = "dashed", linewidth = 0.4) +
  ggplot2::geom_line(linewidth = 0.75) +
  ggplot2::geom_errorbar(ggplot2::aes(ymin = 下限, ymax = 上限), width = 0.07, linewidth = 0.45) +
  ggplot2::geom_label(ggplot2::aes(label = 数値ラベル), size = 3.0, label.size = 0, fill = "white") +
  ggplot2::scale_x_continuous(breaks = 2:5, labels = paste0(2:5, "選択肢")) +
  ggplot2::labs(x = "選択肢数", y = "政党手がかり相対比重（%）", linetype = NULL) +
  ggplot2::theme_bw(base_size = 11) +
  ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), legend.position = "top")
補図I3

表I3 <- 横断相対比重 %>%
  dplyr::transmute(
    実験,
    条件 = paste0(party_n, "選択肢条件"),
    `政党手がかり相対比重（%）` = round(相対比重, 1),
    `95%CI下限` = round(下限, 1),
    `95%CI上限` = round(上限, 1)
  )
knitr::kable(表日本語(表I3), format = "html", row.names = FALSE)

実験	条件	政党手がかり相対比重（%）	95%CI下限	95%CI上限
実験1（2023年）	2選択肢条件	53.1	44.8	59.6
実験1（2023年）	3選択肢条件	54.7	47.4	60.5
実験1（2023年）	4選択肢条件	54.3	48.5	59.5
実験1（2023年）	5選択肢条件	55.6	49.6	60.5
実験2（2026年）	2選択肢条件	48.3	39.9	55.7
実験2（2026年）	3選択肢条件	47.1	42.1	53.1
実験2（2026年）	4選択肢条件	52.8	47.5	57.7
実験2（2026年）	5選択肢条件	59.4	54.4	63.3
実験3（2026年）	2選択肢条件	73.2	68.2	77.4
実験3（2026年）	3選択肢条件	72.8	68.9	76.5
実験3（2026年）	4選択肢条件	74.6	71.0	78.2
実験3（2026年）	5選択肢条件	75.6	72.2	78.6