To copy the code, click the button in the upper right corner of the code-chunks.
rm(list = ls())
gc()
We defined a number custom functions, at Download custom_functions.R.
source("./custom_functions.R")
tidyverse: data wranglingigraph: generate and visualize graphsparallel: parallel computing to speed up
simulationforeach: looping in paralleldoParallel: parallel backend for
foreachggplot2: data visualizationggh4x: hacks for ggplot2ggpubr: make visualizations publication-readypackages = c("tidyverse", "igraph", "ggplot2", "parallel", "doParallel", "foreach", "ggh4x", "ggpubr",
"plotly", "RColorBrewer", "grid", "gridExtra", "patchwork", "ggplotify", "ggraph", "gganimate", "RColorBrewer",
"ggtext", "magick", "jsonlite", "lubridate", "ggtext")
invisible(fpackage.check(packages))
rm(packages)
data <- read.csv("./rawdata/all_apps_wide_2026-02-23.csv")
times <- read.csv("./rawdata/PageTimes-2026-02-23.csv")
table(data$survey.1.player.clarity)
#>
#> 2 3 4 5
#> 1 2 13 19
table(data$survey.1.player.enjoyment)
#>
#> 1 2 3 4 5
#> 1 4 9 11 10
table(data$survey.1.player.strategy)
#>
#>
#> 970
#> At first I tried to predict what other participants would choose but after that I found out that each of them has a different color, so at some point I selected things just randomly but at a certain time they were stuck and chose only their main color
#> 1
#> From the first round, I've noticed that people tend to pick red, because of the maximum points it gives out, therefore after the first round I only picked the red shirt.
#> 1
#> High risk high reward, I wanted to get more so I picked blue
#> 1
#> I choose the strategy of fixed reward in order to minimize the unmatche with neighbours.
#> 1
#> I always like to wear different colors from others And red is my favorite color
#> 1
#> I chose my color based on coordination with my neighbors to maximize points. I observed what my neighbors did in previous rounds and picked the color that would match at least one of them. When neighbors were split, I picked Blue, because it gave slightly higher points than Red in that situation. Once neighbors coordinated fully on one color, I matched that color to get the maximum coordination reward. My reasoning was to balance personal preference with coordination, since coordination gave more points.
#> 1
#> I chose red because i new most of the other participants would choose it.
#> 1
#> i chose the red color
#> 1
#> I chose the Red shirt because it offered a higher fixed reward (15 points) and a higher maximum payout (55 points) when coordinated with both neighbors. My strategy was to stay consistent with Red to encourage my neighbors to coordinate for the maximum mutual benefit
#> 1
#> I mostly chose red because of the points
#> 1
#> I noticed that my neighbor was always choosing red
#> 1
#> I picked the red shirt because of the fixed reward
#> 1
#> I saw most people preferred to use red color shirt so I sticked with that
#> 1
#> I settled for a shirt with guaranteed point which was the red shirt.
#> 1
#> I started out using red, but seeing that most people ended up choosing blue, i swapped to blue
#> 1
#> I stick to red because it gave the highest total points by considering both fixed reward and coordination reward.
#> 1
#> i sticked to my color red
#> 1
#> I tried to figure out a pattern at first, whether people would change their minds on different days or not, and also tested the effect my outfit changes had on others. But after the first few rounds, my neighbors became robotic or fell into a rut, wearing two red and two blue T-shirts every day without any changes. So I tried joining the blue (opposing) team, thinking they might not like it and change to red. I was wrong.
#> 1
#> I tryed to match with my neighbours,they did the same thing and just kept going like that
#> 1
#> I was choosing red it was more popular
#> 1
#> i was choosing what was best for me and it is my favorite color
#> 1
#> Looked at neighbours colours from the previous games on which one is likely to be chosen.
#> 1
#> Majority always wins in the long term
#> 1
#> Paying attention
#> 1
#> Pick red
#> 1
#> Red everytime. No strategy
#> 1
#> the one that i was assigned at the beginning
#> 1
#> The one with more numbers
#> 1
#> the option that gave me and the other 2 the most and they were always picking red so it was pointless me going blue.
#> 1
#> tried to matched my color with at least one of them while prioritized red
#> 1
table(data$survey.1.player.comments)
#>
#>
#> 982
#> I enjoyed the experiment. Should be compensated also for the time waiting for others to join
#> 1
#> It's a very slow experiment, including a game to play while waiting is nice, but the game is rather difficult and not enjoyable at all
#> 1
#> It was very fun thank you!
#> 1
#> no
#> 1
#> No
#> 1
#> No feedback
#> 2
#> no, all good
#> 1
#> none
#> 3
#> None
#> 1
#> nothing else
#> 1
#> Really cool study. I like the idea that there are additional points involved that give out bonus payouts. I've really enjoyed it. Thank you very much.
#> 1
#> Thank you for the survey, I enjoyed.
#> 1
#> The game was clear and engaging. The payoff tables helped understand the trade-off between personal preference and coordination. It was interesting to see how patterns emerged over rounds.
#> 1
#> The study went on a little long. Especially after waiting 20 minutes to be matched with people
#> 1
#> The time to respond seemed too long, and some people deliberately waited until the very end, until the last second, which prolonged the game a bit.
#> 1
table(data$survey.1.player.perceived_rq)
#>
#>
#> 967
#> A test to see if there is a preferential bias towards your own color and to see if this has an impact on your choices although mathematically, choosing blue is better in 2/3 cases.
#> 1
#> decision making
#> 1
#> experiment of how people think and decide when other people choose the opposite side
#> 1
#> fashion
#> 1
#> Go with what gives most
#> 1
#> How greedy people can be, and if seeing the options from others would make to change their minds
#> 1
#> How people are willing to come together to achieve big things.
#> 1
#> How people follow and decide on one thing as a collective
#> 1
#> I guess it was about cooperation, your outcome comes from other people outcomes, so people that in the first rounds chose the blue t-shirt, saw that everyone else is picking the red one - then later on they started picking red themselves to maximise profit.
#> 1
#> I think it is about memory
#> 1
#> i think the experiment was about if people can work together for one common goal
#> 1
#> I think the experiment was intended to investigate the influence of others on one's own choices. Looking at other people's decisions and thinking about them, we start to question our own decisions, which sometimes causes us to even stop listening to ourselves and our priorities (just like I sometimes stopped wearing red, the color I was supposed to strive for).
#> 1
#> I think the researchers wanted to study how people make decisions in a network when their goal is to coordinate with others, even if they have personal preferences. They are likely interested in coordination, social influence, and decision-making under uncertainty.
#> 1
#> i think this experiment for peoples fashion sense and their mindset for fashion
#> 1
#> I think this experiment was based on the deciding factors people tend to have,we as human being more lenient on the majority than to our own beliefs.
#> 1
#> It was about counting the number of neighbors who wears 2 different shirts.
#> 1
#> It was about decision-making and seeing socially what people would choose
#> 1
#> it was about picking a color between two and get points
#> 1
#> Maybe to see at what point people wonder whether they can get better rewards when the truth is already known
#> 1
#> No idea
#> 1
#> Patience
#> 1
#> Patience
#> 1
#> Preference
#> 1
#> Risk more win more
#> 1
#> Seeing the impact of points when it comes to decision making. When do people end up swapping colors.
#> 1
#> Team influence on players
#> 1
#> The experiment seems to be about social coordination and decision-making in networks. It explores how fixed incentives versus group rewards influence individuals to align their choices with others to reach a collective equilibrium
#> 1
#> The experiment was about decision making .The researchers are trying to know the mentality of people when making decisions in variable rewards.
#> 1
#> The researchers are examining coordination behavior and strategic decision-making to see how individuals respond to incentives and social alignment
#> 1
#> to see if other peoples choices would influence my own
#> 1
#> to see what options i would pick
#> 1
#> Wants to see how people make choices
#> 1
#> What will someone choose if they are seeing the points on something?
#> 1
table(data$survey.1.player.majority)
#>
#> 1 2 3
#> 24 8 3
# cbind(data$participant.node,data$participant.role)[complete.cases(
# cbind(data$participant.node,data$participant.role)),]
# bonus <- data[, c('participant.bonus', 'participant.label')][!is.na(data$participant.bonus),]
# row.names(bonus) <- c(1:nrow(bonus))
# bonus_file <- bonus %>% select(participant.label, participant.bonus)
# write.table( bonus_file, file = 'prolific_bonus.csv', sep = ',', row.names = FALSE, col.names =
# FALSE, quote = FALSE )
On 23-2-2026, I recruited 80 Prolific participants, to populate a network of N=50 (with a 10% minority group).
net <- jsonlite::fromJSON("./networks/network_test_n50.json")
g <- graph_from_adjacency_matrix(net$adj_matrix, mode = "undirected")
V(g)$role <- ifelse(net$role_vector == 1, "trendsetter", "conformist")
fplot_graph(g)

