### splot trialwise beta predictive distirbutions

parent 2ae4e77c
 ... ... @@ -40,7 +40,7 @@ posResp = round(posResp,2); #sigma=0.1 #here i define a function that gives us the probability densitiy of all possible values given the mean and the standart deviation #of the posterior beta distribution that results from binomal updating. discretenormalMarble005<-function (possibleResp, a, b){ discreteBetaMarble005<-function (possibleResp, a, b){ lower = min(possibleResp); upper = max(possibleResp); ... ... @@ -107,8 +107,8 @@ linearWeights<- function(v){ # get pr and m. I need to dig into what this means exactly. # i use the estiamted mean and sigma to be able to get descrete log likelihoods. pr = discretenormalMarble005(posResp,aBeta, bBeta)[]; m = discretenormalMarble005(posResp,aBeta, bBeta)[]; pr = discreteBetaMarble005(posResp,aBeta, bBeta)[]; m = discreteBetaMarble005(posResp,aBeta, bBeta)[]; #check where the possible resposnes equal the exact response of the subject. now we have the response liklihood. probEstimate = pr[which(posResp==subEstimate)]; # SEE HERE YOU FIND THE PROB EST THAT FITS THE GIVEN SUBJECTIVE VALUE #zero doesnt work. ... ... @@ -173,8 +173,8 @@ exponentialWeights<- function(v){ # get pr and m. I need to dig into what this means exactly. # i use the estiamted mean and sigma to be able to get descrete log likelihoods. pr = discretenormalMarble005(posResp,aBeta, bBeta)[]; m = discretenormalMarble005(posResp,aBeta, bBeta)[]; pr = discreteBetaMarble005(posResp,aBeta, bBeta)[]; m = discreteBetaMarble005(posResp,aBeta, bBeta)[]; #check where the possible resposnes equal the exact response of the subject. now we have the response liklihood. probEstimate = pr[which(posResp==subEstimate)]; # SEE HERE YOU FIND THE PROB EST THAT FITS THE GIVEN SUBJECTIVE VALUE #zero doesnt work. ... ... @@ -326,4 +326,95 @@ What i get now if i look at the parameter estimate of the exponential model is a print(learningDiscounting) ``` # Retrieve Values In this chunk of code i use the function that i made before to fit the Marble data and get the alpha and beta parameters that i need to calculate all other fancy things. Yeah it works but i´m breaking my head over the visualization. How Can i Visualize it so that it makes sense? ```{r expoBuild,message=FALSE, warning=FALSE} GetShapeParamsExponentialWeights<- function(){ for (i in 1:nrow(subjectLevel)){ #reset shape paramters aBeta<-0 # number of sucesses bBeta<-0 # number of losses #preallocate internal variables mu<-rep(0,nrow(subjectLevel)) sigma<-rep(0,nrow(subjectLevel)) subEstimate<-rep(0,nrow(subjectLevel)) #here i red<-strsplit(subjectLevel\$sequence.marbles.color2[i],"") red<-as.numeric(unlist(red))#prepre the array blue<-strsplit(subjectLevel\$sequence.marbles.color1[i], "") blue<-as.numeric(unlist(blue)) ######## THIS IS WHERE THE WEIGHTING HAPPENS # each draw of the distributions is weighted with a learningrate for (j in 1:length(red)){ bBeta=bBeta+red[j]^subjectLevel\$learningRateExp[i]#update failures }# could do it in one step but its easiear to read this way. for (j in 1:length(blue)){ aBeta=aBeta+blue[j]^subjectLevel\$learningRateExp[i]#update sucesses } #calculate the sufficient statistics of the beta distribution. subjectLevel\$BetaShapeAlpha[i]<-aBeta subjectLevel\$BetaShapeBeta[i]<-bBeta subjectLevel\$mu[i]<-aBeta/(aBeta+bBeta)# calculate only the last mu. subjectLevel\$var[i]<-(aBeta*bBeta)/((aBeta+bBeta)^2*(aBeta+bBeta+1))#calculate the sigma. } return(subjectLevel) } #preallocate subs subjectLevel<-data[data\$sub.id==Subs,] AllParams<-GetShapeParamsExponentialWeights() ### Here i build the DataframeAgain for (i in 2:length(Subs)){ subjectLevel<-data[data\$sub.id==Subs[i],] data2<-GetShapeParamsExponentialWeights() AllParams<-rbind(AllParams,data2) } ``` Eventhough i still dont know how i can visualize this in a meaningful way, you can look at the Distributions for Each Trail per Subject. For this i build a new Dataframe that contains the probability Densities which result from the fitted Parameters that i obtain above in a long format. This Helps me at least to identify bad ModelFits and Subjects. ```{r L,message=FALSE, warning=FALSE, fig.height = 10, fig.width = 20} library(ggfortify) library(tidyverse) x<-seq(0,1,0.01) density<-seq(0,1,0.01) newData<-as.tibble( expand.grid( SubId<-unique(AllParams\$sub.id), Shown<-unique(AllParams\$mean.act), Density<-density # Prob<-x ) ) colnames(newData)<-c("SubId","Shown","Density") newData%>%filter(SubId==AllParams\$sub.id & Shown == AllParams\$mean.act)->FullData FullData\$Density=dbeta(x,AllParams\$BetaShapeAlpha,AllParams\$BetaShapeBeta) FullData\$x<-seq(0,1,0.01) for (i in 1:length(AllParams\$condition)){ newData%>%filter(SubId==AllParams\$sub.id[i] & Shown == AllParams\$mean.act[i])->Subsetted Subsetted\$Density=dbeta(x,AllParams\$BetaShapeAlpha[i],AllParams\$BetaShapeBeta[i]) Subsetted\$x<-seq(0,1,0.01) FullData<-rbind(FullData,Subsetted) } i=1 for (i in 1:length(unique(FullData\$SubId))){ p<-ggplot(FullData[FullData\$SubId==i,],aes(x=x,y=Density,color=as.factor(Shown)))+geom_point()+ scale_y_continuous(name="Estimated Predictive Probability Density of Subject 1")+ scale_color_discrete(name="Actual_Probability Per Trial")+ ggtitle(paste0("Probability Esitmate Subject ",i))+ #facet_grid(~Shown)+ my_theme print(p) } ``` \ No newline at end of file
 ... ... @@ -28,7 +28,7 @@ Make the cumulative Densitiy #sigma=0.1 #here i define a function that gives us the probability densitiy of all possible values given the mean and the standart deviation #of the posterior beta distribution that results from binomal updating. discretenormalMarble005<-function (possibleResp, a, b){ discreteBetaMarble005<-function (possibleResp, a, b){ lower = min(possibleResp); upper = max(possibleResp); ... ... @@ -113,8 +113,8 @@ estimate of the participants to create logliks. # get pr and m. I need to dig into what this means exactly. # i use the estiamted mean and sigma to be able to get descrete log likelihoods. pr = discretenormalMarble005(posResp,aBeta, bBeta)[]; m = discretenormalMarble005(posResp,aBeta, bBeta)[]; pr = discreteBetaMarble005(posResp,aBeta, bBeta)[]; m = discreteBetaMarble005(posResp,aBeta, bBeta)[]; #check where the possible resposnes equal the exact response of the subject. now we have the response liklihood. probEstimate = pr[which(posResp==subEstimate)]; # SEE HERE YOU FIND THE PROB EST THAT FITS THE GIVEN SUBJECTIVE VALUE #zero doesnt work. ... ... @@ -181,8 +181,8 @@ amount of time. # get pr and m. I need to dig into what this means exactly. # i use the estiamted mean and sigma to be able to get descrete log likelihoods. pr = discretenormalMarble005(posResp,aBeta, bBeta)[]; m = discretenormalMarble005(posResp,aBeta, bBeta)[]; pr = discreteBetaMarble005(posResp,aBeta, bBeta)[]; m = discreteBetaMarble005(posResp,aBeta, bBeta)[]; #check where the possible resposnes equal the exact response of the subject. now we have the response liklihood. probEstimate = pr[which(posResp==subEstimate)]; # SEE HERE YOU FIND THE PROB EST THAT FITS THE GIVEN SUBJECTIVE VALUE #zero doesnt work. ... ... @@ -315,3 +315,99 @@ What i get now if i look at the parameter estimate of the exponential model is an **underweghting** of all information considered. ![](LiklelihoodUpdateBeta_files/figure-markdown_strict/Show%20second%20Plot-1.png) Retrieve Values =============== In this chunk of code i use the function that i made before to fit the Marble data and get the alpha and beta parameters that i need to calculate all other fancy things. Yeah it works but i´m breaking my head over the visualization. How Can i Visualize it so that it makes sense? GetShapeParamsExponentialWeights<- function(){ for (i in 1:nrow(subjectLevel)){ #reset shape paramters aBeta<-0 # number of sucesses bBeta<-0 # number of losses #preallocate internal variables mu<-rep(0,nrow(subjectLevel)) sigma<-rep(0,nrow(subjectLevel)) subEstimate<-rep(0,nrow(subjectLevel)) #here i red<-strsplit(subjectLevel\$sequence.marbles.color2[i],"") red<-as.numeric(unlist(red))#prepre the array blue<-strsplit(subjectLevel\$sequence.marbles.color1[i], "") blue<-as.numeric(unlist(blue)) ######## THIS IS WHERE THE WEIGHTING HAPPENS # each draw of the distributions is weighted with a learningrate for (j in 1:length(red)){ bBeta=bBeta+red[j]^subjectLevel\$learningRateExp[i]#update failures }# could do it in one step but its easiear to read this way. for (j in 1:length(blue)){ aBeta=aBeta+blue[j]^subjectLevel\$learningRateExp[i]#update sucesses } #calculate the sufficient statistics of the beta distribution. subjectLevel\$BetaShapeAlpha[i]<-aBeta subjectLevel\$BetaShapeBeta[i]<-bBeta subjectLevel\$mu[i]<-aBeta/(aBeta+bBeta)# calculate only the last mu. subjectLevel\$var[i]<-(aBeta*bBeta)/((aBeta+bBeta)^2*(aBeta+bBeta+1))#calculate the sigma. } return(subjectLevel) } #preallocate subs subjectLevel<-data[data\$sub.id==Subs,] AllParams<-GetShapeParamsExponentialWeights() ### Here i build the DataframeAgain for (i in 2:length(Subs)){ subjectLevel<-data[data\$sub.id==Subs[i],] data2<-GetShapeParamsExponentialWeights() AllParams<-rbind(AllParams,data2) } Eventhough i still dont know how i can visualize this in a meaningful way, you can look at the Distributions for Each Trail per Subject. For this i build a new Dataframe that contains the probability Densities which result from the fitted Parameters that i obtain above in a long format. This Helps me at least to identify bad ModelFits and Subjects. library(ggfortify) library(tidyverse) x<-seq(0,1,0.01) density<-seq(0,1,0.01) newData<-as.tibble( expand.grid( SubId<-unique(AllParams\$sub.id), Shown<-unique(AllParams\$mean.act), Density<-density # Prob<-x ) ) colnames(newData)<-c("SubId","Shown","Density") newData%>%filter(SubId==AllParams\$sub.id & Shown == AllParams\$mean.act)->FullData FullData\$Density=dbeta(x,AllParams\$BetaShapeAlpha,AllParams\$BetaShapeBeta) FullData\$x<-seq(0,1,0.01) for (i in 1:length(AllParams\$condition)){ newData%>%filter(SubId==AllParams\$sub.id[i] & Shown == AllParams\$mean.act[i])->Subsetted Subsetted\$Density=dbeta(x,AllParams\$BetaShapeAlpha[i],AllParams\$BetaShapeBeta[i]) Subsetted\$x<-seq(0,1,0.01) FullData<-rbind(FullData,Subsetted) } i=1 for (i in 1:length(unique(FullData\$SubId))){ p<-ggplot(FullData[FullData\$SubId==i,],aes(x=x,y=Density,color=as.factor(Shown)))+geom_point()+ scale_y_continuous(name="Estimated Predictive Probability Density of Subject 1")+ scale_color_discrete(name="Actual_Probability Per Trial")+ ggtitle(paste0("Probability Esitmate Subject ",i))+ #facet_grid(~Shown)+ my_theme print(p) } ![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-1.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-2.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-3.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-4.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-5.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-6.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-7.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-8.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-9.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-10.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-11.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-12.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-13.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-14.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-15.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-16.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-17.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-18.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-19.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-20.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-21.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-22.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-23.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-24.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-25.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-26.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-27.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-28.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-29.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-30.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-31.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-32.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-33.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-34.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-35.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-36.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-37.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-38.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-39.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-40.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-41.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-42.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-43.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-44.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-45.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-46.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-47.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-48.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-49.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-50.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-51.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-52.png)![](LiklelihoodUpdateBeta_files/figure-markdown_strict/L-53.png)

