### This code contains functions for estimating a mixture IRT model with a 5-category generalized partial credit model in one class and an IRTree model 
### (with a 2-parameter logistic model in the first node (middle category chosen or not) and a 4-category generalized partial credit model in the second node)
### in the second class. The algorithm makes use of functions written in C. The C-code can be found in the supplementary file 'mixture.c'. The C-code needs
### to be compiled to obtain a .dll file before it can be used. To compile the code the following steps should be taken:
###
### 1. Add R bin folder to PATH
### 2. Install R-tools. 
### 3. Add "c:\Rtools\bin;c:\Rtools\gcc-4.6.3\bin;" to PATH 
### 4. Copy the file mixture.c to the R-bin directory (for example C:\R\R-3.3.2\bin\x64) and ensure that writing permission is enabled for that folder
### 5. In Windows command line go to the R-bin directory (e.g., cd C:\R\R-3.3.2\bin\x64) 
### 6. In Windows command line type in: R CMD SHLIB mixture.c
### 7. Paste the produced file mixture.dll to your R working directory together with 'mixture.c'.
###
### The code below includes a general function GibbsMixture with the full algorithm which in addition to .C routines makes use of some auxillary functions
### for sampling from each of the conditional posterior distributions. These functions are included in this file after the main function.
### Below the auxillary functions are Gibbs samplers for estimating the two nonmixture models.
### Finally, two functions are included for generating data under the mixture model.



# Loading the C code and some R packages  
dyn.load('mixture.dll')
library(MASS)



#### The Gibbs sampler for estimating the mixture model ##########################