# subset experimental session
data <- data[data$session.code == "266ra4tr", ]
times <- times[times$session_code == "266ra4tr", ]
# clean
test <- data %>%
transmute(participant_id = participant.code, participant_label = participant.label, id_in_session = participant.id_in_session,
consent_given = consent.1.player.consent, consent_timestamp = consent.1.player.consent_timestamp,
role = participant.role, is_dropout = participant.is_dropout, dropout_app = participant._current_app_name,
comprehension_retries = comprehension.1.player.comprehension_retries, passed_comprehension = !participant._current_app_name %in%
c("consent", "comprehension"), choice = unpop.1.player.choice, failed_checks = participant.failed_checks,
exit_early = participant.exit_early, participated = participant._current_page_name == "PaymentInfo") %>%
filter(!is.na(consent_given)) %>%
mutate(bot = ifelse(participant_label == "", 1, 0), bot = factor(bot, levels = c(0, 1), labels = c("Prolific participant",
"Bot")), consent_timestamp = ymd_hms(consent_timestamp), final_state = case_when(failed_checks >
0 ~ "Failed comprehension", exit_early == 1 ~ "Could not be grouped", participated ~ "Participated",
TRUE ~ "Too late")) %>%
arrange(consent_timestamp) %>%
mutate(arrival_order = row_number())
ggplot(test, aes(x = consent_timestamp, y = arrival_order)) + geom_point(aes(color = role, shape = bot),
size = 3, alpha = 0.5) + scale_shape_manual(values = c(16, 2)) + scale_color_manual(values = c("blue",
"red")) + labs(x = "Arrival time", y = "Arrival order", color = "Role", shape = "Type", title = "Participant arrivals from Prolific over time") +
theme_minimal()

