# --- Multi-CI helper ---
add_multi_ci <- function(df) {
df |> mutate(
lower90 = estimate - 1.645 * std.error,
higher90 = estimate + 1.645 * std.error,
lower95 = estimate - 1.96 * std.error,
higher95 = estimate + 1.96 * std.error,
lower99 = estimate - 2.58 * std.error,
higher99 = estimate + 2.58 * std.error
)
}
# --- Feature labels ---
feature_labels <- c(
"PARTY" = "Party", "BI" = "Sexual orientation", "TRANS" = "Gender identity",
"VEGAN" = "Diet", "ETHNICITY" = "Ethnicity", "FLAG" = "Nationality flag",
"SOLIDARITY" = "Int'l solidarity", "DISTANCE" = "Distance",
"RELATIONSHIP_SEEK" = "Relationship type", "CONGRUENCE" = "Gender congruence",
"EMOTION" = "Facial expression", "CULTURAL_TYPE" = "Cultural identity",
"JOB_SLIM" = "Occupation", "REJECTION_CLEAN" = "Rejection signal"
)
# --- Core multi-CI plot ---
plot_multi_ci <- function(df, h0 = 0.5, title = "", subtitle = "",
xlimits = NULL, show_labels = FALSE, show_facets = FALSE,
color_var = NULL, color_vals = NULL) {
df <- add_multi_ci(df)
# Clean feature labels
if ("feature" %in% names(df)) {
df <- df |> mutate(
feature = ifelse(feature %in% names(feature_labels), feature_labels[feature], feature),
feature = factor(feature, levels = unique(feature))
)
}
ci_caption <- "Thin = 99% CI | Medium = 95% CI | Thick = 90% CI"
if (!is.null(color_var) && color_var %in% names(df)) {
# Two-group overlay with proper legend
df$group_label <- as.character(df[[color_var]])
groups <- unique(df$group_label)
if (is.null(color_vals)) color_vals <- c(pal$left, pal$right)
names(color_vals) <- groups
df$nudge <- ifelse(df$group_label == groups[1], 0.15, -0.15)
g1 <- df |> filter(group_label == groups[1])
g2 <- df |> filter(group_label == groups[2])
p <- ggplot() +
geom_vline(xintercept = h0, color = "grey80", linewidth = 0.5) +
# Group 1 (nudged up)
geom_segment(data = g1, aes(x = lower99, xend = higher99, y = level, yend = level),
color = color_vals[1], linewidth = 1.5, alpha = .5, position = position_nudge(y = .15)) +
geom_segment(data = g1, aes(x = lower95, xend = higher95, y = level, yend = level),
color = color_vals[1], linewidth = 2.5, alpha = .7, position = position_nudge(y = .15)) +
geom_segment(data = g1, aes(x = lower90, xend = higher90, y = level, yend = level),
color = color_vals[1], linewidth = 3.5, alpha = .9, position = position_nudge(y = .15)) +
geom_point(data = g1, aes(x = estimate, y = level, color = group_label),
fill = "white", size = 2.5, pch = 21, stroke = 1.2, position = position_nudge(y = .15)) +
# Group 2 (nudged down)
geom_segment(data = g2, aes(x = lower99, xend = higher99, y = level, yend = level),
color = color_vals[2], linewidth = 1.5, alpha = .5, position = position_nudge(y = -.15)) +
geom_segment(data = g2, aes(x = lower95, xend = higher95, y = level, yend = level),
color = color_vals[2], linewidth = 2.5, alpha = .7, position = position_nudge(y = -.15)) +
geom_segment(data = g2, aes(x = lower90, xend = higher90, y = level, yend = level),
color = color_vals[2], linewidth = 3.5, alpha = .9, position = position_nudge(y = -.15)) +
geom_point(data = g2, aes(x = estimate, y = level, color = group_label),
fill = "white", size = 2.5, pch = 21, stroke = 1.2, position = position_nudge(y = -.15)) +
scale_color_manual(values = color_vals, name = NULL)
} else {
p <- ggplot(df, aes(y = level)) +
geom_vline(xintercept = h0, color = "grey80", linewidth = 0.5) +
geom_segment(aes(x = lower99, xend = higher99, y = level, yend = level),
color = pal$primary, linewidth = 1.5, alpha = .5) +
geom_segment(aes(x = lower95, xend = higher95, y = level, yend = level),
color = pal$primary, linewidth = 2.5, alpha = .7) +
geom_segment(aes(x = lower90, xend = higher90, y = level, yend = level),
color = pal$primary, linewidth = 3.5, alpha = .9) +
geom_point(aes(x = estimate, y = level), fill = "white", color = pal$primary,
size = 2.5, pch = 21, stroke = 1.2)
}
if (show_labels) {
p <- p + geom_text(data = df, aes(x = estimate, y = level,
label = sprintf("%0.2f", estimate)),
hjust = -0.3, size = 3.2, fontface = "bold", color = "grey30")
}
if (show_facets && "feature" %in% names(df)) {
p <- p + facet_grid(feature ~ ., scales = "free_y", space = "free_y")
}
p <- p +
labs(title = title, subtitle = subtitle, x = NULL, y = NULL,
caption = ci_caption) +
theme(strip.text.y = element_text(angle = 0, hjust = 0))
if (!is.null(xlimits)) p <- p + xlim(xlimits)
p
}
# --- Full attribute formula ---
full_attr_formula <- function() {
selected ~ PARTY + BI + TRANS + VEGAN + ETHNICITY + FLAG +
SOLIDARITY + DISTANCE + RELATIONSHIP_SEEK + CONGRUENCE + EMOTION + CULTURAL_TYPE
}
# --- Full attribute overview ---
plot_full_attributes <- function(d) {
conjoint <- d$conjoint
cfg <- d$cfg
mm_full <- mm(conjoint, full_attr_formula(), id = ~response_id, h0 = 0.5)
amce_full <- amce(conjoint, full_attr_formula(), id = ~response_id)
n_resp <- n_distinct(conjoint$response_id)
p_mm <- plot_multi_ci(mm_full, h0 = 0.5,
title = paste0(cfg$label, ": Marginal Means"),
subtitle = paste0("All attributes | N = ", n_resp, " respondents"),
show_facets = TRUE)
p_amce <- plot_multi_ci(amce_full, h0 = 0,
title = paste0(cfg$label, ": AMCEs"),
subtitle = paste0("All attributes | N = ", n_resp, " respondents | ref = first level of each attribute"),
show_facets = TRUE,
show_labels = TRUE)
grid.arrange(p_mm, p_amce, ncol = 2)
}
# --- H1a: Party detail with labels ---
plot_party_detail <- function(d) {
conjoint <- d$conjoint
cfg <- d$cfg
mm_party <- mm(conjoint, selected ~ PARTY, id = ~response_id, h0 = 0.5)
amce_party <- amce(conjoint, selected ~ PARTY, id = ~response_id)
n_resp <- n_distinct(conjoint$response_id)
p_mm <- plot_multi_ci(mm_party, h0 = 0.5,
title = paste0(cfg$label, ": Party Marginal Means"),
subtitle = paste0("H1a: Far-right stigmatization | N = ", n_resp),
show_labels = TRUE) +
labs(x = "MM (Pr of acceptance)")
p_amce <- plot_multi_ci(amce_party, h0 = 0,
title = paste0(cfg$label, ": Party AMCEs"),
subtitle = "Relative to reference category",
show_labels = TRUE) +
labs(x = "AMCE")
grid.arrange(p_mm, p_amce, ncol = 2)
}
# --- Geopolitical attributes: FLAG & SOLIDARITY ---
plot_geopolitical <- function(d) {
conjoint <- d$conjoint
cfg <- d$cfg
n_resp <- n_distinct(conjoint$response_id)
# FLAG
mm_flag <- mm(conjoint, selected ~ FLAG, id = ~response_id, h0 = 0.5)
amce_flag <- amce(conjoint, selected ~ FLAG, id = ~response_id)
p_mm_flag <- plot_multi_ci(mm_flag, h0 = 0.5,
title = paste0(cfg$label, ": Nationality Flag — Marginal Means"),
subtitle = paste0("N = ", n_resp, " respondents | ref: No flag"))
p_amce_flag <- plot_multi_ci(amce_flag, h0 = 0,
title = paste0(cfg$label, ": Nationality Flag — AMCEs"),
subtitle = paste0("N = ", n_resp, " respondents | ref: No flag"))
grid.arrange(p_mm_flag, p_amce_flag, ncol = 2)
# SOLIDARITY
mm_sol <- mm(conjoint, selected ~ SOLIDARITY, id = ~response_id, h0 = 0.5)
amce_sol <- amce(conjoint, selected ~ SOLIDARITY, id = ~response_id)
p_mm_sol <- plot_multi_ci(mm_sol, h0 = 0.5,
title = paste0(cfg$label, ": Trump Signal — Marginal Means"),
subtitle = paste0("N = ", n_resp, " respondents | ref: Anti-Trump"))
p_amce_sol <- plot_multi_ci(amce_sol, h0 = 0,
title = paste0(cfg$label, ": Trump Signal — AMCEs"),
subtitle = paste0("N = ", n_resp, " respondents | ref: Anti-Trump"))
grid.arrange(p_mm_sol, p_amce_sol, ncol = 2)
}
# --- Subgroup heterogeneity (generic) ---
plot_subgroup_party <- function(d, by_var, by_label, color_vals, h_label) {
conjoint <- d$conjoint
cfg <- d$cfg
by_sym <- rlang::ensym(by_var)
# Filter to valid subgroup values
sub_data <- conjoint |> filter(!is.na(!!by_sym))
groups <- unique(sub_data[[rlang::as_name(by_sym)]])
if (length(groups) < 2) return(invisible(NULL))
# Check minimum N per group
group_ns <- sub_data |> distinct(response_id, !!by_sym) |> count(!!by_sym)
if (min(group_ns$n) < 30) {
cat(paste0("Insufficient subgroup N for ", by_label,
" (min = ", min(group_ns$n), ", need 30)\n\n"))
return(invisible(NULL))
}
# Build subtitle with group Ns
ns_text <- paste(paste0(group_ns[[1]], " (N=", group_ns$n, ")"), collapse = " vs ")
# Conditional MMs
mm_sub <- cj(sub_data, selected ~ PARTY, id = ~response_id,
estimate = "mm", by = as.formula(paste0("~", rlang::as_name(by_sym))))
p_mm <- plot_multi_ci(mm_sub, h0 = 0.5,
title = paste0(cfg$label, ": ", h_label),
subtitle = ns_text,
color_var = "BY", color_vals = color_vals) +
labs(x = "Marginal Mean")
# mm_diffs
diff_sub <- mm_diffs(sub_data, selected ~ PARTY, id = ~response_id,
by = as.formula(paste0("~", rlang::as_name(by_sym))))
diff_sub <- add_multi_ci(diff_sub)
p_diff <- ggplot(diff_sub, aes(y = level)) +
geom_vline(xintercept = 0, color = "grey80", linewidth = 0.5) +
geom_segment(aes(x = lower99, xend = higher99, y = level, yend = level),
color = pal$muted, linewidth = 1.5, alpha = .5) +
geom_segment(aes(x = lower95, xend = higher95, y = level, yend = level),
color = pal$muted, linewidth = 2.5, alpha = .7) +
geom_segment(aes(x = lower90, xend = higher90, y = level, yend = level),
color = pal$muted, linewidth = 3.5, alpha = .9) +
geom_point(aes(x = estimate, y = level), fill = "white", color = pal$muted,
size = 2.5, pch = 21, stroke = 1.2) +
geom_text(aes(x = estimate, y = level, label = sprintf("%0.2f", estimate)),
hjust = -0.3, size = 3.2, fontface = "bold", color = "grey30") +
labs(title = paste0("Difference (", paste(groups, collapse = " - "), ")"),
subtitle = "0 = no heterogeneity",
x = "MM Difference", y = NULL,
caption = "Thin = 99% CI | Medium = 95% CI | Thick = 90% CI")
grid.arrange(p_mm, p_diff, ncol = 2)
}
# --- Rejection signal analysis ---
plot_rejection_analysis <- function(d) {
conjoint <- d$conjoint
cfg <- d$cfg
conjoint_nofr <- conjoint |> filter(PARTY != cfg$far_right)
# Overall rejection effect
mm_rej <- mm(conjoint_nofr, selected ~ REJECTION_CLEAN, id = ~response_id, h0 = 0.5)
n_nofr <- n_distinct(conjoint_nofr$response_id)
p_overall <- plot_multi_ci(mm_rej, h0 = 0.5,
title = paste0(cfg$label, ": H5 Rejection Signal Effect"),
subtitle = paste0("Non-far-right profiles | N = ", n_nofr),
show_labels = TRUE) +
labs(x = "Marginal Mean")
# Rejection by party
mm_rej_party <- cj(conjoint_nofr, selected ~ REJECTION_CLEAN, id = ~response_id,
estimate = "mm", by = ~PARTY)
p_party <- plot_multi_ci(mm_rej_party, h0 = 0.5,
title = "Rejection Signal by Party",
subtitle = "Does the effect vary by party?",
show_facets = TRUE,
color_var = NULL) +
labs(x = "Marginal Mean")
grid.arrange(p_overall, p_party, ncol = 2)
}
# --- Rejection subgroup (H5c, H6) ---
plot_rejection_subgroup <- function(d, by_var, by_label, color_vals, h_label) {
conjoint_nofr <- d$conjoint |> filter(PARTY != d$cfg$far_right)
by_sym <- rlang::ensym(by_var)
sub_data <- conjoint_nofr |> filter(!is.na(!!by_sym))
groups <- unique(sub_data[[rlang::as_name(by_sym)]])
if (length(groups) < 2) return(invisible(NULL))
group_ns <- sub_data |> distinct(response_id, !!by_sym) |> count(!!by_sym)
if (min(group_ns$n) < 10) {
cat(paste0("Insufficient subgroup N for ", by_label,
" (min = ", min(group_ns$n), ")\n\n"))
return(invisible(NULL))
}
ns_text <- paste(paste0(group_ns[[1]], " (N=", group_ns$n, ")"), collapse = " vs ")
mm_sub <- cj(sub_data, selected ~ REJECTION_CLEAN, id = ~response_id,
estimate = "mm", by = as.formula(paste0("~", rlang::as_name(by_sym))))
p_mm <- plot_multi_ci(mm_sub, h0 = 0.5,
title = paste0(d$cfg$label, ": ", h_label),
subtitle = ns_text,
color_var = "BY", color_vals = color_vals,
show_labels = TRUE) +
labs(x = "Marginal Mean")
diff_sub <- mm_diffs(sub_data, selected ~ REJECTION_CLEAN, id = ~response_id,
by = as.formula(paste0("~", rlang::as_name(by_sym))))
diff_sub <- add_multi_ci(diff_sub)
p_diff <- ggplot(diff_sub, aes(y = level)) +
geom_vline(xintercept = 0, color = "grey80", linewidth = 0.5) +
geom_segment(aes(x = lower99, xend = higher99, y = level, yend = level),
color = pal$muted, linewidth = 1.5, alpha = .5) +
geom_segment(aes(x = lower95, xend = higher95, y = level, yend = level),
color = pal$muted, linewidth = 2.5, alpha = .7) +
geom_segment(aes(x = lower90, xend = higher90, y = level, yend = level),
color = pal$muted, linewidth = 3.5, alpha = .9) +
geom_point(aes(x = estimate, y = level), fill = "white", color = pal$muted,
size = 2.5, pch = 21, stroke = 1.2) +
geom_text(aes(x = estimate, y = level, label = sprintf("%0.2f", estimate)),
hjust = -0.3, size = 3.2, fontface = "bold", color = "grey30") +
labs(title = paste0("Difference (", paste(groups, collapse = " - "), ")"),
subtitle = "0 = no heterogeneity",
x = "MM Difference", y = NULL,
caption = "Thin = 99% CI | Medium = 95% CI | Thick = 90% CI")
grid.arrange(p_mm, p_diff, ncol = 2)
}
# --- PAP contrasts table ---
build_pap_table <- function(d) {
conjoint <- d$conjoint
cfg <- d$cfg
conjoint_nofr <- conjoint |> filter(PARTY != cfg$far_right)
rows <- list()
# H1a: Far-right MM vs 0.5
tryCatch({
mm_p <- mm(conjoint, selected ~ PARTY, id = ~response_id, h0 = 0.5)
fr_row <- mm_p |> filter(level == cfg$far_right)
z <- (fr_row$estimate - 0.5) / fr_row$std.error
rows$h1a <- tibble(
Hypothesis = "H1a", Contrast = paste0("MM(", cfg$far_right, ") vs 0.5"),
Estimate = fr_row$estimate, SE = fr_row$std.error,
CI_lower = fr_row$lower, CI_upper = fr_row$upper,
p = 2 * pnorm(-abs(z)))
}, error = function(e) NULL)
# H3: mm_diff by party bloc for far-right
tryCatch({
sub <- conjoint |> filter(!is.na(party_bloc))
if (n_distinct(sub$party_bloc) >= 2) {
diff_bloc <- mm_diffs(sub, selected ~ PARTY, id = ~response_id, by = ~party_bloc)
fr_diff <- diff_bloc |> filter(level == cfg$far_right)
if (nrow(fr_diff) > 0) {
z <- fr_diff$estimate[1] / fr_diff$std.error[1]
rows$h3 <- tibble(
Hypothesis = "H3", Contrast = paste0("mm_diff(", cfg$far_right, "): Left vs Right (non-FR) voters"),
Estimate = fr_diff$estimate[1], SE = fr_diff$std.error[1],
CI_lower = fr_diff$lower[1], CI_upper = fr_diff$upper[1],
p = 2 * pnorm(-abs(z)))
}
}
}, error = function(e) NULL)
# H4.1: mm_diff by gender for far-right
tryCatch({
sub <- conjoint |> filter(resp_gender %in% c("Man", "Woman"))
if (n_distinct(sub$resp_gender) >= 2) {
diff_gen <- mm_diffs(sub, selected ~ PARTY, id = ~response_id, by = ~resp_gender)
fr_diff <- diff_gen |> filter(level == cfg$far_right)
if (nrow(fr_diff) > 0) {
z <- fr_diff$estimate[1] / fr_diff$std.error[1]
rows$h41 <- tibble(
Hypothesis = "H4.1", Contrast = paste0("mm_diff(", cfg$far_right, "): Man vs Woman"),
Estimate = fr_diff$estimate[1], SE = fr_diff$std.error[1],
CI_lower = fr_diff$lower[1], CI_upper = fr_diff$upper[1],
p = 2 * pnorm(-abs(z)))
}
}
}, error = function(e) NULL)
# H4.2: mm_diff by LGBTQ+ for far-right
tryCatch({
if (n_distinct(conjoint$resp_lgbtq) >= 2 && min(table(conjoint$resp_lgbtq)) >= 20) {
diff_lgbtq <- mm_diffs(conjoint, selected ~ PARTY, id = ~response_id, by = ~resp_lgbtq)
fr_diff <- diff_lgbtq |> filter(level == cfg$far_right)
if (nrow(fr_diff) > 0) {
z <- fr_diff$estimate[1] / fr_diff$std.error[1]
rows$h42 <- tibble(
Hypothesis = "H4.2", Contrast = paste0("mm_diff(", cfg$far_right, "): Hetero vs LGBTQ+"),
Estimate = fr_diff$estimate[1], SE = fr_diff$std.error[1],
CI_lower = fr_diff$lower[1], CI_upper = fr_diff$upper[1],
p = 2 * pnorm(-abs(z)))
}
}
}, error = function(e) NULL)
# H5: Rejection signal difference
tryCatch({
mm_rej <- mm(conjoint_nofr, selected ~ REJECTION_CLEAN, id = ~response_id, h0 = 0.5)
with_sig <- mm_rej |> filter(level == "With rejection signal")
without_sig <- mm_rej |> filter(level == "Without rejection signal")
if (nrow(with_sig) > 0 && nrow(without_sig) > 0) {
diff_est <- with_sig$estimate - without_sig$estimate
diff_se <- sqrt(with_sig$std.error^2 + without_sig$std.error^2)
z <- diff_est / diff_se
rows$h5 <- tibble(
Hypothesis = "H5", Contrast = "MM(with signal) - MM(without signal)",
Estimate = diff_est, SE = diff_se,
CI_lower = diff_est - 1.96 * diff_se, CI_upper = diff_est + 1.96 * diff_se,
p = 2 * pnorm(-abs(z)))
}
}, error = function(e) NULL)
# H5c: mm_diff rejection by party bloc
tryCatch({
sub <- conjoint_nofr |> filter(!is.na(party_bloc))
if (n_distinct(sub$party_bloc) >= 2) {
diff_rej_bloc <- mm_diffs(sub, selected ~ REJECTION_CLEAN, id = ~response_id, by = ~party_bloc)
sig_row <- diff_rej_bloc |> filter(level == "With rejection signal")
if (nrow(sig_row) > 0) {
z <- sig_row$estimate[1] / sig_row$std.error[1]
rows$h5c <- tibble(
Hypothesis = "H5c", Contrast = "mm_diff(rejection): Left vs Right (non-FR) voters",
Estimate = sig_row$estimate[1], SE = sig_row$std.error[1],
CI_lower = sig_row$lower[1], CI_upper = sig_row$upper[1],
p = 2 * pnorm(-abs(z)))
}
}
}, error = function(e) NULL)
# H6: mm_diff rejection by far-right support
tryCatch({
if (n_distinct(conjoint_nofr$resp_farright) >= 2 &&
min(table(conjoint_nofr$resp_farright)) >= 10) {
diff_rej_fr <- mm_diffs(conjoint_nofr, selected ~ REJECTION_CLEAN,
id = ~response_id, by = ~resp_farright)
sig_row <- diff_rej_fr |> filter(level == "With rejection signal")
if (nrow(sig_row) > 0) {
z <- sig_row$estimate[1] / sig_row$std.error[1]
rows$h6 <- tibble(
Hypothesis = "H6", Contrast = "mm_diff(rejection signal): FR supp vs not",
Estimate = sig_row$estimate[1], SE = sig_row$std.error[1],
CI_lower = sig_row$lower[1], CI_upper = sig_row$upper[1],
p = 2 * pnorm(-abs(z)))
}
}
}, error = function(e) NULL)
tbl_data <- bind_rows(rows) |>
mutate(
Estimate = round(Estimate, 3),
SE = round(SE, 3),
CI = paste0("[", round(CI_lower, 3), ", ", round(CI_upper, 3), "]"),
p = round(p, 4),
Sig = case_when(p < .01 ~ "***", p < .05 ~ "**", p < .10 ~ "*", TRUE ~ "")
) |>
select(Hypothesis, Contrast, Estimate, SE, CI, p, Sig)
sig_rows <- which(tbl_data$p < 0.05)
marg_rows <- which(tbl_data$p >= 0.05 & tbl_data$p < 0.10)
tbl <- tbl_data |>
gt() |>
tab_header(title = paste0(d$cfg$label, ": PAP Contrasts Summary"),
subtitle = paste0("N = ", nrow(d$respondents), " respondents")) |>
opt_row_striping() |>
tab_options(
table.font.size = 13,
heading.title.font.size = 16,
heading.subtitle.font.size = 13,
column_labels.font.weight = "bold",
table.border.top.color = "grey80",
table.border.bottom.color = "grey80"
) |>
cols_align(align = "center", columns = c(Estimate, SE, CI, p, Sig))
if (length(sig_rows) > 0) {
tbl <- tbl |> tab_style(style = cell_fill(color = "#dcfce7"),
locations = cells_body(rows = sig_rows))
}
if (length(marg_rows) > 0) {
tbl <- tbl |> tab_style(style = cell_fill(color = "#fef9c3"),
locations = cells_body(rows = marg_rows))
}
tbl
}
