simulation_study.Rmd

---
title: "Sampling in DfE: Simulation Study"
author: "Linus Hof, Veronika Zilker & Thorsten Pachur"
bibliography: sampling-strategies-in-dfe.bib
csl: apa.csl
output:
  html_document:
    code_folding: hide
    toc: yes
    toc_float: yes
    number_sections: no
---

```{r}
# load packages
pacman::p_load(repro,
               tidyverse,
               R2jags,
               mcmcplots,
               knitr)
```

# Note

-   Some of the R code is folded but can be unfolded by clicking the `Code` buttons.
-   This document was created from the commit with the hash `r repro::current_hash()`.

# Abstract

Synthetic choice data from decisions from experience (DfE) is generated by applying different strategies of sample integration to 2-prospect gambles. The synthetic data is explored for characteristic choice patterns produced by comprehensive and piecewise forms of sample integration under varying structures of the environment (prospect features) and aspects of the sampling- and decision behavior (model parameters).

# Summary

Provide short summary of pilot study results.

# Introduction

A formal introduction to sampling in DfE and the data generating models of this study can be found [here](https://arc-git.mpib-berlin.mpg.de/sampling-strategies-in-dfe/sampling-strategies-in-dfe/-/blob/main/modeling-sampling.Rmd)

# Method

## Test set

Under each condition, i.e., strategy-parameter combinations, all gambles are played by 100 synthetic agents. We test a set of gambles, in which one of the prospects contains a safe outcome and the other two risky outcomes (*safe-risky gambles*). Therefore, 60 gambles from an initial set of 10,000 are sampled. Both, outcomes and probabilities are drawn from uniform distributions, ranging from 0 to 20 for outcomes and from .01 to .99 for probabilities of the lower risky outcomes $p_{low}$. The probabilities of the higher risky outcomes are $1-p_{low}$, respectively. To omit dominant prospects, safe outcomes fall between both risky outcomes. The table below contains the test set of 60 gambles. Sampling of gambles was stratified, randomly drawing an equal number of 20 gambles with no, an attractive, and an unattractive rare outcome. Risky outcomes are considered *"rare"* if their probability is $p < .2$ and *"attractive"* (*"unattractive"*) if they are higher (lower) than the safe outcome.

```{r}
sr_subset <- read_csv("./data/gambles/sr_subset.csv")
kable(sr_subset)
```

## Model Parameters

**Switching probability** $s$ is the probability increment added to the unbiased probability $p = .5$ with which agents draw the succesive single sample from the same prospect they get their most recent single sample from. 
$s$ is varied between -.5 to .4 in increments of .1. To ease interpretation during data analysis, $s$ is transformed by $s_{rec}= 1-(p + s)$ after the simulation such that it ranges from .1 to 1.

The **boundary type** is either the minimum value any prospect's sample statistic must reach (absolute) or the minimum value for the difference of these statistics (relative). 
Sample statistics are sums over outcomes (comprehensive strategy) and sums over wins (piecewise strategy), respectively.

For comprehensive integration, the **boundary value** $a$ is varied between 15 to 80 in increments of 5.
For piecewise integration $a$ is varied between 1 to 7 in increments of 2.

Representations of the sampled outcomes are assumed to be stochastical. 
Therefore, **Gaussian noise** $\epsilon \sim N(0, \sigma)$ in units of outcomes is added. 
To reduce computational load, $\sigma$ is fixed to .5.

# Results

```{r}
# read choice data 
cols <- list(.default = col_double(),
             strategy = col_factor(),
             boundary = col_factor(),
             gamble = col_factor(),
             rare = col_factor(),
             agent = col_factor(),
             choice = col_factor())
choices_comprehensive <- read_csv("data/choices/choices_comprehensive.csv", col_types = cols)
choices_piecewise <- read_csv("data/choices/choices_piecewise.csv", col_types = cols)

# bind data sets
choices <- bind_rows(choices_comprehensive, choices_piecewise)

# remove choices where prospects were not attended
choices <- choices %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp))) 
```

## Sample Size

Below, median sample sizes of all strategy-parameter combinations (circles) are plotted, ranging from $2 \leq \tilde{x} \leq 162$ for piecewise integration and $3 \leq \tilde{x} \leq 51$ for comprehensive integration.

```{r}
choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a, s) %>% 
  summarise(group = as.factor(cur_group_id()),
            med = round(median(n_sample), 0)) %>%
  ggplot(.) + 
  geom_point(aes(x = reorder(group, med), y = med, color = s, size = a), alpha = .8) +
  facet_wrap(~boundary) + 
  scale_color_gradient(low = "blue", high = "red") + 
  scale_y_continuous(breaks = seq(0, 170, 10)) +
  scale_x_discrete(breaks = NULL, expand = expansion(add = 3)) + 
  theme_minimal() +
  labs(title = "Piecewise Integration",
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
```

```{r}
choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a, s) %>% 
  summarise(group = as.factor(cur_group_id()),
            med = round(median(n_sample), 0)) %>%
  ggplot(.) + 
  geom_point(aes(x = reorder(group, med), y = med, color = s, size = a), alpha = .7) +
  facet_wrap(~boundary) + 
  scale_color_gradient(low = "blue", high = "red") + 
  scale_y_continuous(breaks = seq(0, 60, 5)) +
  scale_x_discrete(breaks = NULL, expand = expansion(add = 3)) + 
  theme_minimal() +
  labs(title = "Comprehensive Integration",
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
```

### Boundary value

Both integration strategies show a similiar effect of boundary value on sample size. I.e., large boundary values lead to larger sample sizes. 
However, for comprehensive integration, the range/spread of sample sizes increases with larger boundaries.

```{r}
# piecewise

med_a <- choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a, s) %>%
  summarise(med = round(median(n_sample), 0)) %>%
  ggplot(., aes(x = a, y = med, color = a)) + 
  facet_wrap(~boundary) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = med_a, size = 4) +
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Piecewise Integration",
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()


# comprehensive

med_a <- choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a, s) %>%
  summarise(med = round(median(n_sample), 0)) %>%
  ggplot(., aes(x = a, y = med, color = a)) + 
  facet_wrap(~boundary) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = med_a, size = 4) +
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Comprehensive Integration",
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()
```

### Boundary type

For both integration strategies, relative (as compared to absolute) boundaries lead to larger sample sizes as sequential sampling, i.e., accumulation of evidence, can either stabilize or reduce a prospects' distance to absolute boundaries while the distance to relative boundaries can also increase.

```{r}
# piecewise

med_a <- choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a, s) %>%
  summarise(med = round(median(n_sample), 0)) %>%
  ggplot(., aes(x = a, y = med, color = boundary)) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = med_a, size = 4) +
  scale_color_manual(values = c("blue", "red")) + 
  labs(title = "Piecewise Integration",
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()

# comprehensive

med_a <- choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a, s) %>%
  summarise(med = round(median(n_sample), 0)) %>%
  ggplot(., aes(x = a, y = med, color = boundary)) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = med_a, size = 4) +
  scale_color_manual(values = c("blue", "red")) +
  labs(title = "Comprehensive Integration",
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()
```

### Switching probability

For piecewise forms of integration, there is an inverse relationship between switching probability and sample size. 
I.e., the lower the switching probability, the less frequent prospects are compared and thus, boundaries are only approached with larger sample sizes. 
This effect is particularly pronounced for low probabilities such that the increase in sample size accelerates as switching probability decreases. 
Consequentially, the magnitude of the effect of the boundary value increases.

```{r}
med_s <- choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "piecewise") %>% 
  group_by(boundary, s, a) %>% 
  summarise(med = round(median(n_sample), 0)) %>% 
  ggplot(., aes(x = s, y = med, color = s, shape = boundary)) + 
  geom_jitter(size = 2, alpha = .5) + 
  geom_point(data = med_s, size = 4) +
  geom_line(data = med_s) +
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Piecewise Integration",
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

For comprehensive forms of integration, boundary types differ in the effects of switching probability. 
For absolute boundaries, switching probability has no apparent effect on sample size as the distance of a given prospect to its absolute boundary is not changed by switching to (and sampling from) the other prospect. 
For relative boundaries, however, samples sizes tend to increase with switching probability.

```{r}
med_s <- choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, s, a) %>% 
  summarise(med = round(median(n_sample), 0)) %>% 
  ggplot(., aes(x = s, y = med, color = s, shape = boundary)) + 
  geom_jitter(size = 2, alpha = .5) + 
  geom_point(data = med_s, size = 4) +
  geom_line(data = med_s) +
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Comprehensive Integration",
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

## Choice Behavior

Below, in extension to Hills and Hertwig [-@hillsInformationSearchDecisions2010], the interplay of integration strategies, gambles' features, and model parameters in their effects on choice behavior in general and their contribution to underweighting of rare events in particular is investigated. 
The working definition of underweighting of rare events is as follows: The rarity of an attractive (unattractive) outcome leads to choose the safe (risky) prospect although the risky (safe) prospect has a higher expected value.

### Piecewise integration

The heatmaps below show the proportions of normatively (i.e., according to the ground EV-difference) false choices with blue cells indicating low proportions and red cells indicating high proportions. 
For each combination of integration strategy and boundary type, 6 heatmaps are plotted (3 x 2 grid). 
The upper panel of each grid shows the proportions of false safe choices and the lower panel of false risky choices. 
The horizontal grid dimension separates gambles in which the rare outcome ($p <= .2$) of the risky option was either larger (attractive) or smaller (unattractive) than the safe outcome. 
Accordingly, underweighting of rare events is indicated in the Attractive-False Safe and the Unattractive-False Risky heatplots. 
Within each heatplot, false response proportions are plotted as a function of the model parameters $s$ (switching probability) and $a$ (boundary value).

```{r}
# Absolute 

choices %>% 
  filter(strategy == "piecewise", boundary == "absolute") %>% 
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = s, fill = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_tile(colour="white",size=0.25) +
  scale_x_discrete(expand=c(0,0), name = "Boundary Value")+
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1), name = "Switching Probability")+
  scale_fill_gradient(low="blue", high="red") + 
  theme_minimal() + 
  labs(title = "Piecewise Integration - Absolute Boundary",
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 

# Relative 

choices %>% 
  filter(strategy == "piecewise", boundary == "relative") %>% 
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = s, fill = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_tile(colour="white",size=0.25) +
  scale_x_discrete(expand=c(0,0), name = "Boundary Value")+
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1), name = "Switching Probability")+
  scale_fill_gradient(low="blue", high="red") + 
  theme_minimal() + 
  labs(title = "Piecewise Integration - Relative Boundary",
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 
```

