Moral Dynamics
Tobias Gerstenberg
May 17, 2021
1 Load packages
library("knitr") # for RMarkdown commands
library("kableExtra") # for nice tables
library("tidyjson") # for reading json files
library("corrr") # for correlation tables
library("RSQLite") # for reading databases
library("broom.mixed") # for tidying regressions
library("brms") # for Bayesian models
library("tidybayes") # for Bayesian models
library("DT") # for html tables
library("emmeans") # for estimated marginal means
library("Hmisc") # for bootstrapping
library("patchwork") # for figure panels
library("png") # adding pngs to images
library("janitor") # for cleaning column names
library("egg") # for geom_custom
library("grid") # functions for dealing with images
library("magick") # read in images
library("ggpubr") # put image in background
library("xtable") # for latex tables
library("ggtext") # for text in ggplots
library("tidyverse") # for data wrangling, visualization, etc. 2 Helper functions
theme_set(theme_classic() +
theme(text = element_text(size = 24)))
opts_chunk$set(comment = "",
fig.show = "hold")
options(dplyr.summarise.inform = F)
# mapping conditions to colors
condition_colors = c("effort" = "#f4a261",
"causality" = "#e9c46a",
"responsibility" = "#2a9d8f",
"badness" = "#264653",
"moral" = "#264653")
# function for printing out html or latex tables
print_table = function(data, format = "html", digits = 2){
if(format == "html"){
data %>%
kable(digits = digits) %>%
kable_styling()
}else if(format == "latex"){
data %>%
xtable(digits = digits,
caption = "Caption",
label = "tab:table") %>%
print(include.rownames = F,
booktabs = T,
sanitize.colnames.function = identity,
caption.placement = "top")
}
}
# rmse
rmse = function(x, y){
return(sqrt(mean((x - y)^2)))
}
# scatter plots
func_scatter_plot = function(data, model, fit, xlabel, ylabel, condition){
df.plot = data %>%
group_by(clip) %>%
summarize(value = smean.cl.boot(rating)) %>%
mutate(index = c("rating", "low", "high")) %>%
ungroup() %>%
pivot_wider(names_from = index,
values_from = value) %>%
left_join(model,
by = "clip")
df.plot = fit %>%
fitted(newdata = df.plot,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.plot) %>%
bind_cols(fit %>%
predict(newdata = df.plot,
re_formula = NA,
probs = c(0.25, 0.75)) %>%
as_tibble() %>%
clean_names() %>%
rename(prediction = estimate,
prediction_low = q25,
prediction_high = q75) %>%
select(-est_error))
x = "estimate"
y = "rating"
ggplot(data = df.plot,
mapping = aes(x = estimate,
y = rating)) +
geom_abline(intercept = 0,
slope = 1,
linetype = 2) +
geom_ribbon(mapping = aes(ymin = prediction_low,
ymax = prediction_high),
stat = "identity",
alpha = 0.2,
fill = "lightblue") +
geom_smooth(mapping = aes(y = estimate,
ymin = q2_5,
ymax = q97_5),
stat = "identity",
color = "lightblue",
alpha = 0.4,
fill = "lightblue") +
geom_linerange(mapping = aes(ymin = low,
ymax = high),
size = 1,
color = "gray80") +
geom_point(size = 2.5,
shape = 21,
color = "black",
fill = condition_colors[condition]) +
annotate(geom = "text",
label = df.plot %>%
summarize(r = cor(.data[[x]], .data[[y]]),
rmse = rmse(.data[[x]], .data[[y]])) %>%
mutate(across(.fns = ~ round(., 2))) %>%
unlist() %>%
str_c(names(.), " = ", .),
x = c(0, 0),
y = c(100, 90),
size = 7,
hjust = 0) +
labs(x = xlabel,
y = ylabel) +
scale_color_manual(values = c("black", "#e41a1c"),
guide = F) +
scale_x_continuous(breaks = seq(0, 100, 25)) +
scale_y_continuous(breaks = seq(0, 100, 25)) +
coord_cartesian(xlim = c(0, 100),
ylim = c(0, 100)) +
theme(text = element_text(size = 30),
axis.title.x = element_markdown(size = 30))
}3 Model predictions
df.model.effort = read_csv("../../data/model/model_effort.csv") %>%
select(-X1)
df.model.causality = read_csv("../../data/model/model_causality.csv") %>%
select(-X1)
df.model.features = read_csv("../../data/model/model_features.csv") %>%
select(-X1)4 EXPERIMENT 1
4.1 DATA
4.1.1 Read in data
set.seed(1)
# Connect to database file and collect data
con = dbConnect(SQLite(),
dbname = "../../data/empirical/experiment1_anonymized.db")
df.exp1.data = dbReadTable(con, "moral_dynamics")
dbDisconnect(con)
# filter out incompletes
df.exp1.data = df.exp1.data %>%
filter(status %in% 3:5) %>%
filter(codeversion == "experiment_1")
# collect the demographic data
df.exp1.demographics = df.exp1.data$datastring %>%
spread_values(condition = jstring("condition"),
age = jstring("questiondata", "age"),
gender = jstring("questiondata", "sex"),
feedback = jstring("questiondata", "feedback")) %>%
rename(participant = document.id) %>%
mutate(time = difftime(df.exp1.data$endhit,
df.exp1.data$beginhit,
units = "mins")) %>%
as_tibble() %>%
mutate(age = as.numeric(age))
# structure the trial data
df.exp1.long = df.exp1.data$datastring %>%
as.tbl_json() %>%
enter_object("data") %>%
gather_array("order") %>%
enter_object("trialdata") %>%
spread_values(clip = jstring("clip"),
display = jstring("order"),
rating = jstring("rating")) %>%
as_tibble() %>%
rename(participant = document.id) %>%
mutate(clip = str_remove_all(clip, pattern = "video")) %>%
separate(clip, into = c("clip_left", "clip_right")) %>%
mutate(across(c(participant, contains("clip"), rating), ~ as.numeric(.))) %>%
mutate(clips = str_c(clip_left, clip_right, sep = "_")) %>%
# flip rating scale
mutate(rating = ifelse(display == "flipped", 7 - rating, rating),
clips = factor(clips, levels = c("11_7",
"9_2",
"11_4",
"10_3",
"7_12",
"7_4",
"6_5",
"4_12",
"3_1",
"10_9",
"8_10")),
clip_index = factor(clips,
labels = 1:11)) %>%
relocate(clip_index, .after = participant) %>%
arrange(participant, clip_index)
# flip the 8_10 trial to 10_8 so that the left video is always the one with more
# effort
df.exp1.long = df.exp1.long %>%
mutate(clips = fct_recode(clips, `10_8` = "8_10"),
clip_left = ifelse(clips == "10_8", 10, clip_left),
clip_right = ifelse(clips == "10_8", 8, clip_right),
rating = ifelse(clips == "10_8", 7 - rating, rating),
preference = ifelse(rating <= 3, "left", "right"))
# read in results from moral kinematics experiment
df.exp1.kinematics = read.csv("../../data/empirical/moral_kinematics.csv")
# save the trial info
df.exp1.trialinfo = df.exp1.long %>%
filter(participant == 1) %>%
select(clip_index, clips, contains("causality"), contains("effort"))
# mean on the trial level
df.exp1.means = df.exp1.long %>%
group_by(clip_index, clips) %>%
summarize(rating = smean.cl.boot(rating)) %>%
mutate(index = c("mean", "low", "high")) %>%
pivot_wider(names_from = index,
values_from = rating)
# counts
df.exp1.counts = df.exp1.long %>%
mutate(rating = as.factor(rating)) %>%
count(clip_index, rating, .drop = F) %>%
group_by(clip_index) %>%
mutate(p = n / sum(n)) %>%
ungroup() %>%
left_join(df.exp1.trialinfo %>%
select(clip_index, clips),
by = "clip_index") %>%
relocate(clips, .after = clip_index)4.1.2 Demographics
df.exp1.demographics %>%
summarize(age_mean = mean(age),
age_sd = sd(age),
n_female = sum(gender == "female"),
n_male = sum(gender == "male"),
n_other = sum(!gender %in% c("female", "male")),
n = n(),
time_mean = mean(time),
time_sd = sd(time)) %>%
print_table(digits = 1)| age_mean | age_sd | n_female | n_male | n_other | n | time_mean | time_sd |
|---|---|---|---|---|---|---|---|
| 34.5 | 10.4 | 11 | 34 | 1 | 46 | 10 mins | 3.1 |
4.1.3 Feedback
df.exp1.demographics %>%
select(participant, time, feedback) %>%
mutate(time = round(time, 2)) %>%
datatable(height = 800)4.2 STATS
4.2.1 Choices
4.2.1.1 Overall
df.exp1.long %>%
count(preference) %>%
mutate(p = n/sum(n)) %>%
print_table()| preference | n | p |
|---|---|---|
| left | 398 | 0.79 |
| right | 108 | 0.21 |
4.2.1.2 Per participant
df.exp1.long %>%
group_by(participant) %>%
count(preference, name = "n_left") %>%
filter(row_number() %% 2 == 1) %>%
ungroup() %>%
count(n_left, name = "n_participants") %>%
pivot_wider(names_from = n_left,
values_from = n_participants) %>%
mutate(`# chosen more effort clip` = "# participants") %>%
relocate(`# chosen more effort clip`) %>%
print_table()| # chosen more effort clip | 4 | 5 | 7 | 8 | 9 | 10 | 11 |
|---|---|---|---|---|---|---|---|
| # participants | 2 | 2 | 1 | 13 | 15 | 9 | 4 |
4.2.1.3 Per trial
df.exp1.long %>%
group_by(clip_index, clips) %>%
count(preference) %>%
summarize(p = n/sum(n)) %>%
filter(row_number() %% 2 == 1) %>%
print_table()| clip_index | clips | p |
|---|---|---|
| 1 | 11_7 | 0.93 |
| 2 | 9_2 | 0.93 |
| 3 | 11_4 | 0.89 |
| 4 | 10_3 | 0.87 |
| 5 | 7_12 | 0.87 |
| 6 | 7_4 | 0.85 |
| 7 | 6_5 | 0.83 |
| 8 | 4_12 | 0.80 |
| 9 | 3_1 | 0.78 |
| 10 | 10_9 | 0.63 |
| 11 | 10_8 | 0.26 |
4.3 PLOTS
4.3.1 Bar plot
df.plot = df.exp1.counts %>%
separate(clips,
into = c("clip_left", "clip_right"),
remove = F) %>%
mutate(clip_index = as.numeric(as.character(clip_index)))
df.image_order = df.plot %>%
distinct(clip_index, clip_left, clip_right) %>%
mutate(across(.fns = ~as.numeric(.)))
# Determine the clip labels for the figure
clip_labels = df.plot %>%
distinct(clip_left, clip_right) %>%
t() %>%
as.numeric() %>%
as.factor()
df.plot = df.plot %>%
mutate(clip_left_labeled = factor(clip_left,
levels = unique(clip_labels),
labels = levels(clip_labels)),
clip_right_labeled = factor(clip_right,
levels = unique(clip_labels),
labels = levels(clip_labels)))
df.exp1.mapping = df.plot %>%
select(contains("clip_")) %>%
distinct() %>%
rename(trial = clip_index)
fun_image = function(grob, label){
ggplot() +
background_image(grob) +
annotate(geom = "text",
x = 0.05,
y = 0.95,
hjust = 0,
vjust = 1,
label = label,
size = 10,
color = "white") +
theme_void() +
coord_cartesian(xlim = c(0, 1),
ylim = c(0, 1),
expand = F) +
theme(plot.margin = margin(b = 0.2, r = 0.1, l = 0.1, unit = "cm"))
}
# images
df.images = tibble(clip = 1:12,
label = factor(clip,
levels = unique(clip_labels),
labels = 1:12)) %>%
mutate(grob = map(.x = clip,
.f = ~ image_read(path =
str_c("../../figures/diagrams/experiment1/video",
.x, ".png"))),
plot = map2(.x = grob,
.y = label,
.f = ~ fun_image(grob = .x, label = .y)))
# spacer
pspace = ggplot() +
theme_void() +
theme(plot.margin = margin(b = 0.2, unit = "cm"))
# text
df.text = df.plot %>%
distinct(clip_index) %>%
mutate(label = str_c("trial ", 1:n()),
x = 3.5,
y = Inf)
# plot 1
p1 = ggplot(data = df.plot %>%
filter(clip_index <= 6),
mapping = aes(x = rating,
y = p)) +
geom_col(color = "black",
fill = condition_colors["badness"],
alpha = 0.75) +
geom_text(data = df.text %>%
filter(clip_index <= 6),
mapping = aes(label = label,
x = x,
y = y),
vjust = 1.2,
size = 8) +
facet_wrap(~ clip_index,
ncol = 1) +
scale_x_discrete(labels = c("left\nworse", "", "", "", "", "right\nworse")) +
scale_y_continuous(breaks = seq(0, 1, 0.2),
limits = c(0, 0.8)) +
labs(x = "rating",
title = "Probability of selection") +
theme(strip.background = element_blank(),
strip.text = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
axis.line.x = element_line(),
axis.ticks.y = element_blank(),
panel.grid.major.y = element_line(),
plot.title = element_text(size = 22,
hjust = 0.5),
axis.line.y = element_blank())
p2 = ggplot(data = df.plot %>%
filter(clip_index > 6),
mapping = aes(x = rating,
y = p)) +
geom_col(color = "black",
fill = condition_colors["badness"],
alpha = 0.75) +
geom_text(data = df.text %>%
filter(clip_index > 6),
mapping = aes(label = label,
x = x,
y = y),
vjust = 1.2,
size = 8) +
facet_wrap(~ clip_index,
ncol = 1) +
scale_x_discrete(labels = c("left\nworse", "", "", "", "", "right\nworse")) +
scale_y_continuous(breaks = seq(0, 1, 0.2),
limits = c(0, 0.8)) +
labs(x = "rating",
title = "Probability of selection") +
theme(strip.background = element_blank(),
strip.text = element_blank(),
axis.text.y = element_blank(),
axis.title.y = element_blank(),
axis.ticks.y = element_blank(),
axis.title.x = element_blank(),
axis.line.x = element_blank(),
axis.text.x = element_blank(),
axis.ticks.x = element_blank(),
panel.grid.major.y = element_line(),
plot.title = element_text(size = 22,
hjust = 0.5),
axis.line.y = element_blank())
layout = "
ABCDEF
GBHIEJ
KBLMEN
OBPQER
SBTUEV
WBX###
"
df.images$plot[[df.image_order$clip_left[1]]] +
p1 +
df.images$plot[[df.image_order$clip_right[1]]] +
df.images$plot[[df.image_order$clip_left[7]]] +
p2 +
df.images$plot[[df.image_order$clip_right[7]]] +
df.images$plot[[df.image_order$clip_left[2]]] +
df.images$plot[[df.image_order$clip_right[2]]] +
df.images$plot[[df.image_order$clip_left[8]]] +
df.images$plot[[df.image_order$clip_right[8]]] +
df.images$plot[[df.image_order$clip_left[3]]] +
df.images$plot[[df.image_order$clip_right[3]]] +
df.images$plot[[df.image_order$clip_left[9]]] +
df.images$plot[[df.image_order$clip_right[9]]] +
df.images$plot[[df.image_order$clip_left[4]]] +
df.images$plot[[df.image_order$clip_right[4]]] +
df.images$plot[[df.image_order$clip_left[10]]] +
df.images$plot[[df.image_order$clip_right[10]]] +
df.images$plot[[df.image_order$clip_left[5]]] +
df.images$plot[[df.image_order$clip_right[5]]] +
df.images$plot[[df.image_order$clip_left[11]]] +
df.images$plot[[df.image_order$clip_right[11]]] +
df.images$plot[[df.image_order$clip_left[6]]] +
df.images$plot[[df.image_order$clip_right[6]]] +
plot_layout(design = layout)
ggsave(filename = "../../figures/plots/experiment1_bars.pdf",
width = 12,
height = 8)
4.3.2 Stimulus figure
# images
df.images = tibble(clip = c("effort_low", "effort_medium", "effort_high",
"cause_low", "cause_medium", "cause_high"),
label = c("low effort", "medium effort", "high effort",
"low causality", "medium causality", "high causality")) %>%
mutate(grob = map(.x = clip,
.f = ~ image_read(path =
str_c("../../figures/diagrams/selection/",
.x, ".png"))),
plot = map2(.x = grob,
.y = label,
.f = ~ ggplot() +
background_image(.x) +
annotate(geom = "text",
x = 20,
y = 50,
hjust = 0,
vjust = 0,
label = .y,
size = 8,
color = "white") +
coord_fixed(xlim = c(0, 961),
ylim = c(0, 541),
expand = F) +
theme_void() +
theme(plot.margin = margin(b = 0.2,
r = 0.2,
l = 0.2, unit = "cm"))))
wrap_plots(df.images$plot) +
plot_layout(nrow = 2) +
plot_annotation(tag_levels = "A") &
theme(plot.tag = element_text(face = "bold", size = 20))
ggsave(filename = "../../figures/plots/stimuli_example.pdf",
width = 14,
height = 6)
4.4 Tables
4.4.1 Moral dynamics vs. Moral kinematics
df.exp1.long %>%
group_by(clip_index, clips) %>%
count(preference) %>%
summarize(dynamics = n/sum(n)) %>%
ungroup() %>%
filter(row_number() %% 2 == 1) %>%
left_join(df.exp1.kinematics %>%
mutate(clips = ifelse(trial == 8, "10_8", clips),
rating = ifelse(trial == 8, 1 - rating, rating)) %>%
rename(kinematics = rating),
by = "clips") %>%
select(clip_index, dynamics, kinematics) %>%
pivot_longer(cols = -clip_index,
names_to = "index",
values_to = "value") %>%
mutate(value = value * 100) %>%
pivot_wider(names_from = clip_index,
values_from = value) %>%
print_table(digits = 0)| index | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 |
|---|---|---|---|---|---|---|---|---|---|---|---|
| dynamics | 93 | 93 | 89 | 87 | 87 | 85 | 83 | 80 | 78 | 63 | 26 |
| kinematics | 69 | 100 | 75 | 94 | 100 | 82 | 75 | 75 | 82 | 82 | 25 |
5 EXPERIMENT 2
5.1 DATA
5.1.1 Read in data
set.seed(1)
# Read in data
con = dbConnect(SQLite(),dbname = "../../data/empirical/experiment2_anonymized.db");
df.exp2.data = dbReadTable(con, "moral_dynamics")
dbDisconnect(con)
# Filter out incompletes
df.exp2.data = df.exp2.data %>%
filter(status %in% 3:5) %>%
filter(codeversion %in% c("experiment_2"))
# Demographic data
df.exp2.demographics = df.exp2.data$datastring %>%
spread_values(condition = jstring("condition"),
age = jstring("questiondata", "age"),
gender = jstring("questiondata", "sex"),
feedback = jstring("questiondata", "feedback")) %>%
mutate(time = difftime(df.exp2.data$endhit, df.exp2.data$beginhit, units = "mins"),
condition = factor(condition,
levels = 0:1,
labels = c("effort", "moral"))) %>%
mutate(age = as.numeric(age)) %>%
rename(participant = document.id) %>%
as_tibble()
# Structure data
df.exp2.long = df.exp2.data$datastring %>% # Grab datastring
as.tbl_json() %>% # Structure it as a json
enter_object("data") %>% # Access the recorded data sub-object
gather_array("order") %>%
enter_object("trialdata") %>% # Access the recorded responses from the trials
gather_object("index") %>%
append_values_string("values") %>%
as_tibble() %>% # Compile everything into a dataframe
pivot_wider(names_from = index,
values_from = values) %>%
rename(participant = document.id) %>%
select(-condition) %>%
left_join(df.exp2.demographics %>%
select(participant, condition),
by = "participant") %>%
rename(rating = response) %>%
mutate(rating = as.numeric(rating)) %>%
arrange(participant)
# determine the clip order
df.clip_order2 = df.exp2.long %>%
group_by(clip) %>%
summarize(rating = mean(rating)) %>%
arrange(rating) %>%
mutate(clip_index = 1:n()) %>%
select(-rating)
df.exp2.long = df.exp2.long %>%
left_join(df.clip_order2,
by = "clip") %>%
relocate(clip_index, .after = participant)
# split data set by condition
df.exp2.long.effort = df.exp2.long %>%
filter(condition == "effort")
df.exp2.long.moral = df.exp2.long %>%
filter(condition == "moral")
# calculate means
df.exp2.means = df.exp2.long %>%
group_by(condition, clip) %>%
summarize(value = smean.cl.boot(rating)) %>%
mutate(index = c("mean", "low", "high")) %>%
pivot_wider(names_from = index,
values_from = value) %>%
ungroup() %>%
pivot_wider(names_from = condition,
values_from = c(mean, low, high)) %>%
left_join(df.clip_order2,
by = "clip") %>%
relocate(clip_index) %>%
arrange(clip_index)
# read in model predictions from best-fitting effort and causality model (determined below)
df.exp2.model = df.model.effort %>%
filter(experiment == 2) %>%
select(clip,
effort = `effort_0.56`,
) %>%
left_join(df.model.causality %>%
filter(experiment == 2) %>%
select(clip,
causality = `causality_1.7`),
by = "clip") %>%
mutate(effort = effort / max(effort)) %>%
left_join(df.model.features %>%
filter(experiment == 2),
by = "clip") %>%
mutate(across(c(distance, duration), ~ . / max(.))) %>%
left_join(df.exp2.means %>%
mutate(mean_effort = mean_effort / 100) %>%
select(clip, effort_empirical = mean_effort),
by = "clip") %>%
select(-experiment) %>%
left_join(df.clip_order2,
by = "clip") %>%
relocate(clip_index) %>%
relocate(effort_empirical, .after = effort) %>%
arrange(clip_index)5.1.2 Demographics
df.exp2.demographics %>%
summarize(age_mean = mean(age),
age_sd = sd(age),
n_female = sum(gender == "female"),
n_male = sum(gender == "male"),
n_other = sum(!gender %in% c("female", "male")),
n = n(),
time_mean = mean(time),
time_sd = sd(time)) %>%
print_table(digits = 1)| age_mean | age_sd | n_female | n_male | n_other | n | time_mean | time_sd |
|---|---|---|---|---|---|---|---|
| 35.7 | 12.7 | 42 | 40 | 1 | 83 | 8.8 mins | 4.4 |
5.1.3 Feedback
df.exp2.demographics %>%
select(participant, condition, time, feedback) %>%
mutate(time = round(time, 2)) %>%
datatable(height = 800)5.2 STATS
5.2.1 Find best-fitting effort model
df.fit = df.exp2.means %>%
select(clip, mean_effort) %>%
left_join(df.model.effort %>%
filter(experiment == 2) %>%
select(-experiment),
by = "clip") %>%
mutate(across(contains("effort_"), ~ . / max(.)))
predictor_names = df.fit %>%
select(contains("effort_")) %>%
names()
for (i in predictor_names){
df.fit = df.fit %>%
mutate("{i}" := lm(formula = str_c("mean_effort ~ ", i),
data = df.fit)$fitted.values)
}
df.fit %>%
summarize(across(contains("effort_"), list(rmse = ~ rmse(mean_effort, .x),
r = ~ cor(mean_effort, .x)))) %>%
pivot_longer(cols = everything()) %>%
mutate(name = str_remove(name, "effort_")) %>%
separate(name, into = c("effort", "index"), sep = "_") %>%
pivot_wider(names_from = index,
values_from = value) %>%
arrange(rmse)# A tibble: 100 x 3
effort rmse r
<chr> <dbl> <dbl>
1 0.56 9.25 0.914
2 0.54 9.25 0.914
3 0.55 9.26 0.914
4 0.57 9.26 0.914
5 0.53 9.27 0.914
6 0.52 9.29 0.914
7 0.58 9.30 0.913
8 0.51 9.32 0.913
9 0.59 9.34 0.913
10 0.5 9.37 0.912
# … with 90 more rows5.2.2 Bayesian models
5.2.2.1 Effort
df.data = df.exp2.long.effort %>%
left_join(df.exp2.model,
by = c("clip_index", "clip"))
fit.exp2.effort = brm(formula = rating ~ 1 + effort + (1 + effort | participant),
data = df.data,
file = "cache/fit.exp2.effort",
seed = 1)
fit.exp2.effort Family: gaussian
Links: mu = identity; sigma = identity
Formula: rating ~ 1 + effort + (1 + effort | participant)
Data: df.data (Number of observations: 714)
Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
total post-warmup samples = 4000
Group-Level Effects:
~participant (Number of levels: 42)
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
sd(Intercept) 20.60 3.01 15.50 27.01 1.00 2031
sd(effort) 22.40 4.54 13.91 31.84 1.00 1404
cor(Intercept,effort) -0.63 0.13 -0.84 -0.33 1.00 2300
Tail_ESS
sd(Intercept) 2715
sd(effort) 2017
cor(Intercept,effort) 2693
Population-Level Effects:
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept 13.37 3.64 6.24 20.50 1.00 1950 2003
effort 80.38 4.61 71.29 89.56 1.00 2836 2881
Family Specific Parameters:
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sigma 20.17 0.57 19.10 21.34 1.00 5151 3063
Samples were drawn using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).5.2.2.2 Morality
5.2.2.2.1 Baseline
df.data = df.exp2.long.moral %>%
left_join(df.exp2.model,
by = c("clip_index", "clip"))
fit.exp2.moral_baseline = brm(
formula = rating ~ 1 + (1 | participant),
data = df.data,
file = "cache/fit.exp2.moral_baseline",
seed = 1)5.2.2.2.2 Effort and causality
df.data = df.exp2.long.moral %>%
left_join(df.exp2.model,
by = c("clip_index", "clip"))
# Fit the models
fit.exp2.moral_effort = brm(
formula = rating ~ 1 + effort_empirical + (1 + effort_empirical | participant),
data = df.data,
file = "cache/fit.exp2.moral_effort",
seed = 1)
fit.exp2.moral_causality = brm(
formula = rating ~ 1 + causality + (1 + causality | participant),
data = df.data,
file = "cache/fit.exp2.moral_causality",
seed = 1)
fit.exp2.moral_effort_causality = brm(
formula = rating ~ 1 + effort_empirical + causality +
(1 + effort_empirical + causality | participant),
data = df.data,
file = "cache/fit.exp2.moral_effort_causality",
seed = 1)5.2.2.2.3 Heuristic
df.data = df.exp2.long.moral %>%
left_join(df.exp2.model,
by = c("clip_index", "clip"))
fit.exp2.moral_heuristic = brm(
formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball +
(1 | participant),
data = df.data,
file = "cache/fit.exp2.moral_heuristic",
seed = 1)5.2.2.2.3.1 Pairwise correlations between the different features
df.exp2.model %>%
mutate(across(where(is.logical), ~ . * 1)) %>%
select(where(is.numeric)) %>%
select(-c(clip_index, effort, effort_empirical)) %>%
correlate() %>%
rearrange() %>%
shave() %>%
fashion()
Correlation method: 'pearson'
Missing treated using: 'pairwise.complete.obs' term collision_agent_patient frequency duration distance
1 collision_agent_patient
2 frequency .88
3 duration .43 .41
4 distance .33 .29 .73
5 causality .42 .43 .35 .50
6 agent_moving .11 .15 .19 .43
7 fireball_moving -.17 -.01 -.27 -.27
8 collision_agent_fireball -.75 -.66 -.32 -.13
9 patient_moving -.29 -.20 -.50 -.64
causality agent_moving fireball_moving collision_agent_fireball
1
2
3
4
5
6 .61
7 .14 .20
8 .15 .20 .35
9 -.50 -.39 .03 .03
patient_moving
1
2
3
4
5
6
7
8
9 5.2.2.2.4 Model comparison
5.2.2.2.4.1 Overall
fit.exp2.moral_baseline = add_criterion(
fit.exp2.moral_baseline,
criterion = "loo",
reloo = T,
file = "cache/fit.exp2.moral_baseline")
fit.exp2.moral_effort = add_criterion(
fit.exp2.moral_effort,
criterion = "loo",
reloo = T,
file = "cache/fit.exp2.moral_effort")
fit.exp2.moral_causality = add_criterion(
fit.exp2.moral_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp2.moral_causality")
fit.exp2.moral_effort_causality = add_criterion(
fit.exp2.moral_effort_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp2.moral_effort_causality")
fit.exp2.moral_heuristic = add_criterion(
fit.exp2.moral_heuristic,
criterion = "loo",
reloo = T,
file = "cache/fit.exp2.moral_heuristic")
loo_compare(fit.exp2.moral_effort,
fit.exp2.moral_causality,
fit.exp2.moral_effort_causality,
fit.exp2.moral_heuristic,
fit.exp2.moral_baseline) elpd_diff se_diff
fit.exp2.moral_effort_causality 0.0 0.0
fit.exp2.moral_heuristic -5.5 25.4
fit.exp2.moral_effort -20.3 10.4
fit.exp2.moral_causality -103.8 15.7
fit.exp2.moral_baseline -300.5 28.3 5.2.2.2.4.2 Individual participants
df.data = df.exp2.long.moral %>%
left_join(df.exp2.model)
# initial model fits (used for compilation)
fit.exp2.moral_individual_baseline =
brm(formula = rating ~ 1,
data = df.data %>%
filter(participant == 1),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp2.moral_individual_baseline"))
fit.exp2.moral_individual_effort =
brm(formula = rating ~ 1 + effort_empirical,
data = df.data %>%
filter(participant == 1),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp2.moral_individual_effort"))
fit.exp2.moral_individual_causality =
brm(formula = rating ~ 1 + causality,
data = df.data %>%
filter(participant == 1),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp2.moral_individual_causality"))
fit.exp2.moral_individual_effort_causality =
brm(formula = rating ~ 1 + effort_empirical + causality,
data = df.data %>%
filter(participant == 1),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp2.moral_individual_effort_causality"))
fit.exp2.moral_individual_heuristic =
brm(formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball,
data = df.data %>%
filter(participant == 1),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp2.moral_individual_heuristic"))
# update model fits for different participants
df.exp2.moral.individual_fit = df.data %>%
group_by(participant) %>%
nest() %>%
ungroup() %>%
# fit model for each participant
mutate(fit_baseline = map(.x = data,
.f = ~ update(fit.exp2.moral_individual_baseline,
newdata = .x,
seed = 1)),
fit_effort = map(.x = data,
.f = ~ update(fit.exp2.moral_individual_effort,
newdata = .x,
seed = 1)),
fit_causality = map(.x = data,
.f = ~ update(fit.exp2.moral_individual_causality,
newdata = .x,
seed = 1)),
fit_effort_causality = map(.x = data,
.f = ~ update(fit.exp2.moral_individual_effort_causality,
newdata = .x,
seed = 1)),
fit_heuristic = map(.x = data,
.f = ~ update(fit.exp2.moral_individual_heuristic,
newdata = .x,
seed = 1))) %>%
mutate(fit_baseline = map(.x = fit_baseline,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort = map(.x = fit_effort,
~ add_criterion(.x,
criterion = c("loo"))),
fit_causality = map(.x = fit_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort_causality = map(.x = fit_effort_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_heuristic = map(.x = fit_heuristic,
~ add_criterion(.x,
criterion = c("loo"))),
r_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
model_comparison = pmap(.l = list(baseline = fit_baseline,
effort = fit_effort,
causality = fit_causality,
effort_causality = fit_effort_causality,
heuristic = fit_heuristic),
.f = ~ loo_compare(..1, ..2, ..3, ..4, ..5)),
best_model = map_chr(.x = model_comparison,
.f = ~ rownames(.) %>%
.[1]),
best_model = factor(best_model,
levels = c("..1", "..2", "..3", "..4", "..5"),
labels = c("baseline",
"effort",
"causality",
"effort_causality",
"heuristic")))
# save(list = c("df.exp2.moral.individual_fit"),
# file = "data/exp2_moral_individual_fit.RData")load("data/exp2_moral_individual_fit.RData")
df.exp2.moral.individual_fit %>%
count(best_model) %>%
print_table()| best_model | n |
|---|---|
| baseline | 1 |
| effort | 11 |
| causality | 2 |
| effort_causality | 9 |
| heuristic | 18 |
5.2.3 Correlations
5.2.3.1 Effort
df.data = df.exp2.long.effort %>%
group_by(clip) %>%
summarize(mean = mean(rating)) %>%
ungroup() %>%
left_join(df.exp2.model %>%
select(clip, effort),
by = "clip")
fit.exp2.effort %>%
fitted(newdata = df.data,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.data) %>%
summarize(pearson = cor(estimate, mean),
rmse = rmse(estimate, mean)) %>%
print_table()| pearson | rmse |
|---|---|
| 0.91 | 9.25 |
5.2.3.2 Moral
df.data = df.exp2.long.moral %>%
group_by(clip) %>%
summarize(mean = mean(rating)) %>%
ungroup() %>%
left_join(df.exp2.model,
by = "clip")
fit.exp2.moral_effort_causality %>%
fitted(newdata = df.data,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.data) %>%
summarize(pearson = cor(estimate, mean),
rmse = rmse(estimate, mean)) %>%
print_table()| pearson | rmse |
|---|---|
| 0.91 | 7.86 |
5.2.3.3 Effort vs. causality
df.exp2.model %>%
summarize(r = cor(effort, causality))# A tibble: 1 x 1
r
<dbl>
1 0.6325.3 PLOTS
5.3.1 Scatter plots
5.3.1.1 Effort
func_scatter_plot(data = df.exp2.long.effort,
model = df.exp2.model,
fit = fit.exp2.effort,
xlabel = "effort model<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "effort judgment",
condition = "effort")
5.3.1.2 Morality
5.3.1.2.1 Effort
p1 = func_scatter_plot(data = df.exp2.long.moral,
model = df.exp2.model,
fit = fit.exp2.moral_effort,
xlabel = "effort<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "moral judgment",
condition = "badness")
p1
5.3.1.2.2 Causality
p2 = func_scatter_plot(data = df.exp2.long.moral,
model = df.exp2.model,
fit = fit.exp2.moral_causality,
xlabel = "causality<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "moral judgment",
condition = "badness")
p2 
5.3.1.2.3 Effort + Causality
p3 = func_scatter_plot(data = df.exp2.long.moral,
model = df.exp2.model,
fit = fit.exp2.moral_effort_causality,
xlabel = "effort + causality<br><span style='font-size:26pt'>(3 parameters)</span>",
ylabel = "moral judgment",
condition = "badness")
p3
5.3.1.2.4 Heuristic
p4 = func_scatter_plot(data = df.exp2.long.moral,
model = df.exp2.model,
fit = fit.exp2.moral_heuristic,
xlabel = "kinematic features<br><span style='font-size:26pt'>(9 parameters)</span>",
ylabel = "moral judgment",
condition = "badness")
p4
##### Combined
p1 + p2 + p3 + p4 &
plot_layout(nrow = 1) &
plot_annotation(tag_levels = "A") &
theme(plot.tag = element_text(face = "bold"))
ggsave(filename = "../../figures/plots/experiment2_scatter.pdf",
width = 24,
height = 6)
5.3.2 Bar plot
set.seed(1)
df.plot = df.exp2.long
# load trial images
func_load_image = function(situation){
readPNG(str_c("../../figures/diagrams/experiment2/", situation, ".png"))
}
df.plot.model.effort = fit.exp2.effort %>%
fitted(newdata = df.exp2.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp2.model)
df.plot.model.morality = fit.exp2.moral_effort_causality %>%
fitted(newdata = df.exp2.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp2.model)
# linking images and clips
df.images = df.clip_order2 %>%
select(clip, clip_index) %>%
mutate(condition = NA,
grob = map(.x = clip, .f = ~ func_load_image(situation = .x)))
# add text
df.text = df.clip_order2 %>%
mutate(condition = NA,
x = 0.5,
y = 172)
df.exp2.mapping = df.text %>%
select(trial = clip_index,
clip)
ggplot(data = df.plot,
mapping = aes(x = condition,
y = rating,
fill = condition)) +
stat_summary(fun = "mean",
geom = "bar",
color = "black",
alpha = 0.75) +
stat_summary(fun.data = mean_cl_boot,
geom = "linerange",
color = "black") +
geom_point(position = position_jitter(width = 0.1, height = 0),
shape = 21,
alpha = 0.25,
show.legend = F) +
geom_point(data = df.plot.model.effort %>%
mutate(condition = "effort"),
mapping = aes(x = 1,
y = estimate),
shape = 21,
size = 4,
show.legend = F) +
geom_point(data = df.plot.model.morality %>%
mutate(condition = "moral"),
mapping = aes(x = 2,
y = estimate),
shape = 21,
size = 4,
show.legend = F) +
geom_custom(data = df.images,
mapping = aes(data = grob,
x = -Inf,
y = Inf),
grob_fun = function(x) rasterGrob(x,
interpolate = T,
vjust = 0,
hjust = 0)) +
geom_text(data = df.text,
mapping = aes(x = x,
y = y,
label = clip_index),
hjust = 0,
color = "white",
size = 11) +
facet_wrap(~ clip_index,
ncol = 9) +
scale_fill_manual(values = condition_colors) +
scale_y_continuous(breaks = seq(0, 100, 25),
expand = expansion(mult = 0.01)) +
labs(y = "Judgment",
x = "") +
coord_cartesian(clip = "off",
ylim = c(0, 110)) +
theme(text = element_text(size = 36),
panel.grid.major.y = element_line(),
axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.line.x = element_blank(),
axis.ticks.x = element_blank(),
legend.position = c(1, 0),
legend.justification = c(1.1, -0.4),
strip.background = element_blank(),
strip.text = element_blank(),
panel.spacing.y = unit(4.5, "cm"),
plot.margin = margin(t = 4.5, l = 0.2, r = 0.2, b = 0.5, unit = "cm"))
ggsave(filename = "../../figures/plots/experiment2_bars.pdf",
width = 24,
height = 8)
5.4 Tables
5.4.1 Model comparison
df.elpd = loo_compare(fit.exp2.moral_effort,
fit.exp2.moral_causality,
fit.exp2.moral_effort_causality,
fit.exp2.moral_heuristic,
fit.exp2.moral_baseline) %>%
as_tibble(rownames = "model") %>%
mutate(model = factor(model,
levels = c("fit.exp2.moral_effort",
"fit.exp2.moral_causality",
"fit.exp2.moral_effort_causality",
"fit.exp2.moral_heuristic",
"fit.exp2.moral_baseline"))) %>%
arrange(model)
df.posteriors = fit.exp2.moral_effort %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort") %>%
bind_rows(fit.exp2.moral_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "causality")) %>%
bind_rows(fit.exp2.moral_effort_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort + causality")) %>%
bind_rows(fit.exp2.moral_heuristic %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "kinematic features")) %>%
bind_rows(fit.exp2.moral_baseline %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "baseline")) %>%
mutate(across(where(is.numeric), ~ round(., 2)),
label = str_c(estimate, " [", conf.low, ", ", conf.high, "]")) %>%
select(model, term, label) %>%
pivot_wider(names_from = term,
values_from = label) %>%
rename(intercept = Intercept)
df.individuals = df.exp2.moral.individual_fit %>%
count(best_model)
fun_r_rmse = function(fit, dv){
df = fit %>%
fitted(newdata = df.exp2.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp2.means)
if(sd(df$estimate) > 0){
df = df %>%
summarize(r = cor(.data[[dv]], estimate),
rmse = rmse(.data[[dv]], estimate))
}else{
df = df %>%
summarize(rmse = rmse(.data[[dv]], estimate))
}
return(df)
}
df.table = tibble(model = c("effort",
"causality",
"effort + causality",
"kinematic features",
"baseline"),
formula = c(as.character(fit.exp2.moral_effort$formula[[1]][3]),
as.character(fit.exp2.moral_causality$formula[[1]][3]),
as.character(fit.exp2.moral_effort_causality$formula[[1]][3]),
as.character(fit.exp2.moral_heuristic$formula[[1]][3]),
as.character(fit.exp2.moral_baseline$formula[[1]][3])),
r = c(fun_r_rmse(fit = fit.exp2.moral_effort,
dv = "mean_moral")$r,
fun_r_rmse(fit = fit.exp2.moral_causality,
dv = "mean_moral")$r,
fun_r_rmse(fit = fit.exp2.moral_effort_causality,
dv = "mean_moral")$r,
fun_r_rmse(fit = fit.exp2.moral_heuristic,
dv = "mean_moral")$r,
NA),
rmse = c(fun_r_rmse(fit = fit.exp2.moral_effort,
dv = "mean_moral")$rmse,
fun_r_rmse(fit = fit.exp2.moral_causality,
dv = "mean_moral")$rmse,
fun_r_rmse(fit = fit.exp2.moral_effort_causality,
dv = "mean_moral")$rmse,
fun_r_rmse(fit = fit.exp2.moral_heuristic,
dv = "mean_moral")$rmse,
fun_r_rmse(fit = fit.exp2.moral_baseline,
dv = "mean_moral")$rmse),
elpd = df.elpd$elpd_diff,
elpd_se = df.elpd$se_diff) %>%
mutate(across(where(is.numeric), ~ round(., 2))) %>%
mutate(elpd = str_c(elpd, " (", elpd_se,")")) %>%
select(-elpd_se) %>%
left_join(df.posteriors,
by = "model") %>%
left_join(df.individuals %>%
mutate(best_model = str_replace(best_model,
"effort_causality",
"effort + causality"),
best_model = str_replace(best_model,
"heuristic",
"kinematic features")) %>%
rename(model = best_model,
`# best fit` = n),
by = "model") %>%
rename(effort = effort_empirical) %>%
select(model, intercept, effort, causality, r, rmse, elpd, `# best fit`)
df.table %>%
print_table()| model | intercept | effort | causality | r | rmse | elpd | # best fit |
|---|---|---|---|---|---|---|---|
| effort | 37.96 [30.7, 45.35] | 75.92 [65.72, 87.13] | NA | 0.90 | 8.46 | -20.33 (10.42) | 11 |
| causality | 46.58 [39.4, 53.39] | NA | 44.66 [37.09, 51.87] | 0.80 | 11.54 | -103.79 (15.68) | 2 |
| effort + causality | 36.73 [28.88, 43.8] | 58.78 [49.31, 68.87] | 14.29 [6.99, 20.79] | 0.91 | 7.86 | 0 (0) | 9 |
| kinematic features | 34.06 [27.87, 40.62] | NA | NA | 0.97 | 4.46 | -5.46 (25.39) | 18 |
| baseline | 81.35 [78.07, 84.63] | NA | NA | NA | 19.31 | -300.55 (28.35) | 1 |
5.4.2 Means and predictions for each trial
df.exp2.long.moral %>%
group_by(clip_index) %>%
summarize(moral = mean(rating)) %>%
left_join(df.exp2.model %>%
select(clip_index, effort, causality, effort_empirical) %>%
mutate(across(-clip_index, ~ . * 100)),
by = "clip_index") %>%
rename(model_effort = effort,
model_causality = causality,
people_effort = effort_empirical,
people_moral = moral) %>%
pivot_longer(cols = -clip_index) %>%
pivot_wider(names_from = clip_index) %>%
mutate(name = factor(name, levels = c("model_effort",
"model_causality",
"people_effort",
"people_moral"))) %>%
arrange(name) %>%
print_table()| name | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| model_effort | 15.31 | 0.00 | 48.79 | 42.88 | 38.84 | 49.03 | 43.89 | 42.88 | 49.03 | 43.08 | 43.08 | 83.09 | 83.09 | 70.01 | 93.29 | 77.44 | 100.00 |
| model_causality | 40.30 | 0.00 | 0.00 | 51.10 | 85.80 | 99.40 | 100.00 | 49.10 | 99.50 | 100.00 | 100.00 | 100.00 | 100.00 | 100.00 | 100.00 | 100.00 | 100.00 |
| people_effort | 7.93 | 6.26 | 34.24 | 54.67 | 55.05 | 58.40 | 49.26 | 56.33 | 58.71 | 52.93 | 58.07 | 72.71 | 73.93 | 78.98 | 83.86 | 83.83 | 85.81 |
| people_moral | 30.02 | 34.73 | 62.10 | 84.00 | 84.80 | 81.71 | 91.27 | 86.02 | 85.71 | 92.24 | 93.61 | 88.61 | 91.32 | 89.73 | 91.90 | 94.46 | 96.46 |
5.4.3 Pairwise correlations
df.exp2.means %>%
select(clip,
morality = mean_moral) %>%
ungroup() %>%
left_join(df.exp2.model %>%
rename(effort = effort_empirical,
effort_model = effort,
causality_model = causality),
by = c("clip")) %>%
select(-c(clip, clip_index)) %>%
relocate(effort) %>%
correlate() %>%
shave() %>%
fashion() %>%
print_table()| term | effort | morality | effort_model | causality_model | distance | duration | frequency | agent_moving | patient_moving | fireball_moving | collision_agent_patient | collision_agent_fireball |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| effort | ||||||||||||
| morality | .90 | |||||||||||
| effort_model | .91 | .72 | ||||||||||
| causality_model | .78 | .80 | .63 | |||||||||
| distance | .83 | .54 | .85 | .50 | ||||||||
| duration | .57 | .33 | .68 | .35 | .73 | |||||||
| frequency | .36 | .28 | .35 | .43 | .29 | .41 | ||||||
| agent_moving | .80 | .92 | .66 | .61 | .43 | .19 | .15 | |||||
| patient_moving | -.66 | -.57 | -.67 | -.50 | -.64 | -.50 | -.20 | -.39 | ||||
| fireball_moving | .02 | .16 | -.18 | .14 | -.27 | -.27 | -.01 | .20 | .03 | |||
| collision_agent_patient | .33 | .25 | .28 | .42 | .33 | .43 | .88 | .11 | -.29 | -.17 | ||
| collision_agent_fireball | .08 | .19 | .00 | .15 | -.13 | -.32 | -.66 | .20 | .03 | .35 | -.75 |
5.4.4 Individual predictors
df.exp2.predictors = df.exp2.model %>%
mutate(across(where(is.logical), ~ . * 1)) %>%
left_join(df.exp2.means %>%
select(clip, moral = mean_moral),
by = "clip") %>%
summarize(across(c(effort:collision_agent_fireball), ~ cor(., moral))) %>%
rename(effort_model = effort,
effort = effort_empirical,
causality_model = causality) %>%
pivot_longer(cols = everything(),
names_to = "predictor",
values_to = "r")
df.exp2.predictors %>%
print_table()| predictor | r |
|---|---|
| effort_model | 0.72 |
| effort | 0.90 |
| causality_model | 0.80 |
| distance | 0.54 |
| duration | 0.33 |
| frequency | 0.28 |
| agent_moving | 0.92 |
| patient_moving | -0.57 |
| fireball_moving | 0.16 |
| collision_agent_patient | 0.25 |
| collision_agent_fireball | 0.19 |
5.4.5 Heuristic model
fit.exp2.moral_heuristic %>%
tidy(conf.level = 0.95) %>%
filter(effect == "fixed") %>%
mutate(term = str_to_lower(term),
term = str_remove(term, "true"),
term = str_replace_all(term, "_", " "),
term = str_replace(term, fixed("(intercept)"), "intercept")) %>%
select("predictor" = term,
"posterior mean" = estimate,
"95% credible interval (lower bound)" = conf.low,
"95% credible interval (upper bound)" = conf.high) %>%
print_table()| predictor | posterior mean | 95% credible interval (lower bound) | 95% credible interval (upper bound) |
|---|---|---|---|
| intercept | 34.06 | 27.59 | 40.35 |
| distance | -2.18 | -8.94 | 4.26 |
| duration | 4.26 | -2.90 | 11.51 |
| frequency | 4.97 | 0.67 | 9.35 |
| agent moving | 44.94 | 40.08 | 49.70 |
| patient moving | -7.63 | -11.07 | -4.20 |
| fireball moving | -2.59 | -6.27 | 1.13 |
| collision agent patient | 7.36 | 0.97 | 13.87 |
| collision agent fireball | 14.89 | 9.73 | 20.15 |
6 EXPERIMENT 3
6.1 DATA
6.1.1 Read in data
# Connect to database file and collect data
con = dbConnect(SQLite(), dbname = "../../data/empirical/experiment3_anonymized.db");
df.exp3.data = dbReadTable(con, "moral_dynamics")
dbDisconnect(con)
# Filter out incomplete trials by users
df.exp3.data = df.exp3.data %>%
filter(status %in% 3:5) %>%
filter(codeversion %in% c("experiment_3"))
# Collect the demographic data
df.exp3.demographics = df.exp3.data$datastring %>%
spread_values(condition = jstring("condition"),
age = jstring("questiondata","age"),
gender = jstring("questiondata","sex"),
feedback = jstring("questiondata","feedback"),
question = jstring("questiondata","question_index")) %>%
as_tibble() %>%
mutate(time = difftime(df.exp3.data$endhit, df.exp3.data$beginhit, units = "mins"),
question = replace_na(question, "responsibility"),
age = as.numeric(age)) %>%
rename(participant = document.id)
# Structure the trial data
df.exp3.long = df.exp3.data$datastring %>% # Grab datastring
as.tbl_json() %>% # Structure it as a json
enter_object("data") %>% # Access the recorded data sub-object
gather_array("order") %>%
enter_object("trialdata") %>% # Access the recorded responses from the trials
gather_object("index") %>%
append_values_string("values") %>%
as_tibble() %>% # Compile everything into a dataframe
pivot_wider(names_from = index,
values_from = values) %>%
rename(participant = document.id) %>%
mutate(response = as.numeric(response)) %>%
rename(rating = response) %>%
left_join(df.exp3.demographics %>%
select(participant, question),
by = "participant")
# find participants who didn't pass the attention check
df.exp3.attention = df.exp3.long %>%
filter(clip == "botcheck") %>%
filter((question == "responsibility" & rating > 50) |
(question == "effort" & rating > 50) |
(question == "causality" & rating < 50) |
(question == "badness" & rating > 50))
# exclude participants who didn't pass the attention check
df.exp3.long = df.exp3.long %>%
filter(!participant %in% df.exp3.attention$participant,
clip != "botcheck") %>%
# mutate(clip = str_remove(clip, "video"),
mutate(rating = ifelse(question == "causality",
100 - rating, # flip causality
rating)) %>%
select(participant, clip, order, question, rating, -condition) %>%
arrange(participant, clip)
# add a clip_index
df.clip_order3 = df.exp3.long %>%
group_by(clip) %>%
summarize(rating = mean(rating)) %>%
arrange(rating) %>%
mutate(clip_index = 1:n()) %>%
ungroup() %>%
select(-rating)
df.exp3.long = df.exp3.long %>%
left_join(df.clip_order3,
by = "clip")
# mean judgments per clip
df.exp3.means = df.exp3.long %>%
group_by(question, clip, clip_index) %>%
summarize(value = mean(rating)) %>%
ungroup() %>%
pivot_wider(names_from = question,
values_from = value) %>%
arrange(clip_index)
# read in model predictions from best-fitting effort and causality model (determined below)
df.exp3.model = df.model.effort %>%
filter(experiment == 3) %>%
select(clip, effort_model = `effort_0.56`) %>%
left_join(df.model.causality %>%
filter(experiment == 3) %>%
select(clip,
causality_model = `causality_1.7`),
by = "clip") %>%
left_join(df.model.features %>%
filter(experiment == 3),
by = "clip") %>%
left_join(df.exp3.means,
by = c("clip")) %>%
mutate(across(c(distance,
duration,
effort_model),
~ . / max(.)),
across(c(effort,
causality,
responsibility,
badness),
~ . / 100)) %>%
relocate(clip_index, .after = clip) %>%
arrange(clip_index)6.1.2 Demographics
df.exp3.demographics %>%
summarize(age_mean = mean(age),
age_sd = sd(age),
n_female = sum(gender == "female"),
n_male = sum(gender == "male"),
n_other = sum(!gender %in% c("female", "male")),
n = n(),
time_mean = mean(time),
time_sd = sd(time),
n_excluded = nrow(df.exp3.attention)) %>%
print_table(digits = 1)| age_mean | age_sd | n_female | n_male | n_other | n | time_mean | time_sd | n_excluded |
|---|---|---|---|---|---|---|---|---|
| 37.9 | 11.8 | 86 | 144 | 3 | 233 | 10.9 mins | 4.7 | 24 |
6.1.3 Feedback
df.exp3.demographics %>%
select(participant, time, question, feedback) %>%
mutate(time = round(time, 2)) %>%
datatable(height = 800)6.2 STATS
6.2.1 Find best-fitting effort and causality model
df.fit = df.exp3.means %>%
select(clip, causality, effort) %>%
left_join(df.model.effort %>%
filter(experiment == 3) %>%
select(-experiment),
by = "clip") %>%
left_join(df.model.causality %>%
filter(experiment == 3) %>%
select(-experiment),
by = "clip") %>%
mutate(across(contains("effort_"), ~ . / max(.)))
predictor_names = df.fit %>%
select(contains("effort_"), contains("causality_")) %>%
names()
for (i in predictor_names){
df.fit = df.fit %>%
mutate("{i}" := lm(formula = str_c(str_extract(i, "[a-z]+"), " ~ ", i),
data = df.fit)$fitted.values)
}
df.fit %>%
summarize(across(contains("effort_"), list(rmse = ~ rmse(effort, .x),
r = ~ cor(effort, .x))),
across(contains("causality_"), list(rmse = ~ rmse(causality, .x),
r = ~ cor(causality, .x)))) %>%
pivot_longer(cols = everything()) %>%
separate(name,
into = c("variable", "parameter", "measure"),
sep = "_") %>%
pivot_wider(names_from = measure,
values_from = value) %>%
group_by(variable) %>%
filter(rmse == min(rmse)) %>%
ungroup()# A tibble: 2 x 4
variable parameter rmse r
<chr> <chr> <dbl> <dbl>
1 effort 0.56 8.47 0.897
2 causality 1.7 11.6 0.9146.2.2 Bayesian models
6.2.2.1 Effort
df.data = df.exp3.long %>%
filter(question == "effort") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
fit.exp3.effort = brm(
formula = rating ~ 1 + effort_model + (1 + effort_model | participant),
data = df.data,
file = "cache/fit.exp3.effort",
seed = 1)6.2.2.2 Causality
df.data = df.exp3.long %>%
filter(question == "causality") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
fit.exp3.causality = brm(
formula = rating ~ 1 + causality_model + (1 + causality_model | participant),
data = df.data,
file = "cache/fit.exp3.causality",
seed = 1)6.2.2.3 Responsibility
6.2.2.3.1 Overall
df.data = df.exp3.long %>%
filter(question == "responsibility") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
# Fit the models
fit.exp3.responsibility_baseline = brm(
formula = rating ~ 1 + (1 | participant),
data = df.data,
file = "cache/fit.exp3.responsibility_baseline",
seed = 1)
fit.exp3.responsibility_effort = brm(
formula = rating ~ 1 + effort + (1 + effort | participant),
data = df.data,
file = "cache/fit.exp3.responsibility_effort",
seed = 1)
fit.exp3.responsibility_causality = brm(
formula = rating ~ 1 + causality + (1 + causality | participant),
data = df.data,
file = "cache/fit.exp3.responsibility_causality",
seed = 1)
fit.exp3.responsibility_effort_causality = brm(
formula = rating ~ 1 + effort + causality + (1 + effort + causality | participant),
data = df.data,
file = "cache/fit.exp3.responsibility_effort_causality",
seed = 1)
fit.exp3.responsibility_heuristic = brm(
formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball +
(1 | participant),
data = df.data,
file = "cache/fit.exp3.responsibility_heuristic",
seed = 1)
# Model comparison
fit.exp3.responsibility_baseline = add_criterion(
fit.exp3.responsibility_baseline,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.responsibility_baseline")
fit.exp3.responsibility_effort = add_criterion(
fit.exp3.responsibility_effort,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.responsibility_effort")
fit.exp3.responsibility_causality = add_criterion(
fit.exp3.responsibility_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.responsibility_causality")
fit.exp3.responsibility_effort_causality = add_criterion(
fit.exp3.responsibility_effort_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.responsibility_effort_causality")
fit.exp3.responsibility_heuristic = add_criterion(
fit.exp3.responsibility_heuristic,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.responsibility_heuristic")
# model comparison
loo_compare(fit.exp3.responsibility_effort,
fit.exp3.responsibility_causality,
fit.exp3.responsibility_effort_causality,
fit.exp3.responsibility_heuristic,
fit.exp3.responsibility_baseline) elpd_diff se_diff
fit.exp3.responsibility_effort_causality 0.0 0.0
fit.exp3.responsibility_heuristic -45.6 15.5
fit.exp3.responsibility_effort -130.8 18.7
fit.exp3.responsibility_causality -251.7 24.7
fit.exp3.responsibility_baseline -371.0 26.6 6.2.2.3.2 Individual Participants
df.data = df.exp3.long %>%
filter(question == "responsibility") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
# initial model fits (used for compilation)
fit.exp3.responsibility_individual_baseline =
brm(formula = rating ~ 1,
data = df.data %>%
filter(participant == 2),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.responsibility_individual_baseline"))
fit.exp3.responsibility_individual_effort =
brm(formula = rating ~ 1 + effort,
data = df.data %>%
filter(participant == 2),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.responsibility_individual_effort"))
fit.exp3.responsibility_individual_causality =
brm(formula = rating ~ 1 + causality,
data = df.data %>%
filter(participant == 2),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.responsibility_individual_causality"))
fit.exp3.responsibility_individual_effort_causality =
brm(formula = rating ~ 1 + effort + causality,
data = df.data %>%
filter(participant == 2),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.responsibility_individual_effort_causality"))
fit.exp3.responsibility_individual_heuristic =
brm(formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball,
data = df.data %>%
filter(participant == 2),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.responsibility_individual_heuristic"))
# update model fits for different participants
df.exp3.responsibility.individual_fit = df.data %>%
group_by(participant) %>%
nest() %>%
ungroup() %>%
# fit model for each participant
mutate(fit_baseline = map(.x = data,
.f = ~ update(fit.exp3.responsibility_individual_baseline,
newdata = .x,
seed = 1)),
fit_effort = map(.x = data,
.f = ~ update(fit.exp3.responsibility_individual_effort,
newdata = .x,
seed = 1)),
fit_causality = map(.x = data,
.f = ~ update(fit.exp3.responsibility_individual_causality,
newdata = .x,
seed = 1)),
fit_effort_causality = map(.x = data,
.f = ~ update(fit.exp3.responsibility_individual_effort_causality,
newdata = .x,
seed = 1)),
fit_heuristic = map(.x = data,
.f = ~ update(fit.exp3.responsibility_individual_heuristic,
newdata = .x,
seed = 1))) %>%
mutate(fit_baseline = map(.x = fit_baseline,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort = map(.x = fit_effort,
~ add_criterion(.x,
criterion = c("loo"))),
fit_causality = map(.x = fit_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort_causality = map(.x = fit_effort_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_heuristic = map(.x = fit_heuristic,
~ add_criterion(.x,
criterion = c("loo"))),
r_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
model_comparison = pmap(.l = list(baseline = fit_baseline,
effort = fit_effort,
causality = fit_causality,
effort_causality = fit_effort_causality,
heuristic = fit_heuristic),
.f = ~ loo_compare(..1, ..2, ..3, ..4, ..5)),
best_model = map_chr(.x = model_comparison,
.f = ~ rownames(.) %>%
.[1]),
best_model = factor(best_model,
levels = c("..1", "..2", "..3", "..4", "..5"),
labels = c("baseline",
"effort",
"causality",
"effort_causality",
"heuristic")))
save(list = c("df.exp3.responsibility.individual_fit"),
file = "data/exp3_responsibility_individual_fit.RData")load("data/exp3_responsibility_individual_fit.RData")
df.exp3.responsibility.individual_fit %>%
count(best_model) %>%
print_table()| best_model | n |
|---|---|
| baseline | 3 |
| effort | 13 |
| causality | 7 |
| effort_causality | 24 |
| heuristic | 8 |
6.2.2.4 Badness
6.2.2.4.1 Overall
df.data = df.exp3.long %>%
filter(question == "badness") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
# Fit the models
fit.exp3.badness_baseline = brm(
formula = rating ~ 1 + (1 | participant),
data = df.data,
file = "cache/fit.exp3.badness_baseline",
seed = 1)
fit.exp3.badness_effort = brm(
formula = rating ~ 1 + effort + (1 + effort | participant),
data = df.data,
file = "cache/fit.exp3.badness_effort",
seed = 1)
fit.exp3.badness_causality = brm(
formula = rating ~ 1 + causality + (1 + causality | participant),
data = df.data,
file = "cache/fit.exp3.badness_causality",
seed = 1)
fit.exp3.badness_effort_causality = brm(
formula = rating ~ 1 + effort + causality + (1 + effort + causality | participant),
data = df.data,
file = "cache/fit.exp3.badness_effort_causality",
seed = 1)
fit.exp3.badness_heuristic = brm(
formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball +
(1 | participant),
data = df.data,
file = "cache/fit.exp3.badness_heuristic",
seed = 1)
# Model comparison
fit.exp3.badness_baseline = add_criterion(
fit.exp3.badness_baseline,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.badness_baseline")
fit.exp3.badness_effort = add_criterion(
fit.exp3.badness_effort,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.badness_effort")
fit.exp3.badness_causality = add_criterion(
fit.exp3.badness_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.badness_causality")
fit.exp3.badness_effort_causality = add_criterion(
fit.exp3.badness_effort_causality,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.badness_effort_causality")
fit.exp3.badness_heuristic = add_criterion(
fit.exp3.badness_heuristic,
criterion = "loo",
reloo = T,
file = "cache/fit.exp3.badness_heuristic")
# model comparison
loo_compare(fit.exp3.badness_effort,
fit.exp3.badness_causality,
fit.exp3.badness_effort_causality,
fit.exp3.badness_heuristic,
fit.exp3.badness_baseline) elpd_diff se_diff
fit.exp3.badness_effort 0.0 0.0
fit.exp3.badness_effort_causality -1.0 1.2
fit.exp3.badness_heuristic -75.7 13.7
fit.exp3.badness_causality -328.2 28.4
fit.exp3.badness_baseline -336.9 28.0 6.2.2.4.2 Individual Participants
df.data = df.exp3.long %>%
filter(question == "badness") %>%
left_join(df.exp3.model,
by = c("clip", "clip_index"))
# initial model fits (used for compilation)
fit.exp3.badness_individual_baseline =
brm(formula = rating ~ 1,
data = df.data %>%
filter(participant == 61),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.badness_individual_baseline"))
fit.exp3.badness_individual_effort =
brm(formula = rating ~ 1 + effort,
data = df.data %>%
filter(participant == 61),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.badness_individual_effort"))
fit.exp3.badness_individual_causality =
brm(formula = rating ~ 1 + causality,
data = df.data %>%
filter(participant == 61),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.badness_individual_causality"))
fit.exp3.badness_individual_effort_causality =
brm(formula = rating ~ 1 + effort + causality,
data = df.data %>%
filter(participant == 61),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.badness_individual_effort_causality"))
fit.exp3.badness_individual_heuristic =
brm(formula = rating ~ 1 +
distance +
duration +
frequency +
agent_moving +
patient_moving +
fireball_moving +
collision_agent_patient +
collision_agent_fireball,
data = df.data %>%
filter(participant == 61),
cores = 4,
chains = 4,
iter = 4000,
seed = 1,
file = str_c("cache/fit.exp3.badness_individual_heuristic"))
# update model fits for different participants
df.exp3.badness.individual_fit = df.data %>%
group_by(participant) %>%
nest() %>%
ungroup() %>%
# fit model for each participant
mutate(fit_baseline = map(.x = data,
.f = ~ update(fit.exp3.badness_individual_baseline,
newdata = .x,
seed = 1)),
fit_effort = map(.x = data,
.f = ~ update(fit.exp3.badness_individual_effort,
newdata = .x,
seed = 1)),
fit_causality = map(.x = data,
.f = ~ update(fit.exp3.badness_individual_causality,
newdata = .x,
seed = 1)),
fit_effort_causality = map(.x = data,
.f = ~ update(fit.exp3.badness_individual_effort_causality,
newdata = .x,
seed = 1)),
fit_heuristic = map(.x = data,
.f = ~ update(fit.exp3.badness_individual_heuristic,
newdata = .x,
seed = 1))) %>%
mutate(fit_baseline = map(.x = fit_baseline,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort = map(.x = fit_effort,
~ add_criterion(.x,
criterion = c("loo"))),
fit_causality = map(.x = fit_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_effort_causality = map(.x = fit_effort_causality,
~ add_criterion(.x,
criterion = c("loo"))),
fit_heuristic = map(.x = fit_heuristic,
~ add_criterion(.x,
criterion = c("loo"))),
r_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
r_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ cor(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort = map2_dbl(.x = data,
.y = fit_effort,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_causality = map2_dbl(.x = data,
.y = fit_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_effort_causality = map2_dbl(.x = data,
.y = fit_effort_causality,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
rmse_heuristic = map2_dbl(.x = data,
.y = fit_heuristic,
.f = ~ rmse(.x$rating, .y %>%
fitted() %>%
.[, 1])),
model_comparison = pmap(.l = list(baseline = fit_baseline,
effort = fit_effort,
causality = fit_causality,
effort_causality = fit_effort_causality,
heuristic = fit_heuristic),
.f = ~ loo_compare(..1, ..2, ..3, ..4, ..5)),
best_model = map_chr(.x = model_comparison,
.f = ~ rownames(.) %>%
.[1]),
best_model = factor(best_model,
levels = c("..1", "..2", "..3", "..4", "..5"),
labels = c("baseline",
"effort",
"causality",
"effort_causality",
"heuristic")))
save(list = c("df.exp3.badness.individual_fit"),
file = "data/exp3_badness_individual_fit.RData")load("data/exp3_badness_individual_fit.RData")
df.exp3.badness.individual_fit %>%
count(best_model) %>%
print_table()| best_model | n |
|---|---|
| baseline | 6 |
| effort | 30 |
| causality | 2 |
| effort_causality | 8 |
| heuristic | 6 |
6.2.3 Model predictions
fun_model_predictions_exp3 = function(fit){
fit %>%
fitted(newdata = df.exp3.model,
re_formula = NA) %>%
as_tibble() %>%
bind_cols(df.exp3.model) %>%
clean_names()
}
df.exp3.model.causality = fun_model_predictions_exp3(fit.exp3.causality)
df.exp3.model.effort = fun_model_predictions_exp3(fit.exp3.effort)
df.exp3.model.badness_effort = fun_model_predictions_exp3(fit.exp3.badness_effort)
df.exp3.model.responsibility_effort_causality =
fun_model_predictions_exp3(fit.exp3.responsibility_effort_causality)
df.exp3.model.all = df.exp3.model.causality %>%
select(clip, estimate, q2_5, q97_5) %>%
mutate(question = "causality") %>%
bind_rows(df.exp3.model.effort %>%
select(clip, estimate, q2_5, q97_5) %>%
mutate(question = "effort")) %>%
bind_rows(df.exp3.model.badness_effort %>%
select(clip, estimate, q2_5, q97_5) %>%
mutate(question = "badness")) %>%
bind_rows(df.exp3.model.responsibility_effort_causality %>%
select(clip, estimate, q2_5, q97_5) %>%
mutate(question = "responsibility"))6.2.4 Correlations
6.2.4.1 Effort model vs. effort people
df.data = df.exp3.long %>%
filter(question == "effort") %>%
group_by(clip) %>%
summarize(mean = mean(rating)) %>%
ungroup() %>%
left_join(df.exp3.model,
by = c("clip"))
fit.exp3.effort %>%
fitted(newdata = df.data,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.data) %>%
summarize(pearson = cor(estimate, mean),
rmse = rmse(estimate, mean)) %>%
print_table()| pearson | rmse |
|---|---|
| 0.9 | 8.47 |
6.2.4.2 Causality model vs. causality people
df.data = df.exp3.long %>%
filter(question == "causality") %>%
group_by(clip) %>%
summarize(mean = mean(rating)) %>%
ungroup() %>%
left_join(df.exp3.model,
by = c("clip"))
fit.exp3.causality %>%
fitted(newdata = df.data,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.data) %>%
summarize(pearson = cor(estimate, mean),
rmse = rmse(estimate, mean)) %>%
print_table()| pearson | rmse |
|---|---|
| 0.91 | 11.55 |
6.3 PLOTS
6.3.1 Bar plot
# data
df.plot = df.exp3.long %>%
mutate(question = factor(question,
levels = c("effort",
"causality",
"responsibility",
"badness")))
# model
df.model = df.exp3.model.all %>%
left_join(df.clip_order3,
by = "clip")
# linking images and clips
df.images = df.exp3.model %>%
select(clip, clip_index) %>%
mutate(question = NA,
grob = map(.x = clip,
.f = ~ readPNG(str_c("../../figures/diagrams/experiment3/",
.x, ".png"))))
# add text
df.text = df.images %>%
select(clip, clip_index) %>%
mutate(question = NA,
x = 0.5,
y = 125)
ggplot(data = df.plot,
mapping = aes(x = question,
y = rating,
fill = question)) +
stat_summary(fun = "mean",
geom = "bar",
color = "black",
alpha = 0.75) +
stat_summary(fun.data = "mean_cl_boot",
geom = "linerange",
color = "black") +
geom_point(shape = 21,
alpha = 0.25,
position = position_jitter(width = 0.1, height = 0),
show.legend = F) +
geom_point(data = df.model,
mapping = aes(y = estimate),
show.legend = F,
size = 4,
shape = 21) +
facet_wrap(~ clip_index,
ncol = 10) +
geom_custom(data = df.images,
mapping = aes(data = grob,
x = -Inf,
y = Inf),
grob_fun = function(x) rasterGrob(x,
interpolate = T,
vjust = 0,
hjust = 0)) +
geom_text(data = df.text,
mapping = aes(x = x,
y = y,
label = clip_index),
hjust = 0,
color = "white",
size = 11) +
scale_fill_manual(breaks = c("effort",
"causality",
"responsibility",
"badness"),
values = condition_colors) +
scale_y_continuous(breaks = seq(0, 100, 25),
expand = expansion(mult = 0.01)) +
labs(y = "Judgment",
x = "") +
coord_cartesian(clip = "off",
ylim = c(0, 110)) +
theme(axis.title.x = element_blank(),
axis.text.x = element_blank(),
axis.line.x = element_blank(),
axis.ticks.x = element_blank(),
legend.position = "bottom",
strip.background = element_blank(),
strip.text = element_blank(),
panel.spacing.y = unit(4, "cm"),
plot.margin = margin(t = 4, l = 0.2, r = 0.2, b = 0.1, unit = "cm"),
axis.title.y = element_text(size = 36),
legend.text = element_text(size = 30),
legend.title = element_text(size = 30))
ggsave(filename = "../../figures/plots/experiment3_bars.pdf",
width = 24,
height = 8)
6.3.2 Scatter plots
6.3.2.1 Effort
set.seed(1)
p1 = func_scatter_plot(data = df.exp3.long %>%
filter(question == "effort"),
model = df.exp3.model,
fit = fit.exp3.effort,
xlabel = "effort model<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "effort judgment",
condition = "effort")
p1
#### Causality
set.seed(1)
p2 = func_scatter_plot(data = df.exp3.long %>%
filter(question == "causality"),
model = df.exp3.model,
fit = fit.exp3.causality,
xlabel = "causality model<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "causality judgment",
condition = "causality")
p2
#### Effort & Causality
p1 + p2 +
plot_annotation(tag_levels = "A") &
theme(plot.tag = element_text(face = "bold"))
ggsave(filename = "../../figures/plots/experiment3_scatter_effort_causality.pdf",
width = 12,
height = 6)
6.3.2.2 Badness
set.seed(1)
p1 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "badness"),
model = df.exp3.model,
fit = fit.exp3.badness_effort,
xlabel = "effort<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "badness judgment",
condition = "badness")
p2 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "badness"),
model = df.exp3.model,
fit = fit.exp3.badness_causality,
xlabel = "causality<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "badness judgment",
condition = "badness")
p3 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "badness"),
model = df.exp3.model,
fit = fit.exp3.badness_effort_causality,
xlabel = "effort + causality<br><span style='font-size:26pt'>(3 parameters)</span>",
ylabel = "badness judgment",
condition = "badness")
p4 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "badness"),
model = df.exp3.model,
fit = fit.exp3.badness_heuristic,
xlabel = "kinematic features<br><span style='font-size:26pt'>(9 parameters)</span>",
ylabel = "badness judgment",
condition = "badness")
p1 + p2 + p3 + p4 &
plot_layout(nrow = 1) &
plot_annotation(tag_levels = "A") &
theme(plot.tag = element_text(face = "bold"))
ggsave(filename = "../../figures/plots/experiment3_scatter_badness.pdf",
width = 24,
height = 6)
6.3.2.3 Responsibility
set.seed(1)
p1 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "responsibility"),
model = df.exp3.model,
fit = fit.exp3.responsibility_effort,
xlabel = "effort<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "responsibility judgment",
condition = "responsibility")
p2 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "responsibility"),
model = df.exp3.model,
fit = fit.exp3.responsibility_causality,
xlabel = "causality<br><span style='font-size:26pt'>(2 parameters)</span>",
ylabel = "responsibility judgment",
condition = "responsibility")
p3 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "responsibility"),
model = df.exp3.model,
fit = fit.exp3.responsibility_effort_causality,
xlabel = "effort + causality<br><span style='font-size:26pt'>(3 parameters)</span>",
ylabel = "responsibility judgment",
condition = "responsibility")
p4 = func_scatter_plot(
data = df.exp3.long %>%
filter(question == "responsibility"),
model = df.exp3.model,
fit = fit.exp3.responsibility_heuristic,
xlabel = "kinematic features<br><span style='font-size:26pt'>(9 parameters)</span>",
ylabel = "responsibility judgment",
condition = "responsibility")
p1 + p2 + p3 + p4 &
plot_layout(nrow = 1) &
plot_annotation(tag_levels = "A") &
theme(plot.tag = element_text(face = "bold"))
ggsave(filename = "../../figures/plots/experiment3_scatter_responsibility.pdf",
width = 24,
height = 6)
6.3.3 Heuristic posterior
predictors = c("Intercept",
"distance",
"duration",
"frequency",
"agent_moving",
"patient_moving",
"fireball_moving",
"collision_agent_patient",
"collision_agent_fireball")
df.plot = fit.exp2.moral_heuristic %>%
posterior_samples() %>%
select(contains("b_")) %>%
mean_hdi() %>%
mutate(model = "Experiment 2: Badness") %>%
bind_rows(fit.exp3.responsibility_heuristic %>%
posterior_samples() %>%
select(contains("b_")) %>%
mean_hdi() %>%
mutate(model = "Experiment 3: Responsibility")) %>%
bind_rows(fit.exp3.badness_heuristic %>%
posterior_samples() %>%
select(contains("b_")) %>%
mean_hdi() %>%
mutate(model = "Experiment 3: Badness")) %>%
select(-c(.width, .point, .interval)) %>%
pivot_longer(cols = -model) %>%
mutate(name = str_remove(name, "b_")) %>%
separate(name,
into = c("predictor", "index"),
sep = "\\.") %>%
replace_na(list(index = "mean")) %>%
pivot_wider(names_from = index,
values_from = value) %>%
mutate(predictor = str_remove(predictor, "TRUE"),
predictor = factor(predictor,
levels = predictors,
labels = predictors %>%
str_to_lower() %>%
str_replace_all("_", " ")),
model = factor(model,
levels = c("Experiment 2: Badness",
"Experiment 3: Responsibility",
"Experiment 3: Badness"),
labels = c("Exp 2: Badness",
"Exp 3: Responsibility",
"Exp 3: Badness")))
ggplot(data = df.plot,
mapping = aes(x = mean,
y = predictor,
xmin = lower,
xmax = upper,
group = model,
# color = model,
fill = model)) +
geom_vline(xintercept = 0,
linetype = 2) +
geom_pointinterval(position = position_dodge2(width = 0.9,
reverse = T),
point_size = 4,
shape = 21,
stroke = 1,
color = "black") +
geom_hline(yintercept = seq(from = 1.5, by = 1, length.out = 8),
alpha = 0.1) +
scale_y_discrete(limits = rev) +
scale_x_continuous(breaks = seq(-75, 75, 25)) +
scale_fill_grey(start = 1, end = 0.2) +
labs(x = "posterior mean with 95% credible interval") +
theme(legend.position = "bottom",
legend.direction = "horizontal",
legend.title = element_blank(),
legend.key.width = unit(1, "cm"),
axis.title.y = element_blank()) +
guides(color = guide_legend(override.aes = list(size = 10)))
ggsave(filename = "../../figures/plots/heuristic_posterior.pdf",
width = 12,
height = 8)
6.4 Tables
6.4.1 Pairwise correlations
6.4.1.1 MDM and Judgments
df.exp3.model %>%
select(effort_model,
causality_model,
effort,
causality,
responsibility,
badness) %>%
correlate() %>%
shave() %>%
fashion() %>%
print_table()| term | effort_model | causality_model | effort | causality | responsibility | badness |
|---|---|---|---|---|---|---|
| effort_model | ||||||
| causality_model | .38 | |||||
| effort | .90 | .45 | ||||
| causality | .22 | .91 | .22 | |||
| responsibility | .65 | .80 | .83 | .62 | ||
| badness | .72 | .47 | .94 | .22 | .88 |
6.4.1.2 Kinematic features
df.exp3.model %>%
select(distance:collision_agent_fireball, effort, causality) %>%
correlate() %>%
shave() %>%
fashion() %>%
print_table()| term | distance | duration | frequency | agent_moving | patient_moving | fireball_moving | collision_agent_patient | collision_agent_fireball | effort | causality |
|---|---|---|---|---|---|---|---|---|---|---|
| distance | ||||||||||
| duration | .75 | |||||||||
| frequency | .28 | .43 | ||||||||
| agent_moving | .57 | .17 | .20 | |||||||
| patient_moving | -.15 | -.36 | -.12 | -.06 | ||||||
| fireball_moving | .03 | -.30 | -.23 | .14 | .00 | |||||
| collision_agent_patient | .24 | .41 | .90 | .18 | -.12 | -.30 | ||||
| collision_agent_fireball | -.07 | -.33 | -.73 | .01 | -.04 | .52 | -.81 | |||
| effort | .80 | .59 | .40 | .86 | -.25 | .02 | .35 | -.06 | ||
| causality | -.10 | .27 | .40 | .03 | -.35 | -.05 | .35 | -.04 | .22 |
6.4.2 Model comparison
6.4.2.1 Responsibility
df.elpd = loo_compare(fit.exp3.responsibility_effort,
fit.exp3.responsibility_causality,
fit.exp3.responsibility_effort_causality,
fit.exp3.responsibility_heuristic,
fit.exp3.responsibility_baseline) %>%
as_tibble(rownames = "model") %>%
mutate(model = factor(model,
levels = c("fit.exp3.responsibility_effort",
"fit.exp3.responsibility_causality",
"fit.exp3.responsibility_effort_causality",
"fit.exp3.responsibility_heuristic",
"fit.exp3.responsibility_baseline"))) %>%
arrange(model)
df.posteriors = fit.exp3.responsibility_effort %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort") %>%
bind_rows(fit.exp3.responsibility_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "causality")) %>%
bind_rows(fit.exp3.responsibility_effort_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort + causality")) %>%
bind_rows(fit.exp3.responsibility_heuristic %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "kinematic features")) %>%
bind_rows(fit.exp3.responsibility_baseline %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "baseline")) %>%
mutate(across(where(is.numeric), ~ round(., 2)),
label = str_c(estimate, " [", conf.low, ", ", conf.high, "]")) %>%
select(model, term, label) %>%
pivot_wider(names_from = term,
values_from = label) %>%
rename(intercept = Intercept)Warning in tidy.brmsfit(., effects = "fixed", fix.intercept = F, conf.method
= "HPDinterval"): some parameter names contain underscores: term naming may be
unreliable!df.individuals = df.exp3.responsibility.individual_fit %>%
count(best_model)
fun_r_rmse = function(fit, dv){
df = fit %>%
fitted(newdata = df.exp3.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp3.means)
if(sd(df$estimate) > 0){
df = df %>%
summarize(r = cor(.data[[dv]], estimate),
rmse = rmse(.data[[dv]], estimate))
}else{
df = df %>%
summarize(rmse = rmse(.data[[dv]], estimate))
}
return(df)
}
df.table = tibble(model = c("effort",
"causality",
"effort + causality",
"kinematic features",
"baseline"),
formula = c(as.character(fit.exp3.responsibility_effort$formula[[1]][3]),
as.character(fit.exp3.responsibility_causality$formula[[1]][3]),
as.character(fit.exp3.responsibility_effort_causality$formula[[1]][3]),
as.character(fit.exp3.responsibility_heuristic$formula[[1]][3]),
as.character(fit.exp3.responsibility_baseline$formula[[1]][3])),
r = c(fun_r_rmse(fit = fit.exp3.responsibility_effort,
dv = "responsibility")$r,
fun_r_rmse(fit = fit.exp3.responsibility_causality,
dv = "responsibility")$r,
fun_r_rmse(fit = fit.exp3.responsibility_effort_causality,
dv = "responsibility")$r,
fun_r_rmse(fit = fit.exp3.responsibility_heuristic,
dv = "responsibility")$r,
NA),
rmse = c(fun_r_rmse(fit = fit.exp3.responsibility_effort,
dv = "responsibility")$rmse,
fun_r_rmse(fit = fit.exp3.responsibility_causality,
dv = "responsibility")$rmse,
fun_r_rmse(fit = fit.exp3.responsibility_effort_causality,
dv = "responsibility")$rmse,
fun_r_rmse(fit = fit.exp3.responsibility_heuristic,
dv = "responsibility")$rmse,
fun_r_rmse(fit = fit.exp3.responsibility_baseline,
dv = "responsibility")$rmse),
elpd = df.elpd$elpd_diff,
elpd_se = df.elpd$se_diff) %>%
mutate(across(where(is.numeric), ~ round(., 2))) %>%
mutate(elpd = str_c(elpd, " (", elpd_se,")")) %>%
select(-elpd_se) %>%
left_join(df.posteriors,
by = "model") %>%
left_join(df.individuals %>%
mutate(best_model = str_replace(best_model,
"effort_causality",
"effort + causality"),
best_model = str_replace(best_model,
"heuristic",
"kinematic features")) %>%
rename(model = best_model,
`# best fit` = n),
by = "model") %>%
select(model, intercept, effort, causality, r, rmse, elpd, `# best fit`)
df.table %>%
print_table()| model | intercept | effort | causality | r | rmse | elpd | # best fit |
|---|---|---|---|---|---|---|---|
| effort | 18.89 [13.69, 24.26] | 101.37 [91.47, 112.25] | NA | 0.83 | 12.90 | -130.77 (18.72) | 13 |
| causality | 39.31 [33.7, 44.88] | NA | 50.69 [42.81, 57.86] | 0.62 | 18.31 | -251.75 (24.69) | 7 |
| effort + causality | 3.61 [-2.56, 10.69] | 89.36 [76.64, 101.06] | 37.38 [29.06, 45.83] | 0.95 | 7.55 | 0 (0) | 24 |
| kinematic features | 6.8 [0.32, 13.16] | NA | NA | 0.96 | 6.76 | -45.57 (15.5) | 8 |
| baseline | 68.1 [65.24, 70.53] | NA | NA | NA | 23.33 | -371.04 (26.62) | 3 |
6.4.2.2 Badness
df.elpd = loo_compare(fit.exp3.badness_effort,
fit.exp3.badness_causality,
fit.exp3.badness_effort_causality,
fit.exp3.badness_heuristic,
fit.exp3.badness_baseline) %>%
as_tibble(rownames = "model") %>%
mutate(model = factor(model,
levels = c("fit.exp3.badness_effort",
"fit.exp3.badness_causality",
"fit.exp3.badness_effort_causality",
"fit.exp3.badness_heuristic",
"fit.exp3.badness_baseline"))) %>%
arrange(model)
df.posteriors = fit.exp3.badness_effort %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort") %>%
bind_rows(fit.exp3.badness_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "causality")) %>%
bind_rows(fit.exp3.badness_effort_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort + causality")) %>%
bind_rows(fit.exp3.badness_heuristic %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "kinematic features")) %>%
bind_rows(fit.exp3.badness_baseline %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "baseline")) %>%
mutate(across(where(is.numeric), ~ round(., 2)),
label = str_c(estimate, " [", conf.low, ", ", conf.high, "]")) %>%
select(model, term, label) %>%
pivot_wider(names_from = term,
values_from = label) %>%
rename(intercept = Intercept)Warning in tidy.brmsfit(., effects = "fixed", fix.intercept = F, conf.method
= "HPDinterval"): some parameter names contain underscores: term naming may be
unreliable!df.individuals = df.exp3.badness.individual_fit %>%
count(best_model)
fun_r_rmse = function(fit, dv){
df = fit %>%
fitted(newdata = df.exp3.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp3.means)
if(sd(df$estimate) > 0){
df = df %>%
summarize(r = cor(.data[[dv]], estimate),
rmse = rmse(.data[[dv]], estimate))
}else{
df = df %>%
summarize(rmse = rmse(.data[[dv]], estimate))
}
return(df)
}
df.table = tibble(model = c("effort",
"causality",
"effort + causality",
"kinematic features",
"baseline"),
formula = c(as.character(fit.exp3.badness_effort$formula[[1]][3]),
as.character(fit.exp3.badness_causality$formula[[1]][3]),
as.character(fit.exp3.badness_effort_causality$formula[[1]][3]),
as.character(fit.exp3.badness_heuristic$formula[[1]][3]),
as.character(fit.exp3.badness_baseline$formula[[1]][3])),
r = c(fun_r_rmse(fit = fit.exp3.badness_effort,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_causality,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_effort_causality,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_heuristic,
dv = "badness")$r,
NA),
rmse = c(fun_r_rmse(fit = fit.exp3.badness_effort,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_causality,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_effort_causality,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_heuristic,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_baseline,
dv = "badness")$rmse),
elpd = df.elpd$elpd_diff,
elpd_se = df.elpd$se_diff) %>%
mutate(across(where(is.numeric), ~ round(., 2))) %>%
mutate(elpd = str_c(elpd, " (", elpd_se,")")) %>%
select(-elpd_se) %>%
left_join(df.posteriors,
by = "model") %>%
left_join(df.individuals %>%
mutate(best_model = str_replace(best_model,
"effort_causality",
"effort + causality"),
best_model = str_replace(best_model,
"heuristic",
"kinematic features")) %>%
rename(model = best_model,
`# best fit` = n),
by = "model") %>%
select(model, intercept, effort, causality, r, rmse, elpd, `# best fit`)
df.table %>%
print_table()| model | intercept | effort | causality | r | rmse | elpd | # best fit |
|---|---|---|---|---|---|---|---|
| effort | 18.18 [12.04, 24.99] | 90.75 [76.1, 105.04] | NA | 0.94 | 6.58 | 0 (0) | 30 |
| causality | 54.05 [48.99, 59.63] | NA | 14.2 [8.18, 20.01] | 0.22 | 18.13 | -328.2 (28.36) | 2 |
| effort + causality | 18 [10.91, 24.77] | 90.09 [76.12, 103.17] | 0.82 [-4.06, 5] | 0.94 | 6.57 | -0.99 (1.21) | 8 |
| kinematic features | 11.76 [4.73, 18.3] | NA | NA | 0.94 | 6.20 | -75.7 (13.65) | 6 |
| baseline | 62.15 [58.16, 66.53] | NA | NA | NA | 18.58 | -336.86 (28.04) | 6 |
df.elpd = loo_compare(fit.exp3.badness_effort,
fit.exp3.badness_causality,
fit.exp3.badness_effort_causality,
fit.exp3.badness_heuristic) %>%
as_tibble(rownames = "model") %>%
mutate(model = factor(model,
levels = c("fit.exp3.badness_effort",
"fit.exp3.badness_causality",
"fit.exp3.badness_effort_causality",
"fit.exp3.badness_heuristic"))) %>%
arrange(model)
weights = model_weights(fit.exp3.badness_effort,
fit.exp3.badness_causality,
fit.exp3.badness_effort_causality,
fit.exp3.badness_heuristic)Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.df.posteriors = fit.exp3.badness_effort %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort") %>%
bind_rows(fit.exp3.badness_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "causality")) %>%
bind_rows(fit.exp3.badness_effort_causality %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "effort + causality")) %>%
bind_rows(fit.exp3.badness_heuristic %>%
tidy(effects = "fixed",
fix.intercept = F,
conf.method = "HPDinterval") %>%
mutate(model = "kinematic features")) %>%
mutate(across(where(is.numeric), ~ round(., 2)),
label = str_c(estimate, " [", conf.low, ", ", conf.high, "]")) %>%
select(model, term, label) %>%
pivot_wider(names_from = term,
values_from = label) %>%
rename(intercept = Intercept)Warning in tidy.brmsfit(., effects = "fixed", fix.intercept = F, conf.method
= "HPDinterval"): some parameter names contain underscores: term naming may be
unreliable!fun_r_rmse = function(fit, dv){
fit %>%
fitted(newdata = df.exp3.model,
re_formula = NA) %>%
as_tibble() %>%
clean_names() %>%
bind_cols(df.exp3.means) %>%
summarize(r = cor(.data[[dv]], estimate),
rmse = rmse(.data[[dv]], estimate))
}
df.table = tibble(model = c("effort",
"causality",
"effort + causality",
"kinematic features"),
formula = c(as.character(fit.exp3.badness_effort$formula[[1]][3]),
as.character(fit.exp3.badness_causality$formula[[1]][3]),
as.character(fit.exp3.badness_effort_causality$formula[[1]][3]),
as.character(fit.exp3.badness_heuristic$formula[[1]][3])),
r = c(fun_r_rmse(fit = fit.exp3.badness_effort,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_causality,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_effort_causality,
dv = "badness")$r,
fun_r_rmse(fit = fit.exp3.badness_heuristic,
dv = "badness")$r),
rmse = c(fun_r_rmse(fit = fit.exp3.badness_effort,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_causality,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_effort_causality,
dv = "badness")$rmse,
fun_r_rmse(fit = fit.exp3.badness_heuristic,
dv = "badness")$rmse),
elpd = df.elpd$elpd_diff,
elpd_se = df.elpd$se_diff,
weights = weights) %>%
mutate(across(where(is.numeric), ~ round(., 2))) %>%
mutate(elpd = str_c(elpd, " (", elpd_se,")")) %>%
left_join(df.posteriors,
by = "model") %>%
select(model, intercept, effort, causality, r, rmse, elpd, weights)
df.table %>%
print_table()| model | intercept | effort | causality | r | rmse | elpd | weights |
|---|---|---|---|---|---|---|---|
| effort | 18.18 [12.04, 24.99] | 90.75 [76.1, 105.04] | NA | 0.94 | 6.58 | 0 (0) | 0.95 |
| causality | 54.05 [48.99, 59.63] | NA | 14.2 [8.18, 20.01] | 0.22 | 18.13 | -328.2 (28.36) | 0.05 |
| effort + causality | 18 [10.91, 24.77] | 90.09 [76.12, 103.17] | 0.82 [-4.06, 5] | 0.94 | 6.57 | -0.99 (1.21) | 0.00 |
| kinematic features | 11.76 [4.73, 18.3] | NA | NA | 0.94 | 6.20 | -75.7 (13.65) | 0.00 |
6.4.3 Model predictions: effort & causality
df.exp3.model %>%
select(clip_index, effort_model, causality_model) %>%
pivot_longer(-clip_index) %>%
mutate(value = 100 * value) %>%
arrange(clip_index) %>%
pivot_wider(names_from = clip_index) %>%
rename(model = name) %>%
mutate(model = str_remove(model, "_model")) %>%
print_table()| model | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| effort | 0 | 48.79 | 15.31 | 15.31 | 47.2 | 45.8 | 47.2 | 45.8 | 44.87 | 42.88 | 42.88 | 44.87 | 26.54 | 49.03 | 43.89 | 49.03 | 43.08 | 43.08 | 93.29 | 100 |
| causality | 0 | 0.00 | 40.30 | 40.80 | 0.4 | 3.1 | 0.8 | 2.9 | 58.40 | 51.10 | 49.10 | 61.60 | 100.00 | 99.40 | 100.00 | 99.50 | 100.00 | 100.00 | 100.00 | 100 |
6.4.4 Heuristic model
6.4.4.1 Responsibility
fit.exp3.responsibility_heuristic %>%
tidy(conf.level = 0.95) %>%
filter(effect == "fixed") %>%
mutate(term = str_to_lower(term),
term = str_remove(term, "true"),
term = str_replace_all(term, "_", " "),
term = str_replace(term, fixed("(intercept)"), "intercept")) %>%
select("predictor" = term,
"posterior mean" = estimate,
"95% credible interval (lower bound)" = conf.low,
"95% credible interval (upper bound)" = conf.high) %>%
print_table()| predictor | posterior mean | 95% credible interval (lower bound) | 95% credible interval (upper bound) |
|---|---|---|---|
| intercept | 6.80 | 0.37 | 13.25 |
| distance | -68.72 | -82.77 | -54.09 |
| duration | 65.86 | 51.34 | 80.39 |
| frequency | 11.18 | 5.96 | 16.59 |
| agent moving | 57.96 | 51.87 | 63.90 |
| patient moving | -3.20 | -6.88 | 0.44 |
| fireball moving | 0.38 | -3.59 | 4.24 |
| collision agent patient | 19.74 | 11.86 | 27.63 |
| collision agent fireball | 32.92 | 26.56 | 39.29 |
6.4.4.2 Badness
fit.exp3.badness_heuristic %>%
tidy(conf.level = 0.95) %>%
filter(effect == "fixed") %>%
mutate(term = str_to_lower(term),
term = str_remove(term, "true"),
term = str_replace_all(term, "_", " "),
term = str_replace(term, fixed("(intercept)"), "intercept")) %>%
select("predictor" = term,
"posterior mean" = estimate,
"95% credible interval (lower bound)" = conf.low,
"95% credible interval (upper bound)" = conf.high) %>%
print_table()| predictor | posterior mean | 95% credible interval (lower bound) | 95% credible interval (upper bound) |
|---|---|---|---|
| intercept | 11.76 | 5.04 | 18.70 |
| distance | -13.15 | -26.23 | 0.30 |
| duration | 22.73 | 8.91 | 35.74 |
| frequency | 5.44 | 0.56 | 10.14 |
| agent moving | 43.76 | 38.51 | 49.13 |
| patient moving | 1.18 | -2.03 | 4.37 |
| fireball moving | 0.09 | -3.53 | 3.76 |
| collision agent patient | 10.04 | 2.82 | 17.37 |
| collision agent fireball | 15.13 | 9.48 | 20.74 |
6.4.5 Individual predictors
predictors = c("effort", "effort_model", "causality", "causality_model", "distance", "duration",
"frequency", "agent_moving", "patient_moving", "fireball_moving",
"collision_agent_patient", "collision_agent_fireball")
df.exp3.predictors = df.exp3.model %>%
mutate(across(where(is.logical), ~ . * 1)) %>%
summarize(across(predictors,
list(responsibility = ~ cor(., responsibility),
badness = ~ cor(., badness)),
.names = "{.col}.{.fn}")) %>%
pivot_longer(cols = everything(),
names_to = "predictor",
values_to = "r") %>%
separate(predictor,
into = c("predictor", "judgment"),
sep = "\\.") %>%
pivot_wider(names_from = judgment,
values_from = r)Note: Using an external vector in selections is ambiguous.
ℹ Use `all_of(predictors)` instead of `predictors` to silence this message.
ℹ See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
This message is displayed once per session.df.exp3.predictors %>%
print_table()| predictor | responsibility | badness |
|---|---|---|
| effort | 0.83 | 0.94 |
| effort_model | 0.65 | 0.72 |
| causality | 0.62 | 0.22 |
| causality_model | 0.80 | 0.47 |
| distance | 0.43 | 0.61 |
| duration | 0.38 | 0.35 |
| frequency | 0.48 | 0.39 |
| agent_moving | 0.74 | 0.88 |
| patient_moving | -0.37 | -0.17 |
| fireball_moving | 0.06 | 0.11 |
| collision_agent_patient | 0.42 | 0.35 |
| collision_agent_fireball | -0.05 | -0.04 |
# combine predictors from Experiment 2 and 3
df.exp3.predictors %>%
left_join(df.exp2.predictors,
by = "predictor") %>%
select(predictor,
exp2_badness = r,
exp3_responsibility = responsibility,
exp3_badness = badness) %>%
print_table()| predictor | exp2_badness | exp3_responsibility | exp3_badness |
|---|---|---|---|
| effort | 0.90 | 0.83 | 0.94 |
| effort_model | 0.72 | 0.65 | 0.72 |
| causality | NA | 0.62 | 0.22 |
| causality_model | 0.80 | 0.80 | 0.47 |
| distance | 0.54 | 0.43 | 0.61 |
| duration | 0.33 | 0.38 | 0.35 |
| frequency | 0.28 | 0.48 | 0.39 |
| agent_moving | 0.92 | 0.74 | 0.88 |
| patient_moving | -0.57 | -0.37 | -0.17 |
| fireball_moving | 0.16 | 0.06 | 0.11 |
| collision_agent_patient | 0.25 | 0.42 | 0.35 |
| collision_agent_fireball | 0.19 | -0.05 | -0.04 |
7 Misc
7.1 Mapping between video names and clip names in the different experiments
# Experiment 1
df.exp1.mapping %>%
print_table()| trial | clip_left | clip_right | clip_left_labeled | clip_right_labeled |
|---|---|---|---|---|
| 1 | 11 | 7 | 1 | 2 |
| 2 | 9 | 2 | 3 | 4 |
| 3 | 11 | 4 | 1 | 5 |
| 4 | 10 | 3 | 6 | 7 |
| 5 | 7 | 12 | 2 | 8 |
| 6 | 7 | 4 | 2 | 5 |
| 7 | 6 | 5 | 9 | 10 |
| 8 | 4 | 12 | 5 | 8 |
| 9 | 3 | 1 | 7 | 11 |
| 10 | 10 | 9 | 6 | 3 |
| 11 | 10 | 8 | 6 | 12 |
# Experiment 2
df.clip_order2 %>%
select(trial = clip_index,
clip) %>%
print_table()| trial | clip |
|---|---|
| 1 | video4 |
| 2 | video12 |
| 3 | video7 |
| 4 | victim_moving_static |
| 5 | video11 |
| 6 | harm_moving_moving |
| 7 | video1 |
| 8 | harm_moving_static |
| 9 | victim_moving_moving |
| 10 | harm_static_moving |
| 11 | victim_static_moving |
| 12 | victim_static_static |
| 13 | harm_static_static |
| 14 | video3 |
| 15 | video10 |
| 16 | video9 |
| 17 | video8 |
# Experiment 3
df.clip_order3 %>%
select(trial = clip_index,
clip) %>%
print_table()| trial | clip |
|---|---|
| 1 | video14 |
| 2 | video13 |
| 3 | video1 |
| 4 | video2 |
| 5 | video8 |
| 6 | video11 |
| 7 | video9 |
| 8 | video10 |
| 9 | video4 |
| 10 | video19 |
| 11 | video16 |
| 12 | video5 |
| 13 | video6 |
| 14 | video15 |
| 15 | video3 |
| 16 | video18 |
| 17 | video20 |
| 18 | video17 |
| 19 | video7 |
| 20 | video12 |
8 Session info
R version 4.0.3 (2020-10-10)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS Big Sur 10.16
Matrix products: default
BLAS: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRblas.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/4.0/Resources/lib/libRlapack.dylib
locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
attached base packages:
[1] grid stats graphics grDevices utils datasets methods
[8] base
other attached packages:
[1] forcats_0.5.1 stringr_1.4.0 dplyr_1.0.4 purrr_0.3.4
[5] readr_1.4.0 tidyr_1.1.2 tibble_3.0.6 tidyverse_1.3.0
[9] ggtext_0.1.1 xtable_1.8-4 ggpubr_0.4.0 magick_2.6.0
[13] egg_0.4.5 gridExtra_2.3 janitor_2.1.0 png_0.1-7
[17] patchwork_1.1.1 Hmisc_4.4-2 ggplot2_3.3.3 Formula_1.2-4
[21] survival_3.2-7 lattice_0.20-41 emmeans_1.5.3 DT_0.17
[25] tidybayes_2.3.1 brms_2.14.4 Rcpp_1.0.6 broom.mixed_0.2.6
[29] RSQLite_2.2.3 corrr_0.4.3 tidyjson_0.3.1 kableExtra_1.3.1
[33] knitr_1.31
loaded via a namespace (and not attached):
[1] utf8_1.1.4 tidyselect_1.1.0 lme4_1.1-26
[4] htmlwidgets_1.5.3 TSP_1.1-10 munsell_0.5.0
[7] codetools_0.2-18 statmod_1.4.35 miniUI_0.1.1.1
[10] withr_2.4.1 Brobdingnag_1.2-6 colorspace_2.0-0
[13] highr_0.8 rstudioapi_0.13 stats4_4.0.3
[16] ggsignif_0.6.0 bayesplot_1.8.0 labeling_0.4.2
[19] rstan_2.21.1 bit64_4.0.5 farver_2.1.0
[22] bridgesampling_1.0-0 coda_0.19-4 vctrs_0.3.6
[25] generics_0.1.0 TH.data_1.0-10 xfun_0.21
[28] R6_2.5.0 markdown_1.1 HDInterval_0.2.2
[31] seriation_1.2-9 gamm4_0.2-6 projpred_2.0.2
[34] cachem_1.0.1 assertthat_0.2.1 promises_1.1.1
[37] scales_1.1.1 multcomp_1.4-15 nnet_7.3-15
[40] gtable_0.3.0 processx_3.4.5 sandwich_3.0-0
[43] rlang_0.4.10 splines_4.0.3 rstatix_0.6.0
[46] TMB_1.7.18 broom_0.7.3 checkmate_2.0.0
[49] inline_0.3.17 modelr_0.1.8 yaml_2.2.1
[52] reshape2_1.4.4 abind_1.4-5 threejs_0.3.3
[55] crosstalk_1.1.1 backports_1.2.1 httpuv_1.5.5
[58] rsconnect_0.8.16 gridtext_0.1.4 tools_4.0.3
[61] bookdown_0.21 ellipsis_0.3.1 RColorBrewer_1.1-2
[64] ggridges_0.5.3 plyr_1.8.6 base64enc_0.1-3
[67] ps_1.6.0 prettyunits_1.1.1 rpart_4.1-15
[70] zoo_1.8-8 haven_2.3.1 cluster_2.1.0
[73] fs_1.5.0 magrittr_2.0.1 data.table_1.13.6
[76] ggdist_2.4.0 openxlsx_4.2.3 reprex_1.0.0
[79] colourpicker_1.1.0 mvtnorm_1.1-1 matrixStats_0.57.0
[82] hms_1.0.0 shinyjs_2.0.0 mime_0.10
[85] evaluate_0.14 arrayhelpers_1.1-0 shinystan_2.5.0
[88] rio_0.5.16 jpeg_0.1-8.1 readxl_1.3.1
[91] rstantools_2.1.1 compiler_4.0.3 V8_3.4.0
[94] crayon_1.4.1 minqa_1.2.4 StanHeaders_2.21.0-7
[97] htmltools_0.5.1.1 mgcv_1.8-33 later_1.1.0.1
[100] RcppParallel_5.0.2 lubridate_1.7.9.2 DBI_1.1.1
[103] dbplyr_2.0.0 MASS_7.3-53 boot_1.3-26
[106] Matrix_1.3-2 car_3.0-10 cli_2.3.0
[109] parallel_4.0.3 igraph_1.2.6 pkgconfig_2.0.3
[112] registry_0.5-1 foreign_0.8-81 foreach_1.5.1
[115] xml2_1.3.2 svUnit_1.0.3 dygraphs_1.1.1.6
[118] webshot_0.5.2 estimability_1.3 rvest_0.3.6
[121] snakecase_0.11.0 distributional_0.2.1 callr_3.5.1
[124] digest_0.6.27 rmarkdown_2.6 cellranger_1.1.0
[127] htmlTable_2.1.0 curl_4.3 shiny_1.6.0
[130] gtools_3.8.2 nloptr_1.2.2.2 lifecycle_1.0.0
[133] nlme_3.1-151 jsonlite_1.7.2 carData_3.0-4
[136] fansi_0.4.2 viridisLite_0.3.0 pillar_1.4.7
[139] loo_2.4.1.9000 fastmap_1.1.0 httr_1.4.2
[142] pkgbuild_1.2.0 glue_1.4.2 xts_0.12.1
[145] zip_2.1.1 iterators_1.0.13 shinythemes_1.2.0
[148] bit_4.0.4 stringi_1.5.3 blob_1.2.1
[151] latticeExtra_0.6-29 memoise_2.0.0