Skip to content

Commit 566574e

Browse files
committed
bugfix
1 parent 16d23d8 commit 566574e

10 files changed

+435
-237
lines changed

docs/source/examples/R/Example scripts/Example_analysis_bayesian.Rmd

Lines changed: 69 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,12 @@ output: html_document
99
# **Here we show how to perform a bayesian analysis on the data after it has been collected which is very similar to the "simple" analysis. Please see the "simple analysis before this!**
1010

1111
```{r message=FALSE}
12-
pacman::p_load(tidyverse,ggdist,psycho,caret,patchwork, gt, cowplot, grid,reticulate,cmdstanr,posterior,rstan,bayesplot,here,rmarkdown)
12+
pacman::p_load(tidyverse,ggdist,psycho,caret,patchwork, gt, cowplot,
13+
grid,reticulate,cmdstanr,posterior,rstan,bayesplot,here,rmarkdown,pracma,
14+
brms)
1315
np <- import("numpy")
16+
17+
set.seed(111)
1418
```
1519

1620

@@ -28,12 +32,67 @@ df = psychophysics_df %>% filter(Subject == "sub_0042")
2832
source(here("docs","source","examples","R","src","firstlevelanalysis.R"))
2933
```
3034

31-
The only difference here is that we set bayesian equal to T (TRUE) and specify the model. Here the model is a predefined Stan model that is inside the src folder called first_model.stan
35+
The only difference here is that we set bayesian equal to T (TRUE) and specify the model. The models can be found in the src folder inside the .stan files. These are probabilitic models written in stan that are compiled and does the sampling. There are two options at the moment for re-fitting there is the standard cummulative normal aswell as a cummulative normal that incorporates a lapse rate, that sepcifies the minimum and maximum of the tails of the psychometric. This means that a lapse rate of 5% (0.05) means that the psychometric on the lower end is 5% and on the upper end is 95%. The reason to include a lapse rate is that if responses are made that are attentional slips or misclicks in the far end of the stimulus spectrum (high or low) then this is greatly influence the slope of the psychometric if modelled without the lapse rate.
36+
37+
The priors of the bayesian model is as follows in the unconstrained space (beta is constained to be positive so is exponentially transformed, and the lapse is constrained between 0 and 0.5 meaning its inv_logit transformed and then devided by 2:
38+
39+
alpha ~ normal(0,20);
40+
beta ~ normal(0,3);
41+
lambda ~ normal(-4,2);
42+
43+
This means that the parameters in the constrained space look like this:
44+
```{r}
45+
data.frame(alpha = rnorm(1000,0,20), beta = exp(rnorm(10000,0,3)), lambda = brms::inv_logit_scaled(rnorm(1000,-4,2)) / 2) %>%
46+
pivot_longer(everything(), values_to = "value",names_to = "parameter") %>%
47+
ggplot(aes(x = value, fill = parameter))+geom_histogram(col = "black")+facet_wrap(~parameter, scales = "free")+theme_classic()
48+
```
49+
50+
Below there is a visualization of what this extra lapse rate does as well as what the priors of the model means when looking at the psychometric function itself:
51+
52+
```{r}
53+
n_sim = 25
54+
55+
alpha = rnorm(n_sim,0,20)
56+
beta = rnorm(n_sim,0,3)
57+
lambda = rnorm(n_sim,-4,2)
58+
59+
data.frame(alpha = alpha, beta = exp(beta), lambda = brms::inv_logit_scaled(lambda) / 2) %>%
60+
rowwise() %>%
61+
mutate(x = list(seq(-80,80,0.1)),
62+
y = list(psychometric(seq(-80,80,0.1), alpha, beta, lambda))
63+
) %>%
64+
ungroup %>%
65+
mutate(id = 1:n()) %>%
66+
unnest(cols = c(x, y)) %>% mutate(lapse = T) %>%
67+
ggplot(aes(x = x, y = y, group = id))+
68+
geom_line(alpha = 0.5)+theme_classic()+ggtitle("With Lapse rate")
69+
70+
71+
72+
data.frame(alpha = alpha, beta = exp(beta), lambda = NA) %>%
73+
rowwise() %>%
74+
mutate(x = list(seq(-80,80,0.1)),
75+
y = list(psychometric_nolapse(seq(-80,80,0.1), alpha, beta))
76+
) %>%
77+
ungroup %>%
78+
mutate(id = 1:n()) %>%
79+
unnest(cols = c(x, y)) %>% mutate(lapse = F) %>%
80+
ggplot(aes(x = x, y = y, group = id))+
81+
geom_line(alpha = 0.5)+theme_classic()+ggtitle("Without Lapse rate")
82+
83+
84+
```
85+
86+
If you want to change the priors of the Bayesian model, this has to be done inside the Stan scripts. By opening the .stan File and then changing the last couple of lines of code where the syntax is the same as above, it is therefore possible to visualize what the prior distributions for the parameters and also see what they entail (prior predictive checks) for the shape of the psychometric here in the markdown script and then changing them inside the Stan scripts themselves.
87+
3288

33-
**Doing the same as for the simple analysis with bayesian = T**
89+
**Running the analysis using this bayesian fit invovles the same as for the simple analysis with two addition arguments firstly the flage bayesian needs to be set to T (TRUE), and a model has to be specified. There are at the moment two different models to choose from, one with the lapse rate and one without**
3490

3591
```{r message=FALSE, results='hide',warning=FALSE}
36-
model = cmdstan_model(here("docs","source","examples","R","src","first_model.stan"))
92+
# No lapse rate model:
93+
model = cmdstan_model(here("docs","source","examples","R","src","Standard Cummulative normal.stan"))
94+
# Lapse rate model:
95+
model = cmdstan_model(here("docs","source","examples","R","src","Lapse Cummulative normal.stan"))
3796
3897
results = single_sub_analysis(df,
3998
interoPost = NA,
@@ -43,25 +102,24 @@ results = single_sub_analysis(df,
43102
out = here::here("docs","source","examples","R"))
44103
```
45104

46-
**The results list now also contains a new index called bayesian_plot. This is a list of either 1 or 3 plots. There'll be 1 if you only have one Morality and 3 if you have two (Extero and Intero). Here there is 3 plots**
105+
**The results list now also contains a new index called bayesian_plot. This is a list of either 1 or 3 plots. There will be 1 if you only have one Morality and 2 if you have two (Extero and Intero). Here there is 3 plots**
47106

48107
Lets look at them individually:
49108

50109
```{r}
51110
results$bayesian_plot[[1]]
52111
```
53112

54-
**NOTE: The Import thing to look at for good model convergence is the upper plots: Here we see that all the 4 chains (to the left) seem to capture the same posterior distribution. It is also clear from the trace-plots to the upper right that the chains mix well (hairy catterpillars), meaning good convergence**
113+
**NOTE: The Import thing to look at for good model convergence is the upper plots: Here we see that all the 4 chains (to the left) seem to capture the same posterior distribution. It is also clear from the trace-plots to the upper right that the chains mix well (hairy catterpillars), meaning good convergence. Lastly looking into whether there are divergences in the sampling process is pivotal, these are stored in the stats file under divergences, if this column is not 0, then trusting the estimates even with good looking chains is not advised. Dealing with divergences for single subjects fits like here involves changing priors and or the model itself (i.e. leaving out or including the lapse rate)**
55114

56115
```{r}
57116
results$bayesian_plot[[2]]
58117
```
59-
60-
61-
And the combined plot can be found in the last index
62-
```{r, fig.height=8,fig.width=14}
63-
results$bayesian_plot[[3]]
118+
##**Here is the number of mean in both conditions divergences:**
119+
```{r}
120+
results$stats$divergences
64121
```
122+
Indicating that there are divergences here so perhaps runnning without the Lapse rate would be preferable, or changing the priors.
65123

66124

67125
**Of cause this can be run through several subjects like the "simple" analysis**

docs/source/examples/R/Example scripts/Example_analysis_simple.Rmd

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -59,12 +59,12 @@ out is the output directory for the results of the analysis
5959

6060

6161
```{r message=FALSE, results='hide',warning=FALSE}
62-
results = single_sub_analysis(df, #The raw dataframe
63-
interoPost = interoPost, #numpy array for the intero (NA if not avaliable)
64-
exteroPost = exteroPost, #numpy array for the extero (NA if not avaliable)
65-
bayesian = F, #Bayesian Analysis (TRUE/FALSE)
66-
model = NA, #Bayesian model here a stan script (NA if Bayesian is FALSE)
67-
out = here::here("docs","source","examples","R")) #Output directory for results
62+
results = single_sub_analysis(df, #The raw dataframe
63+
interoPost = interoPost, #numpy array for the intero (NA if not avaliable)
64+
exteroPost = exteroPost, #numpy array for the extero (NA if not avaliable)
65+
bayesian = F, #Bayesian Analysis (TRUE/FALSE)
66+
model = NA, #Bayesian model here a stan script (NA if Bayesian is FALSE)
67+
out = here::here("docs","source","examples","R")) #Output directory for results
6868
```
6969

7070
**Note that these analyses can also be run with only one "Modality", important is that either the interopost or exteropost then gets set to NA i.e. the modality you do not have access to!**
Binary file not shown.
Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
data {
2+
int<lower=0> N;
3+
array[N] int<lower=0> n;
4+
array[N] int <lower=0> y;
5+
vector[N] x;
6+
}
7+
parameters {
8+
real alpha;
9+
real beta_unconstrained;
10+
real lambda_unconstrained;
11+
}
12+
13+
14+
transformed parameters{
15+
16+
real<lower=0> beta = exp(beta_unconstrained);
17+
real<lower=0,upper=0.5> lambda = inv_logit(lambda_unconstrained) / 2;
18+
19+
20+
}
21+
22+
23+
model {
24+
25+
for (i in 1:N){
26+
y[i] ~ binomial(n[i], lambda + (1 - 2 * lambda) * (0.5+0.5*erf((x[i]-alpha)/(beta*sqrt(2)))));
27+
}
28+
29+
alpha ~ normal(0,20);
30+
beta_unconstrained ~ normal(0,3);
31+
lambda_unconstrained ~ normal(-4,2);
32+
33+
34+
}
Binary file not shown.
Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
data {
2+
int<lower=0> N;
3+
array[N] int<lower=0> n;
4+
array[N] int <lower=0> y;
5+
vector[N] x;
6+
}
7+
parameters {
8+
real alpha;
9+
real beta_unconstrained;
10+
}
11+
12+
transformed parameters{
13+
14+
real <lower=0> beta = exp(beta_unconstrained);
15+
}
16+
17+
model {
18+
for (i in 1:N){
19+
y[i] ~ binomial(n[i], 0.5+0.5*erf((x[i]-alpha)/(beta*sqrt(2))));
20+
}
21+
alpha ~ normal(0, 20);
22+
beta_unconstrained ~ normal(0,3);
23+
24+
}
-2.05 MB
Binary file not shown.

docs/source/examples/R/src/first_model.stan

Lines changed: 0 additions & 19 deletions
This file was deleted.

docs/source/examples/R/src/firstlevelanalysis.R

Lines changed: 55 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -153,67 +153,74 @@ single_sub_analysis <- function(df, interoPost = NA, exteroPost = NA, bayesian =
153153
# if the bayesian analysis is selected:
154154
if (bayesian == TRUE) {
155155
if (n_mod == 2) {
156+
157+
# run bayesian analysis on Extero and Intero and append the statistics to the dataframe (resultsdata)
158+
results = run_bayes_analysis(df1, model)
159+
160+
# Combine stuff for stats and plots
161+
stats <- rbind(results[["Intero"]][["stats"]],results[["Extero"]][["stats"]])
162+
163+
resultsdata <- cbind(resultsdata, stats)
164+
165+
baysplot_ex <- results[["Extero"]][["chainplot"]] + results[["Extero"]][["traceplot"]] + results[["Extero"]][["bayseplot"]] +
166+
plot_layout(design = c(
167+
patchwork::area(1, 1, 1, 1),
168+
patchwork::area(1, 2, 1, 2),
169+
patchwork::area(2, 1, 3, 2)
170+
))
171+
172+
baysplot_in <- results[["Intero"]][["chainplot"]] + results[["Intero"]][["traceplot"]] + results[["Intero"]][["bayseplot"]] +
173+
plot_layout(design = c(
174+
patchwork::area(1, 1, 1, 1),
175+
patchwork::area(1, 2, 1, 2),
176+
patchwork::area(2, 1, 3, 2)
177+
))
178+
179+
# save the figures
180+
ggsave(paste0(output_dir,"/resultplot_bayse_intero",idx,".png"), baysplot_in, width = 4000, height = 2200, units = "px")
181+
ggsave(paste0(output_dir,"/resultplot_bayse_extero",idx,".png"), baysplot_ex, width = 4000, height = 2200, units = "px")
182+
183+
bayesplot <- list(baysplot_ex, baysplot_in)
184+
}
185+
186+
187+
if (n_mod == 1) {
188+
189+
modality = unique(df$Modality)
156190
# run bayesian analysis on Extero and Intero and append the statistics to the dataframe (resultsdata)
157-
baysextero <- baysiananalysis(df, "Extero", model)
158-
stats <- baysextero[[4]]
191+
results = run_bayes_analysis(df1, model)
159192

160-
baysintero <- baysiananalysis(df, "Intero", model)
161-
stats <- rbind(stats, baysintero[[4]])
193+
stats <- rbind(results[[modality]][["stats"]])
162194

163195
resultsdata <- cbind(resultsdata, stats)
164196

165-
baysplot_ex <- baysextero[[1]] + baysextero[[2]] + baysextero[[3]] + plot_layout(design = c(
166-
patchwork::area(1, 1, 1, 1),
167-
patchwork::area(1, 2, 1, 2),
168-
patchwork::area(2, 1, 3, 2)
169-
))
170-
171-
baysplot_in <- baysintero[[1]] + baysintero[[2]] + baysintero[[3]] + plot_layout(design = c(
172-
patchwork::area(1, 1, 1, 1),
173-
patchwork::area(1, 2, 1, 2),
174-
patchwork::area(2, 1, 3, 2)
175-
))
176-
177-
baysplot <- baysextero[[1]] + baysextero[[2]] + baysextero[[3]] + baysintero[[1]] + baysintero[[2]] + baysintero[[3]] + plot_layout(design = c(
178-
patchwork::area(1, 1, 1, 1),
179-
patchwork::area(1, 2, 1, 2),
180-
patchwork::area(2, 1, 3, 2),
181-
patchwork::area(1, 3, 1, 3),
182-
patchwork::area(1, 4, 1, 4),
183-
patchwork::area(2, 3, 3, 4)
184-
))
197+
bayesplot <- results[[modality]][["chainplot"]] + results[[modality]][["traceplot"]] + results[[modality]][["bayseplot"]] +
198+
plot_layout(design = c(
199+
patchwork::area(1, 1, 1, 1),
200+
patchwork::area(1, 2, 1, 2),
201+
patchwork::area(2, 1, 3, 2)
202+
))
185203

186204
# save the figures
187-
ggsave(paste0(output_dir,"/resultplot_bayse_intero",idx,".png"), baysplot_in, width = 4000, height = 2200, units = "px")
188-
ggsave(paste0(output_dir,"/resultplot_bayse_extero",idx,".png"), baysplot_ex, width = 4000, height = 2200, units = "px")
189-
ggsave(paste0(output_dir,"/resultplot_bayse",idx,".png"), baysplot, width = 4000, height = 2200, units = "px")
205+
ggsave(paste0(output_dir,paste0("/resultplot_bayse_",modality),idx,".png"), bayesplot, width = 4000, height = 2200, units = "px")
190206

191-
baysplot <- list(baysplot_ex, baysplot_in, baysplot)
207+
bayesplot <- list(bayesplot)
192208
}
193209

194-
if (n_mod == 1) {
195-
bayse <- baysiananalysis(df, as.character(unique(df$Modality)), model)
196-
stats <- bayse[[4]]
197-
resultsdata <- cbind(resultsdata, stats)
210+
211+
# delete all duplicate columns in the resulting dataframe
212+
213+
resultsdata <- resultsdata[, !duplicated(colnames(resultsdata))]
214+
# give it sensisble rownames:
215+
rownames(resultsdata) <- 1:nrow(resultsdata)
216+
# save it
217+
write.csv(resultsdata, paste0(output_dir,"/data",idx,".csv"))
218+
219+
return(list(rt_plot = reactiontimeplot, summary_stat = stat, conf_plot = confidenceplot,AUC_plot = AUC_plot, staircase_plot = intervalplot, histogram_plot = intensityplot, analysis_plot = analysisplot, concatenated_plot = plot, stats = resultsdata, bayesian_plot = bayesplot))
198220

199-
baysplot <- bayse[[1]] + bayse[[2]] + bayse[[3]] + plot_layout(design = c(
200-
patchwork::area(1, 1, 1, 1),
201-
patchwork::area(1, 2, 1, 2),
202-
patchwork::area(2, 1, 3, 2)
203-
))
204-
ggsave(paste0(output_dir,"/resultplot_bayse",idx,".png"), baysplot, width = 4000, height = 2200, units = "px")
205-
}
206-
207-
# delete all duplicate columns in the resulting dataframe
208-
209-
resultsdata <- resultsdata[, !duplicated(colnames(resultsdata))]
210-
# give it sensisble rownames:
211-
rownames(resultsdata) <- 1:nrow(resultsdata)
212-
# save it
213-
write.csv(resultsdata, paste0(output_dir,"/data",idx,".csv"))
214221

215-
return(list(rt_plot = reactiontimeplot, summary_stat = stat, conf_plot = confidenceplot,AUC_plot = AUC_plot, staircase_plot = intervalplot, histogram_plot = intensityplot, analysis_plot = analysisplot, concatenated_plot = plot, stats = resultsdata, bayesian_plot = baysplot))
216222
}
223+
217224
# delete all duplicate columns in the resulting dataframe
218225
resultsdata <- resultsdata[, !duplicated(colnames(resultsdata))]
219226
# give it sensisble rownames:

0 commit comments

Comments
 (0)