As can be seen, the differences between both boundary types (absolute vs. relative) are rather minor and of magnitude than of qualitative pattern. 
Therefore, the remaining analyses are aggregated over both boundary types.
However, false response proportions across the cell configurations are systematically different. 
Apparently, the piecewise integration strategy produces extreme response proportions in either direction, for some configurations generating almost no EV-incoherent decisions (blue areas) and for some almost only EV-incoherent decisions (red areas). 
Below, possible determinants of these distinct patterns of false response rates are discussed.

#### Existence and Attractiveness of Rare Events

The inversed color gradients from left to right panels indicate that the presence and attractiveness of rare events is a large determinant of false response rates with the direction of the effect dependent on whether the risky or the safe prospect has a higher EV.
I.e., consistent with the notion of underweighting, the rarity of an attractive outcome leads to choose the safe prospect although the risky prospect has a higher expected value (top panel). 
Conversely, the rarity of an unattractive outcome leads to choose the risky prospect although the safe prospect has a higher expected value (bottom panel).

Below, this relation is emphasized by plotting the false response proportions against the probability of the unattractive outcome. 
If the latter increases, the piecewise strategy is more likely to falsely choose the safe option (top panel) but less likely to falsely choose the risky option (bottom panel).

```{r}
choices %>% filter(strategy == "piecewise") %>% 
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, gamble, a_p1, s, a, choice) %>% 
  summarise(n = n()) %>% 
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a_p1, y = prop, color = prop)) + 
  geom_jitter(alpha = .5, size = 2) + 
  scale_color_gradient(low="blue", high="red")+
  facet_wrap(~kind, nrow = 2) + 
  labs(title = "Piecewise Integration",
       x = "Probability of Unattractive Event", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

#### Switching Probability and Boundary Value

The heatplots and scatterplots indicate that above and beyond the interplay of the rarity and attractiveness of outcomes, there are additional sources of variation of the choice pattern. 
I.e., within some of the panels of the 3 x 2 grids, especially in those indicative for underweighting, we observe a color gradient from low to high switching probabilities. 
Precisely, the plots below indicate that rates of false responses in general and underweighting in particular increase if switching probability increases. 
This is because round-wise comparisons are based on smaller sample sizes for high switching probabilities, pronouncing the effect of rare events described above.

```{r}
choices %>% 
  filter(strategy == "piecewise") %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp))) %>%
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, boundary, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = s, y = prop, color = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
  labs(title = "Piecewise intgration",
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

Plotting the proporions of false responses against different boundary values, no apparent relationship is observed, indicating that a larger number of necessary wins does not reduce the underweighting of rare events. 
I.e., also a larger number of rounds increases the likelihood of a rare event being sampled, the latters magnitude is largely ignored because all rounds are weighted equally. 
In contrast, the samples on which round comparisons are based grow with decreasing switching probabilites.

```{r}
choices %>% 
  filter(strategy == "piecewise") %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp))) %>%
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, boundary, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = prop, color = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
  labs(title = "Piecewise Integration",
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

### Comprehensive Integration

As can be seen below, again the differences between both boundary types seem rather of magnitude than of quality, with the relative boundary producing lower proportions of false responses.

However, false response proportions across the cell configurations are systematically different, producing an overall pattern that is also distinct from the pattern of the piecewise strategy. 
To begin with, as is indicated by the range of false response rates, the comprehensive (as compared to the piecewise) strategy seems to produce less extreme response rates. 
In fact, no systematic underweighting is indicated as false response rates hardly exceed .5. 
Below, possible drivers of the pattern within the comprehensive sampling strategy and between both sampling strategies are identified.

```{r}

## Absolute 

choices %>% 
  filter(strategy == "comprehensive", boundary == "absolute") %>% 
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = s, fill = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_tile(colour="white",size=0.25) +
  scale_x_discrete(expand=c(0,0), name = "Boundary Value")+
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1), name = "Switching Probability")+
  scale_fill_gradient(low="blue", high="red") + 
  theme_minimal() + 
  labs(title = "Comprehensive Integration - Absolute Boundary",
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 

## Relative 

choices %>% 
  filter(strategy == "comprehensive", boundary == "relative") %>% 
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = s, fill = prop)) + 
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
  geom_tile(colour="white",size=0.25) +
  scale_x_discrete(expand=c(0,0), name = "Boundary Value")+
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1), name = "Switching Probability")+
  scale_fill_gradient(low="blue", high="red") + 
  theme_minimal() + 
  labs(title = "Comprehensive Integration - Relative Boundary",
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 
```

#### Existence and Attractiveness of Rare Events

Although the presence and attractiveness of rare events seems to have a small effect on false response rates (indicated by a larger proportion of red cells in the heatplots indicative for underweighting), the proportions generally do not exceed .5. 
Furthermore, all heatmaps show similiar patterns of low (high) false response proportions for large (small) boundaries and switching probabilities, irrespective of the presence and attractiveness of rare events.

#### Switching Probability and Boundary Value

Plotting false response rates as a function of switching probability produces a trend clearly different from the piecewise strategy. 
Precisely, the plots below indicate that rates of false responses decrease if switching probability increases.

```{r}
choices %>% 
  filter(strategy == "comprehensive") %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp))) %>%
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, boundary, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = s, y = prop, color = prop)) + 
  facet_grid(kind~rare, switch = "y") +
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") +
  labs(title = "Comprehensive Integration",
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

For different boundary values we, somewhat unexpectedly, observe no apparent effect on false response rates. 
Usually you would expect an inverse relationship because high boundary values are equivalent with the amount of evidence that must be collected for one or the other prospect - be that absolute or relative. 
Thus higher boundary values should lead to lower false response rates. However, no such trend could be observed.

```{r}
choices %>% 
  filter(strategy == "comprehensive") %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp))) %>%
  mutate(optimal = case_when(ev_ratio > 1 ~ "A",
                             ev_ratio < 1 ~ "B")) %>% 
  group_by(optimal, boundary, rare, s, a, choice) %>% 
  summarise(n = n()) %>%
  mutate(prop = round(n/sum(n), 2)) %>% 
  mutate(kind = case_when(optimal == choice ~ "norm",
                          optimal == "A" & choice == "B" ~ "False Safe",
                          optimal == "B" & choice == "A" ~ "False Risky")) %>% 
  mutate(kind = as.factor(kind)) %>% 
  filter(kind != "norm") %>%
  ggplot(., aes(x = a, y = prop, color = prop)) + 
  facet_grid(kind~rare, switch = "y") +
  geom_jitter(size = 3) + 
  scale_color_gradient(low = "blue", high = "red") +
  labs(title = "Comprehensive Integration",
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

### Modeling Choices in Cumulative Prospect Theory 


# References