GibbsMixture=function(X,nS,a,iter,burnin,nCh,save.chains=TRUE){
# X - data matrix, values 0,1,2,3,4 , missing data should be coded as NA     
# nS - number of dimensions of primary interest (D in the manuscript), 
# a - vector specifying item dimension memberships (d in the manuscript), 
# iter - number of iterations, burnin - number of iterations in the burnin period, nCh - number of chains
# save.chains - whether not only the estimates of the parameters, but also all the sampled values should be saved; if save.chains==FALSE then $chains in the output will be an empty list

X=as.matrix(X)
		
N=nrow(X) 
n=ncol(X) # N - sample size; n - number of items (K in the manuscript)

					
# The code is suitable for incomplete design. List 'persons' for each item gives the set of persons who answered to it. 

persons=list()
for(i in 1:n){
	persons[[i]]=c(1:N)[is.na(X[,i])==F]
}
	
# Re-structuring the data to match the IRTree model's 1st and 2nd node (this is done for all persons, since it is not known who belongs to the IRTree)
X_IRTree_1node=1*(X==2)
X_IRTree_2node=X
X_IRTree_2node[X==2]=NA
X_IRTree_2node=X_IRTree_2node*(X_IRTree_2node<2)+(X_IRTree_2node-1)*(X_IRTree_2node>1)

Est=list() # for parameter estimates; each element represents a chain
chains=list() # for the sampled values of the parameters; each element represents a chain. If save.chains==FALSE, it will be empty

for(Ch in 1:nCh){   # loop over the chains
					
	# Starting values (item parameters are always the same, person parameters are sampled randomly)
	alpha=matrix(rep(1,3*n),ncol=3)      # item slopes                   
	d=cbind(rep(1.5,n),rep(0.5,n),rep(-0.5,n),rep(-1.5,n))  # (threshold x slope)s in gPCM-5
	b=cbind(rep(1,n),rep(0,n),rep(-1,n),rep(-1,n))	# intercept in the 2PL, (threshold x slope)s in gPCM-4

	Z=rbinom(N,1,0.5) # random person memberships, 50%/50% a priori

	pers.par=mvrnorm(N,rep(0,nS+1),matrix(c(rep(c(1,rep(0,nS+1)),nS),1),ncol=nS+1))					      # theta0 and theta
	tau=pers.par[,1] # theta0
	theta=matrix(pers.par[,-1],ncol=nS)
	
	S=matrix(c(rep(c(1,rep(0,nS+1)),nS),1),ncol=nS+1)   # Starting values of the person covariance matrix (Identity matrix)
	
	sZ = 0.5 # probability of belonging to the gPCM5 class (pi in the manuscript)
	
	# objects to store the output
	ZZ=array(numeric(N*(iter-burnin)),dim=c(N,iter-burnin))                                                        
	D=array(numeric(n*4*(iter-burnin)),dim=c(n,4,iter-burnin))
	B=D
	A=array(numeric(n*3*(iter-burnin)),dim=c(n,3,iter-burnin))
	Tau=ZZ
	Theta=array(numeric(N*nS*(iter-burnin)),dim=c(N,nS,iter-burnin))
	Rho=array(numeric((nS+1)*(nS)/2*(iter-burnin)),dim=c((nS+1)*nS/2, iter-burnin)) # this is for all the correlations between the dimensions (1 if nS=1, or 3 if nS=2)
	LL=NULL; # log-likelohood. It will be used to select the best chain.
	        
	# objects for tuning the Metropolis proposal. se_b,se_d,se_a are the SDs for the Metropolis proposal. During burnin they are fixed to .1, .1, and .05; and after that they are chosen based on the SD in the chain in the burnin period
	se_d=matrix(rep(0.1,n*4),ncol=4)
	se_b=matrix(rep(0.1,n*4),ncol=4)
	se_a=matrix(rep(0.05,n*3),ncol=3)
					
	D_burnin=array(numeric(n*4*burnin),dim=c(n,4,burnin))
	B_burnin=D_burnin
	A_burnin=array(numeric(n*3*burnin),dim=c(n,3,burnin))
	
	# extra objects needed in the sampling for the .C functions (some operations are more difficult in .C, so they are done in R and objects are passed to .C)
	P=numeric(5) # just an empty vector of length 5
	# these are for the specifying the mean and variance of conditional normal distribution. ss is a vector which would be multiplied with the vector (theta-m) to obtain the conditional mean, SD is a conditional standard deviation. 
	ss=NULL
	SD=numeric(nS+1)
	for(j in 1:(nS+1)){
		ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
		SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])    # See formulas for conditional mean and variance in Appendix
	}				
					


		
	# loop over the iterations
	for(it in 1:iter){
		       
		        
	         
		ll=0
		# if both models have at least 2 persons assigned to them:
		if(sum(Z)<(N-1)){
			if(sum(Z)>1){
							
				# these are frequencies of response categories per item among the persons from 5PCM
				Item_scores=apply(X[Z==1,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3),sum(X[is.na(X)==F]==4))}) 
										
				Item_score1=colSums(X_IRTree_1node[Z==0,],na.rm=TRUE) ##  frequencies of score 2  per item among the persons from IRTree
			
				Item_scores2=apply(X_IRTree_2node[Z==0,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3))}) # these are frequencies of the 4 response categories in the 2nd node of the IRTree
	
				Persons2=list() # persons who are in the 2nd node of the IRTree
				for(i in 1:n){
					Persons2[[i]]=c(1:N)[Z==0][X[Z==0,i]!=2]
				}

				Persons1=list() # person without a missing response in the IRTree (no missings in simulation but relevant for real data)
				for(i in 1:n){
					Persons1[[i]]=intersect(persons[[i]],c(1:N)[Z==0])
				}

	
				d=t(mapply(delta=as.data.frame(t(d)),alpha=alpha[,1],Item_scores=as.data.frame(Item_scores),P=persons,a=a,se=as.data.frame(t(se_d)),FUN=function(delta,Item_scores,P,a,alpha,se)
				{
					MH.delta.GPCM(Item_scores,alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
				})) ## sampling the item location parameters of the gPCM5
	
				b[,1:3]=t(mapply(P=Persons2,b=as.data.frame(t(b[,1:3])),alpha=alpha[,3],Score=as.data.frame(Item_scores2),a=a,se=as.data.frame(t(se_b[,1:3])),FUN=function(P,b,Score,a,alpha,se)
			      {
					MH.delta.GPCM(Score,alpha,b,theta[P,a],se)
				}))# sample item parameters in the 4 category gPCM (the second node of the IRTtree)
										
				b[,4]=mapply(X=b[,4],alpha=alpha[,2],Score=Item_score1,P=persons,se=se_b[,4],FUN=function(X,Score,P,alpha,se)
				{
					MH.beta_2PL(Score,tau[intersect((c(1:N)[Z==0]),P)],alpha,X,se)
				}) # sample item intercepts in the 2PL		
	
				alpha[,1]=mapply(alpha=alpha[,1],a=a,delta=as.data.frame(t(d)),X=as.data.frame((X)),P=persons,se=se_a[,1],FUN=function(se,alpha,a,delta,X,P)
				{
					sample_a_PCM5(X[intersect((c(1:N)[Z==1]),P)],alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
				}) # sample item slopes in the gPCM5
			
			
				alpha[,2]=mapply(alpha=alpha[,2],beta=b[,4],P=persons,X=as.data.frame((X_IRTree_1node)),se=se_a[,2],FUN=function(alpha,beta,P,X,se)
				{
					sample_a_2PL(X[intersect((c(1:N)[Z==0]),P)],alpha,beta,tau[intersect((c(1:N)[Z==0]),P)],se)
				}) # item slopes in the 2PL
			
				alpha[,3]=mapply(alpha=alpha[,3],a=a,delta=as.data.frame(t(b[,1:3])),P=Persons2,X=as.data.frame(X_IRTree_2node),se=se_a[,3],FUN=function(alpha,a,delta,X,P,se)
				{
					sample_a_PCM4(X[P],alpha,delta,theta[P,a],se)	
				}) # item slopes in the gPCM4
	
				# sample the probability of belonging to the gPCM5
				sZ=rbeta(1,1+sum(Z),1+(N-sum(Z)))
	
				# sampling person parameters in .C: theta, tau and Z are sampled
 				tmp<-.C('mixture',as.integer(c(X)),as.integer(Z),as.double(c(theta)),as.double(tau),as.double(c(d)),as.double(c(b)),as.double(c(alpha)),as.integer(a),as.double(ss),as.double(SD),as.integer(n),as.integer(N),as.integer(nS),as.double(P),as.double(sZ),as.double(ll))	
	
				theta=matrix(tmp[[3]],ncol=nS)
				tau=tmp[[4]]
	                    ll=tmp[[16]]
				
				if(it>200){ # only after the first 200 iterations do we start sampling person memberships
					Z=tmp[[2]]
				}
								
				if(it<(burnin+1)){
					D_burnin[,,it]=d
					B_burnin[,,it]=b
					A_burnin[,,it]=log(a)
				}
				if(it==burnin){
					se_d=apply(D_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
					se_b=apply(B_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
					se_a=apply(A_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
				}


				# First, sample the covariance matrix for the person distribution. Second, fix the diagonal of the covariance matrix to 1.
				S=sample_S(cbind(theta,tau))	
				mu=rep(0,nS+1)
										
				for(j in 1:nS){
					theta[,j]=(theta[,j])/sqrt(S[j,j])
					alpha[a==j,1]=alpha[a==j,1]*sqrt(S[j,j])
					alpha[a==j,3]=alpha[a==j,3]*sqrt(S[j,j])
				}
				tau=(tau)/sqrt(S[nS+1,nS+1])
				alpha[,2]=alpha[,2]*sqrt(S[nS+1,nS+1])
				sdd=NULL
				for(j in 1:(nS+1)){sdd[j]=sqrt(S[j,j])}
				for(j in 1:(nS+1)){
					S[j,]=S[j,]/sdd[j]
					S[,j]=S[,j]/sdd[j]
				}
				# re-computing the values for ss and SD which are needed in the .C functions
				ss=NULL
				SD=numeric(nS+1)
				for(j in 1:(nS+1)){
					ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
					SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])
				}
			}
		}
# if one of the classes becomes empty, parameters that are unique to it are no longer sampled.

		if(sum(Z)<2){	
              		Z=rep(0,N) # second class is empty
             	     						
				Item_score1=colSums(X_IRTree_1node[Z==0,],na.rm=TRUE) ##  frequencies of score 2  per item among the persons from IRTree
			
				Item_scores2=apply(X_IRTree_2node[Z==0,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3))}) # these are frequencies of the 4 response categories in the 2nd node of the IRTree
	
				Persons2=list() # persons who are in the 2nd node of the IRTree
				for(i in 1:n){
					Persons2[[i]]=c(1:N)[Z==0][X[Z==0,i]!=2]
				}

				Persons1=list() # person without a missing response in the IRTree (no missings in simulation but relevant for real data)
				for(i in 1:n){
					Persons1[[i]]=intersect(persons[[i]],c(1:N)[Z==0])
				}

	
				b[,1:3]=t(mapply(P=Persons2,b=as.data.frame(t(b[,1:3])),alpha=alpha[,3],Score=as.data.frame(Item_scores2),a=a,se=as.data.frame(t(se_b[,1:3])),FUN=function(P,b,Score,a,alpha,se)
			      {
					MH.delta.GPCM(Score,alpha,b,theta[P,a],se)
				}))# sample item parameters in the 4 category gPCM (the second node of the IRTtree)
										
				b[,4]=mapply(X=b[,4],alpha=alpha[,2],Score=Item_score1,P=persons,se=se_b[,4],FUN=function(X,Score,P,alpha,se)
				{
					MH.beta_2PL(Score,tau[intersect((c(1:N)[Z==0]),P)],alpha,X,se)
				}) # sample item intercepts in the 2PL		
				
				alpha[,2]=mapply(alpha=alpha[,2],beta=b[,4],P=persons,X=as.data.frame((X_IRTree_1node)),se=se_a[,2],FUN=function(alpha,beta,P,X,se)
				{
					sample_a_2PL(X[intersect((c(1:N)[Z==0]),P)],alpha,beta,tau[intersect((c(1:N)[Z==0]),P)],se)
				}) # item slopes in the 2PL
			
				alpha[,3]=mapply(alpha=alpha[,3],a=a,delta=as.data.frame(t(b[,1:3])),P=Persons2,X=as.data.frame(X_IRTree_2node),se=se_a[,3],FUN=function(alpha,a,delta,X,P,se)
				{
					sample_a_PCM4(X[P],alpha,delta,theta[P,a],se)	
				}) # item slopes in the gPCM4
	
				# in .C persons parameters (theta, tau and Z are sampled)			
 				tmp<-.C('mixture',as.integer(c(X)),as.integer(Z),as.double(c(theta)),as.double(tau),as.double(c(d)),as.double(c(b)),as.double(c(alpha)),as.integer(a),as.double(ss),as.double(SD),as.integer(n),as.integer(N),as.integer(nS),as.double(P),as.double(sZ),as.double(ll))	
	
				theta=matrix(tmp[[3]],ncol=nS)
				tau=tmp[[4]]
	                  ll=tmp[[16]]
								
				if(it<(burnin+1)){
					B_burnin[,,it]=b
					A_burnin[,,it]=log(a)
				}
				if(it==burnin){
					se_b=apply(B_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
					se_a=apply(A_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
				}						

				# First, sample the covariance matrix for the person distribution. Second, fix the diagonal of the covariance matrix to 1.
				S=sample_S(cbind(theta,tau))	
				mu=rep(0,nS+1)
										
				for(j in 1:nS){
					theta[,j]=(theta[,j])/sqrt(S[j,j])
					alpha[a==j,3]=alpha[a==j,3]*sqrt(S[j,j])
				}
				tau=(tau)/sqrt(S[nS+1,nS+1])
				alpha[,2]=alpha[,2]*sqrt(S[nS+1,nS+1])
				sdd=NULL
				for(j in 1:(nS+1)){sdd[j]=sqrt(S[j,j])}
				for(j in 1:(nS+1)){
					S[j,]=S[j,]/sdd[j]
					S[,j]=S[,j]/sdd[j]
				}
				# re-computing the values for ss and SD, which are needed in the .C functions
				ss=NULL
				SD=numeric(nS+1)
				for(j in 1:(nS+1)){
					ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
					SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])
				}
		}
		if(sum(Z)>(N-2)){
		      Z=rep(1,N) # first class is empty
						        
            S[1:nS,nS+1]=rep(0,nS)
						        
			# these are frequencies of response categories per item among the persons from the gPCM-5
		      Item_scores=apply(X[Z==1,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3),sum(X[is.na(X)==F]==4))}) 
										
			d=t(mapply(delta=as.data.frame(t(d)),alpha=alpha[,1],Item_scores=as.data.frame(Item_scores),P=persons,a=a,se=as.data.frame(t(se_d)),FUN=function(delta,Item_scores,P,a,alpha,se)
			{
				MH.delta.GPCM(Item_scores,alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
			})) ## sampling the item location parameters of the gPCM-5
	
			alpha[,1]=mapply(alpha=alpha[,1],a=a,delta=as.data.frame(t(d)),X=as.data.frame((X)),P=persons,se=se_a[,1],FUN=function(se,alpha,a,delta,X,P)
			{
				sample_a_PCM5(X[intersect((c(1:N)[Z==1]),P)],alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
			}) # sample item slopes in the gPCM-5
			
            out=0 # '1' for if the function is used outside of the mixture model, and '0' for if the function is used inside of the mixture model
							
			# sample persons parameters in .C (theta, tau and Z are sampled)			
 			tmp<-.C('gpcm',as.integer(c(X)),as.double(c(theta)),as.double(c(d)),as.double(alpha[,1]),as.integer(a),as.double(ss),as.double(SD),as.integer(n),as.integer(N),as.integer(nS),as.double(P),as.double(ll),as.integer(out))
	
			theta=matrix(tmp[[2]],ncol=nS)
								
	            ll=tmp[[12]]
								
                  if(it<(burnin+1)){
				D_burnin[,,it]=d
				B_burnin[,,it]=b
				A_burnin[,,it]=log(a)
			}
			if(it==burnin){
				se_d=apply(D_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
				se_b=apply(B_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
				se_a=apply(A_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
			}

	

			# First, sample the covariance matrix for the person distribution. Second, fix the diagonal of S to 1.
			S=sample_S(cbind(theta,tau))	
			mu=rep(0,nS+1)
										
			for(j in 1:nS){
				theta[,j]=(theta[,j])/sqrt(S[j,j])
				alpha[a==j,1]=alpha[a==j,1]*sqrt(S[j,j])
				alpha[a==j,3]=alpha[a==j,3]*sqrt(S[j,j])
			}
			tau=(tau)/sqrt(S[nS+1,nS+1])
			alpha[,2]=alpha[,2]*sqrt(S[nS+1,nS+1])
			sdd=NULL
			for(j in 1:(nS+1)){
				sdd[j]=sqrt(S[j,j])
			}
			for(j in 1:(nS+1)){
				S[j,]=S[j,]/sdd[j]
				S[,j]=S[,j]/sdd[j]
			}
										
			# re-computing the values for ss and SD, which are needed in the .C functions
			ss=NULL
			SD=numeric(nS+1)
			for(j in 1:(nS+1)){
				ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
				SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])
			}
            }
														
		## saving the chains
		if(it>burnin){
			ZZ[,(it-burnin)]=Z
			Theta[,,(it-burnin)]=theta
			Tau[,(it-burnin)]=tau
			D[,,(it-burnin)]=d
			B[,,(it-burnin)]=b
			A[,,(it-burnin)]=alpha
			rhos=NULL
			for(j in 1:(nS)){
				for(i in (j+1):(nS+1)){
					rhos=c(rhos,S[j,i])
				}
			}
			Rho[,(it-burnin)]=rhos
			LL=c(LL,ll)
		}
	}
					
	QUIT=FALSE ### Has the sampling switched to just gPCM-5 because the IRTree did not have any persons?
      if(sum(Z)>(N-2)){
           QUIT=TRUE
      }
      est=list(LL=mean(LL),Q=QUIT,Z=rowMeans(ZZ),theta=apply(Theta,c(1,2),mean),tau=apply(Tau,1,mean),alpha=apply(A,c(1,2),mean),d=apply(D,c(1,2),mean),b=apply(B,c(1,2),mean),rho=rowMeans(Rho))
      Est[[Ch]]=est
      if(save.chains==TRUE){
          chains[[Ch]]=list(ZZ=ZZ,Theta=Theta,Tau=Tau,D=D,B=B,A=A,Rho=Rho,LL=LL)
      }
}
    
    L=sapply(Est,FUN=function(X){X$LL})
    h=c(1:nCh)[L==max(L)] # Selecting the best chain
    
    est=Est[[h]]
    
    t=est$theta
    tau=est$tau
    Z=(est$Z>0.5)
    alpha=est$alpha
    d=est$d
    b=est$b
    
    LL=0
    for(j in 1:N){
        for(i in 1:n){
            if(Z[j]==1){
                Q1=log(1+exp(alpha[i]*t[j,a[i]]+d[i,1])+exp(2*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2])+exp(3*alpha[i]*t[j,a[i]]+d[i,1]+d[i,3]+d[i,2])+exp(4*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]+d[i,4]));
                if(X[j,i]==0){LL=LL-Q1;}
                if(X[j,i]==1){LL=LL+((alpha[i])*t[j,a[i]]+d[i,1]-Q1);}
                if(X[j,i]==2){LL=LL+(2*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]-Q1);}
                if(X[j,i]==3){LL=LL+(3*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]-Q1);}
                if(X[j,i]==4){LL=LL+(4*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]+d[i,4]-Q1);}
            }
            if(Z[j]==0){
                Q2=log(1+exp(alpha[i,2]*tau[j]+b[i,4]));
                Q3=log(1+exp(alpha[i,3]*t[j,a[i]]+b[i,1])+exp(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2])+exp(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]));
                if(X[j,i]==0){LL=LL-Q2-Q3;}
                if(X[j,i]==1){LL=LL+((alpha[i,3])*t[j,a[i]]+b[i,1]-Q2-Q3);}
                if(X[j,i]==2){LL=LL+(alpha[i,2]*tau[j]+b[i,4]-Q2);}
                if(X[j,i]==3){LL=LL+(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]-Q2-Q3);}
                if(X[j,i]==4){LL=LL+(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]-Q2-Q3);}
            }
        }
    }
    
    D_bar=-2*est$LL
    
    pD=-2*est$L-(-2*LL)
    
    DIC= -2*est$L-(-2*LL)+(-2*est$L)
    
    dic=c(D_bar,pD,DIC)
    
    output=list(chains=chains,Est=Est,dic=dic)
    
    return(output)
}




