pilot-study.Rmd 27 KB
Newer Older
1
---
2
title: "Sampling in DfE - Pilot"
linushof's avatar
linushof committed
3
date: "July 27, 2021"
4
5
6
7
8
9
10
11
bibliography: sampling-strategies-in-dfe.bib
csl: apa.csl
output:
  html_document:
    code_folding: hide
    toc: yes
    toc_float: yes
    number_sections: yes
12
13
---

linushof's avatar
linushof committed
14
15
Some of the `R code` is folded but can be unfolded by clicking the `Code` buttons.

16
17
```{r}
# load packages
18
pacman::p_load(tidyverse,
19
20
21
               knitr)
```

linushof's avatar
linushof committed
22
# Description
23

24
Choice data is generated by applying different strategies of sample integration to 2-prospect gambles in decisions from experience (DfE). The synthetic data is explored for characteristic choice patterns eventually 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 ).
25

26
# Method
27

28
## Agents 
29

30
Under each condition, i.e., strategy-parameter combinations, all gambles are played by 100 synthetic agents. 
31

32
## Gambles
33

linushof's avatar
linushof committed
34
A set of gambles, in which one of the prospects contains a safe outcome and the other two risky outcomes (*safe-risky gambles*) will be tested. 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_L$. The probabilities of the higher risky outcomes are $1-p_L$, 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. 
35

36
```{r}
linushof's avatar
linushof committed
37
sr_subset <- read_csv("./data/gambles/sr_subset.csv")
38
39
40
kable(sr_subset)
```

41
## Model Parameters 
42

linushof's avatar
linushof committed
43
**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.   
44

linushof's avatar
linushof committed
45
**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.
46

47
**Boundary value:** For comprehensive integration, $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. 
48

linushof's avatar
linushof committed
49
**Noise parameter:** 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.
50

51
# Descriptive Analyses
52

53
Analyses of the generated choice data focuses on the interplay of integration strategies, different gamble features (e.g. existence and valence of rare outcomes), and parameter combinations in their effects on sample sizes and choice behavior. 
54

55
```{r}
56
57
58
59
60
61
62
63
# 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
64
65
choices_comprehensive <- read_csv("./data/choices/choices_comprehensive.csv", col_types = cols)
choices_piecewise <- read_csv("./data/choices/choices_piecewise.csv", col_types = cols)
66

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

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

linushof's avatar
linushof committed
75
76
## Sample Size

77
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.
78
79

```{r}
80
choices %>%
linushof's avatar
linushof committed
81
82
83
84
85
86
87
88
89
90
91
  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() +
92
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
93
94
95
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
96
97
98
```

```{r}
99
choices %>%
linushof's avatar
linushof committed
100
101
102
103
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a, s) %>% 
  summarise(group = as.factor(cur_group_id()),
            med = round(median(n_sample), 0)) %>%
104
  ggplot(.) + 
linushof's avatar
linushof committed
105
106
107
  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") + 
108
  scale_y_continuous(breaks = seq(0, 60, 5)) +
linushof's avatar
linushof committed
109
110
  scale_x_discrete(breaks = NULL, expand = expansion(add = 3)) + 
  theme_minimal() +
111
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
112
113
114
       x ="Strategy-Parameter Combination", 
       y="Sample Size", size="Boundary Value", 
       col="Switching Probability")
115
116
117
118
```

### Boundary value 

119
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.  
120
121

```{r}
linushof's avatar
linushof committed
122
123
# piecewise

124
med_a <- choices %>%
linushof's avatar
linushof committed
125
126
127
128
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

129
choices %>%
linushof's avatar
linushof committed
130
131
132
133
134
135
136
  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) +
137
138
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
139
140
141
142
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()
143
```
linushof's avatar
linushof committed
144
145


146
```{r}
linushof's avatar
linushof committed
147
148
# comprehensive

149
med_a <- choices %>%
linushof's avatar
linushof committed
150
151
152
153
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

154
choices %>%
linushof's avatar
linushof committed
155
156
157
158
159
160
161
  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) +
162
163
  scale_color_gradient(low = "blue", high = "red") + 
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
164
165
166
167
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Value") + 
  theme_minimal()
168
169
```

170

171
172
### Boundary type 

173
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. 
174
175

```{r}
linushof's avatar
linushof committed
176
177
# piecewise

178
med_a <- choices %>%
linushof's avatar
linushof committed
179
180
181
182
  filter(strategy == "piecewise") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

183
choices %>%
linushof's avatar
linushof committed
184
185
186
187
188
189
  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) +
190
191
  scale_color_manual(values = c("blue", "red")) + 
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
192
193
194
195
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()
196
```
linushof's avatar
linushof committed
197

198
```{r}
linushof's avatar
linushof committed
199
200
# comprehensive

201
med_a <- choices %>%
linushof's avatar
linushof committed
202
203
204
205
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, a) %>% 
  summarise(med = round(median(n_sample), 0))

206
choices %>%
linushof's avatar
linushof committed
207
208
209
210
211
212
  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) +
213
214
  scale_color_manual(values = c("blue", "red")) +
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
215
216
217
218
       x ="Boundary value", 
       y="Sample Size", 
       col="Boundary Type") + 
  theme_minimal()