ggplot(test, aes(x = consent_timestamp, y = arrival_order)) + geom_point(aes(color = final_state), size = 3,
alpha = 0.6) + scale_color_manual(values = c(Participated = "green", `Failed comprehension` = "orange",
`Could not be grouped` = "red", `Too late` = "gray")) + facet_wrap(~role) + labs(x = "Arrival time",
y = "Arrival order", color = "Final state", title = "Participant arrivals by role and final state") +
theme_minimal()

fshowdf(table(test$final_state, test$role), caption = "participant status by role")
| Blue | Red | |
|---|---|---|
| Could not be grouped | 11 | 8 |
| Failed comprehension | 13 | 44 |
| Participated | 5 | 45 |
| Too late | 2 | 0 |
times <- times %>%
mutate(timestamp = as_datetime(epoch_time_completed))
arrival_times <- times %>%
group_by(participant_id_in_session) %>%
summarize(arrival_time = min(timestamp), .groups = "drop")
times <- times %>%
left_join(arrival_times, by = "participant_id_in_session") %>%
mutate(participant_ordered = factor(participant_id_in_session, levels = arrival_times %>%
arrange(arrival_time) %>%
pull(participant_id_in_session)))
times_roles <- times %>%
left_join(test %>%
select(id_in_session, role), by = c(participant_id_in_session = "id_in_session"))
page_levels <- unique(times$page_name)
times_roles <- times_roles %>%
mutate(page_name = factor(page_name, levels = page_levels))
custom_colors <- c(InitializeParticipant = "#c6dbef", ConsentPage = "#9ecae1", IntroductionPage = "#6baed6",
ComprehensionPage = "#3182bd", NetworkFormationWaitPage = "#ffcc99", DecisionPage = "#ff9966", ResultsWaitPage = "#ff6666",
ResultsPage = "#cc0033", FinalGameResults = "#660000")
# colored y-axis labels based on role
y_labels_colored <- times_roles %>%
select(participant_ordered, role) %>%
distinct() %>%
arrange(participant_ordered) %>%
mutate(label_colored = case_when(role == "Red" ~ paste0("<span style='color:red'>", participant_ordered,
"</span>"), role == "Blue" ~ paste0("<span style='color:blue'>", participant_ordered, "</span>"),
TRUE ~ paste0("<span style='color:darkgrey'>", participant_ordered, "</span>")))
# create a named vector for scale_y_discrete labels
y_labels_vector <- y_labels_colored$label_colored
names(y_labels_vector) <- y_labels_colored$participant_ordered
ggplot(times_roles[times_roles$round_number == 1 & !times_roles$page_name == "Questionnaire", ], aes(x = timestamp,
y = participant_ordered, color = page_name)) + geom_line(aes(group = participant_id_in_session),
size = 1) + geom_point(size = 2) + scale_color_manual(values = custom_colors) + scale_y_discrete(labels = y_labels_vector) +
labs(x = "Time", y = "Participant (ordered by arrival)", color = "Stage/Page", title = "Participant progression through experiment stages (by arrival)") +
theme_minimal() + theme(axis.text.y = element_markdown(size = 6))