#### Auxillary sampling functions ################################################################

# Random-walk Metropolis-Hastings for the intercept in 2PL. Prior N(0,10)
MH.beta_2PL=function(Score,th,alpha,beta,se){ 
	b=rnorm(1,beta,se)# proposal - normal with the current value as the mean (b is candidate value, beta is old value)
	if(log(runif(1,0,1))<(dnorm(b,0,sqrt(10),log=TRUE)-dnorm(beta,0,sqrt(10),log=TRUE)+Score*(b-beta)-sum(log(1+exp(alpha*th+b)))+sum(log(1+exp(alpha*th+beta))))){beta=b}
	return(beta)
}

# Random-walk Metropolis-Hastings for the slope in gPCM5. Prior - log-normal with mean 0 and SD=2
sample_a_PCM5=function(X,alpha,delta,theta,se){ 
	a=rlnorm(1,log(alpha),se)
	L=(a-alpha)*sum(theta*X)-sum(log(1+exp(a*theta+delta[1])+exp(2*a*theta+delta[1]+delta[2])+exp(3*a*theta+delta[1]+delta[2]+delta[3])+exp(4*a*theta+sum(delta))))+ sum(log(1+exp(alpha*theta+delta[1])+exp(2*alpha*theta+delta[1]+delta[2])+exp(3*alpha*theta+delta[1]+delta[2]+delta[3])+exp(4*alpha*theta+sum(delta))))
	L=L+(log(alpha))^2/8-(log(a))^2/8 ## log-normal prior
	u=runif(1,0,1)
	alpha=ifelse((log(u)<L),a,alpha)
	return(alpha)
}

