simulation_study.Rmd 28.4 KB
Newer Older
1
---
linushof's avatar
linushof committed
2
3
title: 'Sampling Strategies in Decisions from Experience'
author: "Linus Hof, Thorsten Pachur, Veronika Zilker"
4
5
6
7
8
9
bibliography: sampling-strategies-in-dfe.bib
output:
  html_document:
    code_folding: hide
    toc: yes
    toc_float: yes
linushof's avatar
linushof committed
10
    number_sections: no
linushof's avatar
linushof committed
11
12
13
  pdf_document:
    toc: yes
csl: apa.csl
linushof's avatar
linushof committed
14
15
16
editor_options: 
  markdown: 
    wrap: sentence
17
18
---

19
20
```{r}
# load packages
linushof's avatar
linushof committed
21
22
pacman::p_load(repro,
               tidyverse,
linushof's avatar
linushof committed
23
24
               knitr, 
               viridis)
25
26
```

linushof's avatar
linushof committed
27
# Note
28

linushof's avatar
linushof committed
29
-   This document was created from the commit with the hash `r repro::current_hash()`.
30

linushof's avatar
linushof committed
31
32
# Abstract

33
34
35
Synthetic choice data from so-called decisions from experience is generated by applying different strategies of sample integration to a series of choice problems between two prospects.
The synthetic data is explored for characteristic choice patterns produced by these strategies under varying structures of the environment (prospect features) and aspects of the sampling- and decision behavior.
We start our argument by giving a probability theoretic account of prospects, sampling, and sample integration and derive assumptions about the choice patterns that result from different integration strategies if applied.
linushof's avatar
linushof committed
36
37
38

# Summary

39
Provide short summary of simulation results.
40

linushof's avatar
linushof committed
41
# Introduction
42

43
## Prospects as Probability Spaces
linushof's avatar
linushof committed
44

45
Let a prospect be a *probability space* $(\Omega, \mathscr{F}, P)$ [@kolmogorovFoundationsTheoryProbability1950; @georgiiStochasticsIntroductionProbability2008, for an more accessible introduction].
linushof's avatar
linushof committed
46

47
$\Omega$ is the *sample space* containing a finite set of possible outcomes 
linushof's avatar
linushof committed
48

49
50
51
$$\begin{equation}
\omega_i = \{\omega_1, ..., \omega_n\} \in \Omega
\end{equation}$$ 
linushof's avatar
linushof committed
52

53
$\mathscr{F}$ is a set of subsets of $\Omega$, i.e., the *event space*
linushof's avatar
linushof committed
54

55
56
57
$$\begin{equation}
A_i = \{A_1, ..., A_n\} \in \mathscr{F}
\end{equation}$$
linushof's avatar
linushof committed
58

59
where
linushof's avatar
linushof committed
60

61
62
63
$$\begin{equation}
\mathscr{F} \subset \mathscr{P}(\Omega)
\end{equation}$$
linushof's avatar
linushof committed
64

65
$\mathscr{P}(\Omega)$ denotes the power set of $\Omega$. 
linushof's avatar
linushof committed
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
$P$ is a *probability mass function* (PMF) which maps the event space to the set of real numbers in $[0, 1]$: 

$$\begin{equation}
P: \mathscr{F} \mapsto [0,1]
\end{equation}$$

by assigning each $\omega_i \in \Omega$ a probability of $0 \leq p_i \leq 1$ with $P(\Omega) = 1$.

## Random Processes in Sequential Sampling 

In research on the decision theory, a standard paradigm is the choice between $n \geq 2$ monetary prospects (hereafter indexed with j), where $\omega_{ij} \in \Omega_j$ are monetary outcomes, gains and/or losses respectively.
$P_j$ is then the probability measure which assigns each $\omega_{ij}$ a probability with which they occur. 
In such a choice paradigm, agents are asked to evaluate the prospects and build a preference for, i.e., choose, either one of them. 
It is common to make a rather crude distinction between two variants of this evaluation process [cf. @hertwigDescriptionExperienceGap2009]. 
For decisions from description (DfD), agents are provided a full symbolic description of the triples $(\Omega, \mathscr{F}, P)_j$.
For decision from experience (DfE; e.g., @hertwigDecisionsExperienceEffect2004), the probability triples are not described but must be explored by the means of *sampling*. 