219
220
```

221

222
223
### Switching probability 

224
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
225
226

```{r}
227
med_s <- choices %>%
linushof's avatar
linushof committed
228
229
230
231
  filter(strategy == "piecewise") %>% 
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

232
choices %>%
linushof's avatar
linushof committed
233
234
235
236
237
238
239
240
  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") + 
241
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
242
243
244
245
246
247
248
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

249
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
250
251

```{r}
252
253
med_s <- choices %>%
  filter(strategy == "comprehensive") %>% 
linushof's avatar
linushof committed
254
255
256
  group_by(boundary, s) %>% 
  summarise(med = round(median(n_sample), 0))

257
258
259
choices %>%
  filter(strategy == "comprehensive") %>% 
  group_by(boundary, s, a) %>% 
linushof's avatar
linushof committed
260
  summarise(med = round(median(n_sample), 0)) %>% 
261
  ggplot(., aes(x = s, y = med, color = s, shape = boundary)) + 
linushof's avatar
linushof committed
262
263
264
265
  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") + 
266
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
267
268
269
270
271
272
273
       x ="Switching Probability", 
       y="Sample Size", 
       col="Switching Probability",
       shape = "Boundary Type") + 
  theme_minimal()
```

274
## Choice Behavior and as-if-Underweighting
linushof's avatar
linushof committed
275

276
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
277
278
279

### Interpretation of heatmaps

280
The heatmaps below show the proportions of normatively (i.e., according to the EV-difference) false choices with blueish cells indicating low proportions and redish 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 is 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
281

282
### Piecewise integration
linushof's avatar
linushof committed
283
284
285
286
287

As can be seen below, 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 sampling 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 identified.

linushof's avatar
linushof committed
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
```{r}
choices %>% 
  filter(strategy == "comprehensive") %>% 
  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") %>%
  arrange(desc(prop)) %>% 
  View()
```


linushof's avatar
linushof committed
306
```{r}
307
# Absolute 
linushof's avatar
linushof committed
308

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

333
# Relative 
linushof's avatar
linushof committed
334

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

#### 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) - cf. signal-detection-theory.

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

linushof's avatar
linushof committed
389
390
391
392
393
#### 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}
394
choices %>% 
linushof's avatar
linushof committed
395
396
397
398
399
400
401
402
403
404
405
406
407
  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)) + 
408
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
409
410
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
411
  labs(title = "Piecewise intgration",
linushof's avatar
linushof committed
412
413
414
415
416
417
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
```

418
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.   
419
420

```{r}
421
choices %>% 
422
  filter(strategy == "piecewise") %>% 
linushof's avatar
linushof committed
423
424
425
426
427
428
429
430
431
432
433
434
  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)) + 
435
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
436
437
  geom_jitter(size = 3) +
  scale_color_gradient(low="blue", high="red") + 
438
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
439
440
441
442
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
443
444
445
```


446
### Comprehensive Integration
linushof's avatar
linushof committed
447

448
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
449

450
However, false response proportions across the cell configurations are systematically different, producing an overall pattern that is also clearly different 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.
451
452

```{r}
linushof's avatar
linushof committed
453
454
455

## Absolute 

456
choices %>% 
linushof's avatar
linushof committed
457
458
459
460
461
462
463
464
465
466
467
468
  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)) + 
469
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
470
471
472
473
474
  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() + 
475
  labs(title = "Comprehensive Integration - Absolute Boundary",
linushof's avatar
linushof committed
476
477
478
479
480
481
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 

## Relative 

482
choices %>% 
linushof's avatar
linushof committed
483
484
485
486
487
488
489
490
491
492
493
494
  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)) + 
495
  facet_grid(kind~fct_relevel(rare, "Attractive","None","Unattractive"), switch = "y") +
linushof's avatar
linushof committed
496
497
498
499
500
  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() + 
501
  labs(title = "Comprehensive Integration - Relative Boundary",
linushof's avatar
linushof committed
502
503
504
       x = "Boundary Value", 
       y= "Switching Probability", 
       fill = "% False Responses") 
505
506
```

linushof's avatar
linushof committed
507
508
#### Existence and Attractiveness of Rare Events

509
In contrast to the piecewise strategy, the presence and attractiveness of rare events has only a minor effect on false response rates, indicated by a larger proportion of red cells in the heatplots indicative for underweighting. However, 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
510
511
512

#### Switching Probability and Boundary Value

513
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. 
514
515

```{r}
516
choices %>% 
linushof's avatar
linushof committed
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
  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") +
533
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
534
535
536
537
       x = "Switching Probability", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
538
539
```

540
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. 
541
542

```{r}
543
choices %>% 
linushof's avatar
linushof committed
544
545
546
547
548
549
550
551
552
553
554
555
556
557
  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") +
558
559
560
  geom_jitter(size = 3) + 
  scale_color_gradient(low = "blue", high = "red") +
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
561
562
563
564
       x = "Boundary Value", 
       y= "% False responses", 
       color = "% False Responses")  + 
  theme_minimal()
565
566
```

567
# References
568

linushof's avatar
linushof committed
569
570