# sampling the slope parameter in the gPCM-4. M.-H. with a log-normal centered around the log of the current value with a specified SD equal to se as a proposal.   Prior log-normal (0,2)
sample_a_PCM4=function(X,alpha,delta,theta,se){
	a=rlnorm(1,log(alpha),se)
	L=(a-alpha)*sum(theta*X)-sum(log(1+exp(a*theta+delta[1])+exp(2*a*theta+delta[1]+delta[2])+exp(3*a*theta+delta[1]+delta[2]+delta[3])))+ sum(log(1+exp(alpha*theta+delta[1])+exp(2*alpha*theta+delta[1]+delta[2])+exp(3*alpha*theta+delta[1]+delta[2]+delta[3])))
	L=L+(log(alpha))^2/8-(log(a))^2/8
	u=runif(1,0,1)
	alpha=ifelse((log(u)<L),a,alpha)
	return(alpha)
}

# sampling the slope paramter in the 2PL. M.-H. with a log-normal centered around the log of the current value with a specified SD equal to se as a proposal.  Prior log-normal (0,2)
sample_a_2PL=function(X,alpha,delta,theta,se){
	a=rlnorm(1,log(alpha),se)
	L=(a-alpha)*sum(theta*X)-sum(log(1+exp(a*theta+delta)))+ sum(log(1+exp(alpha*theta+delta)))
	L=L+(log(alpha))^2/8-(log(a))^2/8
	u=runif(1,0,1)
	alpha=ifelse((log(u)<L),a,alpha)
	return(alpha)
}

## sampling location parameters in both gPCMs. 
## Function for sampling parameters of 1 item at a time. 
## Random-walk Metropolis-Hastings with a normal distribution (mean - current value) as a proposal 
## Prior N(0,10) for all 
## Each parameter is sampled separately. A vector of standard deviations (se) of the proposal distribution should be in the input. 
## The same function is used for the item intercepts in gPCM4 and gPCM5
MH.delta.GPCM=function(Item_scores,alpha,delta,theta,se){ 
	k=length(delta);
  d=delta
  if(k==4){m=c(-1.5,-0.5,0.5,1.5)}
  if(k==3){m=c(-1.5,0,1.5)}
	for(i in 1:k){
		d[i]=rnorm(1,delta[i],se[i])
			p=matrix(ncol=k+1,nrow=length(theta))
			p[,1]=rep(1,length(theta))
			for(j in 1:k){
				p[,j+1]=p[,j]*exp(alpha*theta+delta[j])
			}
			P1=sum(log(rowSums(p)))
			p=matrix(ncol=k+1,nrow=length(theta))
			p[,1]=rep(1,length(theta))
			for(j in 1:k){
				p[,j+1]=p[,j]*exp(alpha*theta+d[j])
			}
			P2=sum(log(rowSums(p)))
			if((log(runif(1,0,1)))<(dnorm(d[i],0,sqrt(10)*alpha,log=TRUE)-dnorm(delta[i],0,sqrt(10)*alpha,log=TRUE)+sum((rev(-delta+d))*(cumsum(rev(Item_scores))[-(k+1)]))-P2+P1)){delta=d}
	}
	return(delta)
}