To provide a formal definition of sampling in risky or uncertain choice, we make use of random variables, functions which build the foundation of the random processes decision theory is concerned with but which are rarely explicated. 
Thus, if for each

$$\begin{equation}
\omega_{i} \in \Omega: p(\omega_{i}) \neq 1
\end{equation}$$

we refer to the respective prospect as *"risky"*, where risky describes the fact that if agents would choose the prospect and any of the outcomes $\omega_{i}$ must occur, none of these outcomes will occur with certainty but according to the probability measure $P$. 
It is acceptable to speak of the occurrence of $\omega_{i}$ as the realization of a random variable iff the latter is defined as the function 

$$\begin{equation}
X: (\Omega, \mathscr{F})  \mapsto (\Omega', \mathscr{F'})
\end{equation}$$

where $(\Omega', \mathscr{F'})$ is a measurable image of $(\Omega, \mathscr{F})$. 
I.e., $X$ maps any event $A_i \in \mathscr{F}$ to a quantity $A'_i \in \mathscr{F'}$ and we denote the latter as the realization of the random variable $X$

$$\begin{equation}
A_i \in  \mathscr{F}: X(A_i) \Rightarrow A'_i \in \mathscr{F'}
\end{equation}$$

However, to allow $\omega_{i}$ to be a realization of a random variable defined on $(\Omega, \mathscr{F})$, we must also set 

$$\begin{equation}
\Omega = \mathscr{F} = \mathscr{F'}
\end{equation}$$

Given this restriction, we define a realization of the described random variable as a *single sample* and any systematic approach to generate a sequence of single samples from $n \geq 2$ prospects as a sampling strategy [see also @hillsInformationSearchDecisions2010]. 
Because for a sufficiently large number of single samples from a given prospect the relative frequencies of $\omega_{i}$ approximate their probabilities in $p_i \in P$, sampling in principle allows to explore a prospects probability space. 

So far, we used the random variable defined on a prospect's triple $(\Omega, \mathscr{F}, P)$ and the restriction $\Omega = \mathscr{F'}$ solely to provide a probability theoretic definition of a single sample.
However, since in the decision literature the stochastic occurrence of the raw outcomes in $\Omega$ is often the event of interest, it should be justified to state that this restricted stochastic model is abundantly but implicitly assumed to underlay the evaluation processes of agents. 
We do not contend that this model is not adequate but rather empirically warranted and mathematically convenient because of the measurable nature of monetary outcomes. 
However, in line with the literature that deviates from utility models and its derivatives [@heOntologyDecisionModels2020, for an ontology of decision models], we propose that the above restricted model is not the only suitable for describing the random processes agents are interested in when building a preference between risky prospects.

How to construct alternative stochastic models underlying choices between risky prospects?  
The above definition of a random variable allows us to depart from the standard model of the random process 
linushof's avatar
linushof committed
121
122

...
123

124
125


linushof's avatar
linushof committed
126
127
# Method

linushof's avatar
linushof committed
128
## Test set
129

linushof's avatar
linushof committed
130
131
132
133
134
135
136
137
138
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.
139

linushof's avatar
linushof committed
140
141
142
```{r message=FALSE}
gambles <- read_csv("data/gambles/sr_subset.csv")
gambles %>% kable()
143
144
```

linushof's avatar
linushof committed
145
## Model Parameters
146

linushof's avatar
linushof committed
147
**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.
linushof's avatar
linushof committed
148
$s$ is varied between .1 to 1 in increments of .1.
149

linushof's avatar
linushof committed
150
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).
linushof's avatar
linushof committed
151
Sample statistics are sums over outcomes (comprehensive strategy) and sums over wins (piecewise strategy), respectively.
152