dropout_long <- data %>%
filter(participant._current_page_name == "PaymentInfo") %>% # only completed participants
filter(participant.label != "") %>% # exclude bots (participants controlled by experimener have no label)
select(
participant.label,
participant.role,
matches("unpop\\.[0-9]+\\.player\\.is_dropout")
) %>%
pivot_longer(
cols = matches("unpop\\.[0-9]+\\.player\\.is_dropout"),
names_to = "round",
values_to = "is_dropout"
) %>%
mutate(
round = str_extract(round, "[0-9]+"),
round = as.numeric(round)
)
# get first dropout round per participant
dropout_summary <- dropout_long %>%
group_by(participant.label, participant.role) %>%
summarise(
event = any(is_dropout == 1, na.rm = TRUE),
dropout_round = ifelse(
event,
min(round[is_dropout == 1], na.rm = TRUE),
30
),
.groups = "drop"
)
# count cumulative dropouts
cum_dropout_role <- dropout_summary %>%
filter(event == TRUE) %>%
count(participant.role, dropout_round) %>%
group_by(participant.role) %>%
complete(dropout_round = 1:30, fill = list(n = 0)) %>%
arrange(participant.role, dropout_round) %>%
mutate(
cumulative_dropout = cumsum(n)
) %>%
ungroup()
ggplot(cum_dropout_role,
aes(x = dropout_round,
y = cumulative_dropout,
color = participant.role)) +
geom_line(linewidth = 1.2) +
geom_point() +
scale_x_continuous(breaks = 1:30) +
scale_color_manual(
values = c(
"Red" = "red",
"Blue" = "blue"
)) +
labs(
x = "Round",
y = "Dropout",
color = "Role",
title = "Cumulative dropout (by role)"
) +
theme_minimal()

