Skip to content

GitLab

B
BayesianLearning
Commit 845037f4 authored by Simon Ciranka's avatar Simon Ciranka
Browse files
Options

first model based analyiss

parent 990f82b2
Hide whitespace changes
Inline Side-by-side
Showing with 84532 additions and 9401 deletions
.gitignore
View file @ 845037f4
......@@ -3,3 +3,4 @@
*.RData
*.Ruserdata
.Rproj.user
*.rds
\ No newline at end of file
Developing_Marbles/A_RawData/MarbleOCU_vLabNew.csv 0 → 100644
View file @ 845037f4
This source diff could not be displayed because it is too large. You can view the blob instead.
Developing_Marbles/A_RawData/TidyMarble_JointTask copy.R
View file @ 845037f4
......@@ -155,7 +155,7 @@ keeps<-c("startTime","rt","key_press","riskyKey","red_marbles","blue_marbles",
"OtherChoseRisk","ChooseRisk","valueGamble","probGamble","Social1Ind0","payoff","cumulatedPayoff","valueSure","trialID","PercentBlueEstimate",
"HowSure","test_part","sex","age","subject","subjectNumber")
MarbleData<-read.csv2("A_RawData/MarbleOCU_vlabNew.csv")
MarbleData<-read.csv("A_RawData/MarbleOCU_vlabNew.csv")
colnames(MarbleData)<-names
MarbleDataTibble<-as_tibble(MarbleData)
......
Developing_Marbles/Analyze.Rmd
View file @ 845037f4
......@@ -66,28 +66,28 @@ Lets check it.
MarbleData%>%group_by(subject)%>%mutate(
FinalPayoff=max(cumulatedPayoff)
)%>%ggplot(aes(x=Agegroup,y=FinalPayoff,alpha=Agegroup))+
stat_summary(geom="bar",fun.y="mean")+
stat_summary(geom="bar",fun.y="mean")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-1.96*(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+1.96*(sd(x)/sqrt(length(x))),position = position_dodge(0.9),alpha=0.7)+
scale_x_discrete(name="Agegroup",breaks=c(0,1,2),labels=c("Kids","Adolescents","Adults"))+
scale_y_continuous(name="Final Payoff (Bonuspoints)")+
coord_cartesian(ylim=c(1975,2025))+
guides(alpha=F)
#facet_grid(.~Social1Ind0)
ggtitle("Points Collected by Agegroup")
MarbleData%>%group_by(subject)%>%filter(Social1Ind0==0)%>%mutate(
#facet_grid(.~Social1Ind0)
ggtitle("Points Collected by Agegroup")
MarbleData%>%group_by(subject)%>%filter(Social1Ind0==0)%>%mutate(
FinalPayoff=max(cumulatedPayoff)
)%>%ggplot(aes(x=Agegroup,y=FinalPayoff,alpha=Agegroup))+
stat_summary(geom="bar",fun.y="mean")+
stat_summary(geom="bar",fun.y="mean")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-1.96*(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+1.96*(sd(x)/sqrt(length(x))),position = position_dodge(0.9),alpha=0.7)+
scale_x_discrete(name="Agegroup",breaks=c(0,1,2),labels=c("Kids","Adolescents","Adults"))+
scale_y_continuous(name="Final Payoff (Bonuspoints)")
# coord_cartesian(ylim=c(1800,2000))
#guides(alpha=F)
ggsave(filename = "X_Figures/Winner.pdf")
# coord_cartesian(ylim=c(1800,2000))
#guides(alpha=F)
ggsave(filename = "X_Figures/Winner.pdf")
```
lol. Adolescents. This is going to be interesting.
......@@ -112,8 +112,8 @@ labels2 <- c(
)
#
MarbleData%>%group_by(Agegroup,DFE1DFD0,Social1Ind0)%>%summarise(
PercentRiskyChoice=mean(ChooseRisk),
ci=1.96*sd(ChooseRisk)/sqrt(dplyr::n())
PercentRiskyChoice=mean(ChooseRisk),
ci=1.96*sd(ChooseRisk)/sqrt(dplyr::n())
)%>%ungroup()%>%group_by(Agegroup,DFE1DFD0)%>%filter(Social1Ind0==1)->Social
......@@ -127,11 +127,11 @@ MarbleData%>%ggplot(aes(y=ChooseRisk,x=Agegroup,group=DFE1DFD0))+stat_summary(ma
geom_hline(mapping=aes(yintercept=0.4),linetype="dotted",alpha=0.4)+
geom_hline(mapping=aes(yintercept=0.55),linetype="dotted",alpha=0.2)+
geom_hline(mapping=aes(yintercept=0.35),linetype="dotted",alpha=0.2)+
geom_hline(mapping=aes(yintercept=0.6),linetype="dotted",alpha=0.1)+
geom_hline(mapping=aes(yintercept=0.6),linetype="dotted",alpha=0.1)+
geom_hline(mapping=aes(yintercept=0.3),linetype="dotted",alpha=0.1)+
facet_grid(.~Social1Ind0,
labeller = labeller(Social1Ind0 = labels)
# OtherChoseRisk=labels2
# OtherChoseRisk=labels2
)+
coord_cartesian(ylim=c(0.3,0.6))+
scale_y_continuous(name="p Risky Choice")+
......@@ -142,18 +142,18 @@ ggsave(filename ="X_Figures/RawData.pdf",height = 6,width=10)
# maybe
MarbleData%>%group_by(Agegroup,DFE1DFD0,Social1Ind0)%>%summarise(
PercentRiskyChoice=mean(ChooseRisk),
ci=sd(ChooseRisk)/sqrt(n())
PercentRiskyChoice=mean(ChooseRisk),
ci=sd(ChooseRisk)/sqrt(n())
)%>%ungroup()%>%group_by(Agegroup,DFE1DFD0)%>%filter(Social1Ind0==0)->Solo
Solo$Diff<-Social$PercentRiskyChoice-Solo$PercentRiskyChoice
Solo%>%ggplot(aes(y=Diff,fill=DFE1DFD0,x=Agegroup))+geom_bar(stat="identity",position = "dodge",color= "black")+
scale_x_discrete(name="Agegroup",breaks=c(0,1,2),labels=c("Kids","Adolescents","Adults"))+
scale_x_discrete(name="Agegroup",breaks=c(0,1,2),labels=c("Kids","Adolescents","Adults"))+
geom_errorbar( mapping=aes(y=Diff, ymin=Diff-ci, ymax=Diff+ci),position="dodge")+
scale_y_continuous(name="Mean Difference Social Solo")+
scale_fill_discrete(name="Social Condition",breaks=c(0,1),labels=c("Risk","Uncertainty"))
scale_fill_discrete(name="Social Condition",breaks=c(0,1),labels=c("Risk","Uncertainty"))
```
......@@ -233,12 +233,16 @@ these distributions. For this i treat the real distributions as factors.
```{r}
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%ggplot(aes(x=PercentBlueShownRel,y=PercentBlueEstimate,fill=Agegroup))+
stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%ggplot()+
#stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_summary(aes(x=PercentBlueShownRel,y=PercentBlueEstimate,color=Agegroup),geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
stat_summary(aes(y=as.numeric(PercentBlueShownRel)*10,x=PercentBlueShownRel),geom="pointrange",position = position_dodge(0.9),shape=3,color="red")+
scale_shape_manual(name="Distribution as Seen by Participant")+
scale_color_viridis_d(name="Agegroup",breaks=c("0","1","2"),labels=c("Pre Adolescence","Adolescence","Young Adults"))+
scale_x_discrete(name="Actual Distribution")+
scale_y_continuous(name="Participants Estimate")+
coord_cartesian(ylim=c(30,70))+
#coord_cartesian(ylim=c(30,70))+
ggtitle("Estimation Accuracy")
```
......@@ -299,18 +303,18 @@ labels <- c(
"2" = "Adults"
)
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%mutate(
SquaredError=(as.numeric(PercentBlueEstimate) - as.numeric(PercentBlueShownRel))
)%>%ggplot(aes(x=SquaredError,y=as.numeric(HowSure)))+
stat_summary(geom="point",fun.y = "mean",position="dodge")+
MarbleData%>%filter(PercentBlueEstimate!="NULL")%>%mutate(
Error=(as.numeric(PercentBlueEstimate) - as.numeric(PercentBlueShownRel))
)%>%ggplot(aes(x=Agegroup,y=as.numeric(Error)))+
stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_smooth(method="loess")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
facet_grid(.~Agegroup,
labeller = labeller(Agegroup = labels)
)+
scale_x_continuous(name=" Estimation Error")+
scale_y_continuous(name="Confidence")+
ggtitle(" Estimation Error and Confidence")
#stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
#facet_grid(.~Agegroup,
# labeller = labeller(Agegroup = labels)
#)+
scale_x_discrete(name=" Agegroup")+
scale_y_continuous(name="Estimation Error")+
ggtitle(" Estimation Error and Confidence")+coord_cartesian(ylim=c(50,40))
```
......@@ -360,45 +364,71 @@ We can look at it indivdually later on but i think this can provide a good first
For this I need to retrieve the real Values at some point.
```{r}
load("C_ModelFits/FullLearningModel")
Parameters<-(rstan::extract(fitSep))
library(tidyverse)
#Bin_Update_Data<-Bin_Update_Data[Bin_Update_Data$typeRA=="1",]# keep only The Risk trails.
Bin_Update_Data<-MarbleData%>%arrange(Agegroup)# i order it first so i can make sure that
Agegroups<-unique(Bin_Update_Data$Age.bins)# for indexing my agegroups.
#make it fit with my stan file.
Bin_Update_Data<-Bin_Update_Data%>%dplyr::mutate(
OtherChoseRisk = case_when(
OtherChoseRisk=="NULL" ~ 2,# i dont need this but i restricted the numbers in stan between 1 and 3
OtherChoseRisk=="1" ~ 3,# risky choices are coded as 3 in my stan code
OtherChoseRisk=="0" ~ 1,# safe choices are coded as 1 in my stan code
TRUE~0 # keep the rest.
)
)#end PeerChoice.
#subset it to fit on only one agegroup.
#Bin_Update_Data%>%filter(Agegroup==2)->Bin_Update_Data
#Bin_Update_Data%>%filter(DFE1DFD0==0)->Bin_Update_Data
# now check how many participants we have.
Bin_Update_Data$subject<-as.numeric(Bin_Update_Data$subject)
#change colname of subject into subjID
numSubjs<-length(unique(Bin_Update_Data$subject))#Total Number of Subs
subjList <- unique(Bin_Update_Data$subject)######
ageList<-Bin_Update_Data%>%group_by(subject)%>%dplyr::summarize(
age=mean(age)
)%>%select(age)%>%ungroup()
ageList=as.vector(ageList$age)
confList<-Bin_Update_Data%>%filter(HowSure!=102)%>%group_by(subject)%>%dplyr::summarise(
Confidence=mean(HowSure)
ModelParamsFull=list()
subCount=1
for (j in 1:length(unique(MarbleData$Agegroup))){
fitSep<-readRDS(paste0("C_ModelFits/Marbles_Model_3Age_",j,".rds"))
Parameters<-(rstan::extract(fitSep))
library(tidyverse)
#Bin_Update_Data<-Bin_Update_Data[Bin_Update_Data$typeRA=="1",]# keep only The Risk trails.
Bin_Update_Data<-MarbleData%>%arrange(Agegroup)# i order it first so i can make sure that
Agegroups<-unique(Bin_Update_Data$Age.bins)# for indexing my agegroups.
#make it fit with my stan file.
Bin_Update_Data<-Bin_Update_Data%>%dplyr::mutate(
OtherChoseRisk = case_when(
OtherChoseRisk=="NULL" ~ 2,# i dont need this but i restricted the numbers in stan between 1 and 3
OtherChoseRisk=="1" ~ 3,# risky choices are coded as 3 in my stan code
OtherChoseRisk=="0" ~ 1,# safe choices are coded as 1 in my stan code
TRUE~0 # keep the rest.
)
)#end PeerChoice.
#subset it to fit on only one agegroup.
#Bin_Update_Data%>%filter(Agegroup==2)->Bin_Update_Data
#Bin_Update_Data%>%filter(DFE1DFD0==0)->Bin_Update_Data
# now check how many participants we have.
Bin_Update_Data$subject<-as.numeric(Bin_Update_Data$subject)
#change colname of subject into subjID
numSubjs<-length(unique(Bin_Update_Data$subject))#Total Number of Subs
subjList <- unique(Bin_Update_Data$subject)######
ageList<-Bin_Update_Data%>%group_by(subject)%>%dplyr::summarize(
age=mean(age)
)%>%select(age)%>%ungroup()
ageList=as.vector(ageList$age)
confList<-Bin_Update_Data%>%filter(HowSure!=102)%>%group_by(subject)%>%dplyr::summarise(
Confidence=mean(HowSure)
)
confList=as.vector(confList$Confidence)
confList=as.vector(confList$Confidence)
datalist = list()
for(i in 1:dim(Parameters$alpha_add)[2]){
df=data.frame(
alphaAdd=as.vector(Parameters$alpha_add[,i]),
betaAdd=as.vector(Parameters$beta_add[,i]),
rho=as.vector(Parameters$rho[,i]),
tau=as.vector(Parameters$tau[,i]),
ocusafeRisk=as.vector(Parameters$ocu_safe_Risk[,i]),
ocusafeUncertainty=as.vector(Parameters$ocu_safe_Uncertainty[,i]),
ocuriskRisk=as.vector(Parameters$ocu_risk_Risk[,i]),
ocuriskUncertainty=as.vector(Parameters$ocu_risk_Uncertainty[,i]),
subject=subjList[subCount],
age=ageList[subCount],# Here i need to get some kind of dictionary.
conf=confList[subCount]
)
subCount=subCount+1
datalist[[i]] <- df
}
ModelParamsFull[[j]] <- do.call(rbind, datalist)
}
big_data<-do.call(rbind, ModelParamsFull)
```
In what follows i look at the Whole parameter Distributions.
......@@ -408,35 +438,28 @@ In what follows i look at the Whole parameter Distributions.
After i collect the fits, we can actually nicely concatenate them.
```{r}
datalist = list()
for(i in 1:117){
df<-data.frame(
alphaAdd=as.vector(Parameters$alpha_add[,i]),
betaAdd=as.vector(Parameters$beta_add[,i]),
rho=as.vector(Parameters$rho[,i]),
tau=as.vector(Parameters$tau[,i]),
ocuRisk=as.vector(Parameters$ocu_Risk[,i]),
ocuUncertainty=as.vector(Parameters$ocu_Uncertainty[,i]),
subject=subjList[i],
age=ageList[i],# Here i need to get some kind of dictionary.
conf=confList[i]
)
datalist[[i]] <- df
}
big_data = do.call(rbind, datalist)
```
```{r}
PosteriorMean<-big_data%>%group_by(subject,age,conf)%>%dplyr::summarise(
PosteriorMean<-big_data%>%dplyr::group_by(subject,age,conf)%>%dplyr::summarise(
MeanAlphaAdd=mean(alphaAdd),
MeanBetaAdd=mean(betaAdd),
MeanRho=mean(rho),
meanTau=mean(tau),
meanOcuR=mean(ocuRisk),
meanOCUUnc=mean(ocuUncertainty)
meanOCURiskR=mean(ocuriskRisk),
meanOCURiskUnc=mean(ocuriskUncertainty),
meanOCUSafeR=mean(ocusafeRisk),
meanOCUSafeUnc=mean(ocusafeUncertainty)
)%>%dplyr::mutate(
MeanBoth=(((MeanAlphaAdd+MeanBetaAdd)/2)),
TotalInfluenceUnc=abs(meanOCUSafeUnc+meanOCURiskUnc)/2,
TotalInfluenceRisk=abs(meanOCUSafeR+meanOCURiskR)/2,
#MeanBoth=(9^((MeanAlphaAdd+MeanBetaAdd)/2)),
Group=case_when(
age<13~"1",
(age>12 & age <19)~"2",
age>=19~"3"
#TRUE
)
)
```
......@@ -473,44 +496,106 @@ In what follows i Show yu the mean of the parameter Estiamtes.
#Alpha Scaling: p
```{r}
library(lme4)
lm(MeanAlphaAdd~age,data=PosteriorMean)
#lm(MeanAlphaAdd~age,data=PosteriorMean)
ggplot(PosteriorMean,aes(x=age,y=MeanAlphaAdd))+
geom_point()+geom_smooth(method="lm")
ggplot(PosteriorMean,aes(x=Group,y=MeanAlphaAdd))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+ geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_hline(aes(yintercept=1),linetype="dotdash",alpha=0.2)#geom_jitter(aes(color=Group),alpha=0.1)+coord_cartesian(ylim=c(0.4,1))
```
#Beta Scaling: q
```{r}
ggplot(PosteriorMean,aes(x=Group,MeanBetaAdd))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+ geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_hline(aes(yintercept=1),linetype="dotdash",alpha=0.2)#geom_jitter(aes(color=Group),alpha=0.1)+coord_cartesian(ylim=c(0.4,1))
```
ggplot(PosteriorMean,aes(x=age,y=MeanBetaAdd))+
geom_jitter()+geom_smooth(method="lm")
#Reward Sensitvity
```{r}
#lm(meanTau~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=Group,y=MeanRho))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_hline(aes(yintercept=1),linetype="dotdash",alpha=0.2)
```
#Stochastizity?
```{r}
#lm(meanTau~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=Group,y=meanTau))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))
```
# OCU Risk Decisions from Description
```{r}
lm(MeanRho~poly(age,2),data=PosteriorMean)
#lm(meanOcuR~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=age,MeanRho))+
geom_point()+geom_smooth(method="lm")
ggplot(PosteriorMean,aes(x=Group,meanOCURiskR))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
geom_smooth(method="lm")+geom_hline(aes(yintercept=0),linetype="dotdash",alpha=0.2)
```
# OCU Risk Decisions from Experience
```{r}
lm(meanTau~poly(age,2),data=PosteriorMean)
#lm(meanOcuR~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=age,y=meanTau))+
geom_point()+geom_smooth(method="lm")
ggplot(PosteriorMean,aes(x=Group,meanOCURiskUnc))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
geom_smooth(method="lm")+geom_hline(aes(yintercept=0),linetype="dotdash",alpha=0.2)
```
# OCU Safe Decisions from Description
```{r}
lm(meanOcuR~poly(age,2),data=PosteriorMean)
#lm(meanOcuR~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=age,meanOcuR))+
geom_point()+geom_smooth(method="lm")
ggplot(PosteriorMean,aes(x=Group,meanOCUSafeR))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
geom_smooth(method="lm")+geom_hline(aes(yintercept=0),linetype="dotdash",alpha=0.2)
```
# OCU Safe Decisions from Experience
```{r}
lm(meanOCUUnc~poly(age,2),data=PosteriorMean)
#lm(meanOcuR~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=conf,y=meanOCUUnc))+
geom_point()+geom_smooth(method="lm")
ggplot(PosteriorMean,aes(x=Group,meanOCUSafeUnc))+
stat_summary(fun.data = "mean_se")+scale_x_discrete(name="Agegroup",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
geom_smooth(method="lm")+geom_hline(aes(yintercept=0),linetype="dotdash",alpha=0.2)
```
# Social Influence and Learning?
```{r}
#lm(meanOcuR~poly(age,2),data=PosteriorMean)
ggplot(PosteriorMean,aes(x=TotalInfluenceUnc,MeanBoth))+
stat_summary(fun.data = "mean_se")+#scale_x_continuous(name="SocialInfluence Uncertainty",breaks=c("1","2","3"),labels=c("Age 10-12","Age 13-18","Age >18"))+
geom_jitter(aes(color=Group))+
scale_color_viridis_d(name="Agegroup")+
geom_smooth(method="lm")+geom_hline(aes(yintercept=0),linetype="dotdash",alpha=0.2)+
ggtitle("Social Influence And Uncertainty")
```
\ No newline at end of file
Developing_Marbles/README.md
View file @ 845037f4
......@@ -22,6 +22,13 @@ Simon
- [The Choice Model](#the-choice-model)
- [Alpha Scaling: p](#alpha-scaling-p)
- [Beta Scaling: q](#beta-scaling-q)
- [Reward Sensitvity](#reward-sensitvity)
- [Stochastizity?](#stochastizity)
- [OCU Risk Decisions from Description](#ocu-risk-decisions-from-description)
- [OCU Risk Decisions from Experience](#ocu-risk-decisions-from-experience)
- [OCU Safe Decisions from Description](#ocu-safe-decisions-from-description)
- [OCU Safe Decisions from Experience](#ocu-safe-decisions-from-experience)
- [Social Influence and Learning?](#social-influence-and-learning)
Agenda
======
......@@ -145,15 +152,21 @@ How Good were they at Estimating?
In the Decisions from Expierience trials we asked Pariticpants about what they thing the outcome Ditribution really was. So now see if there are age differnces in estimating these distributions. For this i treat the real distributions as factors.
``` r
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%ggplot(aes(x=PercentBlueShownRel,y=PercentBlueEstimate,fill=Agegroup))+
stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%ggplot()+
#stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_summary(aes(x=PercentBlueShownRel,y=PercentBlueEstimate,color=Agegroup),geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
stat_summary(aes(y=as.numeric(PercentBlueShownRel)*10,x=PercentBlueShownRel),geom="pointrange",position = position_dodge(0.9),shape=3,color="red")+
scale_shape_manual(name="Distribution as Seen by Participant")+
scale_color_viridis_d(name="Agegroup",breaks=c("0","1","2"),labels=c("Pre Adolescence","Adolescence","Young Adults"))+
scale_x_discrete(name="Actual Distribution")+
scale_y_continuous(name="Participants Estimate")+
coord_cartesian(ylim=c(30,70))+
#coord_cartesian(ylim=c(30,70))+
ggtitle("Estimation Accuracy")
```
## No summary function supplied, defaulting to `mean_se()
![](Analyze_files/figure-markdown_github/unnamed-chunk-5-1.png)
Turns out they were accurate and captured the trends. While estimating similarly well, Children & Adolescents tended to be overoptimistic in their estimation. Is this a linear trend? This effect looks smaller with higher proportions of blue marbles. Participants also were all Optimistic for low probabilites and Pessimistic for high ones.
......@@ -220,24 +233,20 @@ labels <- c(
"2" = "Adults"
)
MarbleData%>%filter(DFE1DFD0=="1"&PercentBlueEstimate!="NULL")%>%mutate(
SquaredError=(as.numeric(PercentBlueEstimate) - as.numeric(PercentBlueShownRel))
)%>%ggplot(aes(x=SquaredError,y=as.numeric(HowSure)))+
stat_summary(geom="point",fun.y = "mean",position="dodge")+
MarbleData%>%filter(PercentBlueEstimate!="NULL")%>%mutate(
Error=(as.numeric(PercentBlueEstimate) - as.numeric(PercentBlueShownRel))
)%>%ggplot(aes(x=Agegroup,y=as.numeric(Error)))+
stat_summary(geom="bar",fun.y = "mean",position="dodge")+
stat_smooth(method="loess")+
stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
facet_grid(.~Agegroup,
labeller = labeller(Agegroup = labels)
)+
scale_x_continuous(name=" Estimation Error")+
scale_y_continuous(name="Confidence")+
ggtitle(" Estimation Error and Confidence")
#stat_summary(geom="pointrange",fun.y=mean,fun.ymin =function(x) mean(x)-(sd(x)/sqrt(length(x))),fun.ymax=function(x) mean(x)+(sd(x)/sqrt(length(x))),position = position_dodge(0.9))+
#facet_grid(.~Agegroup,
# labeller = labeller(Agegroup = labels)
#)+
scale_x_discrete(name=" Agegroup")+
scale_y_continuous(name="Estimation Error")+
ggtitle(" Estimation Error and Confidence")+coord_cartesian(ylim=c(50,40))
```
## Warning: Width not defined. Set with `position_dodge(width = ?)`
## Warning: Removed 4 rows containing missing values (geom_pointrange).
![](Analyze_files/figure-markdown_github/unnamed-chunk-8-1.png)
I cant make much of this inverted U shape. Does this really mean, that when they are super wrong, then they are most confident? This bias seems to be least present in Kids.
......@@ -279,44 +288,71 @@ Models
I outsourced Modelfitting to the tardis Here i fit a first model for ALL subjects We should look at the stuff with distributional assumptions afterwards, but judging superficially, there is nothing much going on agetrend wise. We can look at it indivdually later on but i think this can provide a good first look. First i need to concatanete the subject parameters. For this I need to retrieve the real Values at some point.
``` r
load("C_ModelFits/FullLearningModel")
Parameters<-(rstan::extract(fitSep))
library(tidyverse)
#Bin_Update_Data<-Bin_Update_Data[Bin_Update_Data$typeRA=="1",]# keep only The Risk trails.
Bin_Update_Data<-MarbleData%>%arrange(Agegroup)# i order it first so i can make sure that
Agegroups<-unique(Bin_Update_Data$Age.bins)# for indexing my agegroups.
#make it fit with my stan file.
Bin_Update_Data<-Bin_Update_Data%>%dplyr::mutate(
OtherChoseRisk = case_when(
OtherChoseRisk=="NULL" ~ 2,# i dont need this but i restricted the numbers in stan between 1 and 3
OtherChoseRisk=="1" ~ 3,# risky choices are coded as 3 in my stan code
OtherChoseRisk=="0" ~ 1,# safe choices are coded as 1 in my stan code
TRUE~0 # keep the rest.
ModelParamsFull=list()
subCount=1
for (j in 1:length(unique(MarbleData$Agegroup))){
fitSep<-readRDS(paste0("C_ModelFits/Marbles_Model_3Age_",j,".rds"))
Parameters<-(rstan::extract(fitSep))
library(tidyverse)
#Bin_Update_Data<-Bin_Update_Data[Bin_Update_Data$typeRA=="1",]# keep only The Risk trails.
Bin_Update_Data<-MarbleData%>%arrange(Agegroup)# i order it first so i can make sure that
Agegroups<-unique(Bin_Update_Data$Age.bins)# for indexing my agegroups.
#make it fit with my stan file.
Bin_Update_Data<-Bin_Update_Data%>%dplyr::mutate(
OtherChoseRisk = case_when(
OtherChoseRisk=="NULL" ~ 2,# i dont need this but i restricted the numbers in stan between 1 and 3
OtherChoseRisk=="1" ~ 3,# risky choices are coded as 3 in my stan code
OtherChoseRisk=="0" ~ 1,# safe choices are coded as 1 in my stan code
TRUE~0 # keep the rest.
)
)#end PeerChoice.
#subset it to fit on only one agegroup.
#Bin_Update_Data%>%filter(Agegroup==2)->Bin_Update_Data
#Bin_Update_Data%>%filter(DFE1DFD0==0)->Bin_Update_Data
# now check how many participants we have.
Bin_Update_Data$subject<-as.numeric(Bin_Update_Data$subject)
#change colname of subject into subjID
numSubjs<-length(unique(Bin_Update_Data$subject))#Total Number of Subs
subjList <- unique(Bin_Update_Data$subject)######
ageList<-Bin_Update_Data%>%group_by(subject)%>%dplyr::summarize(
age=mean(age)
)%>%select(age)%>%ungroup()
ageList=as.vector(ageList$age)
confList<-Bin_Update_Data%>%filter(HowSure!=102)%>%group_by(subject)%>%dplyr::summarise(
Confidence=mean(HowSure)
)
)#end PeerChoice.
#subset it to fit on only one agegroup.
#Bin_Update_Data%>%filter(Agegroup==2)->Bin_Update_Data
#Bin_Update_Data%>%filter(DFE1DFD0==0)->Bin_Update_Data
# now check how many participants we have.
Bin_Update_Data$subject<-as.numeric(Bin_Update_Data$subject)
#change colname of subject into subjID
numSubjs<-length(unique(Bin_Update_Data$subject))#Total Number of Subs
subjList <- unique(Bin_Update_Data$subject)######
ageList<-Bin_Update_Data%>%group_by(subject)%>%dplyr::summarize(
age=mean(age)