linushof's avatar
linushof committed
153
154
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.
155

linushof's avatar
linushof committed
156
```{r message=FALSE}
157
158
159
160
161
162
163
164
# 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
165
choices <- read_csv("data/choices/choices.csv", col_types = cols)
166
167
```

linushof's avatar
linushof committed
168
In sum, 2 (strategies) x 60 (gambles) x 100 (agents) x 100 (parameter combinations) = `r nrow(choices)` choices are simulated.
linushof's avatar
linushof committed
169

linushof's avatar
linushof committed
170
# Results
171

linushof's avatar
linushof committed
172
173
Because we are not interested in deviations from normative choice due to sampling artifacts (e.g., ceiling effects produced by low boundaries), we remove trials in which only one prospect was attended.
In addition, we use relative frequencies of sampled outcomes rather than 'a priori' probabilities to compare actual against normative choice behavior.
174
175

```{r}
linushof's avatar
linushof committed
176
177
178
# remove choices where prospects were not attended
choices <- choices %>%
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp)))
179
180
```

linushof's avatar
linushof committed
181
182
183
184
185
```{r eval = FALSE}
# remove choices where not all outcomes were sampled
choices <- choices %>% 
  filter(!(is.na(a_ev_exp) | is.na(b_ev_exp) | a_p1_exp == 0 | a_p2_exp == 0))
```
linushof's avatar
linushof committed
186

linushof's avatar
linushof committed
187
Removing the respective trials, we are left with `r nrow(choices)` choices.
linushof's avatar
linushof committed
188

linushof's avatar
linushof committed
189
## Sample Size
linushof's avatar
linushof committed
190

linushof's avatar
linushof committed
191
192
193
194
195
196
```{r message=FALSE}
samples <- choices %>% 
  group_by(strategy, s, boundary, a) %>% 
  summarise(n_med = median(n_sample))
samples_piecewise <- samples %>% filter(strategy == "piecewise")
samples_comprehensive <- samples %>% filter(strategy == "comprehensive")
197
198
```

linushof's avatar
linushof committed
199
The median sample sizes generated by different parameter combinations ranged from `r min(samples_piecewise$n_med)` to `r max(samples_piecewise$n_med)` for piecewise integration and `r min(samples_comprehensive$n_med)` to `r max(samples_comprehensive$n_med)` for comprehensive integration.
200

linushof's avatar
linushof committed
201
### Boundary type and boundary value (a)
202

linushof's avatar
linushof committed
203
As evidence is accumulated sequentially, relative boundaries and large boundary values naturally lead to larger sample sizes, irrespective of the integration strategy.
linushof's avatar
linushof committed
204

linushof's avatar
linushof committed
205
206
```{r message=FALSE}
group_med <- samples_piecewise %>%
linushof's avatar
linushof committed
207
  group_by(boundary, a) %>% 
linushof's avatar
linushof committed
208
  summarise(group_med = median(n_med)) # to get the median across all s values
linushof's avatar
linushof committed
209

linushof's avatar
linushof committed
210
211
samples_piecewise %>%
  ggplot(aes(a, n_med, color = a)) + 
linushof's avatar
linushof committed
212
  geom_jitter(alpha = .5, size = 2) +
linushof's avatar
linushof committed
213
214
215
  geom_point(data = group_med, aes(y = group_med), size = 3) +
  facet_wrap(~boundary) + 
  scale_color_viridis() + 
216
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
217
       x ="a", 
linushof's avatar
linushof committed
218
       y="Sample Size", 
linushof's avatar
linushof committed
219
       col="a") + 
linushof's avatar
linushof committed
220
  theme_minimal()
linushof's avatar
linushof committed
221
```
linushof's avatar
linushof committed
222

linushof's avatar
linushof committed
223
224
```{r message=FALSE}
group_med <- samples_comprehensive %>%
linushof's avatar
linushof committed
225
  group_by(boundary, a) %>% 
linushof's avatar
linushof committed
226
  summarise(group_med = median(n_med)) 
linushof's avatar
linushof committed
227

linushof's avatar
linushof committed
228
229
samples_comprehensive %>%
  ggplot(aes(a, n_med, color = a)) + 
linushof's avatar
linushof committed
230
  geom_jitter(alpha = .5, size = 2) +
linushof's avatar
linushof committed
231
232
233
  geom_point(data = group_med, aes(y = group_med), size = 3) +
  facet_wrap(~boundary) + 
  scale_color_viridis() + 
234
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
235
       x ="a", 
linushof's avatar
linushof committed
236
       y="Sample Size", 
linushof's avatar
linushof committed
237
       col="a") + 
linushof's avatar
linushof committed
238
  theme_minimal()
239
240
```

linushof's avatar
linushof committed
241
### Switching probability (s)
242

linushof's avatar
linushof committed
243
244
245
For piecewise integration, there is an inverse relationship between switching probability and sample size.
I.e., the lower s, 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.
linushof's avatar
linushof committed
246

linushof's avatar
linushof committed
247
248
```{r message=FALSE}
group_med <- samples_piecewise %>%
linushof's avatar
linushof committed
249
  group_by(boundary, s) %>% 
linushof's avatar
linushof committed
250
  summarise(group_med = median(n_med)) # to get the median across all a values
linushof's avatar
linushof committed
251

linushof's avatar
linushof committed
252
253
254
255
256
257
samples_piecewise %>%
  ggplot(aes(s, n_med, color = s)) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = group_med, aes(y = group_med), size = 3) +
  facet_wrap(~boundary) + 
  scale_color_viridis() + 
258
  labs(title = "Piecewise Integration",
linushof's avatar
linushof committed
259
       x ="s", 
linushof's avatar
linushof committed
260
       y="Sample Size", 
linushof's avatar
linushof committed
261
       col="s") + 
linushof's avatar
linushof committed
262
263
264
  theme_minimal()
```

linushof's avatar
linushof committed
265
266
267
For comprehensive 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 increase with switching probability.
linushof's avatar
linushof committed
268

linushof's avatar
linushof committed
269
270
```{r message=FALSE}
group_med <- samples_comprehensive %>%
linushof's avatar
linushof committed
271
  group_by(boundary, s) %>% 
linushof's avatar
linushof committed
272
  summarise(group_med = median(n_med)) # to get the median across all a values
linushof's avatar
linushof committed
273

linushof's avatar
linushof committed
274
275
276
277
278
279
samples_comprehensive %>%
  ggplot(aes(s, n_med, color = s)) + 
  geom_jitter(alpha = .5, size = 2) +
  geom_point(data = group_med, aes(y = group_med), size = 3) +
  facet_wrap(~boundary) + 
  scale_color_viridis() + 
280
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
281
282
283
       x ="s",
       y = "Sample Size", 
       col="s") + 
linushof's avatar
linushof committed
284
285
286
  theme_minimal()
```

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

linushof's avatar
linushof committed
289
Below, in extension to Hills and Hertwig [-@hillsInformationSearchDecisions2010], the interplay of integration strategies, gamble features, and model parameters in their effects on choice behavior in general and their contribution to underweighting of rare events in particular is investigated.
linushof's avatar
linushof committed
290
291
292
293
294
295
296
297
298
299
300
301
We apply two definitions of underweighting of rare events: Considering false response rates, we define underweighting such that the rarity of an attractive (unattractive) outcome leads to choose the safe (risky) prospect although the risky (safe) prospect has a higher expected value.