195 KB

245 KB

243 KB

253 KB

203 KB

257 KB

225 KB

227 KB

238 KB

200 KB

251 KB

270 KB

197 KB

215 KB

218 KB

206 KB

118 KB

202 KB

239 KB

224 KB

226 KB

248 KB

266 KB

228 KB

234 KB

269 KB

198 KB

247 KB

225 KB

251 KB

253 KB

207 KB

217 KB

119 KB

218 KB

117 KB

119 KB

245 KB

234 KB

235 KB

233 KB

254 KB

236 KB

237 KB

246 KB

177 KB

264 KB

235 KB

245 KB

225 KB

213 KB

246 KB

218 KB 48.4 KB | W: | H:

48 KB | W: | H:  • 2-up
• Swipe
• Onion skin 50.9 KB | W: | H:

50.4 KB | W: | H:  • 2-up
• Swipe
• Onion skin 50.7 KB | W: | H:

50.3 KB | W: | H:  • 2-up
• Swipe
• Onion skin
 ... ... @@ -80,9 +80,6 @@ discretenormalMarble005<-function (possibleResp, mean, stdev){ ############ fit ... ... @@ -104,3 +101,39 @@ for (i in 1:length(Subs)){ sub.list[[i]]<-c(pars, LL) ## saves best fitting pars and LL } library(ggfortify) library(tidyverse) x<-seq(0,1,0.01) density<-seq(0,1,0.01) newData<-as.tibble( expand.grid( SubId<-unique(AllParams\$sub.id), Shown<-unique(AllParams\$mean.act), Density<-density # Prob<-x ) ) colnames(newData)<-c("SubId","Shown","Density") newData%>%filter(SubId==AllParams\$sub.id & Shown == AllParams\$mean.act)->FullData FullData\$Density=dbeta(x,AllParams\$BetaShapeAlpha,AllParams\$BetaShapeBeta) FullData\$x<-seq(0,1,0.01) for (i in 1:length(AllParams\$condition)){ newData%>%filter(SubId==AllParams\$sub.id[i] & Shown == AllParams\$mean.act[i])->Subsetted Subsetted\$Density=dbeta(x,AllParams\$BetaShapeAlpha[i],AllParams\$BetaShapeBeta[i]) Subsetted\$x<-seq(0,1,0.01) FullData<-rbind(FullData,Subsetted) } FullData%>%filter(SubId==1)%>%ggplot(aes(x=x,y=Density,color=as.factor(Shown)))+geom_line()+ scale_y_continuous(name="Estimated Predictive Probability Density of Subject 1")+ scale_color_discrete(name="Actual_Probability Per Trial")+ ggtitle("Probability Esitmate")+ facet_grid(~Shown)+ my_theme #ggplot(aes(x=BetaShapeAlpha,y=BetaShapeBeta,color=mean.act))+geom_point()

195 KB

245 KB

243 KB

253 KB

203 KB

257 KB

225 KB

227 KB

238 KB

200 KB

251 KB

270 KB

197 KB

215 KB

218 KB

206 KB

118 KB

202 KB

239 KB

224 KB

226 KB

248 KB

266 KB

228 KB

234 KB

269 KB

198 KB

247 KB

225 KB

251 KB

253 KB

207 KB

217 KB

119 KB

218 KB

117 KB

119 KB

245 KB

234 KB

235 KB

This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!