# Sampling the mean vector of the person parameters. Prior - MVN(means=0,vars=100,cors=0); posterior is also multivariate normal
sample_mu=function(x,s){
	nS=ncol(x)
	m0=rep(0,nS)    # prior mean vector
	s0=matrix(c(rep(c(100,rep(0,nS)),nS-1),100),nS,nS)      # prior covariance matrix
	m=mvrnorm(1,solve(solve(s0)+nrow(x)*solve(s))%*%(solve(s0)%*%m0+nrow(x)*solve(s)%*%colMeans(x)),solve(solve(s0)+nrow(x)*solve(s)))
	return(m)
}
	
# Function to sample covariance matrix of person parameters (which have a multivariate normal distribution with a zero mean vector)
sample_S=function (theta) #  Input: theta - matrix with the current values of person parameters. Inverse-Wishart prior.
 {
     nS = ncol(theta)
     mu=rep(0,nS)
     nP = nrow(theta)
     mu = matrix(mu, ncol = 1, nrow = nS)
     S = matrix(rep(0, nS^2), ncol = nS, nrow = nS)
     for (i in 1:nP) {
         x = matrix(theta[i, ], ncol = 1, nrow = nS)
         x = x - mu
         S = S + x %*% t(x)
     }
     s = matrix(c(rep(c(1, rep(0, nS)), (nS - 1)), 1), nS, nS)
     S = S + s
     S = solve(S)
     Z = mvrnorm(n = (nP + nS + 2), mu = c(rep(0, nS)), Sigma = S) ### sampling from the inverse-Wishart (see Gelman et al. 1995)
     T = matrix(rep(0, nS^2), nS, nS)
     for (i in 1:(nP + nS + 2)) {
         z = matrix(Z[i, ], ncol = 1, nrow = nS)
         T = T + z %*% t(z)
     }
     T = solve(T)
     return(T)
 }	




### Gibbs sampler for the nonmixture gPCM-5 ######################################################

gpcm=function(X,a,iter,burnin){
    
    X=as.matrix(X)
    
    n=ncol(X)
    N=nrow(X)
    nS=max(a)
    
    # The code is suitable for incomplete design. List 'persons' for each item gives the set of persons who answered to it.
    
    persons=list()
    for(i in 1:n){
        persons[[i]]=c(1:N)[is.na(X[,i])==F]
    }
    
    # Starting values (item parameters fixed, person parameters random)
    alpha=matrix(rep(1,3*n),ncol=3)
    d=cbind(rep(1.5,n),rep(0.5,n),rep(-0.5,n),rep(-1.5,n))
    
    Z=rep(1,N) # all person in gpcm
    
    if(nS>1){theta=mvrnorm(N,rep(0,nS),diag(nS))}
    if(nS==1){
        theta=matrix(rnorm(N),ncol=1)
    }
   
   if(nS>1){
    S=diag(nS)  # Starting values of person covariance matrix (Identity matrix) if nS>1
   }
   
   if(nS==1){S=1} # starting value for the variance
   
    # objects to store the output
    
    D=array(numeric(n*4*(iter-burnin)),dim=c(n,4,iter-burnin))
    A=array(numeric(n*3*(iter-burnin)),dim=c(n,3,iter-burnin))
    Theta=array(numeric(N*nS*(iter-burnin)),dim=c(N,nS,iter-burnin))
    Rho=array(numeric((nS-1)*(nS)/2*(iter-burnin)),dim=c((nS-1)*nS/2, iter-burnin)) # this is for all the correlations between the dimensions (1 if nS=1, or 3 if nS=2)
    L=NULL; # log-likelohood.
    
    # objects for tuning the Metropolis proposal. se_b,se_d,se_a are the SDs for the Metropolis proposal. During burnin they are fixed to .1, .1, and .05; and after that they are chosen based on the SD in the chain in the burnin period
    se_d=matrix(rep(0.1,n*4),ncol=4)
    
    se_a=matrix(rep(0.05,n*3),ncol=3)
    
    D_burnin=array(numeric(n*4*burnin),dim=c(n,4,burnin))
    
    A_burnin=array(numeric(n*3*burnin),dim=c(n,3,burnin))
    
    # extra objects needed in the sampling for the .C functions
    P=numeric(5) # just an empty vector of length 5
    
    # Objects for the conditional multivariate normal. ss is a vector which would be multiplied with the vector (theta-m) to obtain the conditional mean, SD is a conditional standard deviation.
    if(nS>1){
        ss=NULL
        SD=numeric(nS)
        for(j in 1:(nS)){
            ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
            SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])    # See formulas for conditional mean and variance in Appendix
        }
    }
    if(nS==1){ss=0;SD=1}
    
    Item_scores=apply(X[Z==1,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3),sum(X[is.na(X)==F]==4))})
    
    for(it in 1:iter){
        ll=0
        
        
        d=t(mapply(delta=as.data.frame(t(d)),alpha=alpha[,1],Item_scores=as.data.frame(Item_scores),P=persons,a=a,se=as.data.frame(t(se_d)),FUN=function(delta,Item_scores,P,a,alpha,se)
        {
            MH.delta.GPCM(Item_scores,alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
        })) ## sampling the item location parameters of the gPCM
        
        
        
        alpha[,1]=mapply(alpha=alpha[,1],a=a,delta=as.data.frame(t(d)),X=as.data.frame((X)),P=persons,se=se_a[,1],FUN=function(se,alpha,a,delta,X,P)
        {
            sample_a_PCM5(X[intersect((c(1:N)[Z==1]),P)],alpha,delta,theta[intersect((c(1:N)[Z==1]),P),a],se)
        }) # sample item slopes in the gPCM5
        
        out=1

        LL=0
        
        tmp<-.C("gpcm",as.integer(X),as.double(theta),as.double(d),as.double(alpha),as.integer(a),as.double(ss),as.double(SD),as.integer(n),as.integer(N),as.integer(nS),as.double(P),as.double(LL),as.integer(out))
        
        
        theta=matrix(tmp[[2]],ncol=nS)
        
        LL=tmp[[12]]
        
        
        
        if(it<(burnin+1)){
            D_burnin[,,it]=d
            A_burnin[,,it]=log(a)
        }
        if(it==burnin){
            se_d=apply(D_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
            se_a=apply(A_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
        }
        
        
        #First, sample the covariance matrix for the person distribution and the mean vector. Second, fix the mean vector to 0, and the disgonal of S to 1.
        if(nS>1){
            S=sample_S(theta)
            mu=rep(0,nS)
        
            for(j in 1:nS){
                theta[,j]=(theta[,j]-mu[j])/sqrt(S[j,j])
                d[a==j,]=t(mapply(d=as.data.frame(t(d[a==j,])),alpha=alpha[a==j,1],FUN=function(d,alpha){d+mu[j]*alpha}))
                alpha[a==j,1]=alpha[a==j,1]*sqrt(S[j,j])
            }
            
            sdd=NULL
            for(j in 1:(nS)){sdd[j]=sqrt(S[j,j])}
            for(j in 1:(nS)){
                S[j,]=S[j,]/sdd[j]
                S[,j]=S[,j]/sdd[j]
            }
            # re-computing the values for ss and SD with are needed in the .C functions
            ss=NULL
            SD=numeric(nS)
            for(j in 1:(nS)){
                ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
                SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])
            }
        }
        
        if(nS==1){
            S=sd(theta[,1])
            theta[,1]=theta[,1]/S
            alpha[,1]=alpha[,1]*S
        }
        
        ## saving the chains
        if(it>burnin){
            Theta[,,(it-burnin)]=theta
            D[,,(it-burnin)]=d
            A[,,(it-burnin)]=alpha
            if(nS>1){Rho=c(Rho,S[1,2])}
            L=c(L,LL)
        }
    }
    
    
    t=apply(Theta,c(1,2),mean)
    alpha=apply(A,c(1,2),mean)
    d=apply(D,c(1,2),mean)
    est_gPCM=list(LL=mean(L),d=d,alpha=alpha,theta=t)
    chains=list(L,Rho,Theta,D,A)
    LL_bar=mean(L)
    # Computing D_hat
    LL=0
    for(j in 1:N){
        for(i in 1:n){
            Q1=log(1+exp(alpha[i]*t[j,a[i]]+d[i,1])+exp(2*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2])+exp(3*alpha[i]*t[j,a[i]]+d[i,1]+d[i,3]+d[i,2])+exp(4*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]+d[i,4]));
            if(X[j,i]==0){LL=LL-Q1;}
            if(X[j,i]==1){LL=LL+((alpha[i])*t[j,a[i]]+d[i,1]-Q1);}
            if(X[j,i]==2){LL=LL+(2*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]-Q1);}
            if(X[j,i]==3){LL=LL+(3*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]-Q1);}
            if(X[j,i]==4){LL=LL+(4*alpha[i]*t[j,a[i]]+d[i,1]+d[i,2]+d[i,3]+d[i,4]-Q1);}
        }
    }
    LL_hat=LL
    
    res_gPCM=c(LL_hat,LL_bar)
    
    D_bar_gPCM=-2*LL_bar
    
    pD_gPCM=-2*LL_bar-(-2*LL_hat)
    
    
    DIC_gPCM= -2*LL_bar-(-2*LL_hat)+(-2*LL_bar)
    
    res=list(
    est=est_gPCM,
    chains=chains,
    dic=c(D_bar_gPCM,pD_gPCM, DIC_gPCM)
    )
    
    return(res)
}





