Load data
load("C:/Users/aaron/Desktop/Research/Projects/Conveyor belt_AI_handover/CB data/CB_data.RData")Load packages
library(rmdformats)
#CB_analysis
library(ggplot2)
library(readxl)
library(dplyr)
#LMM Analysis
library(lme4)
#plot
library(ggeffects)
library(ggplot2)Simple logistic regression
model <- glm(choice ~ group,
data = CB_data,
family = binomial)
summary(model)##
## Call:
## glm(formula = choice ~ group, family = binomial, data = CB_data)
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -1.3575 -0.4996 -0.4389 -0.3944 2.2771
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.0178 0.2219 -9.092 <2e-16 ***
## groupHARD -0.2736 0.3001 -0.912 0.362
## groupIMPOSSIBLE 2.4318 0.2519 9.654 <2e-16 ***
## groupMEDIUM -0.4970 0.3137 -1.584 0.113
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 1165.24 on 1077 degrees of freedom
## Residual deviance: 873.75 on 1074 degrees of freedom
## AIC: 881.75
##
## Number of Fisher Scoring iterations: 5Logistic regression GLMM (correct model)
Participants differ in baseline tendency to delegate. Once you account for that: • EASY: very low choice probability • HARD: slightly lower, but not reliably • MEDIUM: significantly lower • IMPOSSIBLE: dramatically higher.
model_mixed <- glmer(
choice ~ group + (1 | ID),
data = CB_data,
family = binomial
)
summary(model_mixed)## Generalized linear mixed model fit by maximum likelihood (Laplace
## Approximation) [glmerMod]
## Family: binomial ( logit )
## Formula: choice ~ group + (1 | ID)
## Data: CB_data
##
## AIC BIC logLik deviance df.resid
## 684.0 708.9 -337.0 674.0 1073
##
## Scaled residuals:
## Min 1Q Median 3Q Max
## -15.2602 -0.2593 -0.1617 -0.0399 10.0489
##
## Random effects:
## Groups Name Variance Std.Dev.
## ID (Intercept) 3.537 1.881
## Number of obs: 1078, groups: ID, 49
##
## Fixed effects:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.9507 0.4096 -7.203 5.87e-13 ***
## groupHARD -0.4568 0.3887 -1.175 0.2400
## groupIMPOSSIBLE 3.5978 0.3467 10.376 < 2e-16 ***
## groupMEDIUM -0.8406 0.4131 -2.035 0.0419 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Correlation of Fixed Effects:
## (Intr) grHARD gIMPOS
## groupHARD -0.492
## gIMPOSSIBLE -0.679 0.575
## groupMEDIUM -0.451 0.517 0.520Effect sizes (odds ratio)
IMPOSSIBLE trials increase the odds of delegating by over 36× relative to EASY.
Relative to EASY, MEDIUM trials reduce the odds of delegating.
exp(fixef(model_mixed))## (Intercept) groupHARD groupIMPOSSIBLE groupMEDIUM
## 0.05230197 0.63332822 36.51670876 0.4314330595% CIs
exp(confint(model_mixed, parm = "beta_"))## Computing profile confidence intervals ...## 2.5 % 97.5 %
## (Intercept) 0.02237961 0.1132994
## groupHARD 0.29406394 1.3624486
## groupIMPOSSIBLE 19.09678877 74.6726261
## groupMEDIUM 0.18861334 0.9635974Predicted probability
preds <- ggpredict(model_mixed, terms = "group")Compare models (AIC)
Lower is better. Compared GLMM to the simple GLM (AIC ≈ 881). This is a massive improvement, the mixed model fits the data far better.
AIC(model, model_mixed)## df AIC
## model 4 881.7502
## model_mixed 5 683.9655Plot (probabilities not log odds)
Predicted Probability of Choosing is the model’s estimate of the probability that the participant delegated (not odds ratio)
preds$x <- factor(preds$x,
levels = c("EASY", "MEDIUM", "HARD", "IMPOSSIBLE"))
ggplot(preds, aes(x = x, y = predicted)) +
geom_point(data = CB_data, aes(x = group, y = choice),
position = position_jitter(width = 0.2),
alpha = 0.15, colour = "grey40") +
geom_ribbon(aes(ymin = conf.low, ymax = conf.high, group = 1),
fill = "#56B4E9", alpha = 0.35, colour = NA) +
geom_line(aes(group = 1), size = 1.2, colour = "#0072B2") +
geom_point(size = 3, colour = "#0072B2") +
labs(x = "Trial Difficulty", y = "Predicted Probability of Choosing") +
theme_bw()