Skip to content

GitLab

Commit b928077b authored by linushof's avatar linushof
Browse files

Set up rerun of simulation for pilot study

parent da47843a
Hide whitespace changes
Inline Side-by-side
R/simulate_comprehensive.R
View file @ b928077b
# load packages
pacman::p_load(tidyverse)
source("R/fun_cumulative_stats.R") # call functions for computing cumulative stats
# gambles and parameters
gambles <- read_csv("./R/data/gambles/sr_subset.csv")
# test set
gambles <- read_csv("data/gambles/sr_subset.csv")
n_agents <- 100
# initial simulation
source("./R/functions/fun_cumulative.R") # call functions for computing cumulative sums and means
# simulation parameters
theta <- expand_grid(s = seq(-.5, .4, .1), # probability increment added to unbiased sampling probability of p = .5
sigma = .5, # noise
boundary = c("absolute", "relative"), # boundary type
a = c(15, 20, 25, 30, 35)) # boundaries comprehensive
set.seed(765)
param_list <- vector("list", length(nrow(theta)))
for (set in seq_len(nrow(theta))) {
gamble_list <- vector("list", length(nrow(gambles)))
for (gamble in seq_len(nrow(gambles))) {
agents_list <- vector("list", n_agents)
for (agent in seq_along(1:n_agents)){
## initial values of an agent's sampling process
fd <- tibble() # state of ignorance
p <- .5 # no attention bias
s <- 0 # no switching at process initiation
init <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s)) # prospect attended first
attend <- init
boundary_reached <- FALSE
## agent's sampling process
while(boundary_reached == FALSE) {
#### draw single sample
if(attend == "a") {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = sample(x = c(a_o1, a_o2), size = 1, prob = c(a_p1, 1-a_p1)) +
round(rnorm(n = 1, mean = 0, sd = theta[[set, "sigma"]]), 2), # gaussian noise
B = NA)
s <- theta[[set, "s"]] # get switching probability
} else {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = NA,
B = b +
round(rnorm(n = 1, mean = 0, theta[[set, "sigma"]]), 2))
s <- -1*theta[[set, "s"]]
}
#### integrate single sample into frequency distribution
fd <- bind_rows(fd, single_smpl) %>%
mutate(A_sum = cumsum2(A, na.rm = TRUE),
B_sum = cumsum2(B, na.rm = TRUE))
#### evaluate accumulated evidence
if(theta[[set, "boundary"]] == "absolute") {
fd <- fd %>%
mutate(choice = case_when(A_sum >= theta[[set, "a"]] ~ "A",
B_sum >= theta[[set, "a"]] ~ "B"))
} else {
fd <- fd %>%
mutate(diff = round(A_sum - B_sum, 2),
choice = case_when(diff >= theta[[set, "a"]] ~ "A",
diff <= -1*theta[[set, "a"]] ~ "B"))
}
if(is.na(fd[[nrow(fd), "choice"]]) == FALSE) {
boundary_reached <- TRUE
} else {
attend <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s))
}
}
agents_list[[agent]] <- expand_grid(agent, fd)
}
all_agents <- agents_list %>% map_dfr(as.list)
gamble_list[[gamble]] <- expand_grid(gamble, all_agents)
}
all_gambles <- gamble_list %>% map_dfr(as.list)
param_list[[set]] <- expand_grid(theta[set, ], all_gambles)
}
sim_comprehensive_init <- param_list %>% map_dfr(as.list)
write_csv(sim_comprehensive_init, "./R/data/simulation/sim_comprehensive_init.csv")
a = seq(15, 75, 15)) # boundaries
# Simulation with extended boundary range
# simulation
## for each parameter combination (rows of theta), all gambles are played by all agents
## 100 (parameter combinations) x 60 (gambles) x 100 (agents) = 600.000 trials
theta <- expand_grid(s = seq(-.5, .4, .1), # probability increment added to unbiased sampling probability of p = .5
sigma = .5, # noise
boundary = c("absolute", "relative"), # boundary type
a = c(40, 45, 50, 55, 60, 65, 70, 75, 80)) # boundaries comprehensive
# Parameter combinations rows 1 to 122
set.seed(76754)
set.seed(19543)
param_list <- vector("list", length(nrow(theta)))
for (set in 1:122) {
for (set in seq_len(nrow(theta))) { # loop over parameter combinations
gamble_list <- vector("list", length(nrow(gambles)))
for (gamble in seq_len(nrow(gambles))) {
for (gamble in seq_len(nrow(gambles))) { # loop over gambles
agents_list <- vector("list", n_agents)
for (agent in seq_along(1:n_agents)){
for (agent in seq_along(1:n_agents)){ # loop over agents
## initial values of an agent's sampling process
# initiate trials in a state of ignorance
fd <- tibble() # state of ignorance
fd <- tibble() # frequency distribution of sampled outcomes
p <- .5 # no attention bias
s <- 0 # no switching at process initiation
init <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s)) # prospect attended first
attend <- init
boundary_reached <- FALSE
## agent's sampling process
# sampling of outcomes from prospects A and B continues until boundary is reached
while(boundary_reached == FALSE) {
#### draw single sample
# draw single sample from either A or B
if(attend == "a") {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = sample(x = c(a_o1, a_o2), size = 1, prob = c(a_p1, 1-a_p1)) +
round(rnorm(n = 1, mean = 0, sd = theta[[set, "sigma"]]), 2), # gaussian noise
A = sample(x = c(a_o1, a_o2), size = 1, prob = c(a_p1, 1-a_p1)),
B = NA)
s <- theta[[set, "s"]] # get switching probability
s <- theta[[set, "s"]] # to update the probability of sampling from A again
} else {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = NA,
B = b +
round(rnorm(n = 1, mean = 0, theta[[set, "sigma"]]), 2))
s <- -1*theta[[set, "s"]]
B = b_o1)
s <- -1*theta[[set, "s"]] # to update the probability of sampling from B again
}
#### integrate single sample into frequency distribution
# add single sample to frequency distribution of sampled outcomes
fd <- bind_rows(fd, single_smpl) %>%
mutate(A_sum = cumsum2(A, na.rm = TRUE),
B_sum = cumsum2(B, na.rm = TRUE))
#### evaluate accumulated evidence
# evaluate accumulated evidence over fd
# evidence is either compared against the absolute or relative boundary
if(theta[[set, "boundary"]] == "absolute") {
fd <- fd %>%
......@@ -157,83 +70,9 @@ for (set in 1:122) {
choice = case_when(diff >= theta[[set, "a"]] ~ "A",
diff <= -1*theta[[set, "a"]] ~ "B"))
}
if(is.na(fd[[nrow(fd), "choice"]]) == FALSE) {
boundary_reached <- TRUE
} else {
attend <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s))
}
}
agents_list[[agent]] <- expand_grid(agent, fd)
}
all_agents <- agents_list %>% map_dfr(as.list)
gamble_list[[gamble]] <- expand_grid(gamble, all_agents)
}
all_gambles <- gamble_list %>% map_dfr(as.list)
param_list[[set]] <- expand_grid(theta[set, ], all_gambles)
}
sim_comprehensive_ext1 <- param_list %>% map_dfr(as.list)
write_csv(sim_comprehensive_ext1, "./R/data/simulation/sim_comprehensive_ext1.csv")
# Parameter combinations rows 1 to 123
set.seed(659)
param_list <- vector("list", length(nrow(theta)))
for (set in 123:nrow(theta)) {
gamble_list <- vector("list", length(nrow(gambles)))
for (gamble in seq_len(nrow(gambles))) {
agents_list <- vector("list", n_agents)
for (agent in seq_along(1:n_agents)){
## initial values of an agent's sampling process
fd <- tibble() # state of ignorance
p <- .5 # no attention bias
s <- 0 # no switching at process initiation
init <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s)) # prospect attended first
attend <- init
boundary_reached <- FALSE
## agent's sampling process
while(boundary_reached == FALSE) {
#### draw single sample
if(attend == "a") {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = sample(x = c(a_o1, a_o2), size = 1, prob = c(a_p1, 1-a_p1)) +
round(rnorm(n = 1, mean = 0, sd = theta[[set, "sigma"]]), 2), # gaussian noise
B = NA)
s <- theta[[set, "s"]] # get switching probability
} else {
single_smpl <- gambles[gamble, ] %>%
mutate(attended = attend,
A = NA,
B = b +
round(rnorm(n = 1, mean = 0, theta[[set, "sigma"]]), 2))
s <- -1*theta[[set, "s"]]
}
#### integrate single sample into frequency distribution
# if boundary is not reached, draw new sample from A (B) according to s
fd <- bind_rows(fd, single_smpl) %>%
mutate(A_sum = cumsum2(A, na.rm = TRUE),
B_sum = cumsum2(B, na.rm = TRUE))
#### evaluate accumulated evidence
if(theta[[set, "boundary"]] == "absolute") {
fd <- fd %>%
mutate(choice = case_when(A_sum >= theta[[set, "a"]] ~ "A",
B_sum >= theta[[set, "a"]] ~ "B"))
} else {
fd <- fd %>%
mutate(diff = round(A_sum - B_sum, 2),
choice = case_when(diff >= theta[[set, "a"]] ~ "A",
diff <= -1*theta[[set, "a"]] ~ "B"))
}
if(is.na(fd[[nrow(fd), "choice"]]) == FALSE) {
boundary_reached <- TRUE
} else {
......@@ -248,5 +87,5 @@ for (set in 123:nrow(theta)) {
all_gambles <- gamble_list %>% map_dfr(as.list)
param_list[[set]] <- expand_grid(theta[set, ], all_gambles)
}
sim_comprehensive_ext2 <- param_list %>% map_dfr(as.list)
write_csv(sim_comprehensive_ext2, "./R/data/simulation/sim_comprehensive_ext2.csv")
sim_comprehensive <- param_list %>% map_dfr(as.list)
write_csv(sim_comprehensive, "data/simulation/sim_comprehensive.csv")
R/simulate_piecewise.R
View file @ b928077b
pacman::p_load(tidyverse)
source("R/fun_cumulative_stats.R") # call functions for computing cumulative stats
# gambles and parameters
# test set
gambles <- read_csv("data/gambles/sr_subset.csv")
n_agents <- 100
# simulation parameters
theta <- expand_grid(s = seq(-.5, .4, .1), # probability increment added to unbiased sampling probability of p = .5
boundary = c("absolute", "relative"), # boundary type
a = c(1, 3, 5, 7)) # boundaries (number of required wins)
a = seq(1, 5, 1)) # boundaries (number of required round-wins)
# simulation
## for each parameter combination (rows of theta), all gambles are played by all agents
## 100 (parameter combinations) x 60 (gambles) x 100 (agents) = 600.000 trials
set.seed(8739)
set.seed(56221)
param_list <- vector("list", length(nrow(theta)))
for (set in seq_len(nrow(theta))) { # loop over parameter combinations
gamble_list <- vector("list", length(nrow(gambles)))
......@@ -19,9 +22,9 @@ for (set in seq_len(nrow(theta))) { # loop over parameter combinations
agents_list <- vector("list", n_agents)
for (agent in seq_along(1:n_agents)){ # loop over agents
## initial values of an agent's sampling process (unique trial)
# initiate trials in a state of ignorance
fd <- tibble() # state of ignorance
fd <- tibble() # frequency distribution of sampled outcomes
p <- .5 # no attention bias
s <- 0 # no switching at process initiation
init <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s)) # prospect attended first
......@@ -29,16 +32,18 @@ for (set in seq_len(nrow(theta))) { # loop over parameter combinations
round <- 1
boundary_reached <- FALSE
## agent's sampling process
# sampling of outcomes from prospects A and B continues until boundary is reached
while(boundary_reached == FALSE) {
#### sampling round
# prospects are compared round-wise
## a round consists of an uninterrupted sequence of sampled outcomes each from A and B
## prospects with a higher mean of sampled outcomes within a round earn a round-win
smpl_round <- tibble()
while(attend == init) {
while(attend == init) {# sequence of single samples from prospect attended first
##### draw single sample from prospect attended first
# draw single sample from either A or B
if(attend == "a") {
single_smpl <- gambles[gamble, ] %>%
......@@ -46,22 +51,22 @@ for (set in seq_len(nrow(theta))) { # loop over parameter combinations
attended = attend,
A = sample(x = c(a_o1, a_o2), size = 1, prob = c(a_p1, 1-a_p1)),
B = NA)
s <- theta[[set, "s"]]
s <- theta[[set, "s"]] # to update the probability of sampling from A again
} else {
single_smpl <- gambles[gamble, ] %>%
mutate(round = round,
attended = attend,
A = NA,
B = b_o1)
s <- -1*theta[[set, "s"]]
s <- -1*theta[[set, "s"]] # to update the probability of of sampling from B again
}
smpl_round <- bind_rows(smpl_round, single_smpl)
attend <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s))
}
while(attend != init) {
while(attend != init) { # sequence of single samples from prospect attended second
##### draw single sample from prospect attended second
# draw single sample from either A or B
if(attend == "a") {
single_smpl <- gambles[gamble, ] %>%
......@@ -82,7 +87,8 @@ for (set in seq_len(nrow(theta))) { # loop over parameter combinations
attend <- sample(c("a", "b"), size = 1, prob = c(p + s, p - s))
}
##### compare mean outcomes
# compare means over sampled outcomes from A and B
# assign round-win
smpl_round <- smpl_round %>%
mutate(A_rmean = cummean2(A, na.rm = TRUE),
......@@ -93,24 +99,28 @@ for (set in seq_len(nrow(theta))) { # loop over parameter combinations
smpl_round[[nrow(smpl_round), "B_win"]] <- case_when(smpl_round[[nrow(smpl_round), "rdiff"]] >= 0 ~ 0,
smpl_round[[nrow(smpl_round), "rdiff"]] < 0 ~ 1)
##### integrate sampling round into frequency distribution
# add sampling round to frequency distribution of sampled outcomes
fd <- bind_rows(fd, smpl_round)
fd[[nrow(fd), "A_sum"]] <- sum(fd[["A_win"]], na.rm = TRUE)
fd[[nrow(fd), "B_sum"]] <- sum(fd[["B_win"]], na.rm = TRUE)
#### evaluate accumulated evidence
# evaluate accumulated evidence (as round-wins) over fd
# evidence is either compared against the absolute or relative boundary
if(theta[[set, "boundary"]] == "absolute") {
fd <- fd %>%
mutate(choice = case_when(A_sum >= theta[[set, "a"]] ~ "A",
B_sum >= theta[[set, "a"]] ~ "B"))
} else {
fd[[nrow(fd), "wdiff"]] <- fd[[nrow(fd), "A_sum"]] - fd[[nrow(fd), "B_sum"]]
fd[[nrow(fd), "diff"]] <- fd[[nrow(fd), "A_sum"]] - fd[[nrow(fd), "B_sum"]]
fd <- fd %>%
mutate(choice = case_when(wdiff >= theta[[set, "a"]] ~ "A",
wdiff <= -1*theta[[set, "a"]] ~ "B"))
mutate(choice = case_when(diff >= theta[[set, "a"]] ~ "A",
diff <= -1*theta[[set, "a"]] ~ "B"))
}
# if boundary is not reached, start new sampling round
if(is.na(fd[[nrow(fd), "choice"]]) == FALSE) {
boundary_reached <- TRUE
} else {
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment