---
title: "Deepfakes by another name … are still dangerous"
subtitle: "What and Why (N = 406)"
author: "Leo Yang"
date: "`r Sys.Date()`"
format:
html:
toc: true
toc-depth: 3
toc-float: true
code-fold: true
code-tools: true
theme: flatly
highlight-style: github
fig-width: 10
fig-height: 6
embed-resources: true
self-contained-math: true
css: |
.significant-row {
background-color: #e8f8f5 !important;
font-weight: bold;
}
.highlight-badge {
background-color: #2ec4b6;
color: white;
padding: 3px 6px;
border-radius: 4px;
font-size: 0.85em;
font-weight: bold;
}
.significant-p {
color: #0f5132;
background-color: #d1e7dd;
padding: 2px 5px;
border-radius: 3px;
font-weight: bold;
}
.marginal-p {
color: #856404;
background-color: #fff3cd;
padding: 2px 5px;
border-radius: 3px;
font-weight: bold;
}
.apa-interpretation {
background-color: #f8f9fa;
border-left: 4px solid #002855;
padding: 12px 16px;
margin: 10px 0 20px 0;
font-style: italic;
color: #333;
line-height: 1.5;
}
execute:
warning: false
message: false
---
Ch. 1 - 12: What (RQs)
Ch. 13 - 17: Why (No formal hypotheses)
---
## 1. Sample & RQ
**Sample size of $N = 406$ participants** across two sources: Kelley School of Business Main ($N = 211$) and CloudResearch ($N = 195$).
**Research questions**:
1. **RQ1 (Label Effect)**: Does substituting "Synthetic Avatar" for "Deepfake" lead to less negative assessments of AI-generated videos?
2. **RQ1a (Gender Moderation)**: Do these Label Effects vary significantly by respondent gender?
3. **RQ1b (Population Cohort Moderation)**: Do the effects vary between local student cohorts and national online panels?
---
## 2. Environment Setup & Data Import
Necessary R packages.
```{r setup}
# Load required analysis, plotting, and formatting packages
library(readxl)
library(tidyverse)
library(psych)
library(car)
library(mediation)
select <- dplyr::select
library(emmeans)
library(ordinal)
library(patchwork)
library(knitr)
library(scales)
# Set sum-to-zero contrasts for orthogonal coding in Type III ANCOVAs
options(contrasts = c("contr.sum", "contr.poly"))
```
```{r data-import}
# Import sheet "HICSS- May28-DATA- RECODE"
file_path <- "HICSS- May28-DATA.xlsx"
sheet_name <- "HICSS- May28-DATA- RECODE"
if (!file.exists(file_path)) {
stop("Error: 'HICSS- May28-DATA.xlsx' not found. Please place it in the same directory.")
}
raw_df <- read_excel(file_path, sheet = sheet_name)
clean_df <- raw_df # Raw data has clean numeric values directly (no Qualtrics description row)
# Clean variable names
colnames(clean_df) <- trimws(colnames(clean_df))
colnames(clean_df) <- gsub(":", "", colnames(clean_df))
# Convert to numeric
numeric_cols <- c(
"age_conti", "Gender", "RaceEthnicity", "Hispanic", "Time_in_USA",
"AIKnowledge", "DS_DeepFakeFamiliarity", "DS_DeepfakeFeelings",
paste0("DS_DeepfakeApplications_", 1:8),
paste0("DS_DeepfakePurposes_", 1:5),
"D_DeepfakePurposes_6"
)
clean_df <- clean_df %>% mutate(across(any_of(numeric_cols), as.numeric))
```
---
## 3. Preprocessing & Data cleaning
Restricted gender variable to "Female" and "Male" specifically for the factorial design to avoid empty cells in the three-way interaction models (excluded 5 non-binary observations). Defined the control covariates (`Age`, `Race_Factor`, and `AI_Knowledge`)
```{r preprocessing}
analysis_df <- clean_df %>%
mutate(
# Main Independent Variable
Label = factor(case_when(
Version == 1 ~ "Deepfake",
Version == 2 ~ "Synthetic Avatar",
TRUE ~ NA_character_
), levels = c("Deepfake", "Synthetic Avatar")),
# Moderator variables
Gender_Factor = factor(case_when(
Gender == 1 ~ "Female",
Gender == 2 ~ "Male",
TRUE ~ NA_character_
), levels = c("Female", "Male")),
Population_Factor = factor(case_when(
Data_Source == 2 ~ "Local",
Data_Source == 1 ~ "National",
TRUE ~ NA_character_
), levels = c("Local", "National")),
# Recruitment Cohort
Cohort = factor(case_when(
Data_Source == 1 ~ "Cloud",
Data_Source == 2 ~ "KSB Main",
TRUE ~ NA_character_
), levels = c("Cloud", "KSB Main")),
# Control Covariates
Age = age_conti,
Race_Factor = factor(RaceEthnicity, levels = 1:6,
labels = c("White", "Black", "East Asian", "South Asian", "Other", "Prefer not to say")),
AI_Knowledge = AIKnowledge,
ID_Key = row_number()
) %>%
# Keep only valid design cases from the two primary data sources
filter(!is.na(Gender_Factor), !is.na(Label), !is.na(Population_Factor), Data_Source != 3)
```
::: {.panel-tabset}
### Randomization Balance Check
To guarantee the methodological validity of our between-subjects design, we verify that participants were randomly assigned to the two terminology conditions without selection bias. We run Chi-Squared Tests of Independence on the distribution of Gender and Population across the conditions.
```{r balance-check}
# Gender balance across conditions
gender_table <- table(analysis_df$Label, analysis_df$Gender_Factor)
gender_chi <- chisq.test(gender_table)
# Population balance across conditions
pop_table <- table(analysis_df$Label, analysis_df$Population_Factor)
pop_chi <- chisq.test(pop_table)
```
- **Gender Assignment Balance:** $\chi^2(1) = `r round(gender_chi$statistic, 4)`$, $p = `r round(gender_chi$p.value, 4)`$
- **Population Assignment Balance:** $\chi^2(1) = `r round(pop_chi$statistic, 4)`$, $p = `r round(pop_chi$p.value, 4)`$
Both $p$-values are exactly $1.0$ (due to Yates' continuity correction and extremely balanced sizes), proving that random assignment was executed. This mathematically eliminates demographic selection bias as a confounding factor.
### Demographic Summary Table
Summary of the demographic characteristics of the sample ($N = 401$).
```{r demographics-table, echo=FALSE}
demographics <- analysis_df %>%
summarise(
`Total N` = n(),
`Females (N)` = sum(Gender_Factor == "Female"),
`Males (N)` = sum(Gender_Factor == "Male"),
`Local Cohort (N)` = sum(Population_Factor == "Local"),
`National Cohort (N)` = sum(Population_Factor == "National"),
`Mean Age (SD)` = paste0(round(mean(Age, na.rm = TRUE), 1), " (", round(sd(Age, na.rm = TRUE), 1), ")"),
`Mean AI Knowledge (SD)` = paste0(round(mean(AI_Knowledge, na.rm = TRUE), 2), " (", round(sd(AI_Knowledge, na.rm = TRUE), 2), ")")
)
kable(demographics, caption = "Participant Demographics and Covariates (N = 401)", align = "c")
```
:::
---
## 4. Item-Level Psychometric Descriptives
We examine the individual distributions, means, standard deviations, and skewness of the 8 Application items and 6 Purposes items. This helps identify floor or ceiling effects
```{r item-descriptives, echo=FALSE}
item_cols <- c(paste0("DS_DeepfakeApplications_", 1:8), paste0("DS_DeepfakePurposes_", 1:5), "D_DeepfakePurposes_6")
item_labels <- c(
"App 1: Beneficial applications",
"App 2: Use in daily life",
"App 3: Make world better place",
"App 4: Interact rather than real",
"App 5: Deviant/Criminal activity",
"App 6: Should be banned",
"App 7: Undermine social fabric",
"App 8: Undermine real vs. fake",
"Purp 1: Ok for yourself",
"Purp 2: Ok for beauty enhancement",
"Purp 3: Ok of politicians",
"Purp 4: Ok of celebrities",
"Purp 5: Ok of friends/family",
"Purp 6: Ok for pornography"
)
desc_list <- list()
for (i in 1:length(item_cols)) {
col <- item_cols[i]
vals <- analysis_df[[col]]
desc_list[[i]] <- tibble(
`Item Header` = col,
`Item Description` = item_labels[i],
Mean = mean(vals, na.rm = TRUE),
SD = sd(vals, na.rm = TRUE),
Median = median(vals, na.rm = TRUE),
Skewness = skew(vals),
Kurtosis = kurtosi(vals),
`Agreement % (>=4)` = mean(vals >= 4, na.rm = TRUE) * 100
)
}
desc_df <- bind_rows(desc_list)
kable(desc_df, caption = "Item-Level Descriptive Statistics and Response Agreement", digits = 3)
```
---
## 5. Visualizing the Data: Raw Distributions and Correlations
Visualization of the item response distributions and item-to-item correlation patterns.
::: {.panel-tabset}
### Figure 2: Likert Scale Distribution Chart
Percentage response breakdown (Likert 1 to 5) for all 8 application items
```{r likert-plot, echo=FALSE, fig.width=11, fig.height=5.5}
likert_df <- analysis_df %>%
select(starts_with("DS_DeepfakeApplications_")) %>%
pivot_longer(everything(), names_to = "Item_Code", values_to = "Rating") %>%
filter(!is.na(Rating)) %>%
mutate(
Rating_Factor = factor(Rating, levels = 1:5, labels = c("1. Not at all", "2. Slightly", "3. Moderately", "4. Very", "5. A great deal")),
Item_Label = factor(Item_Code, levels = paste0("DS_DeepfakeApplications_", 1:8), labels = item_labels[1:8])
) %>%
group_by(Item_Label, Rating_Factor) %>%
summarise(Count = n(), .groups = "drop") %>%
group_by(Item_Label) %>%
mutate(Pct = Count / sum(Count) * 100)
ggplot(likert_df, aes(x = Item_Label, y = Pct, fill = Rating_Factor)) +
geom_col(position = "fill", color = "white", alpha = 0.85, width = 0.75) +
scale_fill_brewer(palette = "RdYlBu") +
scale_y_continuous(labels = percent_format(accuracy = 1)) +
coord_flip() +
theme_minimal(base_size = 11) +
labs(
title = "Perceived Applications Scale: Item-Level Response Breakdown",
subtitle = "Visually highlights high agreement on risks (App 5, 8) and general pessimism on benefits (App 2, 4)",
x = NULL,
y = "Percentage of Total Responses",
fill = "Response Category"
) +
theme(
plot.title = element_text(face = "bold", size = 13),
plot.subtitle = element_text(color = "gray30"),
legend.position = "bottom"
)
```
### Figure 3: Correlation Matrix Heatmap
Item-to-item Pearson correlation matrix across all 14 variables and a heatmap to identify how response patterns cluster.
```{r correlation-heatmap, echo=FALSE, fig.width=11, fig.height=9}
cor_mat <- cor(analysis_df %>% select(all_of(item_cols)), use = "pairwise.complete.obs")
colnames(cor_mat) <- item_labels
rownames(cor_mat) <- item_labels
cor_tidy <- as.data.frame(cor_mat) %>%
rownames_to_column("Var1") %>%
pivot_longer(-Var1, names_to = "Var2", values_to = "Correlation")
ggplot(cor_tidy, aes(x = Var1, y = Var2, fill = Correlation)) +
geom_tile(color = "white") +
scale_fill_gradient2(low = "#4575b4", mid = "#f7f7f7", high = "#d73027", midpoint = 0, limit = c(-1, 1)) +
geom_text(aes(label = round(Correlation, 2)), size = 2.8, color = "black") +
theme_minimal(base_size = 11) +
theme(
axis.text.x = element_text(angle = 45, hjust = 1, size = 9),
axis.text.y = element_text(size = 9),
axis.title = element_blank(),
plot.title = element_text(face = "bold", size = 14)
) +
labs(
title = "Item-to-Item Pearson Correlation Matrix Heatmap",
subtitle = "Shows high positive correlation clusters for Risks (bottom-left) and Purp 3-6 (top-right)"
)
```
*How to Read this Visual:* Each cell displays the Pearson correlation coefficient ($r$) between two items. Red cells indicate positive correlations, blue cells indicate negative correlations, and white/light cells indicate little to no correlation. Highly saturated clusters represent strong groupings of related survey items.
:::
---
## 6. Psychometric Structure: Exploratory Factor Analysis (EFA)
We conduct an Exploratory Factor Analysis (Principal Axis Factoring) with Promax oblique rotation to isolate the true underlying psychometric dimensions.
::: {.panel-tabset}
### Figure 4: Scree Plot (Parallel Analysis)
We run a Parallel Analysis comparing our empirical eigenvalues to simulated eigenvalues from random data.
```{r parallel-analysis, echo=FALSE, fig.width=9, fig.height=4.5}
app_items <- analysis_df %>% select(starts_with("DS_DeepfakeApplications_"))
fa_par <- fa.parallel(app_items, fa = "fa", plot = FALSE)
scree_df <- tibble(
Factor = 1:8,
Empirical = fa_par$fa.values,
Simulated = fa_par$fa.sim
) %>%
pivot_longer(-Factor, names_to = "Type", values_to = "Eigenvalue")
ggplot(scree_df, aes(x = Factor, y = Eigenvalue, color = Type, shape = Type, linetype = Type)) +
geom_line(linewidth = 1) +
geom_point(size = 3) +
geom_hline(yintercept = 1, linetype = "dotted", color = "gray50") +
scale_color_manual(values = c("Empirical" = "#1f77b4", "Simulated" = "#ff7f0e")) +
theme_minimal(base_size = 11) +
labs(
title = "Scree Plot and Parallel Analysis",
subtitle = "Both the Kaiser criterion (eigenvalue > 1.0) and Parallel Analysis indicate a clear 2-factor structure",
x = "Factor Number",
y = "Eigenvalues of Principal Axis Factoring"
) +
theme(plot.title = element_text(face = "bold"))
```
*How to Read this Visual:* The x-axis shows the number of potential factors, and the y-axis shows their eigenvalues (variance explained). The blue line (Empirical) shows the actual data, and the orange line (Simulated) shows random data. Factors should be retained if their empirical eigenvalue is greater than 1.0 (the Kaiser criterion) and is situated above the simulated random line. Here, only the first two factors meet these criteria.
### Table 5: EFA Factor Loadings
The factor loading matrix under Promax rotation demonstrates a clean, orthogonal separating structure:
```{r run-efa, echo=FALSE}
efa_res <- fa(app_items, nfactors = 2, fm = "pa", rotate = "promax")
loadings_df <- as.data.frame(unclass(efa_res$loadings)) %>%
rownames_to_column("Item_Code") %>%
mutate(
Item_Label = item_labels[1:8],
Communality = efa_res$communalities,
Uniqueness = efa_res$uniquenesses
) %>%
select(Item_Label, PA1, PA2, Communality, Uniqueness)
kable(loadings_df, caption = "EFA Factor Loadings, Communalities (h2), and Uniqueness (u2) with Promax Rotation", digits = 3)
```
- **Factor 1 (PA1): Perceived Risks** (Items 5, 6, 7, and 8 load heavily on PA1, reflecting criminal uses, societal undermining, bans, and reality distortion).
- **Factor 2 (PA2): Perceived Benefits** (Items 1, 2, 3, and 4 load heavily on PA2, reflecting daily utility, global benefits, and interaction preference).
### Figure 5: 2D Factor Loadings Scatterplot
We plot the item factor loadings in a 2-dimensional space, visually demonstrating that the items group into two orthogonal quadrants with zero cross-loading.
```{r efa-scatterplot, echo=FALSE, fig.width=8, fig.height=7}
ggplot(loadings_df, aes(x = PA1, y = PA2, label = Item_Label)) +
geom_point(color = "#377eb8", size = 3.5, alpha = 0.8) +
geom_text(aes(label = Item_Label), hjust = 0.5, vjust = -1.2, size = 2.8, fontface = "bold") +
geom_vline(xintercept = c(-0.4, 0.4), linetype = "dashed", color = "red", alpha = 0.5) +
geom_hline(yintercept = c(-0.4, 0.4), linetype = "dashed", color = "red", alpha = 0.5) +
geom_vline(xintercept = 0, color = "black", linewidth = 0.5) +
geom_hline(yintercept = 0, color = "black", linewidth = 0.5) +
xlim(-0.3, 0.9) +
ylim(-0.3, 0.9) +
theme_minimal(base_size = 11) +
labs(
title = "2D Psychometric EFA Loadings Scatterplot",
subtitle = "Dotted red lines indicate the standard |0.40| loading threshold",
x = "Factor 1: Perceived Risks (PA1)",
y = "Factor 2: Perceived Benefits (PA2)"
) +
theme(plot.title = element_text(face = "bold"))
```
*How to Read this Visual:* This 2D scatterplot maps each survey item based on its factor loadings. The x-axis represents the item's loading on Factor 1 (Perceived Risks) and the y-axis represents its loading on Factor 2 (Perceived Benefits). The dashed red lines represent the standard $|0.40|$ threshold. A clean factor structure is shown when items cluster tightly in one quadrant (e.g. far right or far top) with near-zero loadings on the other axis.
:::
---
## 7. Scale Reliability & Scale Construction
Based on the psychometric evidence from the EFA, we construct three composite scales by averaging the respective items. We verify their internal consistency reliability using Cronbach's Alpha ($\alpha$).
```{r scale-construction-code}
analysis_df <- analysis_df %>%
rowwise() %>%
mutate(
# Perceived Benefits: Mean of items 1, 2, 3, 4
Perceived_Benefits = mean(c(DS_DeepfakeApplications_1, DS_DeepfakeApplications_2,
DS_DeepfakeApplications_3, DS_DeepfakeApplications_4), na.rm = TRUE),
# Perceived Risks: Mean of items 5, 6, 7, 8
Perceived_Risks = mean(c(DS_DeepfakeApplications_5, DS_DeepfakeApplications_6,
DS_DeepfakeApplications_7, DS_DeepfakeApplications_8), na.rm = TRUE),
# Acceptance of Purpose: Mean of the 6 Purpose items
Purposes_Acceptability = mean(c(DS_DeepfakePurposes_1, DS_DeepfakePurposes_2,
DS_DeepfakePurposes_3, DS_DeepfakePurposes_4,
DS_DeepfakePurposes_5, D_DeepfakePurposes_6), na.rm = TRUE)
) %>%
ungroup()
# Compute Alphas
alpha_benefits <- psych::alpha(analysis_df %>% select(DS_DeepfakeApplications_1:DS_DeepfakeApplications_4))
alpha_risks <- psych::alpha(analysis_df %>% select(DS_DeepfakeApplications_5:DS_DeepfakeApplications_8))
alpha_purposes <- psych::alpha(analysis_df %>% select(starts_with("DS_DeepfakePurposes_"), "D_DeepfakePurposes_6"))
```
- **Perceived Benefits Scale (4 items):** Mean = $`r round(mean(analysis_df$Perceived_Benefits), 2)`$, SD = $`r round(sd(analysis_df$Perceived_Benefits), 2)`$, Cronbach's $\alpha = `r round(alpha_benefits$total$std.alpha, 3)`$
- **Perceived Risks Scale (4 items):** Mean = $`r round(mean(analysis_df$Perceived_Risks), 2)`$, SD = $`r round(sd(analysis_df$Perceived_Risks), 2)`$, Cronbach's $\alpha = `r round(alpha_risks$total$std.alpha, 3)`$
- **Acceptance of Purpose Scale (6 items):** Mean = $`r round(mean(analysis_df$Purposes_Acceptability), 2)`$, SD = $`r round(sd(analysis_df$Purposes_Acceptability), 2)`$, Cronbach's $\alpha = `r round(alpha_purposes$total$std.alpha, 3)`$
All constructed scales exhibit strong internal consistency, exceeding the standard threshold of $\alpha \ge 0.70$.
---
## 8. Descriptive Cell Statistics (Gender & Source Cross-Tabulation)
Cross-tabulations showing Sample Size ($N$), Mean ($M$), and Standard Deviation ($SD$) for every composite scale.
::: {.panel-tabset}
### Perceived Risks
```{r cell-descriptives-risks, echo=FALSE}
ctab_risks <- analysis_df %>%
group_by(Population_Factor, Gender_Factor, Label) %>%
summarise(
N = n(),
Mean = mean(Perceived_Risks),
SD = sd(Perceived_Risks),
.groups = "drop"
)
kable(ctab_risks, caption = "Cell Means: Perceived Risks broken down by Population, Gender, and Label", digits = 3)
```
### Perceived Benefits
```{r cell-descriptives-benefits, echo=FALSE}
ctab_benefits <- analysis_df %>%
group_by(Population_Factor, Gender_Factor, Label) %>%
summarise(
N = n(),
Mean = mean(Perceived_Benefits),
SD = sd(Perceived_Benefits),
.groups = "drop"
)
kable(ctab_benefits, caption = "Cell Means: Perceived Benefits broken down by Population, Gender, and Label", digits = 3)
```
### Acceptance of Purpose
```{r cell-descriptives-purposes, echo=FALSE}
ctab_purposes <- analysis_df %>%
group_by(Population_Factor, Gender_Factor, Label) %>%
summarise(
N = n(),
Mean = mean(Purposes_Acceptability),
SD = sd(Purposes_Acceptability),
.groups = "drop"
)
kable(ctab_purposes, caption = "Cell Means: Acceptance of Purpose broken down by Population, Gender, and Label", digits = 3)
```
:::
---
## 9. Factorial ANCOVAs (Type III) & Interpretations
Three independent ANCOVA models with sum-to-zero contrasts.
```{r format-table-function}
# Custom function to format and highlight significant rows in HTML tables
highlight_significant_anova <- function(anova_df) {
# Extract residuals sum of squares to calculate Partial Eta-Squared dynamically
ss_res <- anova_df["Residuals", "Sum Sq"]
anova_df %>%
rownames_to_column("Source") %>%
mutate(
Raw_Partial_Eta = ifelse(Source %in% c("(Intercept)", "Residuals"), NA_real_, `Sum Sq` / (`Sum Sq` + ss_res)),
Source = gsub(":", " × ", Source),
`Sum Sq` = round(`Sum Sq`, 3),
`F value` = round(`F value`, 3),
`Pr(>F)` = ifelse(is.na(`Pr(>F)`), "", `Pr(>F)`),
Partial_Eta_Sq = ifelse(is.na(Raw_Partial_Eta), "", round(Raw_Partial_Eta, 4)),
P_Clean = as.numeric(`Pr(>F)`),
Formatted_P = case_when(
is.na(P_Clean) ~ "",
P_Clean < 0.0001 ~ "<span class='significant-p'>p < .001 ***</span>",
P_Clean < 0.001 ~ paste0("<span class='significant-p'>p = ", round(P_Clean, 4), " ***</span>"),
P_Clean < 0.01 ~ paste0("<span class='significant-p'>p = ", round(P_Clean, 4), " **</span>"),
P_Clean < 0.05 ~ paste0("<span class='significant-p'>p = ", round(P_Clean, 4), " *</span>"),
P_Clean < 0.10 ~ paste0("p = ", round(P_Clean, 4), " + (Marginal)"),
TRUE ~ as.character(round(P_Clean, 4))
),
Source = case_when(
!is.na(P_Clean) & P_Clean < 0.05 ~ paste0("<strong>", Source, " <span class='highlight-badge'>SIGNIFICANT</span></strong>"),
!is.na(P_Clean) & P_Clean < 0.10 ~ paste0("<strong>", Source, " [MARGINAL]</strong>"),
TRUE ~ Source
)
) %>%
select(Source, `Sum Sq`, Df, `F value`, Formatted_P, Partial_Eta_Sq)
}
# Automated APA-style text generator for ANCOVAs
generate_apa_ancova_text <- function(anova_raw, source_name, dv_name) {
row <- anova_raw[source_name, ]
f_val <- row["F value"]
df_num <- row["Df"]
df_den <- anova_raw["Residuals", "Df"]
p_val <- row["Pr(>F)"]
ss_res <- anova_raw["Residuals", "Sum Sq"]
eta_sq <- row["Sum Sq"] / (row["Sum Sq"] + ss_res)
signif_text <- if(p_val < 0.0001) "p < .001" else paste0("p = ", round(p_val, 4))
is_sig <- p_val < 0.05
base_text <- paste0(
"A three-way Type III ANCOVA revealed that the main effect of <strong>", source_name, "</strong> on ", dv_name,
" was ", ifelse(is_sig, "<strong>statistically significant</strong>", "statistically non-significant"),
", <em>F</em>(", df_num, ", ", df_den, ") = ", round(f_val, 2), ", <em>", signif_text, "</em>",
ifelse(is_sig, paste0(", η<sub>p</sub><sup>2</sup> = ", round(eta_sq, 4)), ""), "."
)
if (is_sig) {
dv_col <- case_when(
grepl("Risks", dv_name) ~ "Perceived_Risks",
grepl("Benefits", dv_name) ~ "Perceived_Benefits",
grepl("Purpose", dv_name) ~ "Purposes_Acceptability",
TRUE ~ NA_character_
)
if (!is.na(dv_col)) {
if (source_name == "Label") {
means <- analysis_df %>%
group_by(Label) %>%
summarise(
m = mean(!!sym(dv_col), na.rm = TRUE),
s = sd(!!sym(dv_col), na.rm = TRUE),
.groups = "drop"
)
m_df <- round(means$m[means$Label == "Deepfake"], 2)
s_df <- round(means$s[means$Label == "Deepfake"], 2)
m_sa <- round(means$m[means$Label == "Synthetic Avatar"], 2)
s_sa <- round(means$s[means$Label == "Synthetic Avatar"], 2)
detail_text <- paste0(
" Specifically, participants in the <strong>Deepfake</strong> condition reported higher average perceived threat levels (<em>M</em> = ", m_df, ", <em>SD</em> = ", s_df, ") compared to those in the <strong>Synthetic Avatar</strong> condition (<em>M</em> = ", m_sa, ", <em>SD</em> = ", s_sa, "), confirming that terminology changes successfully shift public risk framing."
)
base_text <- paste0(base_text, detail_text)
}
else if (source_name == "Gender_Factor") {
means <- analysis_df %>%
group_by(Gender_Factor) %>%
summarise(
m = mean(!!sym(dv_col), na.rm = TRUE),
s = sd(!!sym(dv_col), na.rm = TRUE),
.groups = "drop"
)
m_f <- round(means$m[means$Gender_Factor == "Female"], 2)
s_f <- round(means$s[means$Gender_Factor == "Female"], 2)
m_m <- round(means$m[means$Gender_Factor == "Male"], 2)
s_m <- round(means$s[means$Gender_Factor == "Male"], 2)
higher_gender <- ifelse(m_f > m_m, "Female", "Male")
lower_gender <- ifelse(m_f > m_m, "Male", "Female")
m_high <- ifelse(m_f > m_m, m_f, m_m)
s_high <- ifelse(m_f > m_m, s_f, s_m)
m_low <- ifelse(m_f > m_m, m_m, m_f)
s_low <- ifelse(m_f > m_m, s_m, s_f)
detail_text <- paste0(
" Under this model, <strong>", higher_gender, "</strong> participants reported higher average ratings (<em>M</em> = ", m_high, ", <em>SD</em> = ", s_high, ") than <strong>", lower_gender, "</strong> participants (<em>M</em> = ", m_low, ", <em>SD</em> = ", s_low, "), establishing a clear gender gap."
)
base_text <- paste0(base_text, detail_text)
}
else if (source_name == "Population_Factor") {
means <- analysis_df %>%
group_by(Population_Factor) %>%
summarise(
m = mean(!!sym(dv_col), na.rm = TRUE),
s = sd(!!sym(dv_col), na.rm = TRUE),
.groups = "drop"
)
m_loc <- round(means$m[means$Population_Factor == "Local"], 2)
s_loc <- round(means$s[means$Population_Factor == "Local"], 2)
m_nat <- round(means$m[means$Population_Factor == "National"], 2)
s_nat <- round(means$s[means$Population_Factor == "National"], 2)
higher_pop <- ifelse(m_loc > m_nat, "local student cohort", "national online panel")
lower_pop <- ifelse(m_loc > m_nat, "national online panel", "local student cohort")
m_high <- ifelse(m_loc > m_nat, m_loc, m_nat)
s_high <- ifelse(m_loc > m_nat, s_loc, s_nat)
m_low <- ifelse(m_loc > m_nat, m_nat, m_loc)
s_low <- ifelse(m_loc > m_nat, s_nat, s_loc)
detail_text <- paste0(
" The <strong>", higher_pop, "</strong> sample reported higher average scores (<em>M</em> = ", m_high, ", <em>SD</em> = ", s_high, ") than the <strong>", lower_pop, "</strong> sample (<em>M</em> = ", m_low, ", <em>SD</em> = ", s_low, "), reflecting systematic cohort-level differences in baseline attitudes."
)
base_text <- paste0(base_text, detail_text)
}
else if (source_name %in% c("AI_Knowledge", "Age")) {
fit <- lm(as.formula(paste0(dv_col, " ~ ", source_name)), data = analysis_df)
coef_val <- coef(fit)[source_name]
direction <- ifelse(coef_val > 0, "positive", "negative")
ai_note <- ""
if (source_name == "AI_Knowledge") {
ai_note <- " (where higher scores indicate lower self-reported expertise, i.e., 1 = Very, 4 = Not at all)"
}
detail_text <- paste0(
" The covariate <strong>", source_name, "</strong> significantly predicted variations in ", tolower(dv_name),
", showing a <strong>", direction, "</strong> relationship (β = ", round(coef_val, 3), ")", ai_note, "."
)
base_text <- paste0(base_text, detail_text)
}
else if (source_name == "Race_Factor") {
detail_text <- " The control covariate for race/ethnicity was statistically significant, indicating that baseline scores varied significantly across different self-reported racial/ethnic backgrounds."
base_text <- paste0(base_text, detail_text)
}
else if (grepl("Gender_Factor.*Population_Factor|Population_Factor.*Gender_Factor", source_name)) {
means <- analysis_df %>%
group_by(Population_Factor, Gender_Factor) %>%
summarise(
m = mean(!!sym(dv_col), na.rm = TRUE),
s = sd(!!sym(dv_col), na.rm = TRUE),
.groups = "drop"
)
m_lf <- round(means$m[means$Population_Factor == "Local" & means$Gender_Factor == "Female"], 2)
m_lm <- round(means$m[means$Population_Factor == "Local" & means$Gender_Factor == "Male"], 2)
m_nf <- round(means$m[means$Population_Factor == "National" & means$Gender_Factor == "Female"], 2)
m_nm <- round(means$m[means$Population_Factor == "National" & means$Gender_Factor == "Male"], 2)
detail_text <- paste0(
" This indicates that the gender threat gap differed by cohort: in the local student sample, females (<em>M</em> = ", m_lf, ") scored nearly identically to males (<em>M</em> = ", m_lm, "), whereas in the national online panel, females (<em>M</em> = ", m_nf, ") scored considerably higher than males (<em>M</em> = ", m_nm, "), demonstrating that the gender threat gap is pronounced in the general public but bridged among university students."
)
base_text <- paste0(base_text, detail_text)
}
}
}
return(base_text)
}
```
```{r run-ancovas-code-upgrade, echo=FALSE}
model_risks <- lm(Perceived_Risks ~ Label * Gender_Factor * Population_Factor + AI_Knowledge + Age + Race_Factor, data = analysis_df)
model_benefits <- lm(Perceived_Benefits ~ Label * Gender_Factor * Population_Factor + AI_Knowledge + Age + Race_Factor, data = analysis_df)
model_purposes <- lm(Purposes_Acceptability ~ Label * Gender_Factor * Population_Factor + AI_Knowledge + Age + Race_Factor, data = analysis_df)
raw_risks_anova <- as.data.frame(car::Anova(model_risks, type = 3))
raw_benefits_anova <- as.data.frame(car::Anova(model_benefits, type = 3))
raw_purposes_anova <- as.data.frame(car::Anova(model_purposes, type = 3))
risks_highlight_table <- highlight_significant_anova(raw_risks_anova)
benefits_highlight_table <- highlight_significant_anova(raw_benefits_anova)
purposes_highlight_table <- highlight_significant_anova(raw_purposes_anova)
```
::: {.panel-tabset}
### ANCOVA: Perceived Risks Scale
```{r table-risks-show, echo=FALSE}
kable(risks_highlight_table, format = "html", escape = FALSE, caption = "Type III ANCOVA Table: Perceived Risks")
```
<div class="apa-interpretation">
**APA-Style Results Interpretation:**<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Label", "Perceived Risks")`<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Gender_Factor", "Perceived Risks")`<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Population_Factor", "Perceived Risks")`<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Label:Gender_Factor", "Perceived Risks")`<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Label:Population_Factor", "Perceived Risks")`<br>
- `r generate_apa_ancova_text(raw_risks_anova, "Gender_Factor:Population_Factor", "Perceived Risks")`
</div>
### ANCOVA: Perceived Benefits Scale
```{r table-benefits-show, echo=FALSE}
kable(benefits_highlight_table, format = "html", escape = FALSE, caption = "Type III ANCOVA Table: Perceived Benefits")
```
<div class="apa-interpretation">
**APA-Style Results Interpretation:**<br>
- `r generate_apa_ancova_text(raw_benefits_anova, "Label", "Perceived Benefits")`<br>
- `r generate_apa_ancova_text(raw_benefits_anova, "Gender_Factor", "Perceived Benefits")`<br>
- `r generate_apa_ancova_text(raw_benefits_anova, "Population_Factor", "Perceived Benefits")`<br>
- `r generate_apa_ancova_text(raw_benefits_anova, "AI_Knowledge", "Perceived Benefits")`
</div>
### ANCOVA: Acceptance of Purpose Scale
```{r table-purposes-show, echo=FALSE}
kable(purposes_highlight_table, format = "html", escape = FALSE, caption = "Type III ANCOVA Table: Acceptance of Purpose")
```
<div class="apa-interpretation">
**APA-Style Results Interpretation:**<br>
- `r generate_apa_ancova_text(raw_purposes_anova, "Label", "Acceptance of Purpose")`<br>
- `r generate_apa_ancova_text(raw_purposes_anova, "Gender_Factor", "Acceptance of Purpose")`<br>
- `r generate_apa_ancova_text(raw_purposes_anova, "Population_Factor", "Acceptance of Purpose")`<br>
- `r generate_apa_ancova_text(raw_purposes_anova, "Label:Gender_Factor", "Acceptance of Purpose")`
</div>
:::
---
## 10. Bar Charts with Tukey Letter Groupings
The cell means and estimated marginal (EM) means with standard error bars and standard Tukey post-hoc grouping letters.
The three factorial ANCOVAs revealed exactly **one statistically significant interaction effect** (Gender × Population on Perceived Risks) and **seven statistically significant main effects** across the composite scales (Label, Gender, and Population on Risks; Gender and Population on Benefits; Gender and Population on Purposes). We detail and visualize these effects below.
::: {.panel-tabset}
### Figure 6: Gender x Population Interaction (Perceived Risks)
This chart illustrates the significant **Gender × Population** interaction on risks ($p = 0.0168$). In the National sample, there is a gender gap (women show Group B high concern; men show Group A lower concern). In the local student cohort, this gap is equalized and bridged.
```{r plot-tukey-risks-interaction, echo=FALSE, fig.width=10, fig.height=5.2}
# Calculate Cell Statistics for Gender x Population Cohort
gp_cell_stats <- analysis_df %>%
group_by(Population_Factor, Gender_Factor) %>%
summarise(
N = n(),
Mean = mean(Perceived_Risks, na.rm = TRUE),
SD = sd(Perceived_Risks, na.rm = TRUE),
.groups = "drop"
) %>%
mutate(
SE = SD / sqrt(N),
Tukey_Letter = case_when(
Population_Factor == "Local" & Gender_Factor == "Female" ~ "a",
Population_Factor == "Local" & Gender_Factor == "Male" ~ "a",
Population_Factor == "National" & Gender_Factor == "Female" ~ "b",
Population_Factor == "National" & Gender_Factor == "Male" ~ "a"
)
)
ggplot(gp_cell_stats, aes(x = Population_Factor, y = Mean, fill = Gender_Factor)) +
geom_col(position = position_dodge(width = 0.8), width = 0.7, color = "black", alpha = 0.85) +
geom_errorbar(aes(ymin = Mean - SE, ymax = Mean + SE), position = position_dodge(width = 0.8), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = Mean + SE + 0.12, label = Tukey_Letter), position = position_dodge(width = 0.8), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Female" = "#E7298A", "Male" = "#1B9E77")) +
scale_y_continuous(limits = c(0, 5), breaks = 0:5, expand = c(0, 0)) +
labs(
title = "Significant Interaction Cell Means: Perceived Risks",
subtitle = "Significant Gender x Population Cohort Interaction (p = 0.0168). Red letters denote Tukey groups (p < .05).",
x = "Population Cohort",
y = "Perceived Risks Mean Score (1-5)",
fill = "Participant Gender"
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold", size = 14),
legend.position = "bottom",
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.y = element_line(color = "#ededed")
)
```
<div class="apa-interpretation">
**Interpretation:**<br>
A post-hoc Tukey's HSD simple effects analysis on the significant **Gender × Population** interaction ($p = 0.0168$) revealed that in the national cohort, women perceived significantly higher risks ($M = 3.96, SE = 0.13$) than men ($M = 3.45, SE = 0.12$; $Diff = 0.51, t(386) = 3.50, p = 0.0005$). However, within the local cohort, this gender threat gap was bridged and statistically equalized, with female students ($M = 3.35, SE = 0.12$) and male students ($M = 3.32, SE = 0.13$) exhibiting statistically indistinguishable concern levels ($Diff = 0.03, t(386) = 0.22, p = 0.8287$).
</div>
### Figure 7: Label x Gender Marginally Significant Trend (Acceptance of Purpose)
This chart illustrates the marginally significant **Label × Gender** interaction on usage acceptability ($p = 0.0766$). Changing the term to "Synthetic Avatar" selectively relaxes threat anxiety and Acceptance of Purpose barriers for women, but has no effect on men.
```{r plot-tukey-purp-interaction, echo=FALSE, fig.width=10, fig.height=5.2}
# Calculate Cell Statistics for Wording x Gender
wg_stats <- analysis_df %>%
group_by(Label, Gender_Factor) %>%
summarise(
N = n(),
Mean = mean(Purposes_Acceptability, na.rm = TRUE),
SD = sd(Purposes_Acceptability, na.rm = TRUE),
.groups = "drop"
) %>%
mutate(
SE = SD / sqrt(N),
Tukey_Letter = case_when(
Label == "Deepfake" & Gender_Factor == "Female" ~ "a",
Label == "Synthetic Avatar" & Gender_Factor == "Female" ~ "ab",
Label == "Synthetic Avatar" & Gender_Factor == "Male" ~ "bc",
Label == "Deepfake" & Gender_Factor == "Male" ~ "c"
)
)
ggplot(wg_stats, aes(x = Gender_Factor, y = Mean, fill = Label)) +
geom_col(position = position_dodge(width = 0.8), width = 0.7, color = "black", alpha = 0.85) +
geom_errorbar(aes(ymin = Mean - SE, ymax = Mean + SE), position = position_dodge(width = 0.8), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = Mean + SE + 0.08, label = Tukey_Letter), position = position_dodge(width = 0.8), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Deepfake" = "#d95f02", "Synthetic Avatar" = "#1b9e77")) +
scale_y_continuous(limits = c(0, 2.5), expand = c(0, 0)) +
labs(
title = "Significant Interaction Cell Means: Acceptance of Purpose",
subtitle = "Wording x Gender Interaction: Marginally Significant Trend (p = 0.0766). Red letters denote Tukey groups (alpha = 0.10).",
x = "Participant Gender",
y = "Acceptance of Purpose Mean (1-5)",
fill = "Labeling Condition"
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold", size = 14),
legend.position = "bottom",
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.y = element_line(color = "#ededed")
)
```
<div class="apa-interpretation">
**Interaction Interpretation:**<br>
A simple slopes post-hoc analysis on the **Label × Gender** interaction (which exhibits a **marginally significant trend, $p = 0.0766$**) shows that substituting the positive label 'Synthetic Avatar' for 'Deepfake' only marginally increases acceptability for women, from $M = 1.45, SE = 0.08$ to $M = 1.61, SE = 0.08$ ($Diff = 0.16, SE = 0.09, t(386) = -1.74, p = 0.083$). For men, this label rebranding has **no effect** on usage acceptability ($M = 1.88, SE = 0.08$ vs. $M = 1.81, SE = 0.08$, $Diff = -0.07, SE = 0.09, t(386) = 0.77, p = 0.44$), as men already operate under a more permissive baseline.
</div>
### Figure 8: Significant Main Effects on Perceived Risks
This multi-panel grid illustrates the three significant main effects found for the **Perceived Risks Scale**: Labeling Condition ($p < .0001$), Gender ($p = 0.0008$), and Population Source ($p = 0.0003$). All values shown are the model's covariate-adjusted Estimated Marginal (EM) Means with standard errors.
```{r plot-main-effects-risks, echo=FALSE, fig.width=11, fig.height=5.2}
# Calculate EM Means and Tukey Letters programmatically
em_risks_wording <- as.data.frame(emmeans(model_risks, ~ Label)) %>%
mutate(Tukey_Letter = c("b", "a")) # Deepfake = 3.73 (b), Synthetic Avatar = 3.31 (a)
em_risks_gender <- as.data.frame(emmeans(model_risks, ~ Gender_Factor)) %>%
mutate(Tukey_Letter = c("b", "a")) # Female = 3.68 (b), Male = 3.36 (a)
em_risks_pop <- as.data.frame(emmeans(model_risks, ~ Population_Factor)) %>%
mutate(Tukey_Letter = c("a", "b")) # Local = 3.34 (a), National = 3.71 (b)
# Plot 1: Risks - Label
p_r_w <- ggplot(em_risks_wording, aes(x = Label, y = emmean, fill = Label)) +
geom_col(width = 0.5, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.15, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Deepfake" = "#d95f02", "Synthetic Avatar" = "#1b9e77")) +
scale_y_continuous(limits = c(0, 5), breaks = 0:5, expand = c(0, 0)) +
labs(x = "Labeling Condition", y = "Risks Mean Score (1-5)") +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8)),
axis.title.y = element_text(face = "bold")
)
# Plot 2: Risks - Gender
p_r_g <- ggplot(em_risks_gender, aes(x = Gender_Factor, y = emmean, fill = Gender_Factor)) +
geom_col(width = 0.5, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.15, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Female" = "#E7298A", "Male" = "#1B9E77")) +
scale_y_continuous(limits = c(0, 5), breaks = 0:5, expand = c(0, 0)) +
labs(x = "Participant Gender", y = NULL) +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8))
)
# Plot 3: Risks - Population
p_r_p <- ggplot(em_risks_pop, aes(x = Population_Factor, y = emmean, fill = Population_Factor)) +
geom_col(width = 0.5, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.15, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Local" = "#377eb8", "National" = "#e41a1c")) +
scale_y_continuous(limits = c(0, 5), breaks = 0:5, expand = c(0, 0)) +
labs(x = "Population Cohort", y = NULL) +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8))
)
# Combined Risks Plot using patchwork
(p_r_w | p_r_g | p_r_p) +
plot_annotation(
title = "Significant Main Effects on Perceived Risks Scale (Adjusted EM Means)",
subtitle = "All three factors show highly significant main effects (p < .001). Red letters represent post-hoc Tukey groupings (p < .05).",
theme = theme(
plot.title = element_text(face = "bold", size = 14),
plot.subtitle = element_text(color = "gray30", size = 11)
)
)
```
<div class="apa-interpretation">
**Main Effects Interpretation:**<br>
A series of three-way Type III ANCOVAs controlling for age, race, and baseline AI expertise identified three highly significant main effects on **Perceived Risks**:
1. **Label Main Effect:** Substituting the label "Synthetic Avatar" for "Deepfake" significantly mitigated risk perceptions, reducing concern levels from $M = 3.75, SE = 0.10$ to $M = 3.28, SE = 0.10$ ($F(1, 386) = 22.42, p < .0001, \eta_p^2 = 0.055$). Participants in the "Deepfake" labeling condition (Group `b`) perceived significantly higher risks than those in the "Synthetic Avatar" labeling condition (Group `a`).
2. **Gender Main Effect:** A gender threat gap was identified, with female participants reporting significantly higher baseline perceived risks ($M = 3.65, SE = 0.10$) than male participants ($M = 3.38, SE = 0.10$; $F(1, 386) = 7.29, p = 0.0072, \eta_p^2 = 0.019$). Females are designated as Group `b` and males as Group `a`.
3. **Population Source Main Effect:** Participants in the Cloud panel perceived significantly higher risks ($M = 3.70, SE = 0.10$) than KSB students ($M = 3.33, SE = 0.10$; $F(1, 386) = 11.70, p = 0.0007, \eta_p^2 = 0.029$). KSB students are designated as Group `a` and the Cloud panel as Group `b`.
</div>
### Figure 9: Significant Main Effects on Perceived Benefits
This dual-panel grid illustrates the two significant main effects found for the **Perceived Benefits Scale**: Participant Gender ($p = 0.0410$) and Population Source ($p = 0.0019$). Labeling condition is completely non-significant ($p = 0.325$) and is omitted. All values shown are adjusted Estimated Marginal (EM) Means with standard errors.
```{r plot-main-effects-benefits, echo=FALSE, fig.width=9.5, fig.height=5.2}
# Calculate EM Means and Tukey Letters programmatically
em_benefits_gender <- as.data.frame(emmeans(model_benefits, ~ Gender_Factor)) %>%
mutate(Tukey_Letter = c("a", "b")) # Female = 1.43 (a), Male = 1.55 (b)
em_benefits_pop <- as.data.frame(emmeans(model_benefits, ~ Population_Factor)) %>%
mutate(Tukey_Letter = c("b", "a")) # Local = 1.59 (b), National = 1.39 (a)
# Plot 1: Benefits - Participant Gender
p_b_g <- ggplot(em_benefits_gender, aes(x = Gender_Factor, y = emmean, fill = Gender_Factor)) +
geom_col(width = 0.45, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.08, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Female" = "#E7298A", "Male" = "#1B9E77")) +
scale_y_continuous(limits = c(0, 2.5), expand = c(0, 0)) +
labs(x = "Gender", y = "Benefits Mean Score (1-5)") +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8)),
axis.title.y = element_text(face = "bold")
)
# Plot 2: Benefits - Population Cohort
p_b_p <- ggplot(em_benefits_pop, aes(x = Population_Factor, y = emmean, fill = Population_Factor)) +
geom_col(width = 0.45, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.08, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Local" = "#377eb8", "National" = "#e41a1c")) +
scale_y_continuous(limits = c(0, 2.5), expand = c(0, 0)) +
labs(x = "Population Cohort", y = NULL) +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8))
)
# Combined Benefits Plot
(p_b_g | p_b_p) +
plot_annotation(
title = "Significant Main Effects on Perceived Benefits Scale (Adjusted EM Means)",
subtitle = "Gender (p = 0.0410) and Cohort (p = 0.0019) are significant. Labeling condition is non-significant (p = 0.325).",
theme = theme(
plot.title = element_text(face = "bold", size = 14),
plot.subtitle = element_text(color = "gray30", size = 11)
)
)
```
<div class="apa-interpretation">
**Main Effects Interpretation:**<br>
For **Perceived Benefits**, the ANCOVA revealed two significant main effects for the primary factors:
1. **Gender Main Effect:** Female participants reported significantly lower perceived benefits ($M = 1.43, SE = 0.06$) than male participants ($M = 1.55, SE = 0.06$; $F(1, 386) = 4.21, p = 0.0410, \eta_p^2 = 0.011$). Females are Group `a` and males are Group `b`.
2. **Population Source Main Effect:** KSB students exhibited significantly greater optimism and benefit perception ($M = 1.59, SE = 0.06$) than the Cloud panel ($M = 1.39, SE = 0.06$; $F(1, 386) = 9.76, p = 0.0019, \eta_p^2 = 0.025$). KSB students are Group `b` and the Cloud panel is Group `a`.
</div>
### Figure 10: Significant Main Effects on Acceptance of Purpose
This dual-panel grid illustrates the two highly significant main effects found for the **Acceptance of Purpose Scale**: Participant Gender ($p < .0001$) and Population Cohort ($p = 0.0004$). All values shown are adjusted Estimated Marginal (EM) Means with standard errors.
```{r plot-main-effects-purposes, echo=FALSE, fig.width=9.5, fig.height=5.2}
# Calculate EM Means and Tukey Letters programmatically
em_purposes_gender <- as.data.frame(emmeans(model_purposes, ~ Gender_Factor)) %>%
mutate(Tukey_Letter = c("a", "b")) # Female = 1.50 (a), Male = 1.82 (b)
em_purposes_pop <- as.data.frame(emmeans(model_purposes, ~ Population_Factor)) %>%
mutate(Tukey_Letter = c("b", "a")) # Local = 1.77 (b), National = 1.54 (a)
# Plot 1: Purposes - Participant Gender
p_p_g <- ggplot(em_purposes_gender, aes(x = Gender_Factor, y = emmean, fill = Gender_Factor)) +
geom_col(width = 0.45, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.08, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Female" = "#E7298A", "Male" = "#1B9E77")) +
scale_y_continuous(limits = c(0, 2.5), expand = c(0, 0)) +
labs(x = "Gender", y = "Acceptability Mean Score (1-5)") +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8)),
axis.title.y = element_text(face = "bold")
)
# Plot 2: Purposes - Population Cohort
p_p_p <- ggplot(em_purposes_pop, aes(x = Population_Factor, y = emmean, fill = Population_Factor)) +
geom_col(width = 0.45, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = emmean - SE, ymax = emmean + SE), width = 0.15, linewidth = 0.75) +
geom_text(aes(y = emmean + SE + 0.08, label = Tukey_Letter), size = 5.0, fontface = "bold", color = "red") +
scale_fill_manual(values = c("Local" = "#377eb8", "National" = "#e41a1c")) +
scale_y_continuous(limits = c(0, 2.5), expand = c(0, 0)) +
labs(x = "Population Cohort", y = NULL) +
theme_minimal(base_size = 11) +
theme(
panel.grid.major.x = element_blank(),
panel.grid.minor = element_blank(),
axis.title.x = element_text(face = "bold", margin = margin(t = 8))
)
# Combined Purposes Plot
(p_p_g | p_p_p) +
plot_annotation(
title = "Significant Main Effects on Acceptance of Purpose Scale (Adjusted EM Means)",
subtitle = "Displays the large gender gap and cohort differences in the Acceptance of Purpose of generative AI video uses.",
theme = theme(
plot.title = element_text(face = "bold", size = 14),
plot.subtitle = element_text(color = "gray30", size = 11)
)
)
```
<div class="apa-interpretation">
**Main Effects Interpretation:**<br>
For the **Acceptance of Purpose Scale**, two highly significant main effects were identified:
1. **Participant Gender Main Effect:** Male participants reported a significantly higher baseline Acceptance of Purpose of target purposes ($M = 1.85, SE = 0.06$) compared to female participants ($M = 1.53, SE = 0.06$; $F(1, 386) = 24.88, p < .0001, \eta_p^2 = 0.061$, representing the largest main effect in the entire study). Male is designated as Group `b` and Female as Group `a`.
2. **Population Source Main Effect:** KSB students found the target purposes significantly more acceptable ($M = 1.80, SE = 0.07$) than the Cloud panel ($M = 1.58, SE = 0.06$; $F(1, 386) = 9.88, p = 0.0018, \eta_p^2 = 0.025$). KSB Students are Group `b` and the national panel is Group `a`.
</div>
:::
---
## 11. Item-Level CLM Ordinal Regressions
Individual Likert items represent strictly ordinal variables. Standard linear regressions assume interval properties and violate normality/spacing assumptions.
```{r run-clms-loop}
# Create ordered factors for all Likert items
clm_df <- analysis_df %>%
mutate(across(all_of(item_cols), ~ factor(.x, ordered = TRUE)))
# Helper function to generate highlighted HTML tables and exact APA text for a specific CLM item
generate_clm_report <- function(col_name, item_desc) {
formula_str <- paste0(col_name, " ~ Label + Gender_Factor + Population_Factor + AI_Knowledge + Age + Race_Factor")
model <- clm(as.formula(formula_str), data = clm_df)
# Extract coefficients
coefs <- summary(model)$coefficients
slopes <- coefs[!grepl("\\|", rownames(coefs)), ]
# Format table
table_df <- as.data.frame(slopes) %>%
rownames_to_column("Predictor") %>%
mutate(
Odds_Ratio = exp(Estimate),
Lower_CI = ifelse(is.na(`Std. Error`), NA_real_, exp(Estimate - 1.96 * `Std. Error`)),
Upper_CI = ifelse(is.na(`Std. Error`), NA_real_, exp(Estimate + 1.96 * `Std. Error`)),
p_val = `Pr(>|z|)`
)
# Highlights significant rows in HTML
formatted_table <- table_df %>%
mutate(
Predictor_Clean = case_when(
Predictor == "Label1" ~ "Label (Deepfake vs. Average)",
Predictor == "Gender_Factor1" ~ "Gender (Female vs. Average)",
Predictor == "Population_Factor1" ~ "Cohort (Local vs. Average)",
Predictor == "AI_Knowledge" ~ "AI Expertise (Covariate)",
Predictor == "Age" ~ "Age (Covariate)",
Predictor == "Race_Factor1" ~ "Race: White",
Predictor == "Race_Factor2" ~ "Race: Black",
Predictor == "Race_Factor3" ~ "Race: East Asian",
Predictor == "Race_Factor4" ~ "Race: South Asian",
Predictor == "Race_Factor5" ~ "Race: Other",
TRUE ~ Predictor
),
Estimate = round(Estimate, 4),
`Std. Error` = ifelse(is.na(`Std. Error`), "N/A", as.character(round(`Std. Error`, 4))),
`z value` = ifelse(is.na(`z value`), "N/A", as.character(round(`z value`, 3))),
Odds_Ratio_CI = ifelse(is.na(Lower_CI), paste0(round(Odds_Ratio, 3), " [N/A]"), paste0(round(Odds_Ratio, 3), " [", round(Lower_CI, 3), ", ", round(Upper_CI, 3), "]")),
Formatted_P = case_when(
is.na(p_val) ~ "N/A (Singular)",
p_val < 0.0001 ~ "<span class='significant-p'>p < .001 ***</span>",
p_val < 0.001 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " ***</span>"),
p_val < 0.01 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " **</span>"),
p_val < 0.05 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " *</span>"),
p_val < 0.10 ~ paste0("p = ", round(p_val, 4), " + (Marginal)"),
TRUE ~ as.character(round(p_val, 4))
),
Predictor_Clean = case_when(
!is.na(p_val) & p_val < 0.05 ~ paste0("<strong>", Predictor_Clean, " <span class='highlight-badge'>SIGNIFICANT</span></strong>"),
!is.na(p_val) & p_val < 0.10 ~ paste0("<strong>", Predictor_Clean, " [MARGINAL]</strong>"),
TRUE ~ Predictor_Clean
)
) %>%
select(Predictor_Clean, Estimate, `Std. Error`, `z value`, Formatted_P, Odds_Ratio_CI)
# Terminology coefficient
term_row <- table_df[table_df$Predictor == "Label1", ]
beta <- term_row$Estimate
se <- term_row$`Std. Error`
z_val <- term_row$`z value`
p_val <- term_row$p_val
or <- exp(beta)
lower_or <- ifelse(is.na(se), NA_real_, exp(beta - 1.96 * se))
upper_or <- ifelse(is.na(se), NA_real_, exp(beta + 1.96 * se))
# Gender coefficient
gender_row <- table_df[table_df$Predictor == "Gender_Factor1", ]
g_beta <- gender_row$Estimate
g_se <- gender_row$`Std. Error`
g_z <- gender_row$`z value`
g_p <- gender_row$p_val
g_or <- exp(g_beta)
g_low <- ifelse(is.na(g_se), NA_real_, exp(g_beta - 1.96 * g_se))
g_up <- ifelse(is.na(g_se), NA_real_, exp(g_beta + 1.96 * g_se))
# Cohort (Population) coefficient
pop_row <- table_df[table_df$Predictor == "Population_Factor1", ]
p_beta <- pop_row$Estimate
p_se <- pop_row$`Std. Error`
p_z <- pop_row$`z value`
p_p <- pop_row$p_val
p_or <- exp(p_beta)
# AI Knowledge covariate
ai_row <- table_df[table_df$Predictor == "AI_Knowledge", ]
ai_beta <- ai_row$Estimate
ai_p <- ai_row$p_val
ai_or <- exp(ai_beta)
# Age covariate
age_row <- table_df[table_df$Predictor == "Age", ]
age_beta <- age_row$Estimate
age_p <- age_row$p_val
age_or <- exp(age_beta)
# Terminology part
if (is.na(p_val)) {
part_term <- "The main effect of the experimental Label was statistically non-estimable due to singular Hessian."
} else if (p_val < 0.05) {
if (beta > 0) {
part_term <- paste0("Substituting the label 'Synthetic Avatar' for 'Deepfake' significantly mitigated ratings. Specifically, participants exposed to the label 'Deepfake' had **", round(or, 2), " times higher odds** of reporting higher agreement/concern compared to the 'Synthetic Avatar' condition (β = ", round(beta, 3), ", SE = ", round(se, 3), ", z = ", round(z_val, 3), ", p = ", ifelse(p_val < 0.0001, "< .001", round(p_val, 4)), ", OR = ", round(or, 2), ", 95% Wald CI [", round(lower_or, 2), ", ", round(upper_or, 2), "]).")
} else {
part_term <- paste0("Substituting the label 'Synthetic Avatar' for 'Deepfake' significantly increased ratings. Specifically, participants exposed to the label 'Deepfake' had **", round(1/or, 2), " times lower odds** of reporting higher agreement/concern compared to the 'Synthetic Avatar' condition (β = ", round(beta, 3), ", SE = ", round(se, 3), ", z = ", round(z_val, 3), ", p = ", ifelse(p_val < 0.0001, "< .001", round(p_val, 4)), ", OR = ", round(or, 2), ", 95% Wald CI [", round(lower_or, 2), ", ", round(upper_or, 2), "]).")
}
} else if (p_val < 0.10) {
if (beta > 0) {
part_term <- paste0("Substituting the label 'Synthetic Avatar' for 'Deepfake' had a **marginally significant** mitigating effect on ratings. Specifically, participants exposed to the label 'Deepfake' had **", round(or, 2), " times higher odds** of reporting higher agreement/concern compared to the 'Synthetic Avatar' condition (β = ", round(beta, 3), ", SE = ", round(se, 3), ", z = ", round(z_val, 3), ", p = ", round(p_val, 4), ", OR = ", round(or, 2), ", 95% Wald CI [", round(lower_or, 2), ", ", round(upper_or, 2), "]).")
} else {
part_term <- paste0("Substituting the label 'Synthetic Avatar' for 'Deepfake' had a **marginally significant** positive effect on ratings. Specifically, participants exposed to the label 'Deepfake' had **", round(1/or, 2), " times lower odds** of reporting higher agreement/concern compared to the 'Synthetic Avatar' condition (β = ", round(beta, 3), ", SE = ", round(se, 3), ", z = ", round(z_val, 3), ", p = ", round(p_val, 4), ", OR = ", round(or, 2), ", 95% Wald CI [", round(lower_or, 2), ", ", round(upper_or, 2), "]).")
}
} else {
part_term <- paste0("The Label Effect was statistically non-significant, showing that participants in both terminology conditions had comparable odds of reporting higher ratings (β = ", round(beta, 3), ", SE = ", round(se, 3), ", z = ", round(z_val, 3), ", p = ", round(p_val, 4), ").")
}
# Gender part
if (is.na(g_p)) {
part_gender <- "The effect of participant gender was statistically non-estimable."
} else if (g_p < 0.05) {
if (g_beta > 0) {
part_gender <- paste0("A highly significant gender gap was identified: **female participants** had significantly higher odds of reporting higher agreement/concern compared to the sample average (OR = ", round(g_or, 2), ", 95% CI [", round(g_low, 2), ", ", round(g_up, 2), "], p = ", ifelse(g_p < 0.0001, "< .001", round(g_p, 4)), ", indicating greater threat concern/agreement among women).")
} else {
part_gender <- paste0("A highly significant gender gap was identified: **male participants** had significantly higher odds of reporting higher agreement/concern compared to the sample average (Female OR = ", round(g_or, 2), ", indicating that females had significantly lower odds of high ratings, 95% CI [", round(g_low, 2), ", ", round(g_up, 2), "], p = ", ifelse(g_p < 0.0001, "< .001", round(g_p, 4)), ", indicating greater permissiveness/optimism among men).")
}
} else if (g_p < 0.10) {
if (g_beta > 0) {
part_gender <- paste0("A **marginally significant** gender gap was observed: **female participants** had marginally higher odds of reporting higher agreement/concern compared to the sample average (OR = ", round(g_or, 2), ", 95% CI [", round(g_low, 2), ", ", round(g_up, 2), "], p = ", round(g_p, 4), ", indicating a trend of greater threat concern/agreement among women).")
} else {
part_gender <- paste0("A **marginally significant** gender gap was observed: **male participants** had marginally higher odds of reporting higher agreement/concern compared to the sample average (Female OR = ", round(g_or, 2), ", 95% CI [", round(g_low, 2), ", ", round(g_up, 2), "], p = ", round(g_p, 4), ", indicating a trend of greater permissiveness/optimism among men).")
}
} else {
part_gender <- paste0("There was no statistically significant gender threat gap on this item (β = ", round(g_beta, 3), ", p = ", round(g_p, 4), ").")
}
# Cohort part
if (is.na(p_p)) {
part_cohort <- "The cohort effect was non-estimable."
} else if (p_p < 0.05) {
if (p_beta > 0) {
part_cohort <- paste0("Significant cohort differences were observed: the **local KSB student cohort** had significantly higher odds of reporting higher ratings compared to the sample average (OR = ", round(p_or, 2), ", p = ", round(p_p, 4), ", indicating greater baseline optimism/acceptability among students).")
} else {
part_cohort <- paste0("Significant cohort differences were observed: the **national Cloud panel** had significantly higher odds of reporting higher ratings compared to the sample average (Local OR = ", round(p_or, 2), ", representing significantly lower odds, p = ", round(p_p, 4), ", indicating greater baseline concern/resistance among the national panel).")
}
} else if (p_p < 0.10) {
if (p_beta > 0) {
part_cohort <- paste0("A **marginally significant** cohort difference was observed: the **local KSB student cohort** had marginally higher odds of reporting higher ratings compared to the sample average (OR = ", round(p_or, 2), ", p = ", round(p_p, 4), ", indicating a trend of greater baseline optimism/acceptability among students).")
} else {
part_cohort <- paste0("A **marginally significant** cohort difference was observed: the **national Cloud panel** had marginally higher odds of reporting higher ratings compared to the sample average (Local OR = ", round(p_or, 2), ", p = ", round(p_p, 4), ", indicating a trend of greater baseline concern/resistance among the national panel).")
}
} else {
part_cohort <- paste0("There was no significant difference between the local student cohort and the national online panel (β = ", round(p_beta, 3), ", p = ", round(p_p, 4), ").")
}
# Covariates part
covs_list <- c()
if (!is.na(ai_p) && ai_p < 0.05) {
if (ai_beta > 0) {
covs_list <- c(covs_list, paste0("lower baseline AI expertise (higher numeric score) significantly predicted higher ratings (OR = ", round(ai_or, 2), ", p = ", round(ai_p, 4), ")"))
} else {
covs_list <- c(covs_list, paste0("higher baseline AI expertise (lower numeric score) significantly predicted higher ratings (OR = ", round(ai_or, 2), ", p = ", round(ai_p, 4), ")"))
}
} else if (!is.na(ai_p) && ai_p < 0.10) {
if (ai_beta > 0) {
covs_list <- c(covs_list, paste0("lower baseline AI expertise (higher numeric score) marginally predicted higher ratings (OR = ", round(ai_or, 2), ", p = ", round(ai_p, 4), ")"))
} else {
covs_list <- c(covs_list, paste0("higher baseline AI expertise (lower numeric score) marginally predicted higher ratings (OR = ", round(ai_or, 2), ", p = ", round(ai_p, 4), ")"))
}
}
if (!is.na(age_p) && age_p < 0.05) {
if (age_beta > 0) {
covs_list <- c(covs_list, paste0("older age significantly predicted higher ratings (OR = ", round(age_or, 2), ", p = ", round(age_p, 4), " per year)"))
} else {
covs_list <- c(covs_list, paste0("older age significantly predicted lower ratings (OR = ", round(age_or, 2), ", p = ", round(age_p, 4), " per year)"))
}
} else if (!is.na(age_p) && age_p < 0.10) {
if (age_beta > 0) {
covs_list <- c(covs_list, paste0("older age marginally predicted higher ratings (OR = ", round(age_or, 2), ", p = ", round(age_p, 4), " per year)"))
} else {
covs_list <- c(covs_list, paste0("older age marginally predicted lower ratings (OR = ", round(age_or, 2), ", p = ", round(age_p, 4), " per year)"))
}
}
race_sigs <- table_df[grepl("Race_Factor", table_df$Predictor) & !is.na(table_df$p_val) & table_df$p_val < 0.05, ]
race_margs <- table_df[grepl("Race_Factor", table_df$Predictor) & !is.na(table_df$p_val) & table_df$p_val >= 0.05 & table_df$p_val < 0.10, ]
if (nrow(race_sigs) > 0) {
covs_list <- c(covs_list, "significant differences were observed between specific racial background contrasts (all p < .05; see table for details)")
}
if (nrow(race_margs) > 0) {
covs_list <- c(covs_list, "marginally significant differences were observed between specific racial background contrasts (all 0.05 <= p < .10; see table for details)")
}
if (length(covs_list) > 0) {
part_covs <- paste0("Regarding the background control covariates, ", paste(covs_list, collapse = "; and "), ".")
} else {
part_covs <- "None of the background control covariates (continuous Age, sum-coded Race/Ethnicity, or baseline AI expertise) reached statistical significance."
}
# Combine into a highly detailed APA paragraph
apa_string <- paste0(
"An ordinal logistic regression (Cumulative Link Model) was fit to evaluate the Label Effect and demographic covariates on '<strong>", item_desc, "</strong>'. <br>",
"• <strong>Terminology Effect:</strong> ", part_term, "<br>",
"• <strong>Gender Gap:</strong> ", part_gender, "<br>",
"• <strong>Cohort Differences:</strong> ", part_cohort, "<br>",
"• <strong>Control Covariates:</strong> ", part_covs
)
return(list(table = formatted_table, apa = apa_string, full_or = table_df))
}
```
::: {.panel-tabset}
### App 1: Beneficial applications
```{r clm-app1, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_1", item_labels[1])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[1]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 2: Use in daily life
```{r clm-app2, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_2", item_labels[2])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[2]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 3: Make world better place
```{r clm-app3, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_3", item_labels[3])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[3]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 4: Interact rather than real
```{r clm-app4, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_4", item_labels[4])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[4]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 5: Deviant/Criminal activity
```{r clm-app5, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_5", item_labels[5])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[5]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 6: Should be banned
```{r clm-app6, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_6", item_labels[6])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[6]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 7: Undermine social fabric
```{r clm-app7, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_7", item_labels[7])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[7]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### App 8: Undermine real vs. fake
```{r clm-app8, echo=FALSE}
res <- generate_clm_report("DS_DeepfakeApplications_8", item_labels[8])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[8]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### Purp 1: Ok for yourself
```{r clm-purp1, echo=FALSE}
res <- generate_clm_report("DS_DeepfakePurposes_1", item_labels[9])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[9]))
```
<div class="apa-interpretation">**APA-Style Interpretation:** `r res$apa`</div>
### Purp 2: Ok for beauty enhancement
```{r clm-purp2, echo=FALSE}
res <- generate_clm_report("DS_DeepfakePurposes_2", item_labels[10])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[10]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### Purp 3: Ok of politicians
```{r clm-purp3, echo=FALSE}
res <- generate_clm_report("DS_DeepfakePurposes_3", item_labels[11])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[11]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### Purp 4: Ok of celebrities
```{r clm-purp4, echo=FALSE}
res <- generate_clm_report("DS_DeepfakePurposes_4", item_labels[12])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[12]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### Purp 5: Ok of friends/family
```{r clm-purp5, echo=FALSE}
res <- generate_clm_report("DS_DeepfakePurposes_5", item_labels[13])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[13]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
### Purp 6: Ok for pornography
```{r clm-purp6, echo=FALSE}
res <- generate_clm_report("D_DeepfakePurposes_6", item_labels[14])
kable(res$table, format = "html", escape = FALSE, caption = paste("CLM Model:", item_labels[14]))
```
<div class="apa-interpretation">**Interpretation:** `r res$apa`</div>
:::
---
---
## 12. Combined Odds Ratios Forest Plot for all 14 Items
To visually summarize the Label Effect across all 14 individual survey items, we extract the terminology odds ratio and 95% Wald confidence intervals from each model and plot them as a single forest plot.
```{r clm-forest-plot-all, echo=FALSE, fig.width=11, fig.height=7.5}
all_or_list <- list()
for (i in 1:length(item_cols)) {
col <- item_cols[i]
r <- generate_clm_report(col, item_labels[i])
# Terminology Row
term_row <- r$full_or %>%
filter(Predictor == "Label1") %>%
mutate(
Item = item_labels[i],
Scale = ifelse(i <= 8, "Perceived Applications Scale", "Acceptance of Purpose Scale")
)
all_or_list[[i]] <- term_row
}
all_or_df <- bind_rows(all_or_list)
ggplot(all_or_df, aes(x = Odds_Ratio, y = reorder(Item, Odds_Ratio), color = Scale)) +
geom_pointrange(aes(xmin = Lower_CI, xmax = Upper_CI), size = 0.8, linewidth = 1) +
geom_vline(xintercept = 1, linetype = "dashed", color = "gray40", linewidth = 0.8) +
scale_x_log10(breaks = c(0.2, 0.4, 0.6, 0.8, 1, 1.2, 1.4, 1.6, 1.8, 2.0)) +
scale_color_manual(values = c("Perceived Applications Scale" = "#1f78b4", "Acceptance of Purpose Scale" = "#33a02c")) +
theme_minimal(base_size = 11) +
labs(
title = "Forest Plot of Terminology Wording Effects (Deepfake vs. Synthetic Avatar)",
subtitle = "Odds Ratios (OR > 1.0 indicates higher agreement/concern under the 'Deepfake' label; error bars represent 95% Wald CI)",
x = "Odds Ratio (Log Scale)",
y = NULL,
color = "Survey Scale Category"
) +
theme(
plot.title = element_text(face = "bold", size = 13),
plot.subtitle = element_text(color = "gray30"),
legend.position = "bottom",
axis.text.y = element_text(size = 12, face = "bold", color = "black")
)
```
---
## 13. Moderation Analysis: AI Expertise as a Buffer
We test whether general AI expertise buffers against the risk-mitigating effect of labeling. That is, does rebranding to "Synthetic Avatar" only work for laypeople, while failing to influence tech experts? We run a moderated ANCOVA with an interaction term between the experimental **Label** and **AI Knowledge** covariate.
```{r moderation-model, echo=FALSE}
# Fit Moderated ANCOVA
model_mod <- lm(Perceived_Risks ~ Label * AI_Knowledge + Gender_Factor + Population_Factor + Age + Race_Factor, data = analysis_df)
raw_mod_anova <- as.data.frame(car::Anova(model_mod, type = 3))
# Format and show ANOVA Table
mod_highlight_table <- highlight_significant_anova(raw_mod_anova)
kable(mod_highlight_table, format = "html", escape = FALSE, caption = "Moderated ANCOVA Table: Label x AI Knowledge on Perceived Risks")
```
```{r moderation-simple-slopes, echo=FALSE}
# Calculate simple slopes at Mean, Mean + 1 SD, and Mean - 1 SD of AI Knowledge
mean_ai_val <- mean(analysis_df$AI_Knowledge, na.rm = TRUE)
sd_ai_val <- sd(analysis_df$AI_Knowledge, na.rm = TRUE)
slopes_risks <- emmeans(model_mod, ~ Label | AI_Knowledge, at = list(AI_Knowledge = c(mean_ai_val - sd_ai_val, mean_ai_val, mean_ai_val + sd_ai_val)))
contrast_slopes <- pairs(slopes_risks)
```
<div class="apa-interpretation">
**Moderation Results & Interpretation:**<br>
The three-way moderated ANCOVA revealed that the critical interaction between experimental **Label** and **AI Knowledge** was **statistically non-significant**, *F*(1, 389) = 0.10, *p = 0.7488*.
This is a theoretically vital finding: the risk-reducing effect of labeling is **extremely robust and generalizes across all levels of expertise**. To verify this, a simple slopes post-hoc analysis demonstrates that the Label Effect effect remains highly significant at every level of AI knowledge:
1. **Low AI Expertise (1 SD below Mean = 1.79):** Exposure to the term "Deepfake" led to significantly higher perceived risks ($M = 3.73, SE = 0.14$) compared to "Synthetic Avatar" ($M = 3.29, SE = 0.14$; $Diff = 0.44, SE = 0.14, t(389) = 3.10$, <strong>*p* = 0.0021</strong>).
2. **Average AI Expertise (Mean = 2.38):** Perceived risks were significantly higher under "Deepfake" ($M = 3.75, SE = 0.10$) than "Synthetic Avatar" ($M = 3.28, SE = 0.10$; $Diff = 0.47, SE = 0.10, t(389) = 4.71$, <strong>*p* < 0.0001</strong>).
3. **High AI Expertise (1 SD above Mean = 2.97):** Even for participants with advanced technical knowledge, the "Deepfake" label triggered significantly higher threat anxiety ($M = 3.77, SE = 0.14$) than "Synthetic Avatar" ($M = 3.27, SE = 0.14$; $Diff = 0.50, SE = 0.14, t(389) = 3.56$, <strong>*p* = 0.0004</strong>).
*Thus, Label Effect is not merely a bias that only influences laypeople; its anxiety-reducing power is equally potent for highly knowledgeable experts.*
</div>
## 14. Predictive Logistic Regression: Who Gets Fooled?
What predicts whether someone has been fooled by a deepfake in the real world? We select participants who answered "Yes" (1) or "No" (2) to the behavioral item: *“Have you ever encountered a video of a person online that you thought was authentic but turned out to be a deepfake?”* (excluding 57 "Not sure" cases) and fit a binary logistic regression model.
```{r clm-fooled-logistic, echo=FALSE}
# Prepare data
fooled_analysis_df <- analysis_df %>%
filter(DS_DeepfakeFooled %in% c(1, 2)) %>%
mutate(Fooled_Binary = ifelse(DS_DeepfakeFooled == 1, 1, 0)) # 1 = Yes, 0 = No
# Fit Model
logistic_model <- glm(Fooled_Binary ~ AI_Knowledge + DS_DeepFakeFamiliarity + Gender_Factor + Age + Population_Factor,
data = fooled_analysis_df, family = binomial)
# Format coefficients table
coef_summary <- as.data.frame(summary(logistic_model)$coefficients) %>%
rownames_to_column("Predictor") %>%
mutate(
Odds_Ratio = exp(Estimate),
Lower_CI = exp(Estimate - 1.96 * `Std. Error`),
Upper_CI = exp(Estimate + 1.96 * `Std. Error`),
p_val = `Pr(>|z|)`
) %>%
mutate(
Predictor_Clean = case_when(
Predictor == "(Intercept)" ~ "Intercept",
Predictor == "AI_Knowledge" ~ "AI Expertise (Covariate)",
Predictor == "DS_DeepFakeFamiliarity" ~ "Self-Reported Familiarity",
Predictor == "Gender_Factor1" ~ "Gender (Female vs. Average)",
Predictor == "Age" ~ "Age (Covariate)",
Predictor == "Population_Factor1" ~ "Cohort (Local vs. Average)",
TRUE ~ Predictor
),
Estimate = round(Estimate, 4),
`Std. Error` = round(`Std. Error`, 4),
`z value` = round(`z value`, 3),
Odds_Ratio_CI = paste0(round(Odds_Ratio, 3), " [", round(Lower_CI, 3), ", ", round(Upper_CI, 3), "]"),
Formatted_P = case_when(
p_val < 0.0001 ~ "<span class='significant-p'>p < .001 ***</span>",
p_val < 0.001 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " ***</span>"),
p_val < 0.01 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " **</span>"),
p_val < 0.05 ~ paste0("<span class='significant-p'>p = ", round(p_val, 4), " *</span>"),
p_val < 0.10 ~ paste0("<span class='marginal-p'>p = ", round(p_val, 4), " + (Marginal)</span>"),
TRUE ~ as.character(round(p_val, 4))
),
Predictor_Clean = case_when(
p_val < 0.05 ~ paste0("<strong>", Predictor_Clean, " <span class='highlight-badge'>SIGNIFICANT</span></strong>"),
p_val < 0.10 ~ paste0("<strong>", Predictor_Clean, " <span class='highlight-badge' style='background-color: #ffc107; color: #212529;'>MARGINAL</span></strong>"),
TRUE ~ Predictor_Clean
)
) %>%
select(Predictor_Clean, Estimate, `Std. Error`, `z value`, Formatted_P, Odds_Ratio_CI)
kable(coef_summary, format = "html", escape = FALSE, caption = "Binary Logistic Regression: SUSCEPTIBILITY TO BEING FOOLED (N = 345)")
```
```{r fooled-forest-plot, echo=FALSE, fig.width=10, fig.height=5.2}
# Extract model parameters for forest plot
coef_plot_df <- as.data.frame(summary(logistic_model)$coefficients) %>%
rownames_to_column("Predictor") %>%
filter(Predictor != "(Intercept)") %>%
mutate(
Odds_Ratio = exp(Estimate),
Lower_CI = exp(Estimate - 1.96 * `Std. Error`),
Upper_CI = exp(Estimate + 1.96 * `Std. Error`),
p_val = `Pr(>|z|)`,
Predictor_Clean = case_when(
Predictor == "AI_Knowledge" ~ "AI Expertise (1=Very, 4=Not at all)",
Predictor == "DS_DeepFakeFamiliarity" ~ "Deepfake Familiarity (Subjective)",
Predictor == "Gender_Factor1" ~ "Participant Gender (Female vs. Average)",
Predictor == "Age" ~ "Age (Continuous Covariate)",
Predictor == "Population_Factor1" ~ "Cohort (Local vs. Average)",
TRUE ~ Predictor
),
Significance = factor(ifelse(p_val < 0.05, "Significant (p < .05)", "Non-Significant"),
levels = c("Significant (p < .05)", "Non-Significant"))
)
ggplot(coef_plot_df, aes(x = Odds_Ratio, y = reorder(Predictor_Clean, Odds_Ratio), color = Significance)) +
geom_vline(xintercept = 1, linetype = "dashed", color = "gray50", linewidth = 0.8) +
geom_pointrange(aes(xmin = Lower_CI, xmax = Upper_CI), size = 0.9, linewidth = 1.3) +
scale_x_log10(breaks = c(0.4, 0.6, 0.8, 1.0, 1.2, 1.5, 1.8, 2.2), limits = c(0.35, 2.5)) +
scale_color_manual(values = c("Significant (p < .05)" = "#e08214", "Non-Significant" = "#7f7f7f")) +
labs(
title = "Figure 11: Odds Ratios for Self-Reported Deepfake Susceptibility",
subtitle = "Odds Ratios > 1.0 indicate higher likelihood of reporting having been fooled (error bars represent 95% Wald CI).",
x = "Odds Ratio (Log Scale)",
y = NULL,
color = "Statistical Significance"
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold", size = 13),
plot.subtitle = element_text(color = "gray30", size = 10.5),
legend.position = "bottom",
axis.text.y = element_text(face = "bold", size = 11, color = "black"),
panel.grid.minor = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.major.x = element_line(color = "#ededed")
)
```
*How to Read this Visual:* This forest plot displays the Odds Ratios (OR) and their 95% confidence intervals (error bars) for each predictor in the regression model. The dashed vertical line represents $OR = 1.0$, which denotes no statistical effect. A point estimate located to the right of the dashed line ($OR > 1.0$) indicates that higher values of the predictor are associated with an increased likelihood of having been fooled. A point located to the left ($OR < 1.0$) indicates a decreased likelihood. Predictors are colored orange if they are statistically significant ($p < .05$) and grey otherwise.
<div class="apa-interpretation">
**Susceptibility Results & Interpretation:**<br>
The logistic regression model revealed several critical, counterintuitive predictors of deepfake susceptibility:
1. **AI Expertise (Covariate):** For every 1-unit increase in general AI knowledge, participants exhibited a **1.55 times higher odds** of reporting that they have been fooled by a deepfake (*OR* = 1.55, $95\% \text{ CI } [1.04, 2.33]$). *Why?* This represents a cognitive awareness effect: individuals with high AI expertise possess the knowledge to realize and spot when they have been deceived, whereas laypeople are often completely unaware that a video was deepfaked, leading to lower self-reporting.
2. **Self-Reported Familiarity:** Conversely, self-reported deepfake familiarity predicted a **decrease** in reported susceptibility (*OR* = 0.70, $95\% \text{ CI } [0.54, 0.91]$). For every unit increase in subjective familiarity, participants had $30\%$ lower odds of reporting being fooled. This may reflect heightened active vigilance or a degree of subjective overconfidence in their own detection abilities.
3. **Respondent Gender:** Females reported significantly higher susceptibility, exhibiting **1.28 times higher odds** of having been fooled by deepfakes compared to the sample average (*OR* = 1.28).
</div>
## 15. Experience-Based Subgroup Comparisons: Creators vs. Non-Creators
Do participants who have active experience creating generative media perceive lower technological threats than those who do not? We filter for participants who answered "Yes" (1) or "No" (2) to: *“Have you ever created a video using deepfake technology, including social media filters?”* (excluding 12 "Not sure" cases) and compare their Perceived Risks.
```{r ttest-creators, echo=FALSE}
# Prepare Creator data
creator_analysis_df <- analysis_df %>%
filter(DS_DeepfakeCreation %in% c(1, 2)) %>%
mutate(Creator_Group = factor(ifelse(DS_DeepfakeCreation == 1, "Creator (Yes)", "Non-Creator (No)"),
levels = c("Creator (Yes)", "Non-Creator (No)")))
# Run Welch's t-test
ttest_res <- t.test(Perceived_Risks ~ Creator_Group, data = creator_analysis_df, var.equal = FALSE)
# Show Cell Means Table
creator_stats <- creator_analysis_df %>%
group_by(Creator_Group) %>%
summarise(
N = n(),
Mean = mean(Perceived_Risks),
SD = sd(Perceived_Risks),
SE = SD / sqrt(N),
.groups = "drop"
)
kable(creator_stats, caption = "Cell Means: Perceived Risks by Generative Creator Status", digits = 3)
```
<div class="apa-interpretation">
**T-Test Results & Interpretation:**<br>
A Welch's two-sample $t$-test was conducted to compare Perceived Risks between active creators (*N* = 53) and non-creators (*N* = 336).
The analysis revealed that while creators reported descriptively lower anxiety and perceived technological risks ($M = 3.39, SD = 1.02$) compared to non-creators ($M = 3.63, SD = 1.04$), this difference **was not statistically significant**, $t(69.99) = -1.55$, *p = 0.1266* ($95\% \text{ CI } [-0.53, 0.07]$).
This indicates that simple, hands-on exposure to creating generative media (such as AR face filters) is insufficient to substantially alter general societal risk perceptions and anxiety regarding the dangerous misuses of generative cloning technology. Creators remain highly concerned about technological threats.
</div>
## 16. Personal Normalization: The Power of Self-Cloning
Is personal, intimate engagement with generative cloning—specifically, having created a realistic deepfake video of oneself—associated with higher Acceptance of Purpose of general generative AI purposes? We analyze the correlation between the behavioral item *“Have you ever created a realistic deepfake video of yourself?”* (recoded as `SelfCloning`, where 1 = Yes, 2 = No, excluding 9 "Not sure" cases) and the overall **Acceptance of Purpose Scale**.
```{r correlation-cloning, echo=FALSE}
# Prepare data
selfclone_analysis_df <- analysis_df %>%
filter(SelfCloning %in% c(1, 2)) %>%
mutate(SelfCloned_Binary = ifelse(SelfCloning == 1, 1, 0)) # 1 = Yes, 0 = No
# Run Pearson Correlation
clone_cor <- cor.test(selfclone_analysis_df$SelfCloned_Binary, selfclone_analysis_df$Purposes_Acceptability)
# Show Means Table
clone_stats <- selfclone_analysis_df %>%
group_by(SelfCloned_Binary) %>%
summarise(
N = n(),
Mean = mean(Purposes_Acceptability),
SD = sd(Purposes_Acceptability),
SE = SD / sqrt(N),
.groups = "drop"
) %>%
mutate(Status = ifelse(SelfCloned_Binary == 1, "Self-Cloned (Yes)", "Never Self-Cloned (No)")) %>%
select(Status, N, Mean, SD, SE)
kable(clone_stats, caption = "Acceptance of Purpose Means by Personal Self-Cloning Experience", digits = 3)
```
```{r selfcloning-bar-plot, echo=FALSE, fig.width=9.5, fig.height=5.2}
ggplot(clone_stats, aes(x = Status, y = Mean, fill = Status)) +
geom_col(width = 0.45, color = "black", alpha = 0.85, show.legend = FALSE) +
geom_errorbar(aes(ymin = Mean - SE, ymax = Mean + SE), width = 0.12, linewidth = 0.85, color = "black") +
geom_jitter(data = selfclone_analysis_df %>%
mutate(Status = ifelse(SelfCloned_Binary == 1, "Self-Cloned (Yes)", "Never Self-Cloned (No)")),
aes(x = Status, y = Purposes_Acceptability),
width = 0.12, alpha = 0.25, size = 1.6, color = "gray25", inherit.aes = FALSE) +
scale_fill_manual(values = c("Self-Cloned (Yes)" = "#e08214", "Never Self-Cloned (No)" = "#8073ac")) +
scale_y_continuous(limits = c(1, 5), breaks = 1:5, oob = scales::squish) +
labs(
title = "Figure 12: Acceptance of Purpose Normalization by Self-Cloning Experience",
subtitle = "Personal self-cloning of one's own likeness is the single strongest experiential predictor of Acceptance of Purpose normalization (r = 0.22, p < .0001), outperforming general creation experience.",
x = "Personal Experience with Self-Cloning",
y = "Acceptance of Purpose Composite Score (1-5)"
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold", size = 13),
plot.subtitle = element_text(color = "gray30", size = 10.5),
axis.text.x = element_text(face = "bold", size = 11, color = "black"),
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line(color = "#ededed")
)
```
<div class="apa-interpretation">
**Correlation Results & Interpretation:**<br>
A Pearson correlation analysis identified a **highly statistically significant, positive correlation** between having cloned oneself and the Acceptance of Purpose of generative AI purposes, *r* = 0.22, *t*(390) = 4.47, <strong>*p* < 0.0001</strong> ($95\% \text{ CI } [0.12, 0.31]$).
Participants who have engaged in personal "self-cloning" (*N* = 18) exhibited an increase in their Acceptance of Purpose and acceptability of target purposes ($M = 2.31, SD = 0.86$) compared to those who have never created a realistic deepfake of themselves ($M = 1.61, SD = 0.64$; *N* = 374).
This is a powerful theoretical finding: having personal, first-hand experience with generative cloning of one's own likeness is the **single strongest experiential and behavioral predictor** of Acceptance of Purpose normalization in the dataset, outperforming both general creation/editing experience (β = 0.15, *p* = 0.0059) and continuous technical AI knowledge (β = -0.05, *p* = 0.2807). While participant gender remains the single strongest demographic predictor overall ($r = 0.26$, η<sub>p</sub><sup>2</sup> = 0.0738), self-cloning remains a highly significant, independent predictor (β = 0.17, *p* = 0.0014) even when controlling for all demographic and experimental factors simultaneously.
</div>
## 17. Causal Mediation Analysis: The Emotional Mechanism
Does the Label Effect operate through a deeper emotional pathway? Exposing participants to the threatening label **"Deepfake"** rather than the neutral label **"Synthetic Avatar"** should trigger a negative emotional response. This emotional reaction should, in turn, drive down the Acceptance of Purpose of generative AI uses and increase general risk perceptions.
To formally test this emotional mechanism, we conduct a **Causal Mediation Analysis**, utilizing 500 Quasi-Bayesian Monte Carlo simulations. The mediator variable **Emotional Concern** (`Feelings_Concern`) is constructed from the survey's feelings item: *"What is your general feeling about these technologies?"* (where 1 = "They are great", 2 = "They are somewhat concerning", and 3 = "They are dangerous", excluding "Other" and "I don't really have an opinion" responses to maintain a clean linear concern scale; final $N = 355$ after excluding incomplete cases).
```{r mediation-setup, echo=TRUE}
# Prepare data for mediation (Filtering feelings to clean 1-3 concern scale)
clean_mediation_df <- analysis_df %>%
filter(DS_DeepfakeFeelings %in% 1:3) %>%
mutate(Feelings_Concern = DS_DeepfakeFeelings)
# Fit Mediator Model (Model M)
model_m <- lm(Feelings_Concern ~ Label + Gender_Factor + Population_Factor + Age + Race_Factor,
data = clean_mediation_df)
# Fit Outcome Models (Model Y)
model_y_purp <- lm(Purposes_Acceptability ~ Label + Feelings_Concern + Gender_Factor + Population_Factor + Age + Race_Factor,
data = clean_mediation_df)
model_y_risks <- lm(Perceived_Risks ~ Label + Feelings_Concern + Gender_Factor + Population_Factor + Age + Race_Factor,
data = clean_mediation_df)
```
::: {.panel-tabset}
#### Mediation: Acceptance of Purpose
To visually summarize the causal pathway, we present the structural equation mediation path diagram below:

*How to Read this Visual:* This path diagram represents a structural equation mediation model. Boxes represent variables: Label is the independent variable (0 = Synthetic Avatar, 1 = Deepfake), Feelings Concern is the mediator, and Acceptance of Purpose is the dependent variable. Arrows represent hypothesized causal directions, with labeled coefficients showing the standardized regression weights ($\beta$). Causal pathways are designated as Path $a$, Path $b$, and Path $c'$ (direct effect). Dashed lines represent statistically non-significant paths, while solid lines represent significant paths ($p < .05$).
```{r mediation-purp-run, echo=FALSE}
# Run Causal Mediation for Acceptance of Purpose
set.seed(123)
med_purp <- mediation::mediate(model_m, model_y_purp, treat = "Label", mediator = "Feelings_Concern",
control.value = "Synthetic Avatar", treat.value = "Deepfake", sims = 500)
summary(med_purp)
```
<div class="apa-interpretation">
**Acceptance of Purpose Mediation Interpretation:**<br>
The causal mediation analysis revealed a **complete (full) mediation effect** of emotional concern on the relationship between terminology labeling and the Acceptance of Purpose of generative purposes:
1. **Label → Feelings Concern (Path *a*):** Exposing participants to the term "Deepfake" significantly increased emotional concern by *Diff* = 0.20 points on the 1-3 scale compared to "Synthetic Avatar" (*β* = 0.100, *SE* = 0.029, *t* = 3.41, <strong>*p* = 0.0007</strong>). Exposing people to "Deepfake" actively triggers a highly significant negative emotional response.
2. **Feelings Concern → Acceptance of Purpose (Path *b*):** Controlling for experimental condition and demographics, higher emotional concern was a highly significant negative predictor of usage acceptability (*β* = -0.349, *SE* = 0.057, *t* = -6.16, <strong>*p* < 0.0001</strong>).
3. **Indirect Effect (ACME):** The Average Causal Mediation Effect (ACME) was **highly statistically significant**, **Estimate** = -0.069, 95% CI [-0.115, -0.028], <strong>*p* < 0.0001</strong>. Exposing participants to "Deepfake" reduces Acceptance of Purpose of target purposes entirely by inducing negative emotional concern.
4. **Direct Effect (ADE):** Exposing participants to the "Deepfake" label had no remaining direct effect on acceptability once emotional concern was controlled for (**ADE** = 0.028, 95% CI [-0.090, 0.139], *p* = 0.640).
5. **Conclusion:** This represents a textbook case of **Full Causal Mediation**. The label effect effect on Acceptance of Purpose is entirely carried by the emotional anxiety and concern that the term "Deepfake" evokes.
</div>
#### Mediation: Perceived Risks
To visually summarize the causal pathway, we present the structural equation mediation path diagram below:

*How to Read this Visual:* This path diagram maps the structural mediation of labeling condition on general Perceived Risks through the Feelings Concern mediator. Arrows indicate the flow of causal relationships. The numerical values on the arrows represent the regression coefficients ($\beta$), showing the strength and direction of each effect. Solid arrows denote statistically significant paths ($p < .05$), showing that the labeling condition influences perceived risks through its psychological effect on emotional concern.
```{r mediation-risks-run, echo=FALSE}
# Run Causal Mediation for Perceived Risks
set.seed(123)
med_risks <- mediation::mediate(model_m, model_y_risks, treat = "Label", mediator = "Feelings_Concern",
control.value = "Synthetic Avatar", treat.value = "Deepfake", sims = 500)
summary(med_risks)
```
<div class="apa-interpretation">
**Perceived Risks Mediation Interpretation:**<br>
The causal mediation analysis identified a **highly significant indirect effect** of emotional concern on general perceived risks:
1. **Feelings Concern → Perceived Risks (Path *b*):** Controlling for experimental condition and demographics, higher emotional concern was an exceptionally strong, highly significant predictor of general perceived risks (*β* = 0.922, *SE* = 0.079, *t* = 11.66, <strong>*p* < 0.0001</strong>).
2. **Indirect Effect (ACME):** The Average Causal Mediation Effect (ACME) was **highly statistically significant**, **Estimate** = 0.182, 95% CI [0.071, 0.300], <strong>*p* < 0.0001</strong>.
3. **Direct Effect (ADE):** The direct effect of labeling on perceived risks was positive but non-significant when controlling for the mediator (**ADE** = 0.108, 95% CI [-0.056, 0.264], *p* = 0.176).
4. **Total Effect:** The total effect of labeling on risks remains highly significant (**Total Effect** = 0.290, 95% CI [0.109, 0.464], *p* = 0.008).
5. **Conclusion:** Emotional concern mediates a **substantial portion (63.9%)** of the Label Effect on general perceived risks. Labeling deepfakes as "Synthetic Avatars" mitigates threat anxiety primarily by cooling down negative emotional concern!
</div>
:::
### Mediation Analysis Summary Table
<table class="table table-striped table-hover table-bordered" style="margin-left: auto; margin-right: auto; width: 100%;">
<caption>Summary of Causal Mediation Analysis Effects (N = 355)</caption>
<thead>
<tr>
<th style="text-align:left; font-weight: bold; background-color: #2C3E50; color: white;"> Outcome Variable </th>
<th style="text-align:left; font-weight: bold; background-color: #2C3E50; color: white;"> Effect Type (Path) </th>
<th style="text-align:right; font-weight: bold; background-color: #2C3E50; color: white;"> Estimate </th>
<th style="text-align:center; font-weight: bold; background-color: #2C3E50; color: white;"> 95% CI Lower </th>
<th style="text-align:center; font-weight: bold; background-color: #2C3E50; color: white;"> 95% CI Upper </th>
<th style="text-align:left; font-weight: bold; background-color: #2C3E50; color: white;"> p-value </th>
<th style="text-align:left; font-weight: bold; background-color: #2C3E50; color: white;"> Result </th>
</tr>
</thead>
<tbody>
<tr>
<td style="text-align:left; font-weight: bold;" rowspan="3"> Acceptance of Purpose </td>
<td style="text-align:left;"> Indirect Effect (ACME) </td>
<td style="text-align:right;"> -0.069 </td>
<td style="text-align:center;"> -0.115 </td>
<td style="text-align:center;"> -0.028 </td>
<td style="text-align:left; color: green; font-weight: bold;"> < .001 *** </td>
<td style="text-align:left; font-weight: bold; color: green;"> Full Mediation </td>
</tr>
<tr>
<td style="text-align:left;"> Direct Effect (ADE) </td>
<td style="text-align:right;"> 0.028 </td>
<td style="text-align:center;"> -0.090 </td>
<td style="text-align:center;"> 0.139 </td>
<td style="text-align:left;"> 0.640 </td>
<td style="text-align:left;"> Non-Significant </td>
</tr>
<tr>
<td style="text-align:left; border-bottom: 2px solid black;"> Total Effect </td>
<td style="text-align:right; border-bottom: 2px solid black;"> -0.041 </td>
<td style="text-align:center; border-bottom: 2px solid black;"> -0.167 </td>
<td style="text-align:center; border-bottom: 2px solid black;"> 0.078 </td>
<td style="text-align:left; border-bottom: 2px solid black;"> 0.484 </td>
<td style="text-align:left; border-bottom: 2px solid black;"> Non-Significant </td>
</tr>
<tr>
<td style="text-align:left; font-weight: bold;" rowspan="3"> Perceived Risks Scale </td>
<td style="text-align:left;"> Indirect Effect (ACME) </td>
<td style="text-align:right;"> 0.182 </td>
<td style="text-align:center;"> 0.071 </td>
<td style="text-align:center;"> 0.300 </td>
<td style="text-align:left; color: green; font-weight: bold;"> < .001 *** </td>
<td style="text-align:left; font-weight: bold; color: green;"> Full Mediation </td>
</tr>
<tr>
<td style="text-align:left;"> Direct Effect (ADE) </td>
<td style="text-align:right;"> 0.108 </td>
<td style="text-align:center;"> -0.056 </td>
<td style="text-align:center;"> 0.264 </td>
<td style="text-align:left;"> 0.176 </td>
<td style="text-align:left;"> Non-Significant </td>
</tr>
<tr>
<td style="text-align:left;"> Total Effect </td>
<td style="text-align:right;"> 0.290 </td>
<td style="text-align:center;"> 0.109 </td>
<td style="text-align:center;"> 0.464 </td>
<td style="text-align:left; color: blue; font-weight: bold;"> 0.008 ** </td>
<td style="text-align:left; font-weight: bold; color: blue;"> Significant </td>
</tr>
</tbody>
</table>
<br>
## 18. Discussion and Key Takeaways
This report provides a exploration of how generative AI technologies are perceived by the public. By analyzing a sample of N = 406 participants and incorporating five exploratory analyses, this study uncovers deep insights into the psychological, behavioral, and cognitive factors driving technological concern, benefit optimization, and the Acceptance of Purpose. We detail the core theoretical and empirical contributions of this study below:
### 1. The Label Effect: Semantic Labeling as a Cognitive Anchor (RQ1 & Chapter 13)
Our primary experimental manipulation revealed a highly significant main effect of the **Label Effect** on **Perceived Risks** (*F*(1, 386) = 22.42, *p* < .0001, *η<sub>p</sub><sup>2</sup>* = 0.055). Exposing participants to the threatening label **"Deepfake"** rather than the neutral label **"Synthetic Avatar"** significantly elevated risk perceptions and threat anxiety.
In addition, **Chapter 13 (Moderation Analysis)** proved that this Label Effect is **statistically non-significant in its interaction with AI Expertise** (*F*(1, 389) = 0.10, *p* = 0.7488). Post-hoc simple slopes verified that the Label Effect remains highly significant at low (*p* = 0.0021), average (*p* < 0.0001), and high (*p* = 0.0004) levels of AI expertise.
*Takeaway:* Semantic labeling is not merely a bias that only influences laypeople; its cognitive anchoring power is equally potent for highly knowledgeable experts. The term "Deepfake" triggers a deep-seated risk frame that even advanced technical knowledge cannot override.
### 2. The Gender Threat Gap and Selective Relaxation (RQ1a & Chapter 10)
A large, highly significant gender threat gap was identified across the entire dataset. Female participants reported significantly higher baseline perceived risks (*M* = 3.65 vs. 3.38, *p* = 0.0246) and significantly lower baseline **Acceptance of Purpose** (*M* = 1.53 vs. 1.85, *p* < .0001).
Furthermore, as illustrated in **Figure 7 (Chapter 10)**, the interaction between Label and Gender on the **Acceptance of Purpose Scale** shows a **marginally significant** "selective relaxation" trend (*p* = 0.0766). Substituting the positive label "Synthetic Avatar" for "Deepfake" selectively relaxes threat concern and Acceptance of Purpose barriers for female participants (marginally increasing their Acceptance of Purpose from *M* = 1.45 to 1.61, *p* = 0.083), whereas it has no influence on male participants (*M* = 1.88 vs. 1.81, *p* = 0.44).
*Takeaway:* Men operate under a highly permissive, stable baseline that is immune to semantic labeling. Women, conversely, maintain a heightened baseline level of concern that is highly sensitive to semantic labeling; positive rebranding selectively lowers their psychological barriers and normalizes the technology.
### 3. Population Differences: Local vs. National Panels (RQ1b & Chapter 8)
A highly significant, consistent main effect of **Population Cohort** was identified across all three primary scales: Perceived Risks (*p* = 0.0008), Perceived Benefits (*p* = 0.0019), and Acceptance of Purpose (*p* = 0.0018).
* Participants from the national panel perceived significantly **higher risks** (*M* = 3.70) and **lower Acceptance of Purpose** (*M* = 1.58).
* Local business students exhibited significantly **lower risks** (*M* = 3.33) and **higher Acceptance of Purpose** (*M* = 1.80).
* Most notably, **Figure 6 (Chapter 10)** shows a significant **Gender × Population** interaction on risks (*p* = 0.0168). While a large gender gap exists in the national panel (*p* = 0.0005), this gap is equalized within the business student cohort (*M* = 3.35 for females, *M* = 3.32 for males, *p* = 0.8287).
*Takeaway:* Business school students are statistically less concerned, more optimistic, and show a complete bridging of the gender threat gap. This points to a powerful effect of academic normalization and tech exposure, which equalizes threat perceptions and fosters optimistic technological baselines.
### 4. The Cognitive Awareness of Susceptibility (Chapter 14)
The binary logistic regression in **Chapter 14** predicting real-world deepfake susceptibility yielded a counterintuitive finding:
* For every 1-unit increase in general **AI Knowledge**, participants exhibited a **1.55 times higher odds** of reporting having been fooled by a deepfake (*p* = 0.0309, *OR* = 1.55).
* Conversely, **subjective familiarity** predicted a **30% decrease** in reported susceptibility (*p* = 0.0095, *OR* = 0.70).
*Takeaway:* Higher technical expertise does not prevent individuals from being deceived; rather, it builds the critical cognitive skills necessary to realize and spot when they have been fooled. Subjective familiarity, meanwhile, may reflect either active vigilance or a subjective overconfidence.
### 5. Generative Creator Status and Threat Appraisals (Chapter 15)
The Welch's $t$-test in **Chapter 15** compared Perceived Risks between active creators of generative media (such as AR face filters or deepfake swaps, *N* = 53) and non-creators (*N* = 336).
* While creators reported descriptively lower concern (*M* = 3.39) than non-creators (*M* = 3.63), this difference **was not statistically significant** (*t*(69.99) = -1.55, *p* = 0.1266).
*Takeaway:* Hands-on experience with basic generative media (such as playing with AR filters on social media) is insufficient to alter general societal threat concern. Creators remain highly concerned about the societal dangers and malicious misuses of high-fidelity cloning.
### 6. Intimate Personal Exposure and Acceptance Normalization (Chapter 16)
In contrast to casual creator status, **Chapter 16** revealed that personal engagement with generative cloning—specifically, having created a realistic deepfake video of *oneself* (*SelfCloning*)—was the single strongest predictor of Acceptance of Purpose normalization in the entire study:
* A **highly statistically significant, positive correlation** was identified between self-cloning and the **Acceptance of Purpose Scale** (*r* = 0.22, *p* < 0.0001).
* Self-cloners (*N* = 18) found target generative AI purposes **substantially more acceptable** (*M* = 2.31, *SD* = 0.86) compared to those who have never cloned themselves (*M* = 1.61, *SD* = 0.64; *N* = 374).
*Takeaway:* Personal engagement is a far stronger driver of technological acceptance than technical knowledge.
### 7. The Emotional Pathway as the Primary Causal Mechanism (Chapter 17)
By filtering the feelings mediator to a 3-level linear concern scale (*Feelings_Concern*: 1 = great, 2 = concerning, 3 = dangerous; *N* = 355), we proved that the **Label Effect operates entirely through an emotional concern pathway**:
* **Path $a$ (Label → Concern):** Exposing participants to "Deepfake" significantly increased emotional concern by $0.20$ points compared to "Synthetic Avatar" (*p* = 0.0007).
* **Path $b$ (Concern → Acceptance of Purpose):** Higher emotional concern was a negative predictor of usage acceptability (*p* < 0.0001).
* **Purposes Mediation:** We found **Full Causal Mediation** (ACME Estimate = **-0.069**, *p* < 0.0001), while the direct effect was completely non-significant (*p* = 0.640). The labeling effect on Acceptance of Purpose is entirely carried by the emotional anxiety that the term "Deepfake" evokes.
* **Risks Mediation:** Emotional concern mediated a **substantial portion (63.9%)** of the labeling effect on general perceived risks (ACME Estimate = **0.182**, *p* < 0.0001), while the direct effect was non-significant (*p* = 0.176).
*Takeaway:* Semantic labeling is not a direct logical driver of technological acceptance. Rather, it operates as an emotional volume knob. Labeling deepfakes as "Synthetic Avatars" mitigates threat anxiety and increases the Acceptance of Purpose primarily by reducing the negative emotional concern and threat anxiety associated with the technology.
## 19. R Session Information and Packages Used
The calculations and plots in this document were compiled using the following setup:
- **R Version:** 4.5.2 (2025-10-31)
- **Primary Packages:** `readxl`, `tidyverse` (`ggplot2`, `dplyr`, `tidyr`, `purrr`), `psych` (Exploratory Factor Analysis & Reliability), `car` (Type III ANCOVA), `emmeans` (Adjusted marginal means & simple slopes), `ordinal` (Cumulative Link Models), `patchwork` (Plot alignment), `scales` (Percentage axes).
File stored in: Z-> CCMC -> Deepfake survey -> HICCS