```{r message=FALSE}
fr_rates <- choices %>% 
  mutate(ev_ratio_exp = round(a_ev_exp/b_ev_exp, 2), 
         norm = case_when(ev_ratio_exp > 1 ~ "A", ev_ratio_exp < 1 ~ "B")) %>% 
  filter(!is.na(norm)) %>% # exclude trials with normative indifferent options
  group_by(strategy, s, boundary, a, rare, norm, choice) %>% # group correct and incorrect responses
  summarise(n = n()) %>% # absolute numbers 
  mutate(rate = round(n/sum(n), 2), # response rates 
         type = case_when(norm == "A" & choice == "B" ~ "false safe", norm == "B" & choice == "A" ~ "false risky")) %>% 
  filter(!is.na(type)) # remove correct responses
linushof's avatar
linushof committed
302
303
```

linushof's avatar
linushof committed
304
Considering the parameters of Prelec's [-@prelecProbabilityWeightingFunction1998] implementation of the weighting function [CPT; cf. @tverskyAdvancesProspectTheory1992], underweighting is reflected by decisions weights estimated to be smaller than the corresponding objective probabilities.
linushof's avatar
linushof committed
305

linushof's avatar
linushof committed
306
### False Response Rates
linushof's avatar
linushof committed
307

linushof's avatar
linushof committed
308
309
310
```{r message=FALSE}
fr_rates_piecewise <- fr_rates %>% filter(strategy == "piecewise")
fr_rates_comprehensive <- fr_rates %>% filter(strategy == "comprehensive")
linushof's avatar
linushof committed
311
```
312

linushof's avatar
linushof committed
313
The false response rates generated by different parameter combinations ranged from `r min(fr_rates_piecewise$rate)` to `r max(fr_rates_piecewise$rate)` for piecewise integration and from `r min(fr_rates_comprehensive$rate)` to `r max(fr_rates_comprehensive$rate)` for comprehensive integration.
linushof's avatar
linushof committed
314
However, false response rates vary considerably as a function of rare events, indicating that their presence and attractiveness are large determinants of false response rates.
linushof's avatar
linushof committed
315

linushof's avatar
linushof committed
316
317
318
319
320
321
```{r message=FALSE}
fr_rates %>% 
  group_by(strategy, boundary, rare) %>% 
  summarise(min = min(rate),
            max = max(rate)) %>% 
  kable()
linushof's avatar
linushof committed
322
323
```

linushof's avatar
linushof committed
324
The heatmaps below show the false response rates for all strategy-parameter combinations.
linushof's avatar
linushof committed
325
326
Consistent with our - somewhat rough - definition of underweighting, the rate of false risky responses is generally higher, if the unattractive outcome of the risky prospect is rare (top panel).
Conversely, if the attractive outcome of the risky prospect is rare, the rate of false safe responses is generally higher (bottom panel).
linushof's avatar
linushof committed
327
As indicated by the larger range of false response rates, the effects of rare events are considerably larger for piecewise integration.
328

linushof's avatar
linushof committed
329
330
331
332
333
334
335
336
337
338
339
340
341
342
```{r message=FALSE}
fr_rates %>% 
  filter(strategy == "piecewise", boundary == "absolute") %>% 
  ggplot(aes(a, s, fill = rate)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_tile(colour="white", size=0.25) + 
  scale_x_continuous(expand=c(0,0), breaks = seq(1, 5, 1)) +
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1)) +
  scale_fill_viridis() + 
  labs(title = "Piecewise Integration | Absolute Boundary",
       x = "a", 
       y= "s", 
       fill = "% False Responses") + 
  theme_minimal() 
343
344
```

linushof's avatar
linushof committed
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
```{r message=FALSE}
fr_rates %>% 
  filter(strategy == "piecewise", boundary == "relative") %>% 
  ggplot(aes(a, s, fill = rate)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_tile(colour="white", size=0.25) + 
  scale_x_continuous(expand=c(0,0), breaks = seq(1, 5, 1)) +
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1)) +
  scale_fill_viridis() + 
  labs(title = "Piecewise Integration | Relative Boundary",
       x = "a", 
       y= "s", 
       fill = "% False Responses") + 
  theme_minimal() 
```
linushof's avatar
linushof committed
360

linushof's avatar
linushof committed
361
362
```{r message=FALSE}
fr_rates %>% 
linushof's avatar
linushof committed
363
  filter(strategy == "comprehensive", boundary == "absolute") %>% 
linushof's avatar
linushof committed
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
  ggplot(aes(a, s, fill = rate)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_tile(colour="white", size=0.25) + 
  scale_x_continuous(expand=c(0,0), breaks = seq(15, 75, 15)) +
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1)) +
  scale_fill_viridis() + 
  labs(title = "Comprehensive Integration | Absolute Boundary",
       x = "a", 
       y= "s", 
       fill = "% False Responses") + 
  theme_minimal() 
```

```{r message=FALSE}
fr_rates %>% 
linushof's avatar
linushof committed
379
  filter(strategy == "comprehensive", boundary == "relative") %>% 
linushof's avatar
linushof committed
380
381
382
383
384
385
386
387
388
389
390
  ggplot(aes(a, s, fill = rate)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_tile(colour="white", size=0.25) + 
  scale_x_continuous(expand=c(0,0), breaks = seq(15, 75, 15)) +
  scale_y_continuous(expand=c(0,0), breaks = seq(.1, 1, .1)) +
  scale_fill_viridis() + 
  labs(title = "Comprehensive Integration | Relative Boundary",
       x = "a", 
       y= "s", 
       fill = "% False Responses") + 
  theme_minimal() 
391
392
```

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

linushof's avatar
linushof committed
395
As for both piecewise and comprehensive integration the differences between boundary types are rather minor and of magnitude than of qualitative pattern, the remaining analyses of false response rates are summarized across absolute and relative boundaries.
linushof's avatar
linushof committed
396

linushof's avatar
linushof committed
397
Below, the $s$ and $a$ parameter are considered as additional sources of variation in the false response pattern above and beyond the interplay of integration strategies and the rarity and attractiveness of outcomes.
linushof's avatar
linushof committed
398

linushof's avatar
linushof committed
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
```{r message=FALSE}
fr_rates %>% 
  filter(strategy == "piecewise") %>% 
  ggplot(aes(s, rate, color = a)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_jitter(size = 2) + 
  scale_x_continuous(breaks = seq(0, 1, .1)) +
  scale_y_continuous(breaks = seq(0, 1, .1)) +
  scale_color_viridis() + 
  labs(title = "Piecewise Integration",
       x = "s", 
       y= "% False Responses", 
       color = "a") + 
  theme_minimal() 
```
414

linushof's avatar
linushof committed
415
416
```{r message=FALSE}
fr_rates %>% 
linushof's avatar
linushof committed
417
  filter(strategy == "comprehensive") %>% 
linushof's avatar
linushof committed
418
419
420
421
422
423
  ggplot(aes(s, rate, color = a)) + 
  facet_grid(type ~ fct_relevel(rare, "attractive", "none", "unattractive"), switch = "y") +
  geom_jitter(size = 2) + 
  scale_x_continuous(breaks = seq(0, 1, .1)) +
  scale_y_continuous(breaks = seq(0, 1, .1)) +
  scale_color_viridis() + 
424
  labs(title = "Comprehensive Integration",
linushof's avatar
linushof committed
425
426
427
428
       x = "s", 
       y= "% False Responses", 
       color = "a") + 
  theme_minimal() 
429
430
```

linushof's avatar
linushof committed
431
For piecewise integration, switching probability is naturally related to the size of the samples on which the round-wise comparisons of prospects are based on, with low values of $s$ indicating large samples and vice versa.
linushof's avatar
linushof committed
432
Accordingly, switching probability is positively related to false response rates.
linushof's avatar
linushof committed
433
434
I.e., the larger the switching probability, the smaller the round-wise sample size and the probability of experiencing a rare event within a given round.
Because round-wise comparisons are independent of each other and binomial distributions within a given round are skewed for small samples and outcome probabilities [@kolmogorovFoundationsTheoryProbability1950], increasing boundary values do not reverse but rather amplify this relation.
435

linushof's avatar
linushof committed
436
437
438
For comprehensive integration, switching probability is negatively related to false response rates, i.e., an increase in $s$ is associated with decreasing false response rates.
This relation, however, may be the result of an artificial interaction between the $s$ and $a$ parameter.
Precisely, in the current algorithmic implementation of sampling with a comprehensive integration mechanism, decreasing switching probabilities cause comparisons of prospects based on increasingly unequal sample sizes immediately after switching prospects.
linushof's avatar
linushof committed
439
Consequentially, reaching (low) boundaries is rather a function of switching probability and associated sample sizes than of actual evidence for a given prospect over the other.
440

linushof's avatar
linushof committed
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
### Cumulative Prospect Theory

In the following, we examine the possible relations between the parameters of the *choice-generating* sampling models and the *choice-describing* cumulative prospect theory.

For each distinct strategy-parameter combination, we ran 20 chains of 40,000 iterations each, after a warm-up period of 1000 samples.
To reduce potential autocorrelation during the sampling process, we only kept every 20th sample (thinning).

```{r}
# read CPT data
cols <- list(.default = col_double(),
             strategy = col_factor(),
             boundary = col_factor(),
             parameter = col_factor())
estimates <- read_csv("data/estimates/estimates_cpt_pooled.csv", col_types = cols)
```

#### Convergence

```{r}
gel_92 <- max(estimates$Rhat) # get largest scale reduction factor (Gelman & Rubin, 1992) 
```

The potential scale reduction factor $\hat{R}$ was $n \leq$ `r round(gel_92, 3)` for all estimates, indicating good convergence.

465
#### Piecewise Integration
linushof's avatar
linushof committed
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499

```{r}
# generate subset of all strategy-parameter combinations (rows) and their parameters (columns)
curves_cpt <- estimates %>% 
  select(strategy, s, boundary, a, parameter, mean) %>% 
  pivot_wider(names_from = parameter, values_from = mean)
```

##### Weighting function w(p)

We start by plotting the weighting curves for all parameter combinations under piecewise integration.

```{r}

cpt_curves_piecewise <- curves_cpt %>% 
  filter(strategy == "piecewise") %>% 
  expand_grid(p = seq(0, 1, .1)) %>% # add vector of objective probabilities
  mutate(w = round(exp(-delta*(-log(p))^gamma), 2)) # compute decision weights (cf. Prelec, 1998)

# all strategy-parameter combinations 

cpt_curves_piecewise %>% 
  ggplot(aes(p, w)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Piecewise Integration: Weighting functions",
       x = "p", 
       y= "w(p)") + 
  theme_minimal() 
```

```{r}
cpt_curves_piecewise %>% 
  ggplot(aes(p, w)) + 
500
  geom_path() +
linushof's avatar
linushof committed
501
502
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
503
504
505
506
507
  labs(title = "Piecewise Integration: Weighting functions",
       x = "p",
       y= "w(p)",
       color = "Switching Probability") + 
  scale_color_viridis() +
linushof's avatar
linushof committed
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
  theme_minimal() 
```

```{r}
cpt_curves_piecewise %>% 
  ggplot(aes(p, w, color = s)) + 
  geom_path() +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Piecewise Integration: Weighting functions",
       x = "p", 
       y= "w(p)", 
       color = "Switching Probability") + 
  scale_color_viridis() +
  theme_minimal() 
```

```{r}
cpt_curves_piecewise %>% 
  ggplot(aes(p, w, color = s)) + 
  geom_path() +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
  labs(title = "Piecewise Integration: Weighting functions",
       x = "p",
       y= "w(p)",
       color = "Switching Probability") + 
  scale_color_viridis() +
  theme_minimal() 
```

##### Value function v(x)

```{r}

cpt_curves_piecewise <- curves_cpt %>% 
  filter(strategy == "piecewise") %>% 
  expand_grid(x = seq(0, 20, 2)) %>% # add vector of objective outcomes
  mutate(v = round(x^alpha, 2)) # compute decision weights (cf. Prelec, 1998)

# all strategy-parameter combinations 

cpt_curves_piecewise %>% 
  ggplot(aes(x, v)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Piecewise Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  theme_minimal() 
```