#### Gibbs sampler for the non-mixture IRTree model ################################

IRTree=function(X,a,iter,burnin){
    
    n=ncol(X)
    N=nrow(X)
    nS=max(a)
    
    X=as.matrix(X)
    
    # The code is already suitable for incomplete design. List 'persons' for each item give the set of persons who answered to it. (Only useful for real data)
    persons=list()
    for(i in 1:n){
        persons[[i]]=c(1:N)[is.na(X[,i])==F]
    }
    
    # Re-structuring the data to match the IRTree model's 1st and 2nd node
    X_IRTree_1node=1*(X==2)
    X_IRTree_2node=X
    X_IRTree_2node[X==2]=NA
    X_IRTree_2node=X_IRTree_2node*(X_IRTree_2node<2)+(X_IRTree_2node-1)*(X_IRTree_2node>1)
    
    # Starting values (item parameters fixed, person parameters random)
    alpha=matrix(rep(1,3*n),ncol=3)
    b=cbind(rep(1,n),rep(0,n),rep(-1,n),rep(-1,n))
    Z=rep(0,N) # all persons in the IRTree
    
    pers.par=mvrnorm(N,rep(0,nS+1),matrix(c(rep(c(1,rep(0,nS+1)),nS),1),ncol=nS+1))
    tau=pers.par[,1]
    theta=matrix(pers.par[,-1],ncol=nS)
    
    S=matrix(c(rep(c(1,rep(0,nS+1)),nS),1),ncol=nS+1)   # Starting values of the person covariance matrix (Identity matrix)
    
    # objects to store the output
    Tau=array(numeric(N*(iter-burnin)),dim=c(N,iter-burnin))
    B=array(numeric(n*4*(iter-burnin)),dim=c(n,4,iter-burnin))
    A=array(numeric(n*3*(iter-burnin)),dim=c(n,3,iter-burnin))
    Theta=array(numeric(N*nS*(iter-burnin)),dim=c(N,nS,iter-burnin))
    Rho=array(numeric((nS+1)*(nS)/2*(iter-burnin)),dim=c((nS+1)*nS/2, iter-burnin)) # this is for all the correlations between the dimensions (1 if nS=1, or 3 if nS=2)
    L=NULL;
    
    # objects for tuning the Metropolis proposal. se_b,se_d,se_a are the SDs for the Metropolis proposal. During burnin they are fixed to .1, .1, and .05; and after that they are chosen based on the SD in the chain in the burnin period
    se_b=matrix(rep(0.1,n*4),ncol=4)
    se_a=matrix(rep(0.05,n*3),ncol=3)
    
    B_burnin=array(numeric(n*4*burnin),dim=c(n,4,burnin))
    A_burnin=array(numeric(n*3*burnin),dim=c(n,3,burnin))
    
    # extra objects needed in the sampling for the .C functions (some operations are more difficult in .C, so I do them in R and give ready objects to .C)
    P=numeric(5) # just an empty vector of length 5
    # these are for the conditional multivariate normal. ss is a vector which will be multiplied with the vector (theta-m) to obtain the conditional mean, SD is a conditional standard deviation.
    ss=NULL
    SD=numeric(nS+1)
    for(j in 1:(nS+1)){
        ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
        SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])    # See formulas for conditional mean and variance in Appendix
    }
    
    
    
    for(it in 1:iter){
        ll=0
        # if both models have at least 2 persons assigned to them:
        
        Item_score1=colSums(X_IRTree_1node[Z==0,],na.rm=TRUE) ##  frequencies of score 2  per item among the persons from IRTree
        
        Item_scores2=apply(X_IRTree_2node[Z==0,],2,FUN=function(X){c(sum(X[is.na(X)==F]==0),sum(X[is.na(X)==F]==1),sum(X[is.na(X)==F]==2),sum(X[is.na(X)==F]==3))})
        # these are frequencies of the 4 response categories in the 2nd node of the IRTree
        
        Persons2=list() # persons who are in the 2nd node of the IRTree
        for(i in 1:n){
            Persons2[[i]]=c(1:N)[Z==0][X[Z==0,i]!=2]
        }
        
        Persons1=list() # persons without a missing response in the IRTree (no missings in simulation but relevant for real data)
        for(i in 1:n){
            Persons1[[i]]=intersect(persons[[i]],c(1:N)[Z==0])
        }
        
        
        b[,1:3]=t(mapply(P=Persons2,b=as.data.frame(t(b[,1:3])),alpha=alpha[,3],Score=as.data.frame(Item_scores2),a=a,se=as.data.frame(t(se_b[,1:3])),FUN=function(P,b,Score,a,alpha,se)
        {
            MH.delta.GPCM(Score,alpha,b,theta[P,a],se)
            
        }))# sample item parameters in the 4 category gPCM (the second node of the IRTtree)
        
        b[,4]=mapply(X=b[,4],alpha=alpha[,2],Score=Item_score1,P=persons,se=se_b[,4],FUN=function(X,Score,P,alpha,se)
        {
            MH.beta_2PL(Score,tau[intersect((c(1:N)[Z==0]),P)],alpha,X,se)
        }) # sample item intercepts in the 2PL
        
        
        alpha[,2]=mapply(alpha=alpha[,2],beta=b[,4],P=persons,X=as.data.frame((X_IRTree_1node)),se=se_a[,2],FUN=function(alpha,beta,P,X,se)
        {
            sample_a_2PL(X[intersect((c(1:N)[Z==0]),P)],alpha,beta,tau[intersect((c(1:N)[Z==0]),P)],se)
        }) # item slopes in the 2PL
        
        alpha[,3]=mapply(alpha=alpha[,3],a=a,delta=as.data.frame(t(b[,1:3])),P=Persons2,X=as.data.frame(X_IRTree_2node),se=se_a[,3],FUN=function(alpha,a,delta,X,P,se)
        {
            sample_a_PCM4(X[P],alpha,delta,theta[P,a],se)
        }) # item slopes in the gPCM4
        
        # sample the probability of belonging to the gPCM5
        sZ=0.5
        
        
        
        # sample person parameters in .C (theta, tau and Z are sampled)
        d=rep(0,n*4)
        tmp<-.C('mixture',as.integer(c(X)),as.integer(Z),as.double(c(theta)),as.double(tau),as.double(c(d)),as.double(c(b)),as.double(c(alpha)),as.integer(a),
        as.double(ss),as.double(SD),as.integer(n),as.integer(N),as.integer(nS),as.double(P),as.double(sZ),as.double(ll))
        
        theta=matrix(tmp[[3]],ncol=nS)
        tau=tmp[[4]]
        
        if(it>burnin){ # after the burnin compute the log-likelihood
            LL=0
            t=theta
            for(j in 1:N){
                for(i in 1:n){
                    Q2=log(1+exp(alpha[i,2]*tau[j]+b[i,4]));
                    Q3=log(1+exp(alpha[i,3]*t[j,a[i]]+b[i,1])+exp(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2])+exp(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]));
                    if(X[j,i]==0){LL=LL-Q2-Q3;}
                    if(X[j,i]==1){LL=LL+((alpha[i,3])*t[j,a[i]]+b[i,1]-Q2-Q3);}
                    if(X[j,i]==2){LL=LL+(alpha[i,2]*tau[j]+b[i,4]-Q2);}
                    if(X[j,i]==3){LL=LL+(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]-Q2-Q3);}
                    if(X[j,i]==4){LL=LL+(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]-Q2-Q3);}
                }
            }
        }
        
        
        
        if(it<(burnin+1)){
            B_burnin[,,it]=b
            A_burnin[,,it]=log(a)
        }
        if(it==burnin){
            se_b=apply(B_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
            se_a=apply(A_burnin[,,(round(burnin/2):burnin)],c(1,2),sd)*3
        }
        
        
        # First, sample the covariance matrix for the person distribution and the mean vector. Second, fix the mean vector to 0, and the diagonal of S to 1.
        S=sample_S(cbind(theta,tau))
        mu=c(0,0,0)
        
        for(j in 1:nS){
            theta[,j]=(theta[,j]-mu[j])/sqrt(S[j,j])
            b[a==j,1:3]=t(mapply(d=as.data.frame(t(b[a==j,1:3])),alpha=alpha[a==j,3],FUN=function(d,alpha){d+mu[j]*alpha}))
            alpha[a==j,3]=alpha[a==j,3]*sqrt(S[j,j])
        }
        tau=(tau-mu[nS+1])/sqrt(S[nS+1,nS+1])
        b[,4]=b[,4]+mu[nS+1]*alpha[,2]
        alpha[,2]=alpha[,2]*sqrt(S[nS+1,nS+1])
        sdd=NULL
        for(j in 1:(nS+1)){sdd[j]=sqrt(S[j,j])}
        for(j in 1:(nS+1)){
            S[j,]=S[j,]/sdd[j]
            S[,j]=S[,j]/sdd[j]
        }
        # re-computing the values for ss and SD, which are needed in the .C functions
        ss=NULL
        SD=numeric(nS+1)
        for(j in 1:(nS+1)){
            ss=c(ss,S[j,-j]%*%solve(S[-j,-j]))
            SD[j]=sqrt(S[j,j]-S[j,-j]%*%solve(S[-j,-j])%*%S[-j,j])
        }
        
        ## saving the chains
        if(it>burnin){
            Theta[,,(it-burnin)]=theta
            Tau[,(it-burnin)]=tau
            B[,,(it-burnin)]=b
            A[,,(it-burnin)]=alpha
            rhos=NULL
            for(j in 1:(nS)){
                for(i in (j+1):(nS+1)){
                    rhos=c(rhos,S[j,i])
                }
            }
            Rho[,(it-burnin)]=rhos
            L=c(L,LL)
        }
    }
    
    t=apply(Theta,c(1,2),mean)
    tau=apply(Tau,1,mean)
    alpha=apply(A,c(1,2),mean)
    b=apply(B,c(1,2),mean)
    est_IRTree=list(LL=mean(L),b=b,alpha=alpha,theta=t,tau=tau)
    chains=list(L,Rho,Theta,Tau,B,A)
    LL_bar=mean(L)
    LL=0
    for(j in 1:N){
        for(i in 1:n){
            Q2=log(1+exp(alpha[i,2]*tau[j]+b[i,4]));
            Q3=log(1+exp(alpha[i,3]*t[j,a[i]]+b[i,1])+exp(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2])+exp(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]));
            if(X[j,i]==0){LL=LL-Q2-Q3;}
            if(X[j,i]==1){LL=LL+((alpha[i,3])*t[j,a[i]]+b[i,1]-Q2-Q3);}
            if(X[j,i]==2){LL=LL+(alpha[i,2]*tau[j]+b[i,4]-Q2);}
            if(X[j,i]==3){LL=LL+(2*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]-Q2-Q3);}
            if(X[j,i]==4){LL=LL+(3*alpha[i,3]*t[j,a[i]]+b[i,1]+b[i,2]+b[i,3]-Q2-Q3);}
        }
    }
    LL_hat=LL
    
    res_IRTree=c(LL_hat,LL_bar)
    
    D_bar_IRTree=-2*LL_bar
    
    pD_IRTree=-2*LL_bar-(-2*LL_hat)
    
    
    DIC_IRTree= -2*LL_bar-(-2*LL_hat)+(-2*LL_bar)
    
    res=list(est=est_IRTree,chains=chains,dic=c(D_bar_IRTree,pD_IRTree,DIC_IRTree))
    
    return(res)
}



