Manipulation Check
Real / Fake
# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
mutate(Participant = fct_relevel(Participant, df |>
group_by(Participant) |>
summarize(Belief_Answer = mean(Belief_Answer)) |>
ungroup() |>
arrange(Belief_Answer) |>
pull(Participant) |>
as.character())) |>
# mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
geom_vline(xintercept = 0, linetype = "dotted") +
scale_y_discrete(expand = c(0.02, 0)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-0.95, 0, 0.95),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d() +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "grey", color = "white") +
ggside::scale_xsidey_continuous(expand = c(0, 0))
df |>
group_by(Participant, Belief) |>
summarize(n = n() / 108,
Confidence = mean(Belief_Confidence)) |>
pivot_wider(values_from=c("n", "Confidence"), names_from="Belief") |>
ungroup() |>
describe_posterior(centrality = "mean", test=FALSE)
## Summary of Posterior Distribution
##
## Parameter | Mean | 95% CI
## -------------------------------------
## n_Fake | 0.44 | [0.12, 0.64]
## n_Real | 0.56 | [0.36, 0.88]
## Confidence_Fake | 0.60 | [0.24, 1.00]
## Confidence_Real | 0.59 | [0.19, 0.98]
m <- glmmTMB::glmmTMB(Belief ~ 1 + (1|Participant) + (1|Stimulus), data=df, family="binomial")
icc(m, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.090
## Stimulus | 0.096
Colinearity
IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")
correlation::correlation(df[IVs], partial=TRUE)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | r | 95% CI | t(15658) | p
## ----------------------------------------------------------------------------
## Attractive | Beauty | 0.64 | [ 0.64, 0.65] | 105.41 | < .001***
## Attractive | Trustworthy | 0.10 | [ 0.08, 0.11] | 12.28 | < .001***
## Attractive | Familiar | 0.16 | [ 0.14, 0.17] | 19.65 | < .001***
## Beauty | Trustworthy | 0.25 | [ 0.23, 0.26] | 32.01 | < .001***
## Beauty | Familiar | -8.56e-03 | [-0.02, 0.01] | -1.07 | 0.284
## Trustworthy | Familiar | 0.07 | [ 0.06, 0.09] | 8.98 | < .001***
##
## p-value adjustment method: Holm (1979)
## Observations: 15660
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
for (y in IVs) {
if (x == y) next
print(paste(y, "~", x))
model <- glmmTMB::glmmTMB(as.formula(
paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
),
data = df,
family = glmmTMB::beta_family()
)
# model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
# random = list(Participant=~1, Stimulus=~1),
# data = df,
# family=mgcv::betar())
pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
pred$y <- y
pred <- data_rename(pred, x, "Score")
pred$x <- x
preds <- rbind(preds, pred)
dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
}
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"
dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
ggplot(aes(x = Score, y = Predicted)) +
stat_density_2d(aes(fill = after_stat(density)), geom = "raster", contour = FALSE) +
# geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
facet_grid(y ~ x, switch = "both") +
theme_modern() +
labs(title = "Collinearity in the Stimuli Ratings") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggnewscale::new_scale_fill() +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
Effect of Delay
model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Delay, y = Real)) +
stat_density_2d(aes(fill = after_stat(density)), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#795548", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
hdi(df$Delay)
## 95% HDI: [1.28, 29.66]
estimate_relation(model, at="Delay=c(0, 60)")
## Model-based Expectation
##
## Delay | Participant | Stimulus | Predicted | SE | 95% CI
## ----------------------------------------------------------------
## 0.00 | | | 0.58 | 0.02 | [0.54, 0.63]
## 60.00 | | | 0.54 | 0.03 | [0.47, 0.60]
##
## Variable predicted: Belief
## Predictors modulated: Delay=c(0, 60)
parameters::parameters(model, effects="fixed", exponentiate=TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.41 |
0.12 |
(1.19, 1.67) |
3.90 |
< .001 |
| Delay |
1.00 |
2.45e-03 |
(0.99, 1.00) |
-1.37 |
0.172 |
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.79 |
0.09 |
(0.61, 0.97) |
8.56 |
< .001 |
| Belief (Real) |
-0.05 |
0.07 |
(-0.18, 0.09) |
-0.68 |
0.498 |
| Belief (Fake) × Delay |
-2.67e-03 |
2.38e-03 |
(-7.34e-03, 2.00e-03) |
-1.12 |
0.263 |
| Belief (Real) × Delay |
-5.92e-03 |
2.07e-03 |
(-9.98e-03, -1.85e-03) |
-2.85 |
0.004 |
Effect of Presentation Order
model <- glmmTMB::glmmTMB(Belief ~ Block2_Trial + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Block2_Trial", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Block2_Trial + ((Belief / Block2_Trial) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Block2_Trial", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Block2_Trial, y = Real)) +
stat_density_2d(aes(fill = after_stat(density)), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#FF9800"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Presentation Order", x = "Minutes", y="Presentation Order") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#FF9800", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
parameters::parameters(model, effects="fixed", exponentiate=TRUE) |>
display(digits=4)
Fixed Effects
| (Intercept) |
1.4030 |
0.1201 |
(1.19, 1.66) |
3.9547 |
< .001 |
| Block2 Trial |
0.9992 |
0.0006 |
(1.00, 1.00) |
-1.5040 |
0.133 |
parameters::parameters(m_conf, effects="fixed") |>
display(digits=6)
Fixed Effects
| (Intercept) |
0.854086 |
0.097901 |
(0.66, 1.05) |
8.723938 |
< .001 |
| Belief (Real) |
-0.020838 |
0.073228 |
(-0.16, 0.12) |
-0.284563 |
0.776 |
| Belief (Fake) × Block2 Trial |
-0.001767 |
0.000851 |
(-3.44e-03, -9.95e-05) |
-2.076884 |
0.038 |
| Belief (Real) × Block2 Trial |
-0.003127 |
0.000711 |
(-4.52e-03, -1.73e-03) |
-4.396204 |
< .001 |
Determinants of Reality
make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
# Models
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
data = df,
family = "binomial"
)
y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
# gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
# data=df,
# algorithm="sampling",
# family = "bernoulli")
# trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
# slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
# trend$Trend <- interpret_pd(slope$pd)
# trend$group <- 0
# trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
sig1 <- data.frame(x = 0.5,
y = y_real[c(11, 31), "Predicted"],
Sex = y_real[c(11, 31), "Sex"])
param <- parameters::parameters(m_real, effects = "fixed", keep = var)
sig1$p <- c(min(param[str_detect(param$Parameter, sig1$Sex[1]), "p"]), min(param[str_detect(param$Parameter, sig1$Sex[2]), "p"]))
sig1$y <- sig1$y + ifelse(sig1$Sex == "Male", -0.03, 0.03)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .099, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = 0.5,
y = y_conf[c(11, 31, 51, 71), "Predicted"],
Sex = y_conf[c(11, 31, 51, 71), "Sex"],
Belief = y_conf[c(11, 31, 51, 71), "Belief"]) |>
arrange(Sex, Belief)
param <- parameters::parameters(m_conf, effects = "fixed", keep = var) |>
arrange(Parameter)
sig2$p <- c(min(param$p[c(1, 2)]), min(param$p[c(5, 6)]), min(param$p[c(3, 4)]), min(param$p[c(7, 8)]))
sig2$y <- sig2$y + ifelse(sig2$Belief == "Real", 0.03, -0.03)
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .099, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Plot
p <- df |>
ggplot(aes(x = .data[[var]], y = .data[["Real"]])) +
stat_density_2d(aes(fill = after_stat(density)), geom = "raster", contour = FALSE) +
scale_fill_gradientn(colors = c("white", fill), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_point2(alpha = 0.25, size = 4, color = "black") +
geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
geom_line(data = y_real, aes(y = Predicted, color = Sex), linewidth=1) +
# geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
# geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
geom_text(data = sig1, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig1$p < .05, 8.5, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label, color = Sex), size = ifelse(sig2$p < .05, 5, 3)) +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(aes(fill = Sex), alpha=2/3, color = NA) +
ggside::geom_ysidedensity(aes(fill = Sex), alpha=2/3, color = NA) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Beauty, 2) + Trustworthy + Familiar + (1|Participant) + (1|Stimulus)",
var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Trustworthy, 2) + Beauty + Familiar + (1|Participant) + (1|Stimulus)",
var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Familiar, 2) + Beauty + Trustworthy + (1|Participant) + (1|Stimulus)",
var = "Familiar", fill = "#2196F3"
)
Attractiveness
parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Sex (Female) × poly(Attractive, 2)1 |
4.98 |
3.19 |
(-1.27, 11.23) |
1.56 |
0.118 |
| Sex (Male) × poly(Attractive, 2)1 |
16.57 |
4.72 |
(7.33, 25.82) |
3.51 |
< .001 |
| Sex (Female) × poly(Attractive, 2)2 |
7.82 |
3.07 |
(1.81, 13.84) |
2.55 |
0.011 |
| Sex (Male) × poly(Attractive, 2)2 |
2.95 |
5.56 |
(-7.95, 13.85) |
0.53 |
0.596 |
performance::performance(rez_at$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_at$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Belief (Fake) × SexFemale × poly(Attractive, 2)1 |
0.41 |
2.25 |
(-4.01, 4.83) |
0.18 |
0.855 |
| Belief (Real) × SexFemale × poly(Attractive, 2)1 |
2.40 |
1.79 |
(-1.11, 5.91) |
1.34 |
0.181 |
| Belief (Fake) × SexMale × poly(Attractive, 2)1 |
1.97 |
3.72 |
(-5.32, 9.25) |
0.53 |
0.597 |
| Belief (Real) × SexMale × poly(Attractive, 2)1 |
0.92 |
2.91 |
(-4.79, 6.63) |
0.31 |
0.753 |
| Belief (Fake) × SexFemale × poly(Attractive, 2)2 |
5.23 |
2.23 |
(0.86, 9.60) |
2.35 |
0.019 |
| Belief (Real) × SexFemale × poly(Attractive, 2)2 |
4.30 |
1.70 |
(0.97, 7.64) |
2.53 |
0.011 |
| Belief (Fake) × SexMale × poly(Attractive, 2)2 |
-9.92 |
4.62 |
(-18.99, -0.86) |
-2.15 |
0.032 |
| Belief (Real) × SexMale × poly(Attractive, 2)2 |
5.46 |
3.12 |
(-0.64, 11.57) |
1.75 |
0.080 |
rez_at$p
Beauty
parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")|>
display()
Fixed Effects
| Sex (Female) × poly(Beauty, 2)1 |
3.72 |
3.43 |
(-2.99, 10.43) |
1.09 |
0.278 |
| Sex (Male) × poly(Beauty, 2)1 |
11.82 |
4.28 |
(3.44, 20.21) |
2.76 |
0.006 |
| Sex (Female) × poly(Beauty, 2)2 |
4.46 |
3.14 |
(-1.69, 10.61) |
1.42 |
0.156 |
| Sex (Male) × poly(Beauty, 2)2 |
7.65 |
4.69 |
(-1.55, 16.85) |
1.63 |
0.103 |
performance::performance(rez_gl$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_gl$model_belief, by_group = TRUE)|>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty") |>
display()
Fixed Effects
| Belief (Fake) × SexFemale × poly(Beauty, 2)1 |
-1.16 |
2.30 |
(-5.68, 3.35) |
-0.51 |
0.613 |
| Belief (Real) × SexFemale × poly(Beauty, 2)1 |
3.33 |
1.96 |
(-0.51, 7.16) |
1.70 |
0.089 |
| Belief (Fake) × SexMale × poly(Beauty, 2)1 |
-0.95 |
3.34 |
(-7.49, 5.59) |
-0.28 |
0.776 |
| Belief (Real) × SexMale × poly(Beauty, 2)1 |
2.15 |
2.58 |
(-2.90, 7.20) |
0.83 |
0.404 |
| Belief (Fake) × SexFemale × poly(Beauty, 2)2 |
7.84 |
2.27 |
(3.39, 12.29) |
3.46 |
< .001 |
| Belief (Real) × SexFemale × poly(Beauty, 2)2 |
2.15 |
1.88 |
(-1.53, 5.83) |
1.15 |
0.251 |
| Belief (Fake) × SexMale × poly(Beauty, 2)2 |
-6.50 |
3.50 |
(-13.36, 0.37) |
-1.85 |
0.064 |
| Belief (Real) × SexMale × poly(Beauty, 2)2 |
4.67 |
2.71 |
(-0.64, 9.98) |
1.72 |
0.085 |
rez_gl$p
Trustworthiness
parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Sex (Female) × poly(Trustworthy, 2)1 |
6.44 |
3.34 |
(-0.11, 13.00) |
1.93 |
0.054 |
| Sex (Male) × poly(Trustworthy, 2)1 |
5.86 |
4.14 |
(-2.26, 13.98) |
1.41 |
0.157 |
| Sex (Female) × poly(Trustworthy, 2)2 |
-0.21 |
3.31 |
(-6.69, 6.27) |
-0.06 |
0.950 |
| Sex (Male) × poly(Trustworthy, 2)2 |
1.20 |
4.32 |
(-7.27, 9.67) |
0.28 |
0.781 |
performance::performance(rez_tr$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_tr$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Belief (Fake) × SexFemale × poly(Trustworthy, 2)1 |
-0.63 |
2.26 |
(-5.07, 3.80) |
-0.28 |
0.780 |
| Belief (Real) × SexFemale × poly(Trustworthy, 2)1 |
1.84 |
2.15 |
(-2.37, 6.05) |
0.86 |
0.392 |
| Belief (Fake) × SexMale × poly(Trustworthy, 2)1 |
-3.07 |
3.12 |
(-9.19, 3.06) |
-0.98 |
0.326 |
| Belief (Real) × SexMale × poly(Trustworthy, 2)1 |
0.47 |
2.51 |
(-4.46, 5.40) |
0.19 |
0.853 |
| Belief (Fake) × SexFemale × poly(Trustworthy, 2)2 |
6.12 |
2.36 |
(1.49, 10.75) |
2.59 |
0.010 |
| Belief (Real) × SexFemale × poly(Trustworthy, 2)2 |
6.14 |
2.04 |
(2.13, 10.14) |
3.00 |
0.003 |
| Belief (Fake) × SexMale × poly(Trustworthy, 2)2 |
-3.63 |
3.07 |
(-9.65, 2.39) |
-1.18 |
0.237 |
| Belief (Real) × SexMale × poly(Trustworthy, 2)2 |
1.41 |
2.60 |
(-3.69, 6.51) |
0.54 |
0.589 |
rez_tr$p
Familiarity
parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Sex (Female) × poly(Familiar, 2)1 |
0.49 |
3.62 |
(-6.61, 7.59) |
0.13 |
0.893 |
| Sex (Male) × poly(Familiar, 2)1 |
9.24 |
5.18 |
(-0.92, 19.40) |
1.78 |
0.075 |
| Sex (Female) × poly(Familiar, 2)2 |
-0.41 |
3.31 |
(-6.90, 6.09) |
-0.12 |
0.902 |
| Sex (Male) × poly(Familiar, 2)2 |
-0.82 |
5.04 |
(-10.69, 9.06) |
-0.16 |
0.871 |
performance::performance(rez_fa$model_belief, metrics = c("R2")) |>
display()
performance::icc(rez_fa$model_belief, by_group = TRUE) |>
display()
| Participant |
0.07 |
| Stimulus |
0.08 |
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar") |>
display()
Fixed Effects
| Belief (Fake) × SexFemale × poly(Familiar, 2)1 |
2.04 |
2.47 |
(-2.80, 6.88) |
0.83 |
0.408 |
| Belief (Real) × SexFemale × poly(Familiar, 2)1 |
-0.64 |
2.04 |
(-4.64, 3.35) |
-0.32 |
0.753 |
| Belief (Fake) × SexMale × poly(Familiar, 2)1 |
-12.41 |
4.01 |
(-20.27, -4.54) |
-3.09 |
0.002 |
| Belief (Real) × SexMale × poly(Familiar, 2)1 |
9.98 |
3.14 |
(3.83, 16.13) |
3.18 |
0.001 |
| Belief (Fake) × SexFemale × poly(Familiar, 2)2 |
0.14 |
2.31 |
(-4.39, 4.67) |
0.06 |
0.952 |
| Belief (Real) × SexFemale × poly(Familiar, 2)2 |
-1.04 |
1.94 |
(-4.85, 2.77) |
-0.54 |
0.592 |
| Belief (Fake) × SexMale × poly(Familiar, 2)2 |
4.79 |
4.22 |
(-3.49, 13.06) |
1.13 |
0.257 |
| Belief (Real) × SexMale × poly(Familiar, 2)2 |
-0.28 |
2.96 |
(-6.08, 5.52) |
-0.10 |
0.924 |
rez_fa$p
Cross-Validate with Normmative Scores
rez_at_norm <- filter(df, Stimulus_Interest == TRUE) |>
mutate(Norms_Attractive = normalize(Norms_Attractive)) |>
make_model(
formula = "Sex / poly(Norms_Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Norms_Attractive", fill = "#F44336"
)
parameters::parameters(rez_at_norm$model_belief, effects = "fixed", keep = "Attractive") |>
display()
Fixed Effects
| Sex (Female) × poly(Norms Attractive, 2)1 |
1.50 |
3.49 |
(-5.35, 8.34) |
0.43 |
0.668 |
| Sex (Male) × poly(Norms Attractive, 2)1 |
10.12 |
5.10 |
(0.13, 20.12) |
1.98 |
0.047 |
| Sex (Female) × poly(Norms Attractive, 2)2 |
0.39 |
3.46 |
(-6.38, 7.16) |
0.11 |
0.911 |
| Sex (Male) × poly(Norms Attractive, 2)2 |
-3.17 |
5.33 |
(-13.61, 7.27) |
-0.60 |
0.551 |
rez_at_norm$p
rez_tr_norm <- filter(df, Stimulus_Interest == TRUE) |>
mutate(Norms_Trustworthy = normalize(Norms_Trustworthy)) |>
make_model(
formula = "Sex / poly(Norms_Trustworthy, 2) + (1|Participant) + (1|Stimulus)",
var = "Norms_Trustworthy", fill = "#4CAF50"
)
parameters::parameters(rez_tr_norm$model_belief, effects = "fixed", keep = "Trustworthy") |>
display()
Fixed Effects
| Sex (Female) × poly(Norms Trustworthy, 2)1 |
6.34 |
3.46 |
(-0.43, 13.12) |
1.83 |
0.067 |
| Sex (Male) × poly(Norms Trustworthy, 2)1 |
9.74 |
4.99 |
(-0.04, 19.51) |
1.95 |
0.051 |
| Sex (Female) × poly(Norms Trustworthy, 2)2 |
3.45 |
3.50 |
(-3.40, 10.30) |
0.99 |
0.324 |
| Sex (Male) × poly(Norms Trustworthy, 2)2 |
0.28 |
4.79 |
(-9.11, 9.67) |
0.06 |
0.953 |
rez_tr_norm$p
Inter-Individual Correlates
plot_interindividual <- function(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#D81B60") {
y_real <- estimate_relation(m_real, at = c(var), length = 21)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
mid <- max(y_conf[[var]])-diff(range(y_conf[[var]])) / 2
sig1 <- data.frame(x = mid, y = y_real[c(11), "Predicted"] + 0.065,
p = parameters::parameters(m_real, effects = "fixed", keep = var)$p)
sig1$label <- ifelse(sig1$p > .05 & sig1$p < .1, format_p(sig1$p), format_p(sig1$p, stars_only = TRUE))
sig2 <- data.frame(x = mid, y = y_conf[c(11, 31), "Predicted"] + c(-0.065, 0.065),
p = parameters::parameters(m_conf, effects = "fixed", keep = var)$p,
Belief = y_conf[c(11, 31), "Belief"])
sig2$label <- ifelse(sig2$p > .05 & sig2$p < .1, format_p(sig2$p), format_p(sig2$p, stars_only = TRUE))
# Data
dat <- insight::get_data(m_conf) |>
group_by(Participant, Belief) |>
data_select(c("Participant", "Belief", var, "Belief_Confidence")) |>
mean_qi(.width = 0.5) |>
mutate(Belief_Confidence = ifelse(Belief == "Real", datawizard::rescale(Belief_Confidence, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(Belief_Confidence, range = c(1, 0), to = c(0, 0.5))))
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(data=filter(df, Belief=="Real"), aes(fill = after_stat(density)), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#4CAF50"), guide = "none") +
ggnewscale::new_scale_fill() +
stat_density_2d(data=filter(df, Belief=="Fake"), aes(fill = after_stat(density)), geom = "raster", contour = FALSE, alpha=0.5) +
scale_fill_gradientn(colors = c("white", "#F44336"), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
geom_point2(data=dat, aes(y = Belief_Confidence, color = Belief), alpha = 0.25, size = 4) +
geom_ribbon(data = y_conf, aes(y = Predicted, ymin = CI_low, ymax = CI_high, fill = Belief), alpha = 1 / 6) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief, color = Belief)) +
geom_ribbon(data = y_real, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 1 / 6) +
geom_line(data = y_real, aes(y = Predicted), size=1) +
geom_text(data = sig1, aes(y = y, x = x, label = label), size = ifelse(sig1$p < .05, 8, 3.5)) +
geom_text(data = sig2, aes(y = y, x = x, label = label), size = ifelse(sig2$p < .05, 8, 3.5)) +
scale_color_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_fill_manual(values = c("Real" = "#4CAF50", "Fake" = "#F44336")) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(data=dat, fill = fill, color = NA) +
ggside::geom_ysidedensity(data=dat, aes(fill = Belief, y=Belief_Confidence), color = NA) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
p
}
make_correlation <- function(x, y) {
cor <- correlation::correlation(x,
y,
bayesian = TRUE,
bayesian_prior = "medium.narrow",
sort = TRUE
) |>
datawizard::data_remove(c("ROPE_Percentage"))
cor$`BF (Spearman)` <- format_bf(
correlation::correlation(
x, y,
bayesian = TRUE,
ranktransform = TRUE,
bayesian_prior = "medium.narrow"
)$BF,
name = NULL, stars = TRUE
)
cor |>
arrange(desc(BF))
}
analyze_interindividual <- function(df, questionnaire = "IPIP6_") {
param_real <- data.frame()
param_conf <- data.frame()
for(var in names(select(df, starts_with(questionnaire)))) {
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", var)),
data=datawizard::standardise(df, select=var), family = "binomial")
param_real <- rbind(param_real, parameters::parameters(m_real, effects="fixed")[2, ])
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", var)),
data=datawizard::standardise(df, select=var),
family = glmmTMB::beta_family())
param_conf <- rbind(param_conf, parameters::parameters(m_conf, effects="fixed")[3:4, ])
}
param_real <- param_real |>
mutate(Parameter = str_remove(Parameter, questionnaire)) |>
select(-SE)
param_conf <- param_conf |>
tidyr::separate("Parameter", into = c("Belief", "Dimension"), sep = ":") |>
mutate(Belief = str_remove(Belief, "Belief"),
Dimension = str_remove(Dimension, questionnaire)) |>
select(-SE)
list(param_real, param_conf)
}
IPIP-6
f <- paste0("(",paste(names(select(df, starts_with("IPIP"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.96 |
0.91 |
(0.79, 4.88) |
1.45 |
0.147 |
| IPIP6 Extraversion |
0.74 |
0.20 |
(0.43, 1.27) |
-1.10 |
0.272 |
| IPIP6 Conscientiousness |
0.90 |
0.25 |
(0.52, 1.55) |
-0.39 |
0.695 |
| IPIP6 Neuroticism |
0.72 |
0.23 |
(0.39, 1.34) |
-1.03 |
0.302 |
| IPIP6 Openness |
0.96 |
0.31 |
(0.51, 1.82) |
-0.11 |
0.909 |
| IPIP6 HonestyHumility |
0.70 |
0.20 |
(0.39, 1.23) |
-1.24 |
0.215 |
| IPIP6 Agreeableness |
1.31 |
0.45 |
(0.67, 2.57) |
0.80 |
0.424 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.21 |
0.75 |
(-1.27, 1.69) |
0.28 |
0.781 |
| Belief (Real) |
0.17 |
0.16 |
(-0.14, 0.48) |
1.10 |
0.271 |
| Belief (Fake) x IPIP6 Extraversion |
-0.10 |
0.45 |
(-0.98, 0.78) |
-0.22 |
0.824 |
| Belief (Real) x IPIP6 Extraversion |
-0.23 |
0.45 |
(-1.10, 0.65) |
-0.51 |
0.613 |
| Belief (Fake) x IPIP6 Conscientiousness |
-0.12 |
0.46 |
(-1.02, 0.78) |
-0.27 |
0.790 |
| Belief (Real) x IPIP6 Conscientiousness |
0.04 |
0.46 |
(-0.85, 0.94) |
0.09 |
0.927 |
| Belief (Fake) x IPIP6 Neuroticism |
0.25 |
0.51 |
(-0.75, 1.26) |
0.49 |
0.622 |
| Belief (Real) x IPIP6 Neuroticism |
0.38 |
0.51 |
(-0.62, 1.38) |
0.74 |
0.460 |
| Belief (Fake) x IPIP6 Openness |
0.76 |
0.53 |
(-0.28, 1.80) |
1.43 |
0.152 |
| Belief (Real) x IPIP6 Openness |
0.37 |
0.53 |
(-0.67, 1.40) |
0.69 |
0.488 |
| Belief (Fake) x IPIP6 HonestyHumility |
-1.16 |
0.47 |
(-2.09, -0.23) |
-2.45 |
0.014 |
| Belief (Real) x IPIP6 HonestyHumility |
-1.62 |
0.47 |
(-2.55, -0.70) |
-3.43 |
< .001 |
| Belief (Fake) x IPIP6 Agreeableness |
0.88 |
0.56 |
(-0.21, 1.98) |
1.58 |
0.114 |
| Belief (Real) x IPIP6 Agreeableness |
1.01 |
0.56 |
(-0.09, 2.10) |
1.81 |
0.071 |
p_ipip <- plot_interindividual(m_real, m_conf, var = "IPIP6_HonestyHumility", fill = "#00BCD4") + labs(x = "Honesty-Humility")
p_ipip
sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.37, -0.06] | 99.35%** | Beta (5.20 +- 5.20) | 9.41* | 6.32*
## Confidence_Fake | IPIP6_Openness | 0.15 | [ 0.01, 0.31] | 97.70%* | Beta (5.20 +- 5.20) | 1.72 | 2.98
## Confidence_Fake | IPIP6_HonestyHumility | -0.15 | [-0.30, 0.02] | 96.10% | Beta (5.20 +- 5.20) | 1.38 | 0.683
## Confidence_Fake | IPIP6_Extraversion | 0.14 | [-0.02, 0.30] | 95.97% | Beta (5.20 +- 5.20) | 1.14 | 1.53
##
## Observations: 145
Narcissism
f <- paste0("(",paste(names(select(df, starts_with("FFNI"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.23 |
0.40 |
(0.65, 2.33) |
0.62 |
0.533 |
| FFNI AcclaimSeeking |
2.24 |
0.74 |
(1.17, 4.27) |
2.44 |
0.015 |
| FFNI Arrogance |
1.08 |
0.35 |
(0.57, 2.05) |
0.25 |
0.803 |
| FFNI Authoritativeness |
1.01 |
0.32 |
(0.54, 1.86) |
0.02 |
0.986 |
| FFNI Distrust |
1.25 |
0.35 |
(0.72, 2.17) |
0.78 |
0.437 |
| FFNI Entitlement |
0.66 |
0.22 |
(0.34, 1.28) |
-1.23 |
0.219 |
| FFNI Exhibitionism |
1.00 |
0.29 |
(0.57, 1.76) |
-6.20e-04 |
> .999 |
| FFNI Exploitativeness |
1.14 |
0.32 |
(0.66, 1.98) |
0.48 |
0.634 |
| FFNI GrandioseFantasies |
0.87 |
0.20 |
(0.55, 1.38) |
-0.58 |
0.563 |
| FFNI Indifference |
0.86 |
0.25 |
(0.48, 1.54) |
-0.50 |
0.614 |
| FFNI LackOfEmpathy |
1.24 |
0.39 |
(0.67, 2.31) |
0.68 |
0.498 |
| FFNI Manipulativeness |
0.47 |
0.15 |
(0.25, 0.87) |
-2.40 |
0.017 |
| FFNI NeedForAdmiration |
0.86 |
0.27 |
(0.47, 1.59) |
-0.47 |
0.636 |
| FFNI ReactiveAnger |
1.40 |
0.38 |
(0.82, 2.37) |
1.24 |
0.217 |
| FFNI Shame |
0.71 |
0.24 |
(0.37, 1.38) |
-1.00 |
0.317 |
| FFNI ThrillSeeking |
1.04 |
0.23 |
(0.68, 1.60) |
0.18 |
0.855 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.56 |
0.53 |
(-0.47, 1.59) |
1.06 |
0.289 |
| Belief (Real) |
-0.20 |
0.12 |
(-0.43, 0.02) |
-1.74 |
0.081 |
| Belief (Fake) x FFNI AcclaimSeeking |
1.62 |
0.54 |
(0.56, 2.68) |
3.00 |
0.003 |
| Belief (Real) x FFNI AcclaimSeeking |
1.65 |
0.54 |
(0.59, 2.70) |
3.07 |
0.002 |
| Belief (Fake) x FFNI Arrogance |
-0.41 |
0.53 |
(-1.45, 0.64) |
-0.76 |
0.447 |
| Belief (Real) x FFNI Arrogance |
-0.63 |
0.53 |
(-1.68, 0.41) |
-1.20 |
0.232 |
| Belief (Fake) x FFNI Authoritativeness |
-1.49 |
0.51 |
(-2.50, -0.48) |
-2.89 |
0.004 |
| Belief (Real) x FFNI Authoritativeness |
-1.57 |
0.51 |
(-2.58, -0.57) |
-3.08 |
0.002 |
| Belief (Fake) x FFNI Distrust |
-0.17 |
0.46 |
(-1.08, 0.74) |
-0.36 |
0.718 |
| Belief (Real) x FFNI Distrust |
0.26 |
0.46 |
(-0.65, 1.17) |
0.56 |
0.578 |
| Belief (Fake) x FFNI Entitlement |
0.11 |
0.55 |
(-0.97, 1.19) |
0.20 |
0.843 |
| Belief (Real) x FFNI Entitlement |
0.52 |
0.55 |
(-0.56, 1.59) |
0.94 |
0.346 |
| Belief (Fake) x FFNI Exhibitionism |
0.15 |
0.47 |
(-0.78, 1.08) |
0.31 |
0.754 |
| Belief (Real) x FFNI Exhibitionism |
0.04 |
0.47 |
(-0.88, 0.97) |
0.09 |
0.924 |
| Belief (Fake) x FFNI Exploitativeness |
-0.48 |
0.46 |
(-1.38, 0.42) |
-1.04 |
0.298 |
| Belief (Real) x FFNI Exploitativeness |
-0.22 |
0.46 |
(-1.12, 0.68) |
-0.48 |
0.631 |
| Belief (Fake) x FFNI GrandioseFantasies |
0.71 |
0.38 |
(-0.04, 1.46) |
1.86 |
0.064 |
| Belief (Real) x FFNI GrandioseFantasies |
0.59 |
0.38 |
(-0.16, 1.33) |
1.54 |
0.123 |
| Belief (Fake) x FFNI Indifference |
0.04 |
0.48 |
(-0.91, 0.98) |
0.08 |
0.939 |
| Belief (Real) x FFNI Indifference |
-0.32 |
0.48 |
(-1.26, 0.63) |
-0.66 |
0.512 |
| Belief (Fake) x FFNI LackOfEmpathy |
0.10 |
0.52 |
(-0.92, 1.12) |
0.19 |
0.849 |
| Belief (Real) x FFNI LackOfEmpathy |
0.06 |
0.52 |
(-0.96, 1.07) |
0.11 |
0.910 |
| Belief (Fake) x FFNI Manipulativeness |
0.50 |
0.52 |
(-0.52, 1.51) |
0.96 |
0.336 |
| Belief (Real) x FFNI Manipulativeness |
0.32 |
0.51 |
(-0.68, 1.33) |
0.63 |
0.528 |
| Belief (Fake) x FFNI NeedForAdmiration |
-0.35 |
0.51 |
(-1.36, 0.66) |
-0.68 |
0.496 |
| Belief (Real) x FFNI NeedForAdmiration |
-0.35 |
0.51 |
(-1.35, 0.65) |
-0.69 |
0.491 |
| Belief (Fake) x FFNI ReactiveAnger |
0.50 |
0.44 |
(-0.37, 1.36) |
1.12 |
0.262 |
| Belief (Real) x FFNI ReactiveAnger |
0.50 |
0.44 |
(-0.36, 1.36) |
1.14 |
0.256 |
| Belief (Fake) x FFNI Shame |
-0.37 |
0.55 |
(-1.46, 0.71) |
-0.68 |
0.499 |
| Belief (Real) x FFNI Shame |
-0.45 |
0.55 |
(-1.53, 0.63) |
-0.82 |
0.414 |
| Belief (Fake) x FFNI ThrillSeeking |
-0.56 |
0.36 |
(-1.27, 0.14) |
-1.57 |
0.117 |
| Belief (Real) x FFNI ThrillSeeking |
-0.41 |
0.36 |
(-1.11, 0.29) |
-1.14 |
0.253 |
p_ffni1 <- plot_interindividual(m_real, m_conf, var = "FFNI_AcclaimSeeking", fill = "#FFC107") + labs(x = "Narcissism (Acclaim Seeking)")
p_ffni1
p_ffni2 <- plot_interindividual(m_real, m_conf, var = "FFNI_Authoritativeness", fill = "#FF5722") + labs(x = "Narcissism (Authoritativeness)")
p_ffni2
p_ffni3 <- plot_interindividual(m_real, m_conf, var = "FFNI_Manipulativeness", fill = "#FF9800") + labs(x = "Narcissism (Manipulativeness)")
p_ffni3
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | FFNI_AcclaimSeeking | 0.21 | [ 0.07, 0.36] | 99.70%** | Beta (5.20 +- 5.20) | 8.71* | 21.44**
## Confidence_Fake | FFNI_GrandioseFantasies | 0.20 | [ 0.03, 0.33] | 99.28%** | Beta (5.20 +- 5.20) | 5.72* | 3.73*
## Confidence_Fake | FFNI_AcclaimSeeking | 0.19 | [ 0.04, 0.34] | 99.08%** | Beta (5.20 +- 5.20) | 3.86* | 4.39*
## Confidence_Real | FFNI_GrandioseFantasies | 0.18 | [ 0.03, 0.32] | 98.92%* | Beta (5.20 +- 5.20) | 3.25* | 4.15*
## n_Real | FFNI_Manipulativeness | -0.17 | [-0.32, -0.01] | 97.85%* | Beta (5.20 +- 5.20) | 2.14 | 0.985
## Confidence_Fake | FFNI_Manipulativeness | 0.16 | [ 0.02, 0.32] | 98.00%* | Beta (5.20 +- 5.20) | 1.90 | 1.27
##
## Observations: 145
cor_test(dfsub, "FFNI_Authoritativeness", "IPIP6_HonestyHumility")
## Parameter1 | Parameter2 | r | 95% CI | t(143) | p
## --------------------------------------------------------------------------------------------
## FFNI_Authoritativeness | IPIP6_HonestyHumility | -0.35 | [-0.48, -0.20] | -4.46 | < .001***
##
## Observations: 145
# cor_test(dfsub, "FFNI_ThrillSeeking", "IPIP6_HonestyHumility")
Social Anxiety
f <- paste0("(",paste(names(select(df, starts_with("Social_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.27 |
0.18 |
(0.97, 1.67) |
1.76 |
0.079 |
| Social Anxiety |
1.53 |
0.62 |
(0.69, 3.41) |
1.04 |
0.299 |
| Social Phobia |
0.75 |
0.27 |
(0.37, 1.53) |
-0.79 |
0.428 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.90 |
0.21 |
(0.49, 1.31) |
4.30 |
< .001 |
| Belief (Real) |
-0.22 |
0.04 |
(-0.30, -0.14) |
-5.29 |
< .001 |
| Belief (Fake) × Social Anxiety |
-1.12 |
0.69 |
(-2.47, 0.23) |
-1.63 |
0.104 |
| Belief (Real) × Social Anxiety |
-0.74 |
0.69 |
(-2.09, 0.60) |
-1.08 |
0.279 |
| Belief (Fake) × Social Phobia |
0.93 |
0.61 |
(-0.27, 2.13) |
1.52 |
0.127 |
| Belief (Real) × Social Phobia |
0.70 |
0.61 |
(-0.49, 1.90) |
1.15 |
0.249 |
# p_social <- plot_interindividual(m_real, m_conf, var = "Social_Phobia", fill = "#E040FB") + labs(x = "Social Phobia")
# p_social
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)
Intolerance to Uncertainty
f <- paste0("(",paste(names(select(df, starts_with("IUS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.56 |
0.35 |
(1.00, 2.44) |
1.97 |
0.049 |
| IUS ProspectiveAnxiety |
0.95 |
0.39 |
(0.43, 2.12) |
-0.12 |
0.906 |
| IUS InhibitoryAnxiety |
0.77 |
0.24 |
(0.42, 1.41) |
-0.85 |
0.397 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.52 |
0.37 |
(-0.20, 1.23) |
1.41 |
0.157 |
| Belief (Real) |
-0.30 |
0.08 |
(-0.45, -0.15) |
-3.88 |
< .001 |
| Belief (Fake) x IUS ProspectiveAnxiety |
1.16 |
0.68 |
(-0.18, 2.49) |
1.70 |
0.090 |
| Belief (Real) x IUS ProspectiveAnxiety |
1.43 |
0.68 |
(0.10, 2.76) |
2.10 |
0.036 |
| Belief (Fake) x IUS InhibitoryAnxiety |
-0.91 |
0.52 |
(-1.93, 0.11) |
-1.75 |
0.081 |
| Belief (Real) x IUS InhibitoryAnxiety |
-1.00 |
0.52 |
(-2.01, 0.02) |
-1.93 |
0.054 |
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)
Paranoid Beliefs
f <- paste0("(",paste(names(select(df, starts_with("GPTS_"))), collapse = " + "),
") + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.45 |
0.18 |
(1.14, 1.84) |
3.00 |
0.003 |
| GPTS Reference |
0.51 |
0.18 |
(0.25, 1.04) |
-1.86 |
0.062 |
| GPTS Persecution |
1.87 |
0.61 |
(0.99, 3.54) |
1.93 |
0.054 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
1.07 |
0.18 |
(0.71, 1.43) |
5.85 |
< .001 |
| Belief (Real) |
-0.21 |
0.04 |
(-0.29, -0.14) |
-5.63 |
< .001 |
| Belief (Fake) x GPTS Reference |
-0.99 |
0.61 |
(-2.18, 0.20) |
-1.63 |
0.104 |
| Belief (Real) x GPTS Reference |
-1.07 |
0.61 |
(-2.26, 0.12) |
-1.76 |
0.079 |
| Belief (Fake) x GPTS Persecution |
0.47 |
0.55 |
(-0.62, 1.55) |
0.84 |
0.400 |
| Belief (Real) x GPTS Persecution |
0.75 |
0.55 |
(-0.33, 1.83) |
1.37 |
0.171 |
p_gpts1 <- plot_interindividual(m_real, m_conf, var = "GPTS_Persecution", fill = "#673AB7") + labs(x = "Paranoid Thoughts (Persecution)")
p_gpts1
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)
AI
rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)
efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
##
## Variable | MR1 | MR2 | MR3 | Complexity | Uniqueness
## -----------------------------------------------------------------------
## AI_8_Exciting | 0.82 | 0.16 | 0.18 | 1.18 | 0.27
## AI_4_DailyLife | 0.77 | 0.15 | 0.16 | 1.17 | 0.36
## AI_9_Applications | 0.71 | 0.06 | 0.12 | 1.07 | 0.47
## AI_7_RealisticVideos | 0.09 | 0.79 | 0.11 | 1.07 | 0.35
## AI_5_ImitatingReality | 0.28 | 0.64 | 0.03 | 1.37 | 0.51
## AI_1_RealisticImages | 0.19 | 0.54 | 0.09 | 1.31 | 0.67
## AI_3_VideosReal | -0.13 | 0.41 | -0.20 | 1.69 | 0.77
## AI_2_Unethical | 0.20 | 0.07 | 0.72 | 1.17 | 0.44
## AI_6_Dangerous | 0.15 | -0.12 | 0.61 | 1.20 | 0.59
## AI_10_FaceErrors | 0.02 | 0.04 | 0.24 | 1.07 | 0.94
##
## The 3 latent factors (varimax rotation) accounted for 46.36% of the total variance of the original data (MR1 = 19.68%, MR2 = 15.76%, MR3 = 10.92%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(dfsub)
df <- predict(efa, newdata=df, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(df)
f <- paste0("(AI_Enthusiasm + AI_Realness + AI_Danger) + (1|Participant) + (1|Stimulus)")
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", f)), data=df, family = "binomial")
parameters::parameters(m_real, effects="fixed", exponentiate = TRUE) |>
display()
Fixed Effects
| (Intercept) |
1.34 |
0.11 |
(1.15, 1.57) |
3.68 |
< .001 |
| AI Enthusiasm |
0.98 |
0.06 |
(0.87, 1.10) |
-0.41 |
0.682 |
| AI Realness |
1.06 |
0.06 |
(0.94, 1.19) |
0.93 |
0.351 |
| AI Danger |
1.11 |
0.07 |
(0.98, 1.27) |
1.63 |
0.103 |
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief / ", f)),
data=df,
family = glmmTMB::beta_family())
parameters::parameters(m_conf, effects="fixed") |>
display()
Fixed Effects
| (Intercept) |
0.83 |
0.09 |
(0.66, 1.01) |
9.54 |
< .001 |
| Belief (Real) |
-0.16 |
0.02 |
(-0.20, -0.13) |
-8.90 |
< .001 |
| Belief (Fake) × AI Enthusiasm |
0.31 |
0.10 |
(0.12, 0.50) |
3.23 |
0.001 |
| Belief (Real) × AI Enthusiasm |
0.21 |
0.10 |
(0.02, 0.40) |
2.20 |
0.028 |
| Belief (Fake) × AI Realness |
0.10 |
0.10 |
(-0.10, 0.30) |
1.01 |
0.313 |
| Belief (Real) × AI Realness |
0.14 |
0.10 |
(-0.06, 0.33) |
1.36 |
0.174 |
| Belief (Fake) × AI Danger |
-0.09 |
0.11 |
(-0.30, 0.13) |
-0.79 |
0.431 |
| Belief (Real) × AI Danger |
0.04 |
0.11 |
(-0.17, 0.25) |
0.38 |
0.707 |
p_ai <- plot_interindividual(m_real, m_conf, var = "AI_Enthusiasm", fill = "#607D8B") +
labs(x = "Enthusiasm about AI technology")
p_ai
r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## -----------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.22 | [ 0.06, 0.36] | 99.70%** | Beta (5.20 +- 5.20) | 12.32** | 17.75**
## Confidence_Real | AI_Enthusiasm | 0.18 | [ 0.02, 0.33] | 98.52%* | Beta (5.20 +- 5.20) | 2.83 | 2.82
## Confidence_Fake | AI_Realness | 0.15 | [ 0.00, 0.30] | 97.15%* | Beta (5.20 +- 5.20) | 1.44 | 2.21
##
## Observations: 145
Figures
fig1a <- (rez_at$p +
theme(axis.text.x = element_blank()) +
labs(x = "Attractiveness") |
rez_gl$p +
labs(x = "Beauty") +
theme(
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
) /
(rez_tr$p +
labs(x = "Trustworthiness") |
rez_fa$p +
labs(x = "Familiarity") +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank()
)
) +
plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
plot_layout(guides = "collect") &
theme(legend.title = element_text(face = "bold"))
fig <- wrap_elements(fig1a) /
wrap_elements(
# ((p_ffni1 / p_ipip) | (p_ffni2 / p_social) | (p_ffni3 / p_ai)) +
((p_ffni1 / p_ipip) | (p_ffni3 / p_gpts1) | (p_ffni2 / p_ai)) +
plot_layout(guides = "collect") +
plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) &
theme(legend.title = element_text(face = "bold"))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
param <- cor_test(dfsub, x, y, bayesian = TRUE)
# Format stat output
r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")
stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")
label <- data.frame(
x = min(dfsub[[x]], na.rm = TRUE),
y = max(dfsub[[y]], na.rm = TRUE),
label = stat
)
# Plot
dfsub |>
ggplot(aes_string(x = x, y = y)) +
geom_point2(
size = 3,
color = fillx,
# color = DVs[x],
alpha = 2 / 3
) +
geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
labs(y = ylab, x = xlab) +
geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fillx, color = "white") +
ggside::geom_ysidedensity(fill = fill, color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
}
p1 <- plot_correlation(dfsub,
x = "IPIP6_HonestyHumility",
y = "Confidence_Real",
ylab = "Confidence that the stimulus is real",
xlab = "Honesty-Humility",
fillx = "#00BCD4",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p2 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is fake",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p3 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is real",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p4 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p5 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is fake",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p6 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_GrandioseFantasies",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Grandiose Fantasies)",
fillx = "#FFC107",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
fig <- wrap_elements(fig1a) /
wrap_elements(
((p3 / p2) | (p1 / p6) | (p4 / p5)) +
plot_annotation(title = "Personality Correlates of Simulation Monitoring", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
Social Anxiety