--- title: "Adaptive_Adolescence_multi" author: "Simy" date: "28/08/2020" output: github_document: toc: true toc_depth: 2 --- ```{r setup, include=FALSE} knitr::opts_chunk\$set(echo = TRUE) pacman::p_load(tidyverse,cowplot,matrixcalc,gganimate,ggformula,pracma) ``` # I do everything exactly the same as before But I make multiple simulations because there is so much stochastizity in the simluations and we need to get a feeling for the expectation value. ```{r fig.width=12,fig.height=6, include=FALSE} loadfromdisk=T envirionmentMeanKids=seq(-50,50,length.out=5)#define the range of kid envirionemt envirionmentVarianceKids=seq(1,10,length.out=5) EnvirionemntKids=expand.grid(Mean=envirionmentMeanKids,Variance=envirionmentVarianceKids)# we sample from this later #define the range of adolescent environment envirionmentMeanAdol=seq(-100,100,length.out=12) envirionmentVarianceAdol=seq(1,80,length.out=12) EnvirionemntAdol=expand.grid(Mean=envirionmentMeanAdol,Variance=envirionmentVarianceAdol) EnvirionemntAdol%>%ungroup() EnvirionemntAdol%>%dplyr::rowwise()%>%mutate(value=rnorm(1,mean = Mean,sd=Variance))%>% ggplot(aes(x=Mean,y=Variance,fill=value))+geom_tile()+ scale_fill_distiller(name="Outcome",palette = "Spectral",trans = "reverse")+ geom_hline(aes(yintercept=40),size=2)+ geom_vline(aes(xintercept=0),size=2)+ annotate("text",x=50,y=38,label=c("Low Risk / Reward"))+ annotate("text",x=-50,y=38,label=c("Low Risk / Loss"))+ annotate("text",x=50,y=42,label=c("High Risk / Reward"))+ annotate("text",x=-50,y=42,label=c("High Risk / Loss"))+ ggtitle("Adolescent Environment")+theme_minimal(14)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())->Adolescent EnvirionemntAdol%>%dplyr::rowwise()%>%mutate(value=rnorm(1,mean = Mean,sd=Variance))%>% ggplot(aes(x=Mean,y=Variance,fill=value,alpha=Mean>-46&Variance<40&Mean<46))+geom_tile()+ scale_fill_distiller(name="Outcome",palette = "Spectral",trans = "reverse")+ scale_alpha_discrete(range = c(0.2, 1))+ geom_hline(aes(yintercept=40),size=2)+ geom_vline(aes(xintercept=0),size=2)+ annotate("text",x=50,y=38,label=c("Low Risk / Reward"))+ annotate("text",x=-50,y=38,label=c("Low Risk / Loss"))+ annotate("text",x=50,y=42,label=c("High Risk / Reward"))+ annotate("text",x=-50,y=42,label=c("High Risk / Loss"))+ guides(alpha=F)+ ggtitle("Childhood Environment")+theme_minimal(14)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())->Kid ``` ```{r fig.width=12,fig.height=6} legend=cowplot::get_legend(Kid) cowplot::plot_grid(Kid+theme(legend.position="none"), Adolescent+theme(legend.position="none", axis.title.y = element_text(colour="white")), legend,ncol =3,rel_widths = c(1,1,0.2)) ggsave(filename = "../X_Figures/Environments.png") ``` # load the kalman filter and the UCB rule Here i define the kalman filter and the choice rule. The Kalman Agent explores the bandits by representing their mean reward rate and its uncertainty about that mean. Both, beliefs about the mean reward rate and uncertainty about that belief are updated every trials after observing a new outcome. The Agents behavior can be gouverend by 3 parameters: * mu0, or Optimism: its prior assumption about how rewarding the envirionment will be on average. This Paramter will also gouvern the extend of exploration * var0, or speed of learning: its prior uncertainty about that mean. the higher prior uncertainty is, the more extremely will the agent update its beliefs in the beginning after observing a new sample * vare, or imprecision: Imprecision will impact the speed of updating as well. The higher the imprecision parameter, the more uncertain the agent will remain about one options mean, even after observing a lot of samples. New samples are generated using an upper (lower) confidence bound rule where the uncertainty about an option is added to (subtracted from) the beleif about the mean of this option. This policy regulates exploration as well where we can vary uncertaintyphile or phobe behavioral ploicies. This proces is subject to paramter * beta, or uncertainty aversion (seeking) ```{r} bayesianMeanTracker <- function(x, y, theta, prevPost=NULL,mu0Par,var0Par){ #Updates the previous posterior based on a single observation #parameters mu0 <- mu0Par #prior mean var0 <- var0Par #prior variance vare <- theta[1] #error varriance if (is.null(prevPost)){#if no posterior prior, assume it is the first observation predictions <- data.frame(mu=rep(mu0,144), sig=rep(var0,144)) }else{#if previous posterior is provided, update predictions <- prevPost } #Which of the 121 options were chosen at time? allopts<-expand.grid(1:12, 1:12) chosen <- which(allopts\$Var1==x[1] & allopts\$Var2==x[2]) #Kalman gain kGain <- predictions\$sig[chosen] / (predictions\$sig[chosen] + 3600)# feed the uncertainty in here. #update mean predictions\$mu[chosen] <- predictions\$mu[chosen] + (kGain * (y-predictions\$mu[chosen])) #update variance for observed arm predictions\$sig[chosen] <- predictions\$sig[chosen] * (1 - kGain) #return output return(predictions) } class(bayesianMeanTracker)<- c(class(bayesianMeanTracker), "KalmanFilter") ucb<-function(out, pars, refactor=F){ if (refactor==TRUE){ gamma <- pars[1] beta_star<-pars[2] #calulate all the upper confidence bounds outtotal<-(gamma*out\$mu)#+(beta_star*sqrt(out\$sig)) #refactored parameters in combination with softmax tau, where gamma = 1/tau and beta_star = beta/tau #avoid borderline cases #outtotal[outtotal<=0]<-0.0001 #outtotal[outtotal>100]<-100 outtotal<-matrix(outtotal, ncol=1, byrow=TRUE) }else{ beta <- pars[1] #calulate all the upper confidence bounds outtotal<-out\$mu+(beta*sqrt(out\$sig)) #refactored parameters in combination with softmax tau, where gamma = 1/tau and beta_star = beta/tau #avoid borderline cases #outtotal[outtotal<=0]<-0.0001 #outtotal[outtotal>99]<-99 outtotal<-matrix(outtotal, ncol=1, byrow=TRUE) } #return them return(outtotal) } ``` ### some values to set. ```{r setupObser} # get sd of whole environemt for normalizing model input set.seed(as.numeric(Sys.time())) cntrl=list( #get lambda lambda=0.8, #get beta beta=0,# this scales risk attitude. #get tau tau=0.8, mu0=100,#exploration bonus var0=40, #create a parameter vector parVec = c(0.8, 0.8, 1, .0001) , # ExploreBonus=0, #kernel is RBF #k<-rbf #loop through trials out=NULL, AllChoices=NULL, dummy=NULL, overallCnt=1, dat=expand.grid(x1=1:12,x2=1:12) ) ## ## ## Here i store the multiple Sims ntrialss=100 list_Iter <- vector(mode = "list", length = ntrialss) ``` # Make observations Here i let the agent learn about the envirionment. There are three phases of the simulation. Phase one is "childhood". During childhood Agents can explore only the lower middle quadrant. Here all decisions have low risk and there are some low rewards possible. Phase two, that occurs after some learning experience (400 samples), can be understood as the onset of adolescence. Here the whole environment becomes availible but the agent does not know about it so they have to learn. Then after another 400 samples, the agent transitions into "adulthood" where the same environment is still present but the learning expierience now lead to greater exploitation of presumably advantengeous options. #### setup parallel ```{r} if(loadfromdisk==F){ library(doParallel) #####setup parralel cl <- makeCluster(40) registerDoParallel(cl) } ``` ```{r} exploreEnv<-function(explore_func,choiceRule,env2,env1,cntrl,iter){ #for (rep in 1:ntrialss){ #unpack lambda=cntrl\$lambda #get beta beta<-cntrl\$beta# this scales risk attitude. #get tau tau<-cntrl\$tau mu0<-cntrl\$mu0#exploration bonus var0<-cntrl\$var0 #create a parameter vector parVec <- cntrl\$parVec # ExploreBonus=cntrl\$ExploreBonus #kernel is RBF #k<-rbf #loop through trials out=cntrl\$out AllChoices=cntrl\$AllChoices dummy=cntrl\$dummy overallCnt=cntrl\$overallCnt dat=cntrl\$dat mu=list() sig=list() for (nround in 1:3){ #get parameters for participant on that round if (nround==1){ # define vectors that are used by the kalman filter lowestx=4 highestx=9 sampleVec=as.numeric(rownames(dat[dat\$x1>=lowestx & dat\$x1<=highestx & dat\$x2<7,]))# here you define where a child should sample from ind<-sample(sampleVec,1) nTrials=400 }else { ind<-sample(1:144,1) nTrials=400 } #random initialization as observation t=0 #y matrix if (nround==1 & overallCnt==1){ X<-as.matrix(dat[ind,1:2])# generate a new vector of Xs y<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) }else if(overallCnt==1) { print("Youre an adolescent now") X<-as.matrix(dat[ind,1:2])# generate a new vector of Xs y<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) } #X-start, i.e. all possible observations Xstar<-as.matrix(dat[,1:2]) for (trial in 1:nTrials){ #output by GP with particular parameter settings #don't forget mean centering and standardization.... mean is already 0 :) if (overallCnt>1){ out<-bayesianMeanTracker(X[overallCnt,1:2],y[overallCnt], theta=lambda, prevPost=out,mu0Par=mu0,var0Par = var0) }else{ out<-bayesianMeanTracker(X[overallCnt,1:2],y[overallCnt],theta=lambda, prevPost=NULL,mu0Par=mu0,var0Par=var0) } #browser() #utility vector. transpose if you use greedyMean #where is everybody? #here i need a function that calls bayesianMeanTracker. n times and returns the values X for each n. Also, i need some kind of list, where i save the prior for each instance.... # # browser() utilityVec<-ucb(out,beta) utilities <- utilityVec - max(utilityVec) #softmaximization p <- exp(utilities/tau) #probabilities p <- p/colSums(p) #numerical overflow p <- (pmax(p, 0.00001)) p <- (pmin(p, 0.99999)) #index is sampled proprotionally to softmaxed utitily vector if (nround==1){# subset the probability vector so that it corresponds to the right tiles. ind<-sample(sampleVec,1,prob=p[dat\$x1>=lowestx & dat\$x1<=highestx & dat\$x2<7,])# sample from a childhood environemnt #this monster just scales exploration boni }else { ind<-sample(1:144, 1, prob=p)# sample from an adolescent environemnt # print(ind) } X<-rbind(X, as.matrix(dat[ind,1:2])) #bind y-observations y<-rbind(y, as.matrix(rnorm(n=1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)))# change this into a sample. #if(y[overallCnt]<0){ # y[overallCnt]=-1*y[overallCnt]^2# make losses more severe. #} dummy<-data.frame(trial=overallCnt, x=as.numeric(X[overallCnt,1]), y=as.numeric(X[overallCnt,2]), z=as.numeric(y[overallCnt]),round=nround) AllChoices<-rbind(AllChoices,dummy) mu[[overallCnt]]<-out\$mu sig[[overallCnt]]<-out\$sig overallCnt=overallCnt+1 } #dummy data frame } #} #This Here is for Plotting Plot_dat=expand.grid(x=1:12,y=1:12,trials=0:max(dummy\$trial)) Plot_dat\$sample=0 Plot_dat\$out=0 Plot_dat\$mu=0 Plot_dat\$sig=40 for (i in 1:length(AllChoices\$x)){ AllChoices\$y[i] AllChoices\$x[i] Plot_dat[Plot_dat\$x==AllChoices\$x[i] & Plot_dat\$y==AllChoices\$y[i] & Plot_dat\$trials==AllChoices\$trial[i],]\$sample=1 Plot_dat[Plot_dat\$trials==AllChoices\$trial[i],]\$out=AllChoices\$z[i] Plot_dat[Plot_dat\$trials==AllChoices\$trial[i],]\$mu=mu[[i]] Plot_dat[Plot_dat\$trials==AllChoices\$trial[i],]\$sig=sig[[i]] } # browser() Plot_dat\$iter=iter return(Plot_dat) } if(loadfromdisk==F){ Plot_datAll<-foreach(iter=1:ntrialss, .combine='rbind') %dopar%{ exploreEnv(explore_func=bayesianMeanTracker,choiceRule=ucb,env2=EnvirionemntAdol,env1=EnvirionemntKids,cntrl=cntrl,iter=iter) } saveRDS(file="../A_GeneratedFiles/Plot_datAll",object = Plot_datAll) }else{ Plot_datAll<-readRDS(file="../A_GeneratedFiles/Plot_datAll") } # do it. ``` # Now lets contrast the relative & the total number of risky decisions. Here i compare different developmental phases with respect to how many rewards and losses have been encounterd as a consequence of exploring this envirionment. An exploring agent likely samples highly disadventegous options which agents with more expierience may avoid. Therefore I also show how severe the losses were on average in each developmental phase. An interesting divergence occurs here: While encountered losses decrease and rewards increase across development; the severity of losses is highest for the adolescent agents who still need to explore the environment. ```{r fig.width=10} Plot_datAll%>%group_by(x,y,iter)%>%filter(trials<=400)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out))->Kids Plot_datAll%>%group_by(x,y,iter)%>%filter(trials>=400 & trials<800)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out))->Adolescents Plot_datAll%>%group_by(x,y,iter)%>%filter(trials>800 & trials<2400)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out) )->YoungAdults Adolescents\$Stage="2" Kids\$Stage="1" YoungAdults\$Stage="3" Adolescents\$Soc="0" Kids\$Soc="0" YoungAdults\$Soc="0" Plot_labels=c("Children","Adolescents","Adults") rbind(Kids,Adolescents,YoungAdults)->AllIndi ``` ```{r fig.width=11, fig.height=3} AllIndi%>%ungroup()%>%select(howMany)%>%min()->minScale AllIndi%>%ungroup()%>%select(howMany)%>%max()->maxScale #first show distribution of risky decisions as kid ggplot(Kids,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ coord_cartesian(ylim=c(0,400))+ scale_y_continuous(name="#")+ ggtitle("outcomes children\nsolo")+ guides(fill=F)+ theme_minimal(8)->One #then show distribution of risky decisions as adolescent ggplot(Adolescents,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ coord_cartesian(ylim=c(0,400))+ scale_y_continuous(name="")+ ggtitle("outcomes adolescents\nsolo")+ guides(fill=F)+ theme_minimal(8)->Two #then Adults distribution of risky decisions as adolescent ggplot(YoungAdults,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_y_continuous(name="")+ coord_cartesian(ylim=c(0,400))+ guides(fill=F)+ ggtitle("outcomes adults\nsolo")+ theme_minimal(8)->Three #Now, look at the outcome ggplot(AllIndi[AllIndi\$Outcome=="Loss",],aes(x=Stage,y=howMuch,fill=Stage))+ geom_jitter(aes(group=iter,color=Stage),alpha=0.3)+ stat_summary(aes(color=Stage),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_y_continuous(name="Cumulative Loss")+ scale_x_discrete("Developmental Stage",breaks=c("1","2","3"),labels=Plot_labels)+ ggtitle("Severety of bad\noutcomes")+ scale_color_brewer(palette = "Set2")+ coord_cartesian(ylim=c(-2000000,0))+ guides(fill=F)+ theme_minimal(8)->Four cowplot::plot_grid(One,Two,Three,NULL,Four,ncol=5,rel_widths = c(1,1,1,0.3,1.7))->Solo ggsave(plot = Solo,"../X_Figures/EmergentBehavior_summary.png",width = 11,height = 4) print(Solo) ``` # Number of explorative decisions Not only the outcomes are interesting but also how much exploraiton happens. So i now declare an explorative decision as switching a bandit. This is done by observing whether sampling of one xy pair changes from 0 to 1. ```{r} #this is why i love dplyr! #create count for each new decision. # do it in parralel again compute_sampling_strategy<-function(Plot_datAll,subject){ library(dplyr) Plot_datAll%>%filter(iter==subject)%>%group_by(x,y)%>%mutate(cumDens=cumsum(sample))%>%ungroup()%>% group_by(x,y, trials) %>% mutate(newC = ifelse(cumDens == 1 & lag(cumDens)==0, 1, 0))->newExp# if i take the derivative of this this might be exaclty what wouter was intersted in. newExp[is.na(newExp\$newC),]\$newC=1# #now i have to "reset" so that each trial there can only be one new decision and because otherwise this will scale up the cumulative sum too much newExp\$newExplore=0 newExp\$generalExplore=0 for( i in 1:length(unique(newExp\$trials))){ newExp[newExp\$trials==i,]\$newExplore=xor(newExp[newExp\$trials==i,]\$newC,newExp[newExp\$trials==i-1,]\$newC)# print(i) # newExp[newExp\$trials==i,]\$generalExplore=xor(newExp[newExp\$trials==i,]\$sample,newExp[newExp\$trials==i-1,]\$sample) } newExp\$iter=subject return(newExp) } #saveRDS(newExp,"Derivatives_TrialWise.rds") if (loadfromdisk==F){ #newExp_all<-NULL #for(subject in 1:ntrialss){ # print(subject) newExp_all<-foreach(subject = 1:ntrialss,.combine = "rbind",.verbose=T) %dopar%{ compute_sampling_strategy(Plot_datAll,subject) } saveRDS(file = "../A_GeneratedFiles/solotraj2.rds",object = newExp_all) }else { newExp_all<-readRDS(file = "../A_GeneratedFiles/solotraj2.rds") } # to compute the derivative ``` I then compute the cumulative sum of this count and subtract the cumulative count from 50 trials earlier from it, which gives me a "slope" of new explorative decisions. But i also contrast this to the raw cumulative count, in order for us to inspect how these values correspond. ```{r} newExp_all%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ), Which="Solo" )%>%#filter(trials>36 & (trials <401 | trials >508))%>% filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ stat_summary(geom="line",fun.y = "mean",color="black")+ # geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_spline(size=1)+ geom_point(aes(shape=Stage),size=1,alpha=0.1)+ stat_summary(aes(shape=Stage),geom="point",fun.y = "mean",size=2.5,color="black",fill="white")+ scale_shape_manual(name="Developmental\nStage",values=c(22,21,24))+ geom_vline(xintercept = 420, linetype="dotted",color="red")+ geom_vline(xintercept = 410, linetype="dotted",color="red")+ geom_vline(xintercept = 800, linetype="dotted",color="red")+ geom_vline(xintercept = 790, linetype="dotted",color="red")+ annotate("text",x=150,y=60,label=c("Children"))+ annotate("text",x=600,y=60,label=c("Adolescents"))+ annotate("text",x=950,y=60,label=c("Adults"))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ #coord_cartesian(ylim=c(0,))+ scale_y_continuous(name="Exploration decisions")+ scale_x_continuous(name="trials")+ guides(linetype=F)+ theme_minimal(14) #->ExploreSoloPlot #ggsave(plot=ExploreSoloPlot,filename="../X_Figures/TimecourseExplore.png",width=6.3,height=5) ``` ```{r} newExp_all%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"1", (trials>400&trials<800)~"2", (trials>800)~"3" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>%group_by(Stage,iter)%>% summarize(AUC=trapz(trials,explore2))->AUCSoloTbl ylimauc<-AUCSoloTbl%>%ungroup()%>%select(AUC)%>%max() ggplot(AUCSoloTbl,aes(x=Stage,y=AUC))+ #geom_jitter(aes(group=iter,color=Stage),alpha=0.1)+ stat_summary(aes(x=Stage,y=AUC,fill=Stage),geom="bar",color="black",fun.y = "mean",stat="identity")+ stat_summary(aes(color=Stage),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_x_discrete(name="Developmental Stage",breaks=c(1,2,3),labels=c("Children","Adolescents","Adults"))+ ggtitle("Exploration (AUC) - Solo")+ scale_fill_brewer(palette = "Set2",breaks=c(1,2,3),labels=c("Children","Adolescents","Adults"))+ scale_y_continuous(name=c("AUC Explore"),limits=c(0,ylimauc))+ theme_minimal(14)->AUCSolo ``` # Social One particular feature about adolescents is that they are sensitive to social information. In order to invesitage how such a sensitivity impacts 1) exploration behavior and 2) encountered outcomes. For this i let _n_ agents perform the task in parallel and introduce a bonus to the choice utilites that depends on how many others have visited this option in the previous trial. ```{r setupsims} # get sd of whole environemt for normalizing model input set.seed(as.numeric(Sys.time())) loadfromdisk=T ### ### ### ### ### PARAMETERS ### ### ### #get lambda #get beta cntrl_social<-list( beta=0,# this scales risk attitude. #get tau tau=1, mu0=100,#exploration bonus var0=40, #create a parameter vector parVec <- c(0.8, 0.8, 1, .0001) , #loop through trials out=NULL, AllChoices_social=NULL, dummy=NULL, overallCnt=1, dat_social=expand.grid(x1=1:12,x2=1:12), HowManyOthers=19, diminishingSocial=0.8 # info about the agents ) ``` # Social function This here is a function that returns the location of other kalman agent in the space. You can modify the agents risk attitudes by changing the prior mu0 in the beginning. ```{r} ### ### ### This here is a function that returns the location of other kalman agent in the space. ### You can modify their risk attitudes by changing the prior mu0 in the beginning. ### WhereIsEverybody<-function(HowManyOthers,others,otherLoc,dat_social,X_oth,y_oth,diminishingSocial,nround,overallCnt,cntrl,sampleVec){ lowestx=4 highestx=9 lambda=cntrl\$lambda #get beta beta<-cntrl\$beta# this scales risk attitude. #get tau tau<-cntrl\$tau mu0<-cntrl\$mu0#exploration bonus var0<-cntrl\$var0 #create a parameter vector parVec <- cntrl\$parVec # ExploreBonus=cntrl\$ExploreBonus #kernel is RBF #k<-rbf #loop through trials out=cntrl\$out mu0=100 if (HowManyOthers==1){ return(list(Others=dat_social\$others,LastSamples=X_oth,LastReturn=y_oth,OthersUtil=others)) } else{ #### ####Update_socialing process for each individual #### if (nround==1 & overallCnt==1){ sampleVec=as.numeric(rownames(dat_social[dat_social\$x1>=lowestx & dat_social\$x1<=highestx & dat_social\$x2<7,]))# here you define where a child should sample from ind<-sample(sampleVec,1) X_oth[[HowManyOthers]]<-as.matrix(dat_social[ind,1:2])# generate a new vector of Xs y_oth[HowManyOthers]<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) }else if(overallCnt==1) { ind<-sample(1:144,1) print("Youre an adolescent now") X_oth[[HowManyOthers]]<-as.matrix(dat_social[ind,1:2])# generate a new vector of Xs y_oth[HowManyOthers]<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) } if (overallCnt>1){ others[[HowManyOthers]]<-bayesianMeanTracker(X_oth[[HowManyOthers]],y_oth[HowManyOthers], theta=lambda, prevPost=others[[HowManyOthers]],mu0Par=mu0,var0Par = var0) }else{ others[[HowManyOthers]]<-bayesianMeanTracker(X_oth[[HowManyOthers]],y_oth[HowManyOthers],theta=lambda, prevPost=NULL,mu0Par=mu0,var0Par=var0) } utilityVec<-ucb(others[[HowManyOthers]],beta) #browser() #if(nround==1){ # no social impact in "kids environment" # utilityVec=utilityVec#+otherLoc #} else{ #social impact follows a power law starting in adolescnece. # browser() utilityVec=utilityVec+otherLoc^diminishingSocial #} utilities <- utilityVec - max(utilityVec) # utilities=utilities #softmaximization p <- exp(utilities/tau) #probabilities p <- p/colSums(p) #numerical overflow p <- (pmax(p, 0.00001)) p <- (pmin(p, 0.99999)) #index is sampled proprotionally to softmaxed utitily vector if (nround==1){# subset the probability vector so that it corresponds to the right tiles. ind<-sample(sampleVec,1,prob=p[dat_social\$x1>=lowestx & dat_social\$x1<=highestx & dat_social\$x2<7,])# sample from a childhood environemnt #this monster just scales exploration boni }else { ind<-sample(1:144, 1, prob=p)# sample from an adolescent environemnt # print(ind) } X_oth[[HowManyOthers]]<-as.matrix(dat_social[ind,1:2]) #bind y-observations y_oth[HowManyOthers]<-as.matrix(rnorm(n=1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance))# change this into a sample. dat_social[ind,]\$others=dat_social[ind,]\$others+1 #### ####Now, let the others play #### WhereIsEverybody(HowManyOthers-1,others,otherLoc,dat_social,X_oth,y_oth,diminishingSocial,nround,overallCnt,cntrl,sampleVec)# recursion } } ``` ```{r} #otherLoc=0 exploreEnv_Social<-function(explore_func,choiceRule,socialfunc,env2,env1,cntrl,iter){ #for (rep in 1:ntrialss){ #unpack lambda=cntrl\$lambda #get beta beta<-cntrl\$beta# this scales risk attitude. #get tau tau<-cntrl\$tau mu0<-cntrl\$mu0#exploration bonus var0<-cntrl\$var0 #create a parameter vector parVec <- cntrl\$parVec # ExploreBonus=cntrl\$ExploreBonus #kernel is RBF #k<-rbf #loop through trials out=cntrl\$out AllChoices_social=cntrl\$AllChoices_social dummy=cntrl\$dummy overallCnt=cntrl\$overallCnt dat_social=cntrl\$dat_social dat_social\$others=0#to get the right indices otherLoc=dat_social\$others# location of others in last turn i need it to pass it to the social updating function to avoid social info to have a cumulative effect relative to trials. HowManyOthers=cntrl\$HowManyOthers diminishingSocial=cntrl\$diminishingSocial # info about the agents others = vector(mode = "list", length = HowManyOthers)# environment for everybody_needed for learning X_oth= vector(mode = "list",length = HowManyOthers)#new sample y_oth= vector(length = HowManyOthers)#new outcome AllOthers=NULL for (nround in 1:3){ #get parameters for participant on that round if (nround==1){ # define vectors that are used by the kalman filter lowestx=4 highestx=9 sampleVec=as.numeric(rownames(dat_social[dat_social\$x1>=lowestx & dat_social\$x1<=highestx & dat_social\$x2<7,]))# here you define where a child should sample from ind<-sample(sampleVec,1) nTrials=400 }else { ind<-sample(1:144,1) nTrials=400 } #random initialization as observation t=0 #y matrix if (nround==1 & overallCnt==1){ X<-as.matrix(dat_social[ind,1:2])# generate a new vector of Xs y<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) }else if(overallCnt==1) { print("Youre an adolescent now") X<-as.matrix(dat_social[ind,1:2])# generate a new vector of Xs y<-as.matrix(rnorm(1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)) } #X-start, i.e. all possible observations Xstar<-as.matrix(dat_social[,1:2]) for (trial in 1:nTrials){ #dat_social\$others=0 #output by GP with particular parameter settings #don't forget mean centering and standardization.... mean is already 0 :) if (overallCnt>1){ out<-bayesianMeanTracker(X[overallCnt,1:2],y[overallCnt], theta=lambda, prevPost=out,mu0Par=mu0,var0Par = var0) }else{ out<-bayesianMeanTracker(X[overallCnt,1:2],y[overallCnt],theta=lambda, prevPost=NULL,mu0Par=mu0,var0Par=var0) } #utility vector. transpose if you use greedyMean #where is everybody? #here i need a function that calls bayesianMeanTracker. n times and returns the values X for each n. Also, i need some kind of list, where i save the prior for each instance.... #### #### Out_Others=WhereIsEverybody(HowManyOthers,others,otherLoc,dat_social,X_oth,y_oth,diminishingSocial,nround,overallCnt,cntrl,sampleVec) otherLoc=Out_Others\$Others X_oth=Out_Others\$LastSamples y_oth=Out_Others\$LastReturn others=Out_Others\$OthersUtil #add social info #browser() #### #### #print(otherLoc) utilityVec<-ucb(out,beta) # if(nround==1){ # no social impact in "kids environment" # utilityVec=utilityVec#+otherLoc #} else{ #social impact follows a power law starting in adolescnece. utilityVec=utilityVec+otherLoc^diminishingSocial #} #utilityVec=utilityVec+otherLoc^diminishingSocial#add social info utilities <- utilityVec - max(utilityVec) #softmaximization p <- exp(utilities/tau) #probabilities p <- p/colSums(p) #numerical overflow p <- (pmax(p, 0.00001)) p <- (pmin(p, 0.99999)) #index is sampled proprotionally to softmaxed utitily vector if (nround==1){# subset the probability vector so that it corresponds to the right tiles. ind<-sample(sampleVec,1,prob=p[dat_social\$x1>=lowestx & dat_social\$x1<=highestx & dat_social\$x2<7,])# sample from a childhood environemnt #this monster just scales exploration boni }else { ind<-sample(1:144, 1, prob=p)# sample from an adolescent environemnt # print(ind) } X<-rbind(X, as.matrix(dat_social[ind,1:2])) #bind y-observations y<-rbind(y, as.matrix(rnorm(n=1,mean = EnvirionemntAdol[ind,]\$Mean,sd=EnvirionemntAdol[ind,]\$Variance)))# change this into a sample. #if(y[overallCnt]<0){ # y[overallCnt]=-1*y[overallCnt]^2# make losses more severe. #} AllOthers=rbind(AllOthers,data.frame(Loc=otherLoc,trial=overallCnt)) dummy<-data.frame(trial=overallCnt, x=as.numeric(X[overallCnt,1]), y=as.numeric(X[overallCnt,2]), z=as.numeric(y[overallCnt]),round=nround) AllChoices_social<-rbind(AllChoices_social,dummy) overallCnt=overallCnt+1 } #dummy data frame } #} #This Here is for Plotting Plot_dat_social=expand.grid(x=1:12,y=1:12,trials=0:max(dummy\$trial)) Plot_dat_social\$sample=0 Plot_dat_social\$out=0 for (i in 1:length(AllChoices_social\$x)){ AllChoices_social\$y[i] AllChoices_social\$x[i] Plot_dat_social[Plot_dat_social\$x==AllChoices_social\$x[i] & Plot_dat_social\$y==AllChoices_social\$y[i] & Plot_dat_social\$trials==AllChoices_social\$trial[i],]\$sample=1 Plot_dat_social[Plot_dat_social\$trials==AllChoices_social\$trial[i],]\$out=AllChoices_social\$z[i] } ## here add the tally of "others". Plot_dat_social\$Others=0 for(k in unique(Plot_dat_social\$trials)){ if (k>0){ Plot_dat_social[Plot_dat_social\$trials==k,]\$Others=AllOthers[AllOthers\$trial==k,]\$Loc } } Plot_dat_social\$iter=iter return(Plot_dat_social) } #loadfromdisk==F if (loadfromdisk==F){ Plot_dat_social_All<-foreach(trials=1:ntrialss, .combine='rbind') %dopar%{ exploreEnv_Social(explore_func=bayesianMeanTracker, choiceRule=ucb, socialfunc=WhereIsEverybody, env2=EnvirionemntAdol, env1=EnvirionemntKids, cntrl=cntrl_social, trials) } saveRDS(file="../A_GeneratedFiles/Plot_dat_social_All.rds",object=Plot_dat_social_All) } else{ Plot_dat_social_All<-readRDS(file="../A_GeneratedFiles/Plot_dat_social_All.rds") } ``` # Now lets contrast the relative & the total number of risky decisions. This plot shows the same as above. Counts of Gains and Losses and Severity in Losses. Generally having others in this patch seems to help making better decisions, also during adolescence! ```{r fig.width=10} Plot_dat_social_All[length(Plot_dat_social_All\$x),]\$out=-0.1# dummy to make the x axis for the adult plot right Plot_dat_social_All%>%group_by(x,y,iter)%>%filter(trials<=400)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out))->KidsSoc Plot_dat_social_All%>%group_by(x,y,iter)%>%filter(trials>=400 & trials<800)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out))->AdolescentsSoc Plot_dat_social_All%>%group_by(x,y,iter)%>%filter(trials>800 & trials<1200)%>%mutate(cumDens=cumsum(sample), Outcome=case_when( (out<0)~"Loss", (out>=0)~"Gain" ) )%>%group_by(Outcome,iter)%>%summarise(howMany=n()/144, howMuch=sum(out) )->YoungAdultsSoc AdolescentsSoc\$Stage="2" KidsSoc\$Stage="1" YoungAdultsSoc\$Stage="3" AdolescentsSoc\$Soc="1" KidsSoc\$Soc="1" YoungAdultsSoc\$Soc="1" Plot_labels=c("Children","Adolescents","Adults") rbind(KidsSoc,AdolescentsSoc,YoungAdultsSoc)->AllSoc ``` ```{r fig.width=11,fig.height=3} #first show distribution of risky decisions as kid ggplot(KidsSoc,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ coord_cartesian(ylim=c(0,400))+ scale_y_continuous(name="#")+ ggtitle("outcomes children\nsolo")+ guides(fill=F)+ theme_minimal(8)->One #then show distribution of risky decisions as adolescent ggplot(AdolescentsSoc,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ coord_cartesian(ylim=c(0,400))+ scale_y_continuous(name="")+ ggtitle("outcomes adolescents\nsolo")+ guides(fill=F)+ theme_minimal(8)->Two #then Adults distribution of risky decisions as adolescent ggplot(YoungAdultsSoc,aes(x=Outcome,y=howMany,fill=Outcome))+ geom_jitter(aes(group=iter,color=Outcome),alpha=0.3)+ stat_summary(aes(color=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_y_continuous(name="")+ coord_cartesian(ylim=c(0,400))+ guides(fill=F)+ ggtitle("outcomes adults\nsolo")+ theme_minimal(8)->Three #Now, look at the outcome ggplot(AllSoc[AllSoc\$Outcome=="Gain",],aes(x=Stage,y=howMuch,fill=Stage))+ geom_jitter(aes(group=iter,color=Stage),alpha=0.3)+ stat_summary(aes(color=Stage),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_y_continuous(name="Cumulative Loss")+ scale_x_discrete("Developmental Stage",breaks=c("1","2","3"),labels=Plot_labels)+ ggtitle("Severety of bad\noutcomes")+ scale_color_brewer(palette = "Set2")+ #coord_cartesian(ylim=c(-2000000,0))+ guides(fill=F)+ theme_minimal(8)->Four cowplot::plot_grid(One,Two,Three,NULL,Four,ncol=5,rel_widths = c(1,1,1,0.3,1.7))->Social ggsave(plot = Social,"../X_Figures/EmergentBehavior_summary_Social.png",width = 11,height = 4) #print(Social) ``` #make plot ```{r fig.width=9,fig.height=4} AllSoc%>%ggplot(aes(x=Stage,y=howMany,color=Outcome))+ geom_jitter(aes(group=iter,shape=Stage),alpha=0.2)+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5,position = position_dodge(0))+ scale_y_continuous(name="N outcomes")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ coord_cartesian(ylim=c(0,400))+ scale_shape_manual(name="",breaks=c("1","2","3"),labels=Plot_labels,values=c(24,22,21))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->SocialQual AllSoc%>%ggplot(aes(x=Stage,y=abs(howMuch),color=Outcome))+ geom_jitter(aes(group=iter,shape=Stage),alpha=0.2)+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5,position = position_dodge(0))+ #stat_summary(aes(group=Outcome,shape=Stage,fill=Outcome),geom="pointrange",color="black",fun.data = "mean_cl_boot",size=0.7)+ scale_y_continuous(name="Outcome magnitude")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ ggtitle("")+ scale_shape_manual(name="",breaks=c("1","2","3"),labels=Plot_labels,values=c(24,22,21))+ coord_cartesian(ylim=c(0,7000000))+ guides(fill=F,shape=F)+ theme_minimal(14)->SocialQuant ggplot(AllIndi,aes(x=Stage,y=abs(howMuch),color=Outcome))+ geom_jitter(aes(group=iter,shape=Stage),alpha=0.2)+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5,position = position_dodge(0))+ scale_y_continuous(name="Outcome magnitude")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ ggtitle("")+ scale_shape_manual(name="",breaks=c("1","2","3"),labels=Plot_labels,values=c(24,22,21))+ coord_cartesian(ylim=c(0,7000000))+ guides(fill=F,shape=F)+ theme_minimal(14)->IndiQuant AllIndi%>%ggplot(aes(x=Stage,y=howMany,color=Outcome))+ geom_jitter(aes(group=iter,shape=Stage),alpha=0.2)+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5,position = position_dodge(0))+ scale_y_continuous(name="N outcomes")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ scale_shape_manual(name="",breaks=c("1","2","3"),labels=Plot_labels,values=c(24,22,21))+ coord_cartesian(ylim=c(0,400))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->IndiQual leg<-get_legend(SocialQual) title1 <- ggdraw() +draw_label("Solo Outcomes",fontface = 'bold',x = 0,hjust = 0) + theme(plot.margin = margin(0, 0, 0, 0)) title2 <- ggdraw() +draw_label("Social Outcomes",fontface = 'bold',x = 0,hjust = 0) + theme(plot.margin = margin(0, 0, 0, 0)) cowplot::plot_grid(IndiQuant+guides(fill=F,color=F,shape=F),NULL,IndiQual+guides(fill=F,color=F,shape=F),leg,labels=c("A","","B",""),rel_widths = c(1,0.1,1,0.4),ncol = 4)->OutcomesSolo plot_grid(title1,OutcomesSolo,ncol = 1,rel_heights = c(0.2, 1)) ggsave(filename = "../X_Figures/OutcomesSolo3.png",width = 9.5,height = 5) cowplot::plot_grid(SocialQuant+guides(fill=F,color=F,shape=F),NULL,SocialQual+guides(fill=F,color=F,shape=F),leg,labels=c("A","","B",""),rel_widths = c(1,0.1,1,0.4),ncol = 4)->OutcomesSocial plot_grid(title2,OutcomesSocial,ncol = 1,rel_heights = c(0.2, 1)) ggsave(filename = "../X_Figures/OutcomesSocial3.png",width = 9.5,height = 5) ``` # Compare Solo and Social Returns ```{r fig.width=11,fig.height=6} cowplot::plot_grid(Solo,NULL,Social,nrow=3,rel_heights = c(1,0.2,1))->both ggsave(filename="../X_Figures/Solo_Social_Outcomes.png",plot = both, width = 11, height=6) print(both) ``` # Plot Returns differently hm not sure how nice his looks but it shows two things about adolescence well: 1) high variance and 2) the most severe losses are all "adolescents" ```{r fig.width=15} ggplot(AllSoc[AllSoc\$Outcome=="Loss",],aes(howMuch,fill=Stage))+ # geom_histogram()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ geom_density(alpha=0.8,color="#F8766D")+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ # scale_fill_discrete("Developmental Stage",)+ ggtitle("")+ theme_minimal(14)->LossesDitrsSoc ggplot(AllSoc[AllSoc\$Outcome=="Gain",],aes(howMuch,fill=Stage))+ # geom_histogram()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ geom_density(alpha=0.8,color="#00BFC4")+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ # scale_fill_discrete("Developmental Stage",)+ ggtitle("")+ theme_minimal(14)->GainsDistrSoc ggplot(AllIndi[AllIndi\$Outcome=="Loss",],aes(howMuch,fill=Stage))+ # geom_histogram()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ geom_density(alpha=0.8,color="#F8766D")+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ # scale_fill_discrete("Developmental Stage",)+ ggtitle("Distribution of Losses")+ theme_minimal(14)->LossesDitrsIndi ggplot(AllIndi[AllIndi\$Outcome=="Gain",],aes(howMuch,fill=Stage))+ # geom_histogram()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ geom_density(alpha=0.8,color="#00BFC4")+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ # scale_fill_discrete("Developmental Stage",)+ ggtitle("Distribution of Gains")+ theme_minimal(14)->GainsDistrIndi #leg<-get_legend(LossesDitrs) #cowplot::plot_grid(LossesDitrs+guides(fill=F),GainsDistr+guides(fill=F),leg,ncol = 3,rel_widths = 1,1,0.2) ``` ```{r fig.width=7} ggplot(AllSoc,aes(howMany,fill=Stage,color=Outcome))+ geom_histogram()+ #stat_summary()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ #geom_density(alpha=0.5)+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ scale_color_discrete("Outcome Type",)+ ggtitle("")+ theme_minimal(14)->socialhist ``` ```{r} ggplot(AllIndi,aes(howMany,fill=Stage,color=Outcome))+ geom_histogram()+ #geom_density(aes(group=interaction(Stage,iter),color=Stage))+ #geom_density(alpha=0.5)+ scale_fill_brewer(palette = "Greys",breaks=c("1","2","3"),labels=Plot_labels)+ scale_color_discrete("Outcome Type",)+ ggtitle("Outcomes")+ theme_minimal(14)->solohist ``` ### Alternative Panel Version Not sure what to think of this, it looks cool but maybe the panel above is easier to understand. So now the different rows in the panel correspond to individual (upper) and social (lower) simulations. The histogram is just a tally of how often the agent encountered a loss or a gain. One histogram correspons to the first three columns of the previous panel. The densities show the magnitude of the outcomes but also the spread. The previous panel only depicted losses, therefore there is more information here. ```{r fig.width=18, include=FALSE} #create common x and y labels library(grid) library(gridExtra) Solo.grob <- textGrob("Solo", gp=gpar(col="black", fontsize=25)) Social.grob <- textGrob("Social", gp=gpar(col="black", fontsize=25)) leg<-get_legend(solohist) soloNew<-cowplot::plot_grid(NULL,NULL,NULL, solohist+guides(color=F,fill=F), LossesDitrsIndi+guides(color=F,fill=F), GainsDistrIndi+guides(color=F,fill=F),nrow=2,ncol=3,rel_heights = c(0.02,1)) grid.arrange(arrangeGrob(soloNew, top = Solo.grob))->soloTitle socialsNew<-cowplot::plot_grid(NULL,NULL,NULL, socialhist+guides(color=F,fill=F), LossesDitrsSoc+guides(color=F,fill=F), GainsDistrSoc+guides(color=F,fill=F),nrow=2,ncol=3,rel_heights = c(0.005,1)) grid.arrange(arrangeGrob(socialsNew, top = Social.grob))->socialTitle cowplot::plot_grid(soloTitle,NULL,socialTitle,nrow=3,rel_heights = c(1,0.2,1))->NoLeg #ggsave(filename="../X_Figures/Solo_Social_OutcomesNew.png",plot = NoLeg, width = 11, height=6) #print(NoLeg) ``` ```{r fig.width=18} cowplot::plot_grid(NoLeg,NULL,leg,rel_widths = c(1.7,0.1,0.2),ncol=3) ``` ```{r} #this is why i love dplyr! #create count for each new decision. compute_sampling_strategySocial<-function(Plot_dat_social_All,subject){ library(dplyr) Plot_dat_social_All%>%filter(iter==subject)%>%group_by(x,y)%>%mutate(cumDens=cumsum(sample))%>%ungroup()%>% group_by(x,y, trials) %>% mutate(newC = ifelse(cumDens == 1 & lag(cumDens)==0, 1, 0))->newExpSoc# if i take the derivative of this this might be exaclty what wouter was intersted in. newExpSoc[is.na(newExpSoc\$newC),]\$newC=1# #now i have to "reset" so that each trial there can only be one new decision and because otherwise this will scale up the cumulative sum too much newExpSoc\$newExplore=0 newExpSoc\$generalExplore=0 for( i in 1:length(unique(newExpSoc\$trials))){ newExpSoc[newExpSoc\$trials==i,]\$newExplore=xor(newExpSoc[newExpSoc\$trials==i,]\$newC,newExpSoc[newExpSoc\$trials==i-1,]\$newC)# # newExp[newExp\$trials==i,]\$generalExplore=xor(newExp[newExp\$trials==i,]\$sample,newExp[newExp\$trials==i-1,]\$sample) } newExpSoc\$iter=subject return(newExpSoc) } #saveRDS(newExpSoc,"Derivatives_TrialWise_Social.rds") # to compute the derivative # # #saveRDS(newExp,"Derivatives_TrialWise.rds") # newExp_all_Social<-foreach(trials=1:ntrialss, .combine='rbind') %dopar%{ # compute_sampling_strategySocial(Plot_dat_social_All,trials) # } if(loadfromdisk==F){ newExp_all_Social_socialOutcomes<-foreach(subject=1:ntrialss, .combine='rbind',.verbose=T) %dopar%{ compute_sampling_strategySocial(Plot_dat_social_All,subject) } saveRDS(file="../A_GeneratedFiles/newExp_all_Social_socialOutcomes_2.rds",object = newExp_all_Social_socialOutcomes) }else{ newExp_all_Social_socialOutcomes<-readRDS(file="../A_GeneratedFiles/newExp_all_Social_socialOutcomes.rds") } ``` ```{r} # newExp%>%ungroup()%>% # mutate(newCum=cumsum(newExplore))%>% # group_by(trials)%>% # summarise(explore=max(newCum))%>%mutate( # explore2=explore-lag(explore,50) # )%>%mutate( # Stage=case_when( # (trials<401)~"Kids", # (trials>400&trials<800)~"Adolescents", # (trials>800)~"Adults" # ) # )%>%filter(trials<1200)%>% # ggplot(aes(x=trials,y=explore2))+ # # geom_point(size=2)+ # geom_rect(aes(xmin=0,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ # geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ # geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ # geom_spline(size=2,)+ # geom_vline(xintercept = 400, linetype="dotted",size=2)+ # geom_vline(xintercept = 800, linetype="dotted",size=2)+ # scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ # scale_y_continuous(name="Explorative Decisions")+ # scale_x_continuous(name="trials")+ # ggtitle("Exploration - Spline")+ # theme_minimal(14) # ggsave("../X_Figures/TimecourseExplore_Spline.png") newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>%#filter(trials>36 & (trials <401 | trials >508))%>% filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ #stat_summary(geom="line",fun.y = "mean",color="black")+ #geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_spline(size=1)+ geom_point(aes(shape=Stage),size=1,alpha=0.1)+ stat_summary(aes(shape=Stage),geom="point",fun.y = "mean",size=2.5,color="black",fill="white")+ scale_shape_manual(name="Developmental\nStage",values=c(22,21,24))+ geom_vline(xintercept = 420, linetype="dotted",color="red")+ geom_vline(xintercept = 410, linetype="dotted",color="red")+ geom_vline(xintercept = 800, linetype="dotted",color="red")+ geom_vline(xintercept = 790, linetype="dotted",color="red")+ annotate("text",x=150,y=60,label=c("Children"))+ annotate("text",x=600,y=60,label=c("Adolescents"))+ annotate("text",x=950,y=60,label=c("Adults"))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,60))+ scale_y_continuous(name="Exploration decisions")+ scale_x_continuous(name="trials")+ guides(linetype=F)+ theme_minimal(14)->ExploreSocPlot ggsave(plot=ExploreSocPlot,"../X_Figures/TimecourseExplore_Raw_Social.png",width = 7,height = 4) ``` # Number of explorative decisions In comparison to solo agents we can see that introducing social information and a social folloGaing rule, seems to lead to less exploration. # put stuff into the same graph Lets start with exploration. ```{r} #prepare data newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ), Which="Social" )%>%#filter(trials>36 & (trials <401 | trials >508))%>% filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))->Social_Exp newExp_all%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ), Which="Solo" )%>%#filter(trials>36 & (trials <401 | trials >508))%>% filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))->SoloExp library("wesanderson") rbind(SoloExp,Social_Exp)%>% ggplot(aes(x=trials,y=explore2,color=Which,linetype=Which))+ # stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ #stat_summary(geom="line",fun.y = "mean",color="black")+ geom_jitter(aes(shape=Which),size=2,alpha=.5)+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_spline(size=3)+ stat_summary(aes(shape=Which),geom="pointrange",fun.data="mean_cl_boot",color="black",fill="white",size=1)+ scale_shape_manual(name="",values=c(23,24))+ geom_vline(xintercept = 420, linetype="dotted",size=1)+ geom_vline(xintercept = 410, linetype="dotted",size=1)+ geom_vline(xintercept = 800, linetype="dotted",size=1)+ geom_vline(xintercept = 790, linetype="dotted",size=1)+ annotate("text",x=150,y=55,label=c("Children"),size=6)+ annotate("text",x=600,y=55,label=c("Adolescents"),size=6)+ annotate("text",x=950,y=55,label=c("Adults"),size=6)+ scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2],wes_palette("Darjeeling1")[3]))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,55),xlim=c(0,1150))+ scale_y_continuous(name="Exploration")+ scale_x_continuous(name="trials")+ guides(linetype=F)+ theme_minimal(16)->Social_Solo_ExplorePlot ``` # Now outcomes; Start with loss. ```{r,fig.width=10,fig.height=5} rbind(AllSoc%>%mutate(Which="Social"),AllIndi%>%mutate(Which="Solo"))%>%filter(Outcome=="Gain")%>% ggplot(aes(x=Stage,y=howMany,color=Which))+ geom_jitter(aes(group=Which),alpha=0.2,position = position_dodge(0.5))+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5)+ scale_y_continuous(name="")+ scale_x_discrete("",breaks=c("1","2","3"),labels=c("","",""))+ scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2],wes_palette("Darjeeling1")[3]))+ coord_cartesian(ylim=c(0,400))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->GainMany rbind(AllSoc%>%mutate(Which="Social"),AllIndi%>%mutate(Which="Solo"))%>%filter(Outcome=="Loss")%>% ggplot(aes(x=Stage,y=howMany,color=Which))+ geom_jitter(aes(group=Which),alpha=0.2,position = position_dodge(0.5))+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5)+ scale_y_continuous(name="N outcomes")+ scale_x_discrete("",breaks=c("1","2","3"),labels=c("","",""))+ scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2],wes_palette("Darjeeling1")[3]))+ coord_cartesian(ylim=c(0,400))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->LossMany rbind(AllSoc%>%mutate(Which="Social"),AllIndi%>%mutate(Which="Solo"))%>%filter(Outcome=="Loss")%>% ggplot(aes(x=Stage,y=abs(howMuch)/40000,color=Which))+ geom_jitter(aes(group=Which),alpha=0.2,position = position_dodge(0.5))+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5)+ scale_y_continuous(name="mean magnitude")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2],wes_palette("Darjeeling1")[3]))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->LossMuch rbind(AllSoc%>%mutate(Which="Social"),AllIndi%>%mutate(Which="Solo"))%>%filter(Outcome=="Gain")%>% ggplot(aes(x=Stage,y=abs(howMuch)/40000,color=Which))+ geom_jitter(aes(group=Which),alpha=0.2,position = position_dodge(0.5))+ #stat_summary(aes(fill=Outcome),geom="pointrange",fun.data = "mean_cl_boot",size=0.7,color="black")+ stat_smooth(aes(x=as.numeric(Stage)))+ geom_boxplot(width=0.5)+ scale_y_continuous(name="")+ scale_x_discrete("",breaks=c("1","2","3"),labels=Plot_labels)+ scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2],wes_palette("Darjeeling1")[3]))+ # coord_cartesian(ylim=c(0,400))+ guides(fill=F,shape=F)+ ggtitle("")+ theme_minimal(14)->GainMuch leg=get_legend(LossMany) one<-plot_grid(LossMany+guides(color=F),LossMuch+guides(color=F),nrow=2,labels=c("A","B")) two<-plot_grid(GainMany+guides(color=F),GainMuch+guides(color=F),nrow=2,labels=c("C","D")) together=plot_grid(one,NULL,two,leg,ncol=4,rel_widths = c(1,0.1,1,0.3)) ggsave(plot=together,filename = "All_Indices.png",width = 10,height = 5) ``` ```{r} # Area under the curve newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(newExplore))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"1", (trials>400&trials<800)~"2", (trials>800)~"3" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>%group_by(Stage,iter)%>% summarize(AUC=trapz(trials,explore2))%>% ggplot(aes(x=Stage,y=AUC))+ #geom_jitter(aes(group=iter,color=Stage),alpha=0.1)+ stat_summary(aes(x=Stage,y=AUC,fill=Stage),geom="bar",color="black",fun.y = "mean",stat="identity")+ stat_summary(aes(color=Stage),geom="pointrange",color="black",fun.data = "mean_cl_boot")+ scale_x_discrete(name="Developmental Stage",breaks=c(1,2,3),labels=c("Kids","Adolescents","Adults"))+ ggtitle("Exploration (AUC) - Social")+ scale_fill_brewer(palette = "Set2",breaks=c(1,2,3),labels=c("Kids","Adolescents","Adults"))+ scale_y_continuous(name=c("AUC Explore"),limits=c(0,ylimauc))+ theme_minimal(14)->AUCSocial ``` #Compare Solo & Social AUCs ```{r fig.width=10} leg<-get_legend(AUCSocial) cowplot::plot_grid(AUCSolo+guides(fill=F),AUCSocial+guides(fill=F)+theme(axis.title.y = element_text(color="white")),leg,ncol=3,rel_widths = c(1,1,0.2)) ``` #to be done. # 4 types of Social decisions. But The social dimension also allows for examining additional dimensions of behavior. Specifically a four fold pattern of exploration emerges in respect to social content. 1) Individuals could switch to a patch that is favoured by SI 2) Individuals could switch to a patch that is _not_ favoured by SI 3) Individuals could stay at a patch that has been favoured by SI 4) Individuals could stay at a patch that has been _not_ favoured by SI ```{r} compute_SocialOutcomes<-function(newExp_all_Social_socialOutcomes,subject){ #for( i in 1:length(unique(newExpSoc\$trials))){ #If you explored a new option that was sampled my more than 0 others before. library(dplyr) newExpSoc<-newExp_all_Social_socialOutcomes%>%filter(iter==subject) newExpSoc\$GoToOthers=0 newExpSoc\$GoToNoone=0 newExpSoc\$StayWithOthers=0 newExpSoc\$StayWithNoone=0 for (i in 2:length(unique(newExpSoc\$trials))){ newExpSoc[newExpSoc\$trials==i,]\$GoToOthers=as.numeric(newExpSoc[newExpSoc\$trials==i,]\$newExplore & (newExpSoc[newExpSoc\$trials==i-1,]\$Others!=0))# #If you explored a new option that was sampled my 0 others before. newExpSoc[newExpSoc\$trials==i,]\$GoToNoone=as.numeric(newExpSoc[newExpSoc\$trials==i,]\$newExplore & (newExpSoc[newExpSoc\$trials==i-1,]\$Others==0))# # newExp[newExp\$trials==i,]\$generalExplore=xor(newExp[newExp\$trials==i,]\$sample,newExp[newExp\$trials==i-1,]\$sample) # If you sample an option, where others have been and still are and you dont explore again. newExpSoc[newExpSoc\$trials==i,]\$StayWithOthers=as.numeric(newExpSoc[newExpSoc\$trials==i,]\$sample & (newExpSoc[newExpSoc\$trials==i-1,]\$Others!=0) & (newExpSoc[newExpSoc\$trials==i,]\$Others!=0) & (newExpSoc[newExpSoc\$trials==i,]\$newExplore==0))# # If you sample an option, where no others have been and still none are and you dont explore again. newExpSoc[newExpSoc\$trials==i,]\$StayWithNoone=as.numeric(newExpSoc[newExpSoc\$trials==i,]\$sample & (newExpSoc[newExpSoc\$trials==i-1,]\$Others==0) & (newExpSoc[newExpSoc\$trials==i,]\$Others==0) & (newExpSoc[newExpSoc\$trials==i,]\$newExplore==0)) } return (newExpSoc) } # # # } if(loadfromdisk==F){ newExp_all_Social_socialOutcomes<-foreach(subject=1:ntrialss, .combine='rbind') %dopar%{ compute_SocialOutcomes(newExp_all_Social_socialOutcomes,subject) } saveRDS(file="../A_GeneratedFiles/newExp_all_Social_socialOutcomes.rds",object = newExp_all_Social_socialOutcomes) }else{ #probably dont need ot do anything newExp_all_Social_socialOutcomes<-readRDS(file="../A_GeneratedFiles/newExp_all_Social_socialOutcomes.rds") } ``` ```{r} newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(GoToNoone))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ stat_summary(geom="line",fun.y = "mean",color="black")+ #geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ #geom_spline(size=1)+ geom_point(aes(shape=Stage),size=1,alpha=0.1)+ stat_summary(aes(shape=Stage),geom="point",fun.y = "mean",size=2.5,color="black",fill="white")+ scale_shape_manual(name="Developmental Stage",values=c(22,21,24))+ geom_vline(xintercept = 420, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 410, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 800, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 790, linetype="dotted",color="royalblue")+ annotate("text",x=150,y=60,label=c("Children"))+ annotate("text",x=600,y=60,label=c("Adolescents"))+ annotate("text",x=950,y=60,label=c("Adults"))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,60))+ scale_fill_brewer(name="Developmental\nStage",labels=c("Childhood","Adolescence","Adulthood"),palette = "Reds")+ scale_y_continuous(name="Decisions")+ scale_x_continuous(name="trials")+ ggtitle("Switch Where Noone Is")+ theme_minimal(14) #ggsave("../X_Figures/TimecourseExplore_Raw_Social_Gotonoone.png") ``` ```{r} newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(GoToOthers))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>% filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ # stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ #stat_summary(geom="line",fun.y = "mean",color="black")+ #geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_jitter(size=2,alpha=.5,shape=21,color=wes_palette("Darjeeling1")[5])+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_spline(size=3,color=wes_palette("Darjeeling1")[5])+ stat_summary(geom="pointrange",fun.data="mean_cl_boot",fill="white",size=1,shape=21,color="black")+ geom_vline(xintercept = 420, linetype="dotted",color="black",size=1)+ geom_vline(xintercept = 410, linetype="dotted",color="black",size=1)+ geom_vline(xintercept = 800, linetype="dotted",color="black",size=1)+ geom_vline(xintercept = 790, linetype="dotted",color="black",size=1)+ guides(shape=F)+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,55),xlim=c(0,1150))+ #ggtitle("Following Others")+ scale_y_continuous(name="Following others")+ scale_x_continuous(name="timepoint")+ theme_minimal(16)->following ggsave(filename = "../X_Figures/SwitchWhereOthersAre.png") ``` ```{r fig.width=12,fig.height=6} legsocialnonsocial<-get_legend(Social_Solo_ExplorePlot) explore_social_plot=plot_grid(Social_Solo_ExplorePlot+scale_x_continuous(name="")+guides(color=F,shape=F),legsocialnonsocial, following,NULL,rel_widths = c(1,0.2),labels=c("A","","B","")) ggsave(explore_social_plot,filename = "SocialSolo_Explore_Follow.png",dpi = 320,width = 12,height = 6) explore_social_plot ``` ```{r} newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(StayWithOthers))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ stat_summary(geom="line",fun.y = "mean",color="black")+ #geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ #geom_spline(size=1)+ geom_point(aes(shape=Stage),size=1,alpha=0.1)+ stat_summary(aes(shape=Stage),geom="point",fun.y = "mean",size=2.5,color="black",fill="white")+ scale_shape_manual(name="Developmental Stage",values=c(22,21,24))+ geom_vline(xintercept = 420, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 410, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 800, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 790, linetype="dotted",color="royalblue")+ annotate("text",x=150,y=60,label=c("Children"))+ annotate("text",x=600,y=60,label=c("Adolescents"))+ annotate("text",x=950,y=60,label=c("Adults"))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,60))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Children","Adolescents","Adults"),palette = "Reds")+ scale_y_continuous(name="Decisions")+ scale_x_continuous(name="trials")+ ggtitle("Stay With Others")+ theme_minimal(14) ``` ```{r} newExp_all_Social_socialOutcomes%>%group_by(iter)%>% mutate(newCum=cumsum(StayWithNoone))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ stat_summary(geom="line",fun.y = "mean",color="black")+ #geom_jitter()+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ #geom_spline(size=1)+ geom_point(aes(shape=Stage),size=1,alpha=0.1)+ stat_summary(aes(shape=Stage),geom="point",fun.y = "mean",size=2.5,color="black",fill="white")+ scale_shape_manual(name="Developmental Stage",values=c(22,21,24))+ geom_vline(xintercept = 420, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 410, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 800, linetype="dotted",color="royalblue")+ geom_vline(xintercept = 790, linetype="dotted",color="royalblue")+ annotate("text",x=150,y=60,label=c("Children"))+ annotate("text",x=600,y=60,label=c("Adolescents"))+ annotate("text",x=950,y=60,label=c("Adults"))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,60))+ scale_fill_brewer(name="Developmental Stage",labels=c("Children","Adolescents","Adults"),palette = "Reds")+ scale_y_continuous(name="Decisions")+ scale_x_continuous(name="trials")+ ggtitle("Stay With Noone")+ theme_minimal(14) ``` # Arbitrary choice Exploration ```{r} Plot_datAll%>% mutate(Criterion=case_when((sample==1 & sig>38)~1,TRUE~0) )%>%mutate(newCum=cumsum(Criterion))%>% ungroup()%>%group_by(trials,iter)%>% summarise(explore=max(newCum))%>% ungroup()%>% arrange(iter)%>% #ungroup()%>%#### looks about right but doublecheck. mutate( explore2=explore-lag(explore,50) )%>%mutate( Stage=case_when( (trials<401)~"Children", (trials>400&trials<800)~"Adolescents", (trials>800)~"Adults" ) )%>%filter(!is.na(Stage) & trials %in% round(seq(50,1200,length.out = 24)))%>% ggplot(aes(x=trials,y=explore2))+ # stat_summary(geom="ribbon", fun.data="mean_sdl",alpha=0.2)+ #stat_summary(geom="line",fun.y = "mean",color="black")+ geom_jitter(size=2,alpha=.5,color=wes_palette("Darjeeling1")[1])+ #geom_rect(aes(xmin=50,xmax=400,ymin=-5,ymax=100,fill="1"),alpha=0.1)+ #geom_rect(aes(xmin=400,xmax=800,ymin=-5,ymax=100,fill="2"),alpha=0.1)+ #geom_rect(aes(xmin=801,xmax=1200,ymin=-5,ymax=100,fill="3"),alpha=0.1)+ geom_spline(size=3)+ stat_summary(geom="pointrange",fun.data="mean_cl_boot",color="black",fill="white",size=1,shape=23)+ #scale_shape_manual(name="",values=c(23,24))+ geom_vline(xintercept = 420, linetype="dotted",size=1)+ geom_vline(xintercept = 410, linetype="dotted",size=1)+ geom_vline(xintercept = 800, linetype="dotted",size=1)+ geom_vline(xintercept = 790, linetype="dotted",size=1)+ annotate("text",x=150,y=55,label=c("Children"),size=6)+ annotate("text",x=600,y=55,label=c("Adolescents"),size=6)+ annotate("text",x=950,y=55,label=c("Adults"),size=6)+ # scale_color_manual(name="",values=c(wes_palette("Darjeeling1")[2]))+ #scale_fill_brewer(name="Developmental Stage",labels=c("Kids","Adolescents","Adults"),palette = "YlGnBu")+ coord_cartesian(ylim=c(0,55),xlim=c(0,1150))+ scale_y_continuous(name="Exploration")+ scale_x_continuous(name="trials")+ guides(linetype=F)+ theme_minimal(16)+ ggtitle("Sample Where Agents is Uncertain")+ theme_minimal(14) %>% ggplot(aes(x=trials,y=sig,color=iter))+ geom_point() #stat_summary() ```