Commit 688d806a authored by linushof's avatar linushof
Browse files

Messy Draft of CPT results

parent c779002c
---
title: 'Sampling in DfE: Simulation Study'
author: "Linus Hof, Veronika Zilker & Thorsten Pachur"
title: 'Sampling Strategies in Decisions from Experience'
author: "Linus Hof, Thorsten Pachur, Veronika Zilker"
bibliography: sampling-strategies-in-dfe.bib
output:
html_document:
......@@ -11,6 +11,9 @@ output:
pdf_document:
toc: yes
csl: apa.csl
editor_options:
markdown:
wrap: sentence
---
```{r}
......@@ -28,7 +31,7 @@ pacman::p_load(repro,
# Abstract
Synthetic choice data from decisions from experience (DfE) is generated by applying different strategies of sample integration to 2-prospect gambles.
Synthetic choice data from decisions from experience is generated by applying different strategies of sample integration to choice problems of 2-prospects.
The synthetic data is explored for characteristic choice patterns produced by comprehensive and piecewise forms of sample integration under varying structures of the environment (gamble features) and aspects of the sampling- and decision behavior (model parameters).
# Summary
......@@ -37,19 +40,49 @@ Provide short summary of simulation study results.
# Introduction
A formal introduction to sampling in DfE and the data generating models of this study can be found [here](https://arc-git.mpib-berlin.mpg.de/sampling-strategies-in-dfe/sampling-strategies-in-dfe/-/blob/main/modeling-sampling.Rmd)
## Prospects
Let a single prospect be a *probability space* $(\Omega, \Sigma, P)$ [cf. @kolmogorovFoundationsTheoryProbability1950]. $\Omega$ is the *sample space* containing a finite set of possible outcomes $\{\omega_1, ..., \omega_n\}$.
$\Sigma$ is a set of subsets of $\Omega$, i.e., the *event space*.
$P$ is then a *probability mass function* (PMF) which maps the event space to the set of real numbers in the interval between 0 and 1: $P: \Sigma \mapsto [0,1]$.
I.e., the PMF assigns each event $\varsigma_i$ a probability of $0 \leq p_i \leq 1$ with $\sum_{i=1}^{n} p(\varsigma_i) = 1$.
The PMF also fulfills the condition $P(\Omega) = 1$.
## Monetary Prospects as Random Variables
We can define a random variable on the probability space of a prospect by defining a function that maps the sample space to a measurable space: $X: \Omega \mapsto E$, where $E = \mathbb{R}$.
Hence, every subset of $E$ has a preimage in $\Sigma$ and can be assigned a probability.
In choice problems, where agents are asked to make a decision between $n$ monetary prospects, the mapping $\Omega \mapsto E$ is often implicit since all elements of $\Omega$ are real numbered (monetary gains or losses) and usually equal to the elements in $\Sigma$.
## Sampling in Decisions from Experience (DFE)
In DFE [@hertwigDecisionsExperienceEffect2004], where no summary description of prospects' probability spaces are provided, agents can either first explore them before arriving to a final choice (*sampling paradigm*), or, exploration and exploitation occur simultaneously (*partial-* or *full-feedback paradigm*) [cf. @hertwigDescriptionExperienceGap2009].
Below, only the sampling paradigm is considered.
In the context of choice problems between monetary gambles, we define a *single sample* as an outcome obtained when randomly drawing from a prospect's sample space $\Omega$.
Technically, a single sample is thus the realization of a discrete random variable $X$, which fulfills the conditions outlined above.
In general terms, we define a *sampling strategy* as a systematic approach to generate a sequence of single samples from a choice problem's prospects as a means of exploring their probability spaces.
Single samples that are generated from the same prospect reflect a sequence of realizations of random variables that are independent and identically distributed.
### Sampling Strategies and Sample Integration
...
# Method
## Test set
Under each condition, i.e., strategy-parameter combinations, all gambles are played by 100 synthetic agents. We test a set of gambles, in which one of the prospects contains a safe outcome and the other two risky outcomes (*safe-risky gambles*).
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.
Sampling of gambles was stratified, randomly drawing an equal number of 20 gambles with no, an attractive, and an unattractive rare outcome.
Risky outcomes are considered *"rare"* if their probability is $p < .2$ and *"attractive"* (*"unattractive"*) if they are higher (lower) than the safe outcome.
```{r message=FALSE}
gambles <- read_csv("data/gambles/sr_subset.csv")
......@@ -356,4 +389,332 @@ Consequentially, reaching (low) boundaries is rather a function of switching pro
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.
#### Piecewise Integration
```{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()
```
Similarly to the false response rates, the patterns of the weighting function do not differ for the boundary types.
```{r}
cpt_curves_piecewise %>%
ggplot(aes(p, w)) +
geom_path(size = .5) +
geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
facet_wrap(~boundary)
labs(title = "Piecewise Integration: Weighting functions",
x = "p",
y= "w(p)") +
theme_minimal()
```
Regarding the boundary value, we observe a distinct pattern for the smallest boundary, i.e. a = 1.
```{r}
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)") +
facet_wrap(~a) +
theme_minimal()
```
As a general trend we find that with decreasing switching probabilities, probability weighting becomes more linear.
```{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()
```
This trend holds for different boundary values.
```{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)) +
geom_path(size = .5) +
geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
facet_wrap(~boundary) +
labs(title = "Piecewise Integration: Value functions",
x = "p",
y= "w(p)") +
theme_minimal()
```
```{r}
cpt_curves_piecewise %>%
ggplot(aes(x, v)) +
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)") +
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()
```
#### Comprehensive Integration
##### Weighting function w(p)
We start by plotting the weighting curves for all parameter combinations under piecewise integration.
```{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) +
facet_wrap(~boundary)
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",
y= "w(p)") +
facet_wrap(~a) +
theme_minimal()
```
```{r}
cpt_curves_comprehensive %>%
ggplot(aes(p, w, color = s)) +
geom_path() +
geom_abline(intercept = 0, slope = 1, color = "red", size = 1) +
labs(title = "Comprehensive Integration: Weighting functions",
x = "p",
y= "w(p)",
color = "Switching Probability") +
scale_color_viridis() +
theme_minimal()
```
```{r}
cpt_curves_comprehensive %>%
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(~boundary) +
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()
```
# References
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment