# one participant managed to participate twice. therefore we drop him/her entirely.
sneaky_guy <- '63d196c147d1f420690e5b87'
risk_fn<-'/Users/chapkovski/Documents/umbrella_analysis/Data/raw_data/Study 5/umbrella_2023-10-18.csv'
q_fn<-'/Users/chapkovski/Documents/umbrella_analysis/Data/raw_data/Study 5/q_2023-10-18.csv'
risk_df<-read_csv(risk_fn) %>% filter(session.is_demo==0,
!is.na(participant.label),
participant._index_in_pages==32,
participant.label!=sneaky_guy)
q_df<-read_csv(q_fn) %>% filter(session.is_demo==0,
!is.na(participant.label),
participant._index_in_pages==32,
participant.label!=sneaky_guy)
df<-risk_df %>% inner_join(q_df, by='participant.label') %>%
rename_with(~ gsub("^player\\.", "", .), starts_with("player.")) %>%
mutate(
big5_1_reversed = 6 - big5_1, # Reverse scoring for reserved (Extraversion)
big5_7_reversed = 6 - big5_7, # Reverse scoring for finds fault with others (Agreeableness)
big5_3_reversed = 6 - big5_3, # Reverse scoring for tends to be lazy (Conscientiousness)
big5_4_reversed = 6 - big5_4, # Reverse scoring for relaxed, handles stress well (Neuroticism)
big5_5_reversed = 6 - big5_5, # Reverse scoring for few artistic interests (Openness)
Extraversion = (big5_1_reversed + big5_6) / 2,
Agreeableness = (big5_2 + big5_7_reversed) / 2,
Conscientiousness = (big5_3_reversed + big5_8) / 2,
Neuroticism = (big5_4_reversed + big5_9) / 2,
Openness = (big5_5_reversed + big5_10) / 2
) %>%
rename(participant=participant.code.x,
round_number=subsession.round_number.x)
creating the dataset for the regression model
maindvs<-c('mpl_switching_row', 'scl_lottery_choice', "cem_switching_row")
df %>% group_by(cem_switching_row) %>% tally
## # A tibble: 10 × 2
## cem_switching_row n
## <dbl> <int>
## 1 1 110
## 2 2 33
## 3 3 74
## 4 4 115
## 5 5 393
## 6 6 114
## 7 7 67
## 8 8 19
## 9 9 33
## 10 10 26
df %>% select(contains('treatment')) %>%names
## [1] "glob_treatment" "treatment" "payable_treatment"
data_model <- df %>%
mutate (
cem_count = cem_switching_row -1, # reflecting the number of risky choices
mpl_count = 11- mpl_switching_row, # reflecting the number of risky choices
scl_count = scl_lottery_choice
) %>%
mutate(
mpl_max = 10,
scl_max = 6,
cem_max = 9,
) %>%
select(-participant._max_page_index.x,-participant._max_page_index.y) %>%
select(condition=treatment, participant,round_number, contains(c( "count","max"))) %>%
pivot_longer(cols = -c("participant","condition", "round_number"),
names_to = c("task",".value"),
names_sep = "_")%>%
mutate(ratio_risk = case_when(task == "cem" ~ count / (max-count),
task == "scl" ~ count / (max-count),
task == "bret" ~ count / (max -count),
task == "mpl" ~ count / (max - count)),
log_ratio_risk = log(ratio_risk),
log_ratio_risk = rationalize(log_ratio_risk),
risky_prop = count/max)
#data_model %>%
# write_csv2("../../Data/Experiment_4.csv")
Demographics
demographic_vars <-c('age', 'gender','marital',
"employment",
"income",
"instructions_clarity")
big5_vars<-c('Extraversion', 'Agreeableness','Conscientiousness','Neuroticism','Openness')
# table by global treatment
df %>%
group_by(participant.label) %>%
select(all_of(demographic_vars), all_of(big5_vars), glob_treatment) %>%
dplyr::slice(1) %>%
ungroup() %>%
select(-participant.label) %>%
tbl_summary(
by=glob_treatment,
statistic=list(all_continuous() ~ "{mean} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)"),
type=list(instructions_clarity~'continuous',
Extraversion~'continuous',
Agreeableness~'continuous',
Conscientiousness~'continuous',
Neuroticism~'continuous',
Openness~'continuous'))
| Characteristic |
T1-CC, N = 71 |
T2-CR, N = 72 |
T3-CA, N = 71 |
T4-RA, N = 70 |
T5-AR, N = 69 |
T6-RC, N = 69 |
T7-AC, N = 70 |
| age |
|
|
|
|
|
|
|
| 18 - 24 |
6 (8.5%) |
3 (4.2%) |
6 (8.5%) |
4 (5.7%) |
5 (7.2%) |
3 (4.3%) |
8 (11%) |
| 25 - 34 |
21 (30%) |
26 (36%) |
19 (27%) |
22 (31%) |
28 (41%) |
27 (39%) |
18 (26%) |
| 35 - 44 |
22 (31%) |
16 (22%) |
20 (28%) |
24 (34%) |
16 (23%) |
13 (19%) |
21 (30%) |
| 45 - 54 |
10 (14%) |
19 (26%) |
16 (23%) |
12 (17%) |
13 (19%) |
14 (20%) |
17 (24%) |
| 55 - 64 |
9 (13%) |
7 (9.7%) |
8 (11%) |
6 (8.6%) |
6 (8.7%) |
10 (14%) |
5 (7.1%) |
| 65 - 74 |
2 (2.8%) |
1 (1.4%) |
2 (2.8%) |
1 (1.4%) |
0 (0%) |
1 (1.4%) |
1 (1.4%) |
| 75 - 84 |
1 (1.4%) |
0 (0%) |
0 (0%) |
0 (0%) |
1 (1.4%) |
1 (1.4%) |
0 (0%) |
| 85 or older |
0 (0%) |
0 (0%) |
0 (0%) |
1 (1.4%) |
0 (0%) |
0 (0%) |
0 (0%) |
| gender |
|
|
|
|
|
|
|
| Female |
34 (48%) |
27 (38%) |
31 (44%) |
28 (40%) |
30 (43%) |
32 (46%) |
26 (37%) |
| Male |
35 (49%) |
45 (63%) |
39 (55%) |
41 (59%) |
38 (55%) |
37 (54%) |
44 (63%) |
| Other |
2 (2.8%) |
0 (0%) |
0 (0%) |
0 (0%) |
1 (1.4%) |
0 (0%) |
0 (0%) |
| Prefer not to say |
0 (0%) |
0 (0%) |
1 (1.4%) |
1 (1.4%) |
0 (0%) |
0 (0%) |
0 (0%) |
| marital |
|
|
|
|
|
|
|
| Divorced |
0 (0%) |
2 (2.8%) |
6 (8.5%) |
3 (4.3%) |
3 (4.3%) |
7 (10%) |
2 (2.9%) |
| Married, or in a domestic partnership |
37 (52%) |
37 (51%) |
37 (52%) |
30 (43%) |
31 (45%) |
34 (49%) |
35 (50%) |
| Separated |
1 (1.4%) |
0 (0%) |
1 (1.4%) |
3 (4.3%) |
4 (5.8%) |
1 (1.4%) |
0 (0%) |
| Single (never married) |
32 (45%) |
33 (46%) |
26 (37%) |
33 (47%) |
30 (43%) |
26 (38%) |
33 (47%) |
| Widowed |
1 (1.4%) |
0 (0%) |
1 (1.4%) |
1 (1.4%) |
1 (1.4%) |
1 (1.4%) |
0 (0%) |
| employment |
|
|
|
|
|
|
|
| Employed full time (35 or more hours per week) |
39 (55%) |
47 (65%) |
40 (56%) |
41 (59%) |
42 (61%) |
40 (58%) |
35 (50%) |
| Employed part time (up to 34 hours per week) |
6 (8.5%) |
5 (6.9%) |
6 (8.5%) |
10 (14%) |
5 (7.2%) |
7 (10%) |
11 (16%) |
| Homemaker |
2 (2.8%) |
3 (4.2%) |
2 (2.8%) |
2 (2.9%) |
3 (4.3%) |
3 (4.3%) |
2 (2.9%) |
| Retired |
6 (8.5%) |
3 (4.2%) |
5 (7.0%) |
0 (0%) |
3 (4.3%) |
5 (7.2%) |
1 (1.4%) |
| Self-employed |
8 (11%) |
5 (6.9%) |
7 (9.9%) |
8 (11%) |
5 (7.2%) |
3 (4.3%) |
9 (13%) |
| Student |
2 (2.8%) |
1 (1.4%) |
1 (1.4%) |
2 (2.9%) |
2 (2.9%) |
2 (2.9%) |
3 (4.3%) |
| Unable to work |
4 (5.6%) |
3 (4.2%) |
2 (2.8%) |
1 (1.4%) |
1 (1.4%) |
2 (2.9%) |
0 (0%) |
| Unemployed and currently looking for work |
3 (4.2%) |
4 (5.6%) |
5 (7.0%) |
3 (4.3%) |
6 (8.7%) |
6 (8.7%) |
7 (10%) |
| Unemployed not currently looking for work |
1 (1.4%) |
1 (1.4%) |
3 (4.2%) |
3 (4.3%) |
2 (2.9%) |
1 (1.4%) |
2 (2.9%) |
| income |
|
|
|
|
|
|
|
| $1,000 - $2,000 |
1 (1.4%) |
3 (4.2%) |
2 (2.8%) |
2 (2.9%) |
1 (1.4%) |
1 (1.4%) |
4 (5.7%) |
| $10,000 - $25,000 |
9 (13%) |
10 (14%) |
8 (11%) |
9 (13%) |
10 (14%) |
14 (20%) |
10 (14%) |
| $100,000 - $150,000 |
2 (2.8%) |
7 (9.7%) |
5 (7.0%) |
6 (8.6%) |
6 (8.7%) |
8 (12%) |
5 (7.1%) |
| $2,000 - $5,000 |
2 (2.8%) |
1 (1.4%) |
1 (1.4%) |
1 (1.4%) |
0 (0%) |
1 (1.4%) |
0 (0%) |
| $25,000 - $50,000 |
25 (35%) |
23 (32%) |
19 (27%) |
22 (31%) |
17 (25%) |
21 (30%) |
22 (31%) |
| $5,000 - $10,000 |
3 (4.2%) |
3 (4.2%) |
4 (5.6%) |
2 (2.9%) |
2 (2.9%) |
3 (4.3%) |
1 (1.4%) |
| $50,000 - $75,000 |
17 (24%) |
15 (21%) |
19 (27%) |
13 (19%) |
16 (23%) |
11 (16%) |
15 (21%) |
| $75,000 - $100,000 |
8 (11%) |
6 (8.3%) |
7 (9.9%) |
9 (13%) |
10 (14%) |
8 (12%) |
8 (11%) |
| More than $150,000 |
2 (2.8%) |
4 (5.6%) |
2 (2.8%) |
1 (1.4%) |
3 (4.3%) |
1 (1.4%) |
2 (2.9%) |
| Prefer not to answer |
2 (2.8%) |
0 (0%) |
4 (5.6%) |
5 (7.1%) |
4 (5.8%) |
1 (1.4%) |
3 (4.3%) |
| instructions_clarity |
4.39 (4.00, 5.00) |
4.38 (4.00, 5.00) |
4.49 (4.00, 5.00) |
4.20 (4.00, 5.00) |
4.22 (4.00, 5.00) |
4.57 (4.00, 5.00) |
4.41 (4.00, 5.00) |
| Extraversion |
2.52 (1.75, 3.00) |
2.63 (1.50, 3.63) |
2.68 (2.00, 3.00) |
2.54 (1.63, 3.00) |
2.80 (2.00, 3.50) |
2.66 (2.00, 3.50) |
2.49 (1.50, 3.00) |
| Agreeableness |
3.54 (3.00, 4.50) |
3.49 (3.00, 4.50) |
3.55 (3.00, 4.50) |
3.43 (2.50, 4.50) |
3.46 (3.00, 4.00) |
3.46 (3.00, 4.00) |
3.56 (3.00, 4.00) |
| Conscientiousness |
3.83 (3.50, 4.50) |
3.86 (3.00, 4.63) |
4.06 (3.50, 5.00) |
3.66 (3.00, 4.50) |
3.84 (3.50, 4.50) |
3.88 (3.00, 4.50) |
3.80 (3.50, 4.50) |
| Neuroticism |
3.06 (2.00, 4.00) |
2.82 (2.00, 3.50) |
2.97 (2.00, 4.00) |
2.86 (2.00, 3.50) |
2.89 (2.00, 4.00) |
2.91 (2.00, 4.00) |
3.03 (2.00, 4.00) |
| Openness |
3.65 (3.00, 4.00) |
3.71 (3.00, 4.50) |
3.70 (3.00, 4.50) |
3.59 (3.00, 4.00) |
3.59 (3.00, 4.50) |
3.56 (3.00, 4.50) |
3.86 (3.00, 4.50) |
# overall table:
df %>%
group_by(participant.label) %>%
select(all_of(demographic_vars), all_of(big5_vars), glob_treatment) %>%
dplyr::slice(1) %>%
ungroup() %>%
select(-participant.label) %>%
tbl_summary(
statistic=list(all_continuous() ~ "{mean} ({p25}, {p75})", all_categorical() ~ "{n} ({p}%)"),
type=list(instructions_clarity~'continuous',
Extraversion~'continuous',
Agreeableness~'continuous',
Conscientiousness~'continuous',
Neuroticism~'continuous',
Openness~'continuous'))
| Characteristic |
N = 492 |
| age |
|
| 18 - 24 |
35 (7.1%) |
| 25 - 34 |
161 (33%) |
| 35 - 44 |
132 (27%) |
| 45 - 54 |
101 (21%) |
| 55 - 64 |
51 (10%) |
| 65 - 74 |
8 (1.6%) |
| 75 - 84 |
3 (0.6%) |
| 85 or older |
1 (0.2%) |
| gender |
|
| Female |
208 (42%) |
| Male |
279 (57%) |
| Other |
3 (0.6%) |
| Prefer not to say |
2 (0.4%) |
| marital |
|
| Divorced |
23 (4.7%) |
| Married, or in a domestic partnership |
241 (49%) |
| Separated |
10 (2.0%) |
| Single (never married) |
213 (43%) |
| Widowed |
5 (1.0%) |
| employment |
|
| Employed full time (35 or more hours per week) |
284 (58%) |
| Employed part time (up to 34 hours per week) |
50 (10%) |
| Homemaker |
17 (3.5%) |
| Retired |
23 (4.7%) |
| Self-employed |
45 (9.1%) |
| Student |
13 (2.6%) |
| Unable to work |
13 (2.6%) |
| Unemployed and currently looking for work |
34 (6.9%) |
| Unemployed not currently looking for work |
13 (2.6%) |
| income |
|
| $1,000 - $2,000 |
14 (2.8%) |
| $10,000 - $25,000 |
70 (14%) |
| $100,000 - $150,000 |
39 (7.9%) |
| $2,000 - $5,000 |
6 (1.2%) |
| $25,000 - $50,000 |
149 (30%) |
| $5,000 - $10,000 |
18 (3.7%) |
| $50,000 - $75,000 |
106 (22%) |
| $75,000 - $100,000 |
56 (11%) |
| More than $150,000 |
15 (3.0%) |
| Prefer not to answer |
19 (3.9%) |
| instructions_clarity |
4.38 (4.00, 5.00) |
| Extraversion |
2.62 (2.00, 3.00) |
| Agreeableness |
3.50 (3.00, 4.50) |
| Conscientiousness |
3.85 (3.00, 4.50) |
| Neuroticism |
2.94 (2.00, 4.00) |
| Openness |
3.67 (3.00, 4.50) |
| glob_treatment |
|
| T1-CC |
71 (14%) |
| T2-CR |
72 (15%) |
| T3-CA |
71 (14%) |
| T4-RA |
70 (14%) |
| T5-AR |
69 (14%) |
| T6-RC |
69 (14%) |
| T7-AC |
70 (14%) |
plotting stuff
Differences in the ratio of risk choices
label_measure <- c(cem = "CEM",
scl = "SCL",
mpl = "MPL")
data_model %>% group_by(condition) %>% tally
## # A tibble: 3 × 2
## condition n
## <chr> <int>
## 1 ambiguity 840
## 2 control 1272
## 3 risk 840
data_model %>% ggplot(aes(x = condition, y = log_ratio_risk))+
geom_violin()+
geom_boxplot(width = .1, outlier.shape = NA) +
stat_summary(fun=mean, geom="point", shape=23, size=3, color="black", fill="black") +
geom_jitter(alpha = .2, width = .05) +
geom_hline(yintercept = 0, color = "darkgrey")+
facet_wrap(~task, labeller = labeller(task = label_measure)) +
scale_y_continuous(name = "Risk preference") +
scale_x_discrete(name = "Experimental Group",
breaks = c("control","ambiguity", "risk"),
labels = c("Control","Ambiguity", "Risk"))+
theme_classic()
ggsave("figs/log_ratio_risk.png",dpi = 1200)
comparing the log ratios for the risky vs. safe choices
# Model 1 with random intercepts only
m1 <- lmerTest::lmer(log_ratio_risk ~ condition + task +round_number+ (1 | participant), data = data_model)
# Model 2 with random intercepts and a random slope for either condition or task, not both
m2 <- lmerTest::lmer(log_ratio_risk ~ condition * task + round_number+(1 + condition | participant), data = data_model)
anova(m1,m2) %>% kbl %>% kable_classic_2()
|
|
npar
|
AIC
|
BIC
|
logLik
|
deviance
|
Chisq
|
Df
|
Pr(>Chisq)
|
|
m1
|
8
|
6250.037
|
6296.418
|
-3117.018
|
6234.037
|
NA
|
NA
|
NA
|
|
m2
|
17
|
6265.595
|
6364.156
|
-3115.797
|
6231.595
|
2.442022
|
9
|
0.9824023
|
sjPlot::tab_model(m1,m2)
|
|
log_ratio_risk
|
log_ratio_risk
|
|
Predictors
|
Estimates
|
CI
|
p
|
Estimates
|
CI
|
p
|
|
(Intercept)
|
-0.24
|
-0.37 – -0.11
|
<0.001
|
-0.26
|
-0.41 – -0.12
|
<0.001
|
|
condition [control]
|
-0.01
|
-0.10 – 0.08
|
0.789
|
0.01
|
-0.12 – 0.15
|
0.865
|
|
condition [risk]
|
0.05
|
-0.04 – 0.14
|
0.322
|
0.07
|
-0.07 – 0.22
|
0.316
|
|
task [mpl]
|
-0.31
|
-0.38 – -0.23
|
<0.001
|
-0.26
|
-0.40 – -0.11
|
0.001
|
|
task [scl]
|
-0.16
|
-0.23 – -0.08
|
<0.001
|
-0.14
|
-0.28 – -0.00
|
0.049
|
|
round number
|
0.01
|
-0.05 – 0.08
|
0.662
|
0.02
|
-0.05 – 0.08
|
0.632
|
condition [control] ×
task [mpl]
|
|
|
|
-0.05
|
-0.23 – 0.14
|
0.634
|
condition [risk] × task
[mpl]
|
|
|
|
-0.10
|
-0.30 – 0.11
|
0.360
|
condition [control] ×
task [scl]
|
|
|
|
-0.03
|
-0.21 – 0.15
|
0.738
|
condition [risk] × task
[scl]
|
|
|
|
0.00
|
-0.20 – 0.20
|
0.979
|
|
Random Effects
|
|
σ2
|
0.62
|
0.62
|
|
τ00
|
0.22 participant
|
0.19 participant
|
|
τ11
|
|
0.00 participant.conditioncontrol
|
|
|
|
0.00 participant.conditionrisk
|
|
ρ01
|
|
1.00
|
|
|
|
1.00
|
|
ICC
|
0.26
|
0.26
|
|
N
|
489 participant
|
489 participant
|
|
Observations
|
2435
|
2435
|
|
Marginal R2 / Conditional R2
|
0.019 / 0.272
|
0.019 / 0.272
|
data_model %>% filter (task == "mpl") %>% pairwise_t_test(log_ratio_risk ~ condition) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
n1
|
n2
|
p
|
p.signif
|
p.adj
|
p.adj.signif
|
|
log_ratio_risk
|
ambiguity
|
control
|
280
|
424
|
0.572
|
ns
|
1
|
ns
|
|
log_ratio_risk
|
ambiguity
|
risk
|
280
|
280
|
0.603
|
ns
|
1
|
ns
|
|
log_ratio_risk
|
control
|
risk
|
424
|
280
|
0.999
|
ns
|
1
|
ns
|
data_model %>% filter (task == "scl") %>% pairwise_t_test(log_ratio_risk ~ condition) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
n1
|
n2
|
p
|
p.signif
|
p.adj
|
p.adj.signif
|
|
log_ratio_risk
|
ambiguity
|
control
|
280
|
424
|
0.667
|
ns
|
1.000
|
ns
|
|
log_ratio_risk
|
ambiguity
|
risk
|
280
|
280
|
0.579
|
ns
|
1.000
|
ns
|
|
log_ratio_risk
|
control
|
risk
|
424
|
280
|
0.303
|
ns
|
0.908
|
ns
|
data_model %>% filter (task == "cem") %>% pairwise_t_test(log_ratio_risk ~ condition) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
n1
|
n2
|
p
|
p.signif
|
p.adj
|
p.adj.signif
|
|
log_ratio_risk
|
ambiguity
|
control
|
280
|
424
|
0.892
|
ns
|
0.935
|
ns
|
|
log_ratio_risk
|
ambiguity
|
risk
|
280
|
280
|
0.312
|
ns
|
0.935
|
ns
|
|
log_ratio_risk
|
control
|
risk
|
424
|
280
|
0.332
|
ns
|
0.935
|
ns
|
cohens_d(log_ratio_risk ~ condition, data = data_model %>% filter (task == "mpl")) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
effsize
|
n1
|
n2
|
magnitude
|
|
log_ratio_risk
|
ambiguity
|
control
|
0.0503074
|
215
|
317
|
negligible
|
|
log_ratio_risk
|
ambiguity
|
risk
|
0.0499682
|
215
|
221
|
negligible
|
|
log_ratio_risk
|
control
|
risk
|
-0.0000899
|
317
|
221
|
negligible
|
cohens_d(log_ratio_risk ~ condition, data = data_model %>% filter (task == "scl")) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
effsize
|
n1
|
n2
|
magnitude
|
|
log_ratio_risk
|
ambiguity
|
control
|
0.0355791
|
242
|
357
|
negligible
|
|
log_ratio_risk
|
ambiguity
|
risk
|
-0.0510984
|
242
|
235
|
negligible
|
|
log_ratio_risk
|
control
|
risk
|
-0.0870862
|
357
|
235
|
negligible
|
cohens_d(log_ratio_risk ~ condition, data = data_model %>% filter (task == "cem")) %>% kbl %>% kable_classic_2()
|
.y.
|
group1
|
group2
|
effsize
|
n1
|
n2
|
magnitude
|
|
log_ratio_risk
|
ambiguity
|
control
|
-0.0112289
|
244
|
359
|
negligible
|
|
log_ratio_risk
|
ambiguity
|
risk
|
-0.0931110
|
244
|
245
|
negligible
|
|
log_ratio_risk
|
control
|
risk
|
-0.0798139
|
359
|
245
|
negligible
|