# choice behavior over rounds:
df_long <- data %>%
filter(participant._current_page_name == "PaymentInfo") %>% # filter actual participants
select(participant.label, participant.role, participant.node, starts_with("unpop.")) %>% #also include network node.
pivot_longer(
cols = matches("unpop\\.\\d+\\.player\\.choice$"), # only choice columns
names_to = "round",
values_to = "choice"
) %>%
mutate(
round = as.integer(gsub("unpop\\.(\\d+)\\.player\\.choice", "\\1", round)),
is_bot = ifelse(participant.label == "", TRUE, FALSE)
) %>%
select(participant.label, participant.node, participant.role, round, choice, is_bot)
# identify round of dropout:
first_dropout <- dropout_long %>%
filter(is_dropout == 1) %>%
group_by(participant.label) %>%
summarise(dropout_round = min(round),
.groups = "drop")
# and add to the df:
df_long <- df_long %>%
left_join(first_dropout, by = "participant.label")
# aggregated
df_plot <- df_long %>%
group_by(round) %>%
summarise(
pct_choice1 = mean(choice, na.rm = TRUE) * 100, # proportion * 100
n = n()
)
ggplot(df_plot, aes(x = round, y = pct_choice1)) +
geom_line(group = 1, color = "steelblue", size = .5) +
geom_point(color = "steelblue", size = 2) +
geom_hline(yintercept = 10, linetype = "longdash", color = "darkgrey", size = 0.8) + # dashed line at 10
scale_x_continuous(breaks = df_plot$round) +
scale_y_continuous(limits = c(0, 100)) +
labs(
x = "Round",
y = "% agents choosing 'blue'",
title = "Evolution of an unpopular norm"
)

#sort by node
df_long <- df_long %>%
arrange(participant.node) %>%
select(-participant.label)
df_long$dropout_round[is.na(df_long$dropout_round)] <- 30 #non dropouts, set to 30.
# make roles consistent with utility function roles
df_long$role <- ifelse(df_long$participant.role == "Blue", "trendsetter", "conformist")
# specificy incentive structure parameters
params = list(s = 15, e = 10, w = 40, z = 50, lambda1 = 5, lambda2 = 1.8)
df_long$id <- df_long$participant.node + 1 #nodes are 0-indexed
#add degree
deg <- degree(g)
df_long <- df_long %>%
mutate(degree = deg[id])
calculate_round_utilities <- function(current_round, df_long, network, params) {
# previous round data
df_prev <- df_long %>%
filter(round == current_round - 1) %>%
select(id, role, choice)
# current round data
df_curr <- df_long %>%
filter(round == current_round)
# compute utilities
df_curr <- df_curr %>%
rowwise() %>%
mutate(
util_0 = futility(agent_id = id, choice = 0,
agents = df_prev,
network = network,
params = params)$utility,
util_1 = futility(agent_id = id, choice = 1,
agents = df_prev,
network = network,
params = params)$utility
) %>%
ungroup()
return(df_curr)
}
##calculate_round_utilities(2, df_long, network = g, params = params)
#compute utilities for all rounsd (except round 1)
max_round <- max(df_long$round)
df <- map_dfr(2:max_round, ~calculate_round_utilities(.x, df_long, g, params))
# identify best replies
df <- df %>%
mutate(
predicted_choice = ifelse(util_1 > util_0, 1, 0),
best_reply = (choice == predicted_choice) # TRUE if agent picked the choice with highest utility
)
df_summary <- df %>%
mutate(
preferred_choice = ifelse(role == "trendsetter", 1, 0), # define preferred option by role
chose_preferred = (choice == preferred_choice) # TRUE if they picked their preferred option
) %>%
group_by(round, role) %>%
summarize(
n_agents = n(),
prop_preferred = mean(chose_preferred), # fraction that chose their preferred option
prop_best_reply = mean(best_reply), # fraction that picked the highest-utility choice
.groups = "drop"
)
ggplot(df_summary, aes(x = round)) +
geom_line(aes(y = prop_preferred, color = "Preference"), size = 1) +
geom_line(aes(y = prop_best_reply, color = "Best reply"), size = 1, linetype = "dashed") +
facet_wrap(~role) +
scale_y_continuous(labels = scales::percent_format(accuracy = 1), limits = c(0,1)) +
scale_color_manual(values = c("Preference" = "darkgreen", "Best reply" = "steelblue")) +
labs(
x = "Round",
y = "Proportion of agents",
color = "Metric",
title = "Following preference vs best-reply over rounds"
)

Copyright © Rob Franken