```{r}
cpt_curves_piecewise %>% 
  ggplot(aes(x, v, color = s)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Piecewise Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  scale_color_viridis() + 
  theme_minimal() 
```

```{r}
cpt_curves_piecewise %>% 
  ggplot(aes(x, v, color = s)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
  labs(title = "Piecewise Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  scale_color_viridis() + 
  theme_minimal() 
```

584
#### Comprehensive Integration
linushof's avatar
linushof committed
585
586
587
588

##### Weighting function w(p)

We start by plotting the weighting curves for all parameter combinations under piecewise integration.
linushof's avatar
linushof committed
589

linushof's avatar
linushof committed
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
```{r}

cpt_curves_comprehensive <- curves_cpt %>% 
  filter(strategy == "comprehensive") %>% 
  expand_grid(p = seq(0, 1, .1)) %>% # add vector of objective probabilities
  mutate(w = round(exp(-delta*(-log(p))^gamma), 2)) # compute decision weights (cf. Prelec, 1998)

# all strategy-parameter combinations 

cpt_curves_comprehensive %>% 
  ggplot(aes(p, w)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Comprehensive Integration: Weighting functions",
       x = "p", 
       y= "w(p)") + 
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
  ggplot(aes(p, w)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Comprehensive Integration: Weighting functions",
       x = "p", 
616
617
       y= "w(p)") + 
  facet_wrap(~a) + 
linushof's avatar
linushof committed
618
619
620
621
622
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
623
624
  ggplot(aes(p, w, color = s)) + 
  geom_path() +
linushof's avatar
linushof committed
625
626
627
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Comprehensive Integration: Weighting functions",
       x = "p", 
628
629
630
       y= "w(p)", 
       color = "Switching Probability") + 
  scale_color_viridis() +
linushof's avatar
linushof committed
631
632
633
634
635
636
637
638
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
  ggplot(aes(p, w, color = s)) + 
  geom_path() +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
639
  facet_wrap(~a) + 
linushof's avatar
linushof committed
640
  labs(title = "Comprehensive Integration: Weighting functions",
641
642
       x = "p",
       y= "w(p)",
linushof's avatar
linushof committed
643
644
645
646
647
648
649
       color = "Switching Probability") + 
  scale_color_viridis() +
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
650
  filter(s >= .7) %>% 
linushof's avatar
linushof committed
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
  ggplot(aes(p, w, color = s)) + 
  geom_path() +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
  labs(title = "Comprehensive Integration: Weighting functions",
       x = "p",
       y= "w(p)",
       color = "Switching Probability") + 
  scale_color_viridis() +
  theme_minimal() 
```

##### Value function v(x)

```{r}

cpt_curves_comprehensive <- curves_cpt %>% 
  filter(strategy == "comprehensive") %>% 
  expand_grid(x = seq(0, 20, 2)) %>% # add vector of objective outcomes
  mutate(v = round(x^alpha, 2)) # compute decision weights (cf. Prelec, 1998)


# all strategy-parameter combinations 

cpt_curves_comprehensive %>% 
  ggplot(aes(x, v)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Comprehensive Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
  ggplot(aes(x, v)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
  labs(title = "Comprehensive Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
  ggplot(aes(x, v, color = s)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  labs(title = "Comprehensive Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  scale_color_viridis() + 
  theme_minimal() 
```

```{r}
cpt_curves_comprehensive %>% 
  ggplot(aes(x, v, color = s)) + 
  geom_path(size = .5) +
  geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
  facet_wrap(~a) + 
  labs(title = "Comprehensive Integration: Value functions",
       x = "p", 
       y= "w(p)") + 
  scale_color_viridis() + 
  theme_minimal() 
```
linushof's avatar
linushof committed
721

linushof's avatar
linushof committed
722
# References