simulation_study.Rmd 26.1 KB
Newer Older
1
---
linushof's avatar
linushof committed
2
title: "Sampling in DfE: Simulation Study"
linushof's avatar
linushof committed
3
author: "Linus Hof, Veronika Zilker & Thorsten Pachur"
4
5
6
7
8
9
10
bibliography: sampling-strategies-in-dfe.bib
csl: apa.csl
output:
  html_document:
    code_folding: hide
    toc: yes
    toc_float: yes
linushof's avatar
linushof committed
11
    number_sections: no
12
13
---

14
15
```{r}
# load packages
linushof's avatar
linushof committed
16
17
pacman::p_load(repro,
               tidyverse,
18
19
20
               knitr)
```

linushof's avatar
linushof committed
21
# Note
22

linushof's avatar
linushof committed
23
24
-   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()`.
25

linushof's avatar
linushof committed
26
27
# Abstract

linushof's avatar
linushof committed
28
29
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 (gamble features) and aspects of the sampling- and decision behavior (model parameters).
linushof's avatar
linushof committed
30
31
32

# Summary

linushof's avatar
linushof committed
33
Provide short summary of simulation study results.
34

linushof's avatar
linushof committed
35
# Introduction
36

linushof's avatar
linushof committed
37
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)
38

linushof's avatar
linushof committed
39
40
# Method

linushof's avatar
linushof committed
41
## Test set
42

linushof's avatar
linushof committed
43
44
45
46
47
48
49
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.
50

51
```{r}
linushof's avatar
linushof committed
52
sr_subset <- read_csv("data/gambles/sr_subset.csv")
53
54
55
kable(sr_subset)
```

linushof's avatar
linushof committed
56
## Model Parameters
57

linushof's avatar
linushof committed
58
59
**Switching probability** $s$ is the probability with which agents draw the following single sample from the prospect they did not get their most recent single sample from. 
$s$ is varied between .1 to 1 in increments of .1.
60

linushof's avatar
linushof committed
61
62
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.
63

linushof's avatar
linushof committed
64
65
For comprehensive integration, the **boundary value** $a$ is varied between 15 to 75 in increments of 15.
For piecewise integration $a$ is varied between 1 to 5 in increments of 1.
66

linushof's avatar
linushof committed
67
# Results
68

69
```{r}
70
71
72
73
74
75
76
77
# 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())
linushof's avatar
linushof committed
78
79
choices_comprehensive <- read_csv("data/choices/choices_comprehensive.csv", col_types = cols)
choices_piecewise <- read_csv("data/choices/choices_piecewise.csv", col_types = cols)
80

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

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

linushof's avatar
linushof committed
89
90
## Sample Size

91
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.
92
93

```{r}
94
choices %>%
linushof's avatar
linushof committed
95
96
97
98
99
100
101
102
103
104
105
  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() +
106
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
107
108
109
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
110
111
112
```

```{r}
113
choices %>%
linushof's avatar
linushof committed
114
115
116
117
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a, s) %>% 
  summarise(group = as.factor(cur_group_id()),
            med = round(median(n_sample), 0)) %>%
118
  ggplot(.) + 
linushof's avatar
linushof committed
119
120
121
  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") + 
122
  scale_y_continuous(breaks = seq(0, 60, 5)) +
linushof's avatar
linushof committed
123
124
  scale_x_discrete(breaks = NULL, expand = expansion(add = 3)) + 
  theme_minimal() +
125
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
126
127
128
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
129
130
```

linushof's avatar
linushof committed
131
### Boundary value
132

linushof's avatar
linushof committed
133
134
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.
135
136

```{r}
linushof's avatar
linushof committed
137
138
# piecewise

139
med_a <- choices %>%
linushof's avatar
linushof committed
140
141
142
143
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

144
choices %>%
linushof's avatar
linushof committed
145
146
147
148
149
150
151
  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) +
152
153
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
154
155
156
157
158
159
160
161
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()


# comprehensive

162
med_a <- choices %>%
linushof's avatar
linushof committed
163
164
165
166
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

167
choices %>%
linushof's avatar
linushof committed
168
169
170
171
172
173
174
  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) +
175
176
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
177
178
179
180
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()
181
182
```

linushof's avatar
linushof committed
183
### Boundary type
184

linushof's avatar
linushof committed
185
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.
186
187

```{r}
linushof's avatar
linushof committed
188
189
# piecewise

190
med_a <- choices %>%
linushof's avatar
linushof committed
191
192
193
194
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

195
choices %>%
linushof's avatar
linushof committed
196
197
198
199
200
201
  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) +
202
203
  scale_color_manual(values = c("blue", "red")) + 
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
204
205
206
207
208
209
210
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()

# comprehensive

211
med_a <- choices %>%
linushof's avatar
linushof committed
212
213
214
215
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

216
choices %>%
linushof's avatar
linushof committed
217
218
219
220
221
222
  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) +
223
224
  scale_color_manual(values = c("blue", "red")) +
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
225
226
227
228
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()
229
230
```

linushof's avatar
linushof committed
231
### Switching probability
232

linushof's avatar
linushof committed
233
234
235
236
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.
linushof's avatar
linushof committed
237
238