#### Functions for generating data under the mixture model ##################################

generate.true.values=function(n,N,nS){
  
  #### generating item parameters (see simulation design description in paper)
  alpha=matrix(ncol=3,nrow=n)
  alpha[,2]=rlnorm(n,-0.5,0.5) # discriminations in the first node of the IRTree. The scale is not very 'strong', so mean(log(slope))=-.5
  alpha[,c(1,3)]=exp(mvrnorm(n,c(0,0),matrix(c(0.5^2,0.5^3,0.5^3,0.5^2),ncol=2)))
  # slopes in the gPCM-5 and gPCM-4, their logs have a correlation of 0.5 (in line with what we observed in real data sets) and standard deviations of .5. The mean of log(slopes)=1
  
  ## First, threshold parameters in the outside formulation alpha(t-delta) are generated, and later multiplied with alphas to get the intercept parameters, which are used throughout the code
  average_location=rnorm(n,0,1) ## this average of the threshold parameters per item is equal for gPCM-4 (2nd node IRTree) and gPCM-5
  ## the locations of the categories are equidistant around the average, but the parameters in the gPCM-5 are more spread (in line with what we observed in real data sets)
  delta=cbind(average_location+1.5,average_location+0.5,average_location-0.5,average_location-1.5)### gPCM-5, fixed distances between thresholds
  beta=cbind(average_location+1.5,average_location,average_location-1.5)### gPCM-4, fixed distances between thresholds
  
  b=matrix(ncol=4,nrow=n) # Will contains intercepts for gPCM4 and 2PL
  d=matrix(ncol=4,nrow=n) # Will contains intercepts for gPCM5
  
  b[,4]=rnorm(n,-2,0.5)*alpha[,2] # item intercepts in the 2PL (1st node IRTree)
  b[,1:3]=t(mapply(d=as.data.frame(t(beta)),a=alpha[,3],FUN=function(d,a){d*a})) # item intercepts in the 2nd node IRTree (gPCM4)
  d=t(mapply(d=as.data.frame(t(delta)),a=alpha[,1],FUN=function(d,a){d*a})) # item intercepts in the gPCM5
  
  # generating person parameters
  theta=NULL; # substantive latent variable, possibly multidimensional
  for(k in 1:nS){theta=cbind(theta,rnorm(N))}
  theta=matrix(theta,ncol=nS) # theta needs to be a matrix even if it has only 1 column
  tau=rnorm(N) # extra dimension in the IRTree (theta0 in the manuscript)
  
  true.values=list(theta=theta,tau=tau,d=d,b=b,alpha=alpha)
  
  return(true.values)
}

