pilot-study.Rmd 28.3 KB
Newer Older
1
---
linushof's avatar
linushof committed
2
3
title: "Sampling in DfE: Pilot Study"
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
18
19
pacman::p_load(repro,
               tidyverse,
               R2jags,
               mcmcplots,
20
21
22
               knitr)
```

linushof's avatar
linushof committed
23
# Note
24

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

linushof's avatar
linushof committed
28
29
30
31
32
33
34
# 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.
35

linushof's avatar
linushof committed
36
# Introduction
37

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

linushof's avatar
linushof committed
40
41
42
# Method

## Data Set
43

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

46
```{r}
linushof's avatar
linushof committed
47
sr_subset <- read_csv("./data/gambles/sr_subset.csv")
48
49
50
kable(sr_subset)
```

linushof's avatar
linushof committed
51
## Model Parameters
52

linushof's avatar
linushof committed
53
54
**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.
55

linushof's avatar
linushof committed
56
57
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.
58

linushof's avatar
linushof committed
59
60
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.
61

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

linushof's avatar
linushof committed
66
# Results
67

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

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

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

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

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

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

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

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

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

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

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

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


# comprehensive

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

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

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

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

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

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

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

# comprehensive

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

328
# Relative 
linushof's avatar
linushof committed
329

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

linushof's avatar
linushof committed
355
356
357
358
359
360
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
361
362
#### Existence and Attractiveness of Rare Events

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

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

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

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

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

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

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

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

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

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

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

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

## Absolute 

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

## Relative 

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

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

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

#### Switching Probability and Boundary Value

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

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

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

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

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

584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
```{r}
# parameters
parameters <- c("alpha",
                "gamma",
                "delta",
                "rho")
n_chains <- 4
```

```{r}
# prepare data for JAGS 

## select strategy-parameter combination

choices_MCMC <- choices %>% 
  filter(strategy == "piecewise" & boundary == "relative" & s == 1, a == 7) %>% 
  mutate(choice_A = case_when(choice == "A" ~ 1,
                              choice == "B" ~ 0),
         i = row_number(),
         a_p2 = 1-a_p1, 
         b_o1 = b,
         b_p1 = b_p,
         b_o2 = 0,
         b_p2 = 0) %>% 
  select(strategy:rare, a_p1, a_o1, a_p2, a_o2, a_ev, b_p1, b_o1, b_p2, b_o2, choice_A, i)

data = list(
      resp = choices_MCMC$choice_A, 
      x_A = choices_MCMC$a_o2, # higher risky outcome 
      y_A = choices_MCMC$a_o1, # lower risky outcome
      x_B = choices_MCMC$b_o1, # safe outcome
      y_B = choices_MCMC$b_o2, # 0
      px_A = choices_MCMC$a_p2, # probability higher risky outcome
      py_A = choices_MCMC$a_p1, # probability lower risky outcome
      px_B = choices_MCMC$b_p1, # probability safe outcome (1)
      py_B = choices_MCMC$b_p2, # 0
      min_i = min(choices_MCMC$i),
      max_i = max(choices_MCMC$i)
    )
```

```{r}
# MCMC sampling
samples <- jags.parallel(data,
                         parameters,
                         model.file = "JAGS/cpt_trial_level.txt",
                         inits = NULL, 
                         n.chains = n_chains, 
                         n.iter = 10000,
                         n.burnin = 5000, 
                         n.thin = 1,
                         n.cluster = n_chains, 
                         jags.seed = 888)


# MCMC diagnostics
samples$BUGSoutput$summary
mcmcplots::mcmcplot(samples)
```



linushof's avatar
linushof committed
646

linushof's avatar
linushof committed
647
# References