```{r}
239
med_s <- choices %>%
linushof's avatar
linushof committed
240
241
242
243
  filter(strategy == "piecewise") %>% 
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

244
choices %>%
linushof's avatar
linushof committed
245
246
247
248
249
250
251
252
  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") + 
253
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
254
255
256
257
258
259
260
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

linushof's avatar
linushof committed
261
262
263
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.
linushof's avatar
linushof committed
264
265

```{r}
266
267
med_s <- choices %>%
  filter(strategy == "comprehensive") %>% 
linushof's avatar
linushof committed
268
269
270
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

271
272
273
choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, s, a) %>% 
linushof's avatar
linushof committed
274
  summarise(med = round(median(n_sample), 0)) %>% 
275
  ggplot(., aes(x = s, y = med, color = s, shape = boundary)) + 
linushof's avatar
linushof committed
276
277
278
279
  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") + 
280
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
281
282
283
284
285
286
287
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

linushof's avatar
linushof committed
288
## Choice Behavior
linushof's avatar
linushof committed
289

linushof's avatar
linushof committed
290
291
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.
linushof's avatar
linushof committed
292

293
### Piecewise integration
linushof's avatar
linushof committed
294

linushof's avatar
linushof committed
295
296
297
298
299
300
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).
linushof's avatar
linushof committed
301

linushof's avatar
linushof committed
302
```{r}
303
# Absolute 
linushof's avatar
linushof committed
304

305
choices %>% 
linushof's avatar
linushof committed
306
307
308
309
310
311
312
313
314
315
316
317
  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)) + 
318
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
319
320
321
322
323
  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() + 
324
  labs(title = "Piecewise Integration - Absolute Boundary",
linushof's avatar
linushof committed
325
326
327
328
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 

329
# Relative 
linushof's avatar
linushof committed
330

331
choices %>% 
linushof's avatar
linushof committed
332
333
334
335
336
337
338
339
340
341
342
343
  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)) + 
344
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
345
346
347
348
349
  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() + 
350
  labs(title = "Piecewise Integration - Relative Boundary",
linushof's avatar
linushof committed
351
352
353
354
355
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 
```

linushof's avatar
linushof committed
356
357
358
359
360
361
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.

linushof's avatar
linushof committed
362
363
#### Existence and Attractiveness of Rare Events

linushof's avatar
linushof committed
364
365
366
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).
linushof's avatar
linushof committed
367

linushof's avatar
linushof committed
368
369
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).
linushof's avatar
linushof committed
370
371

```{r}
372
choices %>% filter(strategy == "piecewise") %>% 
linushof's avatar
linushof committed
373
374
375
376
377
378
379
380
381
382
383
384
385
386
  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) + 
387
388
  labs(title = "Piecewise Integration",
       x = "Probability of Unattractive Event", 
linushof's avatar
linushof committed
389
390
391
392
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```
393

linushof's avatar
linushof committed
394
395
#### Switching Probability and Boundary Value

linushof's avatar
linushof committed
396
397
398
399
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.
linushof's avatar
linushof committed
400
401

```{r}
402
choices %>% 
linushof's avatar
linushof committed
403
404
405
406
407
408
409
410
411
412
413
414
415
  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)) + 
416
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
417
418
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
419
  labs(title = "Piecewise intgration",
linushof's avatar
linushof committed
420
421
422
423
424
425
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

linushof's avatar
linushof committed
426
427
428
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.
429
430

```{r}
431
choices %>% 
432
  filter(strategy == "piecewise") %>% 
linushof's avatar
linushof committed
433
434
435
436
437
438
439
440
441
442
443
444
  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)) + 
445
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
446
447
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
448
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
449
450
451
452
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
453
454
```

455
### Comprehensive Integration
linushof's avatar
linushof committed
456

linushof's avatar
linushof committed
457
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.
linushof's avatar
linushof committed
458

linushof's avatar
linushof committed
459
460
461
462
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.
463
464

```{r}
linushof's avatar
linushof committed
465
466
467

## Absolute 

468
choices %>% 
linushof's avatar
linushof committed
469
470
471
472
473
474
475
476
477
478
479
480
  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)) + 
481
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
482
483
484
485
486
  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() + 
487
  labs(title = "Comprehensive Integration - Absolute Boundary",
linushof's avatar
linushof committed
488
489
490
491
492
493
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 

## Relative 

494
choices %>% 
linushof's avatar
linushof committed
495
496
497
498
499
500
501
502
503
504
505
506
  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)) + 
507
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
508
509
510
511
512
  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() + 
513
  labs(title = "Comprehensive Integration - Relative Boundary",
linushof's avatar
linushof committed
514
515
516
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 
517
518
```

linushof's avatar
linushof committed
519
520
#### Existence and Attractiveness of Rare Events

linushof's avatar
linushof committed
521
522
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.
linushof's avatar
linushof committed
523
524
525

#### Switching Probability and Boundary Value

linushof's avatar
linushof committed
526
527
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.
528
529

```{r}
530
choices %>% 
linushof's avatar
linushof committed
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
  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") +
547
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
548
549
550
551
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
552
553
```

linushof's avatar
linushof committed
554
555
556
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.
557
558

```{r}
559
choices %>% 
linushof's avatar
linushof committed
560
561
562
563
564
565
566
567
568
569
570
571
572
573
  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") +
574
575
576
  geom_jitter(size = 3) + 
  scale_color_gradient(low = "blue", high = "red") +
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
577
578
579
580
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
581
582
```

linushof's avatar
linushof committed
583
### Modeling Choices in Cumulative Prospect Theory 
linushof's avatar
linushof committed
584
585


linushof's avatar
linushof committed
586
# References