generate.data.mixture=function(n,N,nS,true.values,prop){
  
  # item memberships (important only for nS=2, 1 - dimension 1, 2 - dimension 2)
  if(nS==1){a=rep(1,n)}# all items are from the same dimension
  if(nS==2){a=c(rep(1,n/2),rep(2,n/2))} # First half are in scale 1, second in scale 2
  
  theta=true.values$theta
  tau=true.values$tau
  d=true.values$d
  b=true.values$b
  alpha=true.values$alpha
  
  ### generating IRTree data for the persons [1:(N*prop)]
  X0=NULL
  if(prop!=0){
    for(j in 1:n){
      y=rbinom(N*prop,1,1/(1+exp(-alpha[j,2]*tau[1:(N*prop)]-b[j,4]))) # 1st node
      
      p=cbind(rep(1,N*prop),exp(alpha[j,3]*theta[1:(N*prop),a[j]]+b[j,1]),exp(2*alpha[j,3]*theta[1:(N*prop),a[j]]+b[j,1]+b[j,2]),exp(3*alpha[j,3]*theta[1:(N*prop),a[j]]+b[j,1]+b[j,2]+b[j,3])) # p = numerators of probabilities for the 2nd node (gPCM4)
      z=apply(p,1,FUN=function(X){r=c(rmultinom(1,1,X)); return(1*(r[2]==1)+3*(r[3]==1)+4*(r[4]==1))}) # data in the 2nd node (only used if y=0, i.e. not missing), already coded as 0,1,3,4 instead of 0,1,2,3
      
      X0=cbind(X0,y*2+(1-y)*z) # combining 1st node with the 2nd node, the 2nd node plays a role only if there is 0 in the 1st node
    }
  }
  
  ### generating gPCM-5 data for the persons [(N*prop+1):N]
  X1=NULL
  if(prop!=1){
    for(j in 1:n){
      p=cbind(rep(1,N*(1-prop)),exp(alpha[j,1]*theta[(N*prop+1):(N),a[j]]+d[j,1]),exp(2*alpha[j,1]*theta[(N*prop+1):N,a[j]]+d[j,1]+d[j,2]),exp(3*alpha[j,1]*theta[(N*prop+1):N,a[j]]+d[j,1]+d[j,2]+d[j,3]),exp(4*alpha[j,1]*theta[(N*prop+1):N,a[j]]+d[j,1]+d[j,2]+d[j,3]+d[j,4]))
      z=apply(p,1,FUN=function(X){r=c(rmultinom(1,1,X)); return(1*(r[2]==1)+2*(r[3]==1)+3*(r[4]==1)+4*(r[5]==1))})
      X1=cbind(X1,z)
    }
  }
  
  X=rbind(X0,X1)
  
  return(X)
}