#source("C:/Local Storage/Papers/michael/QforRR/LOR_moments_final.txt")



# This file is used in the R-file "F:QforLOR.r".
# The main function Qfor_LOR calculates Cochran's Q for the log odds ratio = LOR, in meta analysis.
# The proposed P-value by, gamma approx, is found by the approximation formula for E(Q) and Var(Q)
# defined by Kulinskaya&Dollinger(2015)
# There is also a program for calculation of the Breslow-Day test, 
# and the standard Q test (using inverse variances)

Qfor_LOR<-function(n.t,n.c,x.t,x.c,a=0,data = NULL, subset= NULL, na.action = na.fail){
xT<-xC<-nT<-nC<-Q<-EhatQ<-E2hatQ<-par<-numeric(0)
add<-0.5
K<-length(x.t)
par<-paras_QLOR(x.t,n.t,x.c,n.c,a=a)
pare<-numeric(0)
m<-matrix(par,nrow=5)
Deltah<-m[1,]
LOR<-round(Deltah,3)
wh<-m[5,]
w_pct<-round(wh/sum(wh)*100,1)
zetah<-m[2,]
q<-m[3,]
N<-m[4,]
Q<-Q_LOR(par)[1]
Deltabar<-Q_LOR(par)[2]

###### RESTRICTIONS ON pT0, pC0


wtm<-((2+2*cosh(b*Deltabar+zetah))/(n.t+1)+(2+2*cosh(zetah-a*Deltabar))/(n.c+1))^(-1)
pT0<-1/(1+exp(-b*Deltabar-zetah))
pC0<-1/(1+exp(a*Deltabar-zetah))

for (k in 1:K)
pare<-c(pare,Deltabar,zetah[k],q[k],N[k],wtm[k]) #estimated null parametrs
cmo<-cmomLOR(n.t,n.c,pT0,pC0,a)
EhatQ<-EQ(pare,cmo,n.t,n.c,a=a)
E2hatQ<-EQ2(pare,cmo,n.t,n.c,a=a)
VARhatQ<-E2hatQ-EhatQ^2
beta.est<-VARhatQ/EhatQ
alfa.est<-EhatQ/beta.est
{if (VARhatQ>0) gam.pvalue.est<-1-pgamma(Q,alfa.est,scale=beta.est)
     else gam.pvalue.est<-(-1)}
chi.pvalue.est<-1-pchisq(Q,(K-1))
Results<-c(Deltabar,Q,EhatQ,E2hatQ,chi.pvalue.est,gam.pvalue.est)
Results<-round(Results,3)
Results<-c(Results,LOR,w_pct)
return(Results)
}


paras_QLOR <- function(x1, n1, x2, n2, add=.5, only0=FALSE,a=0) {
	# returns the estimated values of the parameters
   	# a is the weight of log-odds in zeta (0 by default):
  	# a*ln(p1/1-p1)+(1-a)*l n(p2/1-p2)
	# add=.5 by default. It is the value we add to estimate p=(x+add)/(n+2*add)
	# only0=TRUE by default. We only use add when the variance is zero.
	# When only0=FALSE we always use add.
	
parm <- numeric(0)
K <- length(n1)
Delta<-zeta<-w<-N<-q<-p1<-p2<- numeric(K)
if (only0==TRUE) {
   for (k in 1:K) {
	if ( (x1[k]==0)|(x2[k]==0) | (x1[k]==n1[k])|(x2[k]==n2[k]))
	   {p1[k] <- (x1[k]+add)/(n1[k]+2*add)
	    p2[k] <- (x2[k]+add)/(n2[k]+2*add) }
	else
	   {p1[k] <- x1[k]/n1[k]
	   p2[k] <- x2[k]/n2[k]   }
   }  }
else {
	p1 <- (x1+add)/(n1+2*add)
	p2 <- (x2+add)/(n2+2*add)
}
Delta <- log(p1/(1-p1))-log(p2/(1-p2))
   N <- n1+n2
   q <- n2/N
   zeta <- a*log(p1/(1-p1))+(1-a)*log(p2/(1-p2))
#   zeta <- log(p2/(1-p2))
   w<-(1/((n1+1)*p1*(1-p1))+  1/((n2+1)*p2*(1-p2)))^(-1) #####
                                                          
######## standard weights should have n1 not n1+1, n2 not n2+1. ########## !!!!!

   for (k in 1:K) {parm <- c(parm, Delta[k], zeta[k],q[k], N[k],w[k])}
return(parm)
}

paras_QLOR_std <- function(x1, n1, x2, n2, add=.5, only0=FALSE,a=0) {
	# returns the estimated values of the parameters
        # only used in calculation of standard Q statistic
        # added 5/09/2014
   	# a is the weight of log-odds in zeta (0 by default):
  	# a*ln(p1/1-p1)+(1-a)*l n(p2/1-p2)
	# add=.5 by default. It is the value we add to estimate p=(x+add)/(n+2*add)
	# only0=TRUE by default. We only use add when the variance is zero.
	# When only0=FALSE we always use add.
	
parm <- numeric(0)
K <- length(n1)
Delta<-zeta<-w<-N<-q<-p1<-p2<- numeric(K)
if (only0==TRUE) {
   for (k in 1:K) {
	if ( (x1[k]==0)|(x2[k]==0) | (x1[k]==n1[k])|(x2[k]==n2[k]))
	   {p1[k] <- (x1[k]+add)/(n1[k]+2*add)
	    p2[k] <- (x2[k]+add)/(n2[k]+2*add) }
	else
	   {p1[k] <- x1[k]/n1[k]
	   p2[k] <- x2[k]/n2[k]   }
   }  }
else {
	p1 <- (x1+add)/(n1+2*add)
	p2 <- (x2+add)/(n2+2*add)
}
Delta <- log(p1/(1-p1))-log(p2/(1-p2))
   N <- n1+n2
   q <- n2/N
   zeta <- a*log(p1/(1-p1))+(1-a)*log(p2/(1-p2))
#   zeta <- log(p2/(1-p2))
   w<-(1/((n1)*p1*(1-p1))+  1/((n2)*p2*(1-p2)))^(-1) #####
                                                          
######## standard weights  have n1 not n1+1, n2 not n2+1. ########## !!!!!

   for (k in 1:K) {parm <- c(parm, Delta[k], zeta[k],q[k], N[k],w[k])}
return(parm)
}
Q_LOR<-function(parm){
	# Calculates Q and combined LOR
m<-matrix(parm,nrow=5)
Delta<-m[1,]
w<-m[5,]
W<-sum(w)
Deltabar<-sum(w*Delta)/W
Q<-sum(w*(Delta-Deltabar)^2)
Q_Deltabar<-c(Q,Deltabar)
return(Q_Deltabar)
}


momLogit<-function(n,p){
	# calculates 6 central moments of logit L_(x,n) for add=1/2
#in binomial distribution
mom<-numeric(0)
K<-length(n)
if(length(p)==1) p<-rep(p,K)
 M1p<-0
  M2p<- p*(1-p)/n
  M3p<-(1-2*p)*p*(1-p)/n^2
  M4p<-3*p^2*(1-p)^2/n^2+p*(1-p)*(1-6*p*(1-p))/n^3
  M5p<-10*(1-2*p)*p^2*(1-p)^2/n^3+(1-2*p)*p*(1-p)*(1-12*p*(1-p))/n^4
M6p<-15*p^3*(1-p)^3/n^3 +10*(1-2*p)^2*p^2*(1-p)^2/n^4+
15*p^2*(1-p)^2*(1-6*p*(1-p))/n^4+
p*(1-p)*(1-30*p*(1-p)+120*p^2*(1-p)^2)/n^5
B01<-(1-2*p)/(2*p*(1-p)) 
B02<-(2*p-1)/(8*p^2*(1-p)^2)
B10<-1/(p*(1-p))
 B20<-(2*p-1)/(2*p^2*(1-p)^2)
B30<-(p^3+(1-p)^3)/(3*p^3*(1-p)^3)
B40<-(2*p-1)*(p^2+(1-p)^2)/(4*p^4*(1-p)^4)
 B11<- -(p^2+(1-p)^2)/(2*p^2*(1-p)^2)
 B21<-((1-p)^3-p^3)/(2*p^3*(1-p)^3)
 #M1L<-log(p)-log(1-p)+(2*p-1)/6/(n*p*(1-p))^2
  M1L<- -(1-2*p)/(24*p^2*(1-p)^2*n^2)
  M2L<-1/(n*p*(1-p))+(2*p-1)^2/(2*n^2*p^2*(1-p)^2) 
  M3L<-B01^3/n^3+3*(B01^2*B20/n^2+B01*B10^2/n+
  2*B01*B10*B11/n^2+B02*B10^2/n^2)*M2p+
  (B10^3+3*B10^2*B11/n+6*B01*B10*B20/n)*M3p +
3*(B10^2*B20+B10^2*B21/n+2*B10*B11*B20/n+
B01*B20^2/n+2*B01*B10*B30/n)*M4p+
3*(B10^2*B30+B10*B20^2)*M5p+(B20^3+3*B10^2*B40+6*B10*B20*B30)*M6p
M4L<- 6*B01^2*B10^2/n^2*M2p +4*B01*B10^3/n*M3p+
(B10^4+4*B10^3*B11/n+12*B01*B10^2*B20/n)*M4p +4*B10^3*B20*M5p+
(4*B10^3*B30+6*B10^2*B20^2)*M6p
 M5L<- -20*(1-2*p)/(n*p*(1-p))^3
M6L<-15/(n*p*(1-p))^3 
 mom<-c(M1L,M2L,M3L,M4L,M5L,M6L)
mom<-matrix(mom,nrow=K) 
return(mom) }



momLogit1<-function(n,p){
	# calculates 6 central moments of logit L_(x,n) for add=1/2
	# for  binomial distribution
	# to 0(n^{-4})
mom<-numeric(0)
K<-length(n)
if(length(p)==1) p<-rep(p,K)
 M1p<-0
  M2p<- p*(1-p)/n
  M3p<-(1-2*p)*p*(1-p)/n^2
  M4p<-3*p^2*(1-p)^2/n^2+p*(1-p)*(1-6*p*(1-p))/n^3
  M5p<-10*(1-2*p)*p^2*(1-p)^2/n^3+(1-2*p)*p*(1-p)*(1-12*p*(1-p))/n^4
M6p<-15*p^3*(1-p)^3/n^3 +10*(1-2*p)^2*p^2*(1-p)^2/n^4+
15*p^2*(1-p)^2*(1-6*p*(1-p))/n^4+
p*(1-p)*(1-30*p*(1-p)+120*p^2*(1-p)^2)/n^5

kappa2=n*p*(1-p)
kappa3=n*p*(1-p)*(1-2*p)
kappa4=n*p*(1-p)*(1-6*p*(1-p))
kappa5=n*(1-2*p)*p*(1-p)*(1-12*p*(1-p))
kappa6=n*p*(1-p)*(1-30*p*(1-p)+120*p^2*(1-p)^2)
kappa7=n*(1-2*p)*p*(1-p)*(1-60*p*(1-p)+360*p^2*(1-p)^2)
kappa8=n*p*(1-p)*(1-126*p*(1-p)+1680*p^2*(1-p)^2-5040*p^3*(1-p)^3)


M7p=n^(-7)*(kappa7+21*kappa5*kappa2+35*kappa4*kappa3+105*kappa3*kappa2^2)
M8p=n^(-8)*(kappa8+28*kappa6*kappa2+56*kappa5*kappa3+35*kappa4^2+210*kappa4*kappa2^2+280*kappa2*kappa3^2+105*kappa2^4)


B01<-(1-2*p)/(2*p*(1-p)) 
B02<-(2*p-1)/(8*p^2*(1-p)^2)
B10<-1/(p*(1-p))
 B20<-(2*p-1)/(2*p^2*(1-p)^2)
B30<-(p^3+(1-p)^3)/(3*p^3*(1-p)^3)
B40<-(2*p-1)*(p^2+(1-p)^2)/(4*p^4*(1-p)^4)
 B11<- -(p^2+(1-p)^2)/(2*p^2*(1-p)^2)
 B21<-((1-p)^3-p^3)/(2*p^3*(1-p)^3)

B50<-(p^(-5)+(1-p)^(-5))/5
B51<--(p^(-6)+(1-p)^(-6))/2

 B31<- -(p^(-4)+(1-p)^(-4))/2
 B41<- -(-p^(-5)+(1-p)^(-5))/2
B60<-(-p^(-6)+(1-p)^(-6))/6
B61<- -(-p^(-7)+(1-p)^(-7))/2

B0=B01/n+B02/n^2
B1<-B10+B11/n
B2<-B20+B21/n
B3<-B30+B31/n
B4<-B40+B41/n
B5<-B50+B51/n
B6<-B60+B61/n


  M1L<- -(1-2*p)/(24*p^2*(1-p)^2*n^2)
  M2L<-1/(n*p*(1-p))+(2*p-1)^2/(2*n^2*p^2*(1-p)^2) 

M3L<- B0^3+3*B0^2*B1*M1p+3*(B0*B1^2+B0^2*B2)*M2p+
    (B1^3+3*B0^2*B3+6*B0*B1*B2)*M3p+
  3*(B0^2*B4+B1^2*B2+(B0*B2^2+2*B0*B1*B3))*M4p+
3*(B1^2*B3+B1*B2^2+2*B0*B1*B4)*M5p+
(B2^3+3*B1^2*B4+6*B1*B2*B3+6*(B0*B1*B5+3*B0*B3^2))*M6p+
(3*B1^2*B5+3*B2^2*B3+3*B1*B3^2+6*B1*B2*B4)*M7p+
(3*B1^2*B6+3*B2*B3^2+3*B4*B2^2+6*B1*B2*B5+6*B1*B3*B4)*M8p  


M4L<-B0^4+B1^4*M4p+B2^4*M8p+ 4*(B1^3*B2*M5p+B1*B2^3*M7p+B1^3*B3*M6p+B1^3*B4*M7p+B1^3*B5*M8p+B0*B1^3*M3p+B0*B2^3*M6p)+
6*(B0^2*B1^2*M2p+B0^2*B2^2*M4p+B1^2*B2^2*M6p+B1^2*B3^2*M8p)+12*(B0^2*B1*B2*M3p+B0^2*B1*B3*M4p+
B1^2*B0*B2*M4p+B1^2*B0*B3*M5p+B1^2*B0*B4*M6p+B1^2*B2*B3*M7p+B2^2*B0*B1*M5p)+24*B0*B1*B2*B3*M6p

M5L<-B1^5*M5p+5*(B0*B1^4*M4p+B2*B1^4*M6p+ B3*B1^4*M7p +B4*B1^4*M8p)+
10*(B0^3*B1^2*M2p+B0^2*B1^3*M3p+B1^3*B2^2*M7p +B1^2*B2^3*M8p) +30*B0*B1^2*B2^2*M6p +20*(B0*B1^3*B2*M5p+
B0*B1^3*B3*M6p+B1^3*B2*B3*M8p)

M6L<-B1^6*M6p+6*(B0*B1^5*M5p+B2*B1^5*M7p+B3*B1^5*M8p)+ 15*(B0^2*B1^4*M4p+B1^4*B2^2*M8p)+ 30*B0*B1^4*B2*M6p


 
mom<-c(M1L,M2L,M3L,M4L,M5L,M6L)
mom<-matrix(mom,nrow=K) 
return(mom) }

momLogit_exactth1<-function(n,p){
	# calculates exactly  6 central moments of logit L_(x,n)
    #for estimated logit=log(x+1/2)/(n+1/2-x) for x binomially distributed
    # B(n,p) when p is known
    # at the moment works only for equal n's and p's

mom<-numeric(0)
K<-length(n)
if(length(p)==1) p<-rep(p,K)
 X<-c(0:n[1])
 b<-dbinom(X,n[1],p[1])
 l<-log((X+.5)/(n[1]+.5-X))-log(p[1]/(1-p[1]))
 M1L<-sum(b*l)
 M2L<-sum(b*l*l)
 M3L<-sum(b*l^3)
 M4L<-sum(b*l^4)
 M5L<-sum(b*l^5)
 M6L<-sum(b*l^6)

 mom<-c(rep(M1L,K),rep(M2L,K),rep(M3L,K),rep(M4L,K),rep(M5L,K),rep(M6L,K))
mom<-matrix(mom,nrow=K)
return(mom) }

momLogit_exactth<-function(n,p){
	# calculates exactly  6 central moments of logit L_(x,n)
    #for estimated logit=log(x+1/2)/(n+1/2-x) for x binomially distributed
    # B(n,p) when p is known
    #  works  for unequal n's and p's

mom<-numeric(0)
K<-length(n)
if(length(p)==1) p<-rep(p,K)
M1L<-M2L<-M3L<-M4L<-M5L<-M6L<-numeric(K)

for (v in 1:K) { # cycle for studies

 X<-c(0:n[v])
 b<-dbinom(X,n[v],p[v])
 l<-log((X+.5)/(n[v]+.5-X))-log(p[v]/(1-p[v]))
 M1L[v]<-sum(b*l)
 M2L[v]<-sum(b*l*l)
 M3L[v]<-sum(b*l^3)
 M4L[v]<-sum(b*l^4)
 M5L[v]<-sum(b*l^5)
 M6L[v]<-sum(b*l^6)}

 mom<-c(M1L,M2L,M3L,M4L,M5L,M6L)
mom<-matrix(mom,nrow=K)
return(mom) }


cmomLOR<-function(n1,n2, p1,p2,a=0){
	# calculates central moments of the log odds ratio, Delta=log(p1/(1-p1))-log(p2/(1-p2))
        ####  includes full binomial expansion for (a+b)^k
Mp1<-Mp2<-numeric(6)
K<-length(n1)
cmom<-numeric(0)
Mp1<-momLogit1(n1,p1)
Mp2<-momLogit1(n2,p2)

b<-1-a
Et2<- Mp1[,2] + Mp2[,2] -2*Mp1[,1]*Mp2[,1]
Et3<- Mp1[,3] - Mp2[,3]	-3*Mp1[,2]*Mp2[,1]+3*Mp2[,2]*Mp1[,1]						
Et4<- Mp1[,4] +6*Mp1[,2]*Mp2[,2] +Mp2[,4]  - 4*Mp1[,3]*Mp2[,1]	- 4*Mp2[,3]*Mp1[,1]		
Et5<- Mp1[,5] +10*Mp1[,3]*Mp2[,2] -10*Mp1[,2]*Mp2[,3] -Mp2[,5] - 5*Mp1[,4]*Mp2[,1]	+ 5*Mp2[,4]*Mp1[,1]
Et6<- Mp1[,6] +15*Mp1[,4]*Mp2[,2]  +15*Mp1[,2]*Mp2[,4] +Mp2[,6]	-20*Mp1[,3]*Mp2[,3] - 6*Mp1[,5]*Mp2[,1]	- 6*Mp2[,5]*Mp1[,1]		
Ez2<- a^2*Mp1[,2]+b^2*Mp2[,2]  +2*a*b*Mp1[,1]*Mp2[,1]
Etz<- a*Mp1[,2] - b*Mp2[,2]  -(a-b)*Mp1[,1]*Mp2[,1]
Et2z<- a*Mp1[,3] + b*Mp2[,3]+(b-2*a)*Mp1[,2]*Mp2[,1]+(a-2*b)*Mp1[,1]*Mp2[,2]
Et2z2<- a^2*Mp1[,4]+(a^2+b^2-4*a*b)*Mp1[,2]*Mp2[,2]+b^2*Mp2[,4]+2*a*(b-a)*Mp1[,3]*Mp2[,1]+2*b*(a-b)*Mp1[,1]*Mp2[,3]
Et3z<- a*Mp1[,4]+3*(a-b)*Mp1[,2]*Mp2[,2]-b*Mp2[,4] +(b-3*a)*Mp1[,3]*Mp2[,1]+(3*b-a)*Mp1[,1]*Mp2[,3]
Et4z<- a*Mp1[,5] + (6*a-4*b)*Mp1[,3]*Mp2[,2] + (6*b-4*a)*Mp1[,2]*Mp2[,3] + b*Mp2[,5] +(b-4*a)*Mp1[,4]*Mp2[,1]-(4*b-a)*Mp1[,1]*Mp2[,4]
Et5z<- a*Mp1[,6] + (10*a-5*b)*Mp1[,4]*Mp2[,2] + (5*a-10*b)*Mp1[,2]*Mp2[,4] - b*Mp2[,6]  +10*(b-a)*Mp1[,3]*Mp2[,3] +(b-5*a)*Mp1[,5]*Mp2[,1]+(5*b-a)*Mp1[,1]*Mp2[,5]
Et4z2<- a^2*Mp1[,6] + (6*a^2-8*a*b+b^2)*Mp1[,4]*Mp2[,2]  + (a^2-8*a*b+6*b^2)*Mp1[,2]*Mp2[,4]+ b^2*Mp2[,6] + (12*a*b-4*a^2-4*b^2)*Mp1[,3]*Mp2[,3]   +2*a*(b-2*a)*Mp1[,5]*Mp2[,1]+2*b*(a-2*b)*Mp1[,1]*Mp2[,5]

cmom<-c(Et2,Et3,Et4,Et5,Et6,Ez2,Etz,Et2z,Et2z2,Et3z,Et4z,Et5z,Et4z2)	
cmom<-matrix(cmom,nrow=K)									
return(cmom)
}

cmomLOR_th<-function(n1,n2, p1,p2,a=0){
	# calculates exact theoretical central moments of the log odds ratio, Delta=log(p1/(1-p1))-log(p2/(1-p2))
        ####  includes full binomial expansion for (a+b)^k
	### differs from cmomLOR1 only by the use of momLogit_exactth
Mp1<-Mp2<-numeric(6)
K<-length(n1)
cmom<-numeric(0)
Mp1<-momLogit_exactth(n1,p1)
Mp2<-momLogit_exactth(n2,p2)

b<-1-a
Et2<- Mp1[,2] + Mp2[,2] -2*Mp1[,1]*Mp2[,1]
Et3<- Mp1[,3] - Mp2[,3]	-3*Mp1[,2]*Mp2[,1]+3*Mp2[,2]*Mp1[,1]						
Et4<- Mp1[,4] +6*Mp1[,2]*Mp2[,2] +Mp2[,4]  - 4*Mp1[,3]*Mp2[,1]	- 4*Mp2[,3]*Mp1[,1]		
Et5<- Mp1[,5] +10*Mp1[,3]*Mp2[,2] -10*Mp1[,2]*Mp2[,3] -Mp2[,5] - 5*Mp1[,4]*Mp2[,1]	+ 5*Mp2[,4]*Mp1[,1]
Et6<- Mp1[,6] +15*Mp1[,4]*Mp2[,2]  +15*Mp1[,2]*Mp2[,4] +Mp2[,6]	-20*Mp1[,3]*Mp2[,3] - 6*Mp1[,5]*Mp2[,1]	- 6*Mp2[,5]*Mp1[,1]		
Ez2<- a^2*Mp1[,2]+b^2*Mp2[,2]  +2*a*b*Mp1[,1]*Mp2[,1]
Etz<- a*Mp1[,2] - b*Mp2[,2]  -(a-b)*Mp1[,1]*Mp2[,1]
Et2z<- a*Mp1[,3] + b*Mp2[,3]+(b-2*a)*Mp1[,2]*Mp2[,1]+(a-2*b)*Mp1[,1]*Mp2[,2]
Et2z2<- a^2*Mp1[,4]+(a^2+b^2-4*a*b)*Mp1[,2]*Mp2[,2]+b^2*Mp2[,4]+2*a*(b-a)*Mp1[,3]*Mp2[,1]+2*b*(a-b)*Mp1[,1]*Mp2[,3]
Et3z<- a*Mp1[,4]+3*(a-b)*Mp1[,2]*Mp2[,2]-b*Mp2[,4] +(b-3*a)*Mp1[,3]*Mp2[,1]+(3*b-a)*Mp1[,1]*Mp2[,3]
Et4z<- a*Mp1[,5] + (6*a-4*b)*Mp1[,3]*Mp2[,2] + (6*b-4*a)*Mp1[,2]*Mp2[,3] + b*Mp2[,5] +(b-4*a)*Mp1[,4]*Mp2[,1]-(4*b-a)*Mp1[,1]*Mp2[,4]
Et5z<- a*Mp1[,6] + (10*a-5*b)*Mp1[,4]*Mp2[,2] + (5*a-10*b)*Mp1[,2]*Mp2[,4] - b*Mp2[,6]  +10*(b-a)*Mp1[,3]*Mp2[,3] +(b-5*a)*Mp1[,5]*Mp2[,1]+(5*b-a)*Mp1[,1]*Mp2[,5]
Et4z2<- a^2*Mp1[,6] + (6*a^2-8*a*b+b^2)*Mp1[,4]*Mp2[,2]  + (a^2-8*a*b+6*b^2)*Mp1[,2]*Mp2[,4]+ b^2*Mp2[,6] + (12*a*b-4*a^2-4*b^2)*Mp1[,3]*Mp2[,3]   +2*a*(b-2*a)*Mp1[,5]*Mp2[,1]+2*b*(a-2*b)*Mp1[,1]*Mp2[,5]

cmom<-c(Et2,Et3,Et4,Et5,Et6,Ez2,Etz,Et2z,Et2z2,Et3z,Et4z,Et5z,Et4z2)	
cmom<-matrix(cmom,nrow=K)									
return(cmom)
}

cmomLOR1<-function(n1,n2, p1,p2,a=0){
	# calculates central moments of the log odds ratio, Delta=log(p1/(1-p1))-log(p2/(1-p2))
        # adds only terms of appropriate orders 
Mp1<-Mp2<-numeric(6)
K<-length(n1)
cmom<-numeric(0)
Mp1<-momLogit(n1,p1)
Mp2<-momLogit(n2,p2)

b<-1-a
Et2<- Mp1[,2] + Mp2[,2] 
Et3<- Mp1[,3] - Mp2[,3]							
Et4<- Mp1[,4] +6*Mp1[,2]*Mp2[,2] +Mp2[,4]  		
Et5<- Mp1[,5] +10*Mp1[,3]*Mp2[,2] -10*Mp1[,2]*Mp2[,3] -Mp2[,5] 
Et6<- Mp1[,6] +15*Mp1[,4]*Mp2[,2]  +15*Mp1[,2]*Mp2[,4] +Mp2[,6]	-20*Mp1[,3]*Mp2[,3] 		
Ez2<- a^2*Mp1[,2]+b^2*Mp2[,2]  
Etz<- a*Mp1[,2] - b*Mp2[,2]  
Et2z<- a*Mp1[,3] + b*Mp2[,3]
Et2z2<- a^2*Mp1[,4]+(a^2+b^2-4*a*b)*Mp1[,2]*Mp2[,2]+b^2*Mp2[,4]
Et3z<- a*Mp1[,4]+3*(a-b)*Mp1[,2]*Mp2[,2]-b*Mp2[,4] 
Et4z<- a*Mp1[,5] + (6*a-4*b)*Mp1[,3]*Mp2[,2] + (6*b-4*a)*Mp1[,2]*Mp2[,3] + b*Mp2[,5] 
Et5z<- a*Mp1[,6] + (10*a-5*b)*Mp1[,4]*Mp2[,2] + (5*a-10*b)*Mp1[,2]*Mp2[,4] - b*Mp2[,6]  +10*(b-a)*Mp1[,3]*Mp2[,3] 
Et4z2<- a^2*Mp1[,6] + (6*a^2-8*a*b+b^2)*Mp1[,4]*Mp2[,2]  + (a^2-8*a*b+6*b^2)*Mp1[,2]*Mp2[,4]+ b^2*Mp2[,6] 

cmom<-c(Et2,Et3,Et4,Et5,Et6,Ez2,Etz,Et2z,Et2z2,Et3z,Et4z,Et5z,Et4z2)	
cmom<-matrix(cmom,nrow=K)									
return(cmom)
}


EQ<-function(parm, cmo,n1,n2,a=0){
	# Calculates estimated value of EQ
m<-matrix(parm,nrow=5)
Delta<-m[1,]
zeta<-m[2,]
q<-m[3,]
N<-m[4,]
wt<-m[5,]
W<-sum(wt)
U<-1-wt/W

####### Moments of Delta, zeta and some mixed moments
E2D<-cmo[,1] 	##\e(Delta^2)
E3D<-cmo[,2] 	##\e(Delta^3)
E4D<-cmo[,3] 	##\e(Delta^4)
E5D<-cmo[,4] 	##\e(Delta^5)
E6D<-cmo[,5] 	##\e(Delta^6)
E2z<-cmo[,6] 	##\e(\zeta^2)
EDz<-cmo[,7] 	##\e(Delta\zeta)
ED2z<-cmo[,8] 	##\e(Delta^2\zeta)
ED2z2<-cmo[,9] 	##\e(Delta^2\zeta^2)
ED3z<-cmo[,10] 	##\e(Delta^3\zeta)
ED4z<-cmo[,11] 	##\e(Delta^4\zeta)
ED5z<-cmo[,12] 	##\e(Delta^5\zeta)
ED4z2<-cmo[,13] 	##\e(Delta^4\zeta^2)

##### Derivatives of the weights

b<-1-a
C<-b*sinh(b*Delta+zeta)/(n1+1)-a*sinh(zeta-a*Delta)/(n2+1)
D<-sinh(b*Delta+zeta)/(n1+1)+sinh(zeta-a*Delta)/(n2+1)
d1fD<- (-2*C)*wt^2
d1fz<- (-2*D)*wt^2

d2fD<- 8*C^2*wt^3-2*wt^2*(b^2*cosh(b*Delta+zeta)/(n1+1)+a^2*cosh(zeta-a*Delta)/(n2+1))
d2fz<- 8*D^2*wt^3-2*wt^2*(cosh(b*Delta+zeta)/(n1+1)+cosh(zeta-a*Delta)/(n2+1))
d2fDz<- 8*C*D*wt^3-2*wt^2*(b*cosh(b*Delta+zeta)/(n1+1)-a*cosh(zeta-a*Delta)/(n2+1))

#### derivatives of Q
d2Q_D2<-2*wt*U
d3Q_D3<-6*U^2*d1fD
d3Q_D2z<-2*U^2*d1fz
d4Q_D4<-12*U^2*(d2fD-2*d1fD^2/W)
d4Q_D3z<-6*U^2*(d2fDz-2*d1fD*d1fz/W)
d4Q_D2z2<-2*U^2*(d2fz-2*d1fz^2/W)
d4Q_D2iD2j<-(-4/W^3)*(crossprod(t(d1fD^2),t(wt^2))+crossprod(t(wt^2),t(d1fD^2)))+(2/W^2)*(crossprod(t(d2fD),t(wt^2))
+crossprod(t(wt^2),t(d2fD)))+(8/W^2)*(crossprod(t(d1fD*wt),t(U*d1fD))+crossprod(t(U*d1fD),t(d1fD*wt))-W*crossprod(t(d1fD)))
diag(d4Q_D2iD2j)<-0
d4Q_DiDjzizj<-(2/W^2)*(crossprod(t(d1fz*wt),t(U*d1fz))+crossprod(t(U*d1fz),t(d1fz*wt))-W*crossprod(t(d1fz)))
diag(d4Q_DiDjzizj)<-0
d4Q_D2iDjzj<-(4/W^2)*(crossprod(t(d1fD*wt),t(U*d1fz))+crossprod(t(U*d1fD),t(d1fz*wt))-W*crossprod(t(d1fD),t(d1fz)))+
(2/W^2)*crossprod(t(wt^2),t(d2fDz))-(4/W^3)*crossprod(t(wt^2),t(d1fz*d1fD))
diag(d4Q_D2iDjzj)<-0
d4Q_D2iz2j<-(2/W^2)*crossprod(t(wt^2),t(d2fz))-(4/W^3)*crossprod(t(wt^2),t(d1fz^2))
diag(d4Q_D2iz2j)<-0

EQ<-.5*crossprod(d2Q_D2,E2D)+(1/6)*crossprod(d3Q_D3,E3D)+.5*crossprod(d3Q_D2z,ED2z)+(1/24)*crossprod(d4Q_D4,E4D)+(1/6)*
crossprod(d4Q_D3z,ED3z)+
(1/4)*crossprod(d4Q_D2z2,ED2z2)+(1/8)*t(E2D)%*%d4Q_D2iD2j%*%E2D+(1/2)*t(EDz)%*%d4Q_DiDjzizj%*%EDz+
+(1/2)*t(E2D)%*%d4Q_D2iDjzj%*%EDz+(1/4)*t(E2D)%*%d4Q_D2iz2j%*%E2z
return(drop(EQ))
}


EQ2<-function(parm,cmo,n1,n2,a=0){
	# Calculates estimated value of EQ^2
K<-length(n1)
m<-matrix(parm,nrow=5)
Delta<-m[1,]
zeta<-m[2,]
q<-m[3,]
N<-m[4,]
wt<-m[5,]
W<-sum(wt)
U<-1-wt/W

#### Moments of Delta, zeta and some mixed moments
E2D<-cmo[,1] ##\e(Delta^2)
E3D<-cmo[,2] ##\e(Delta^3)
E4D<-cmo[,3] ##\e(Delta^4)
E5D<-cmo[,4] ##\e(Delta^5)
E6D<-cmo[,5] ##\e(Delta^6)
E2z<-cmo[,6] ##\e(\zeta^2)
EDz<-cmo[,7] ##\e(Delta\zeta)
ED2z<-cmo[,8] ##\e(Delta^2\zeta)
ED2z2<-cmo[,9] ##\e(Delta^2\zeta^2)
ED3z<-cmo[,10] ##\e(Delta^3\zeta)
ED4z<-cmo[,11] ##\e(Delta^4\zeta)
ED5z<-cmo[,12] ##\e(Delta^5\zeta)
ED4z2<-cmo[,13] ##\e(Delta^4\zeta^2)

##### Derivatives of the weights
b<-1-a
C<-b*sinh(b*Delta+zeta)/(n1+1)-a*sinh(zeta-a*Delta)/(n2+1)
D<-sinh(b*Delta+zeta)/(n1+1)+sinh(zeta-a*Delta)/(n2+1)
d1fD<- (-2*C)*wt^2
d1fz<- (-2*D)*wt^2

d2fD<- 8*C^2*wt^3-2*wt^2*(b^2*cosh(b*Delta+zeta)/(n1+1)+a^2*cosh(zeta-a*Delta)/(n2+1))
d2fz<- 8*D^2*wt^3-2*wt^2*(cosh(b*Delta+zeta)/(n1+1)+cosh(zeta-a*Delta)/(n2+1))
d2fDz<- 8*C*D*wt^3-2*wt^2*(b*cosh(b*Delta+zeta)/(n1+1)-a*cosh(zeta-a*Delta)/(n2+1))

#### derivatives of Q2
d4Q2_D4<-24*wt^2*U^2
d5Q2_D5<-240*wt*U^3*d1fD
d6Q2_D6<-720*U^3*((U-2*wt/W)*d1fD^2+wt*d2fD)
d4Q2_D2iD2j<-8*crossprod(t(wt*U))+16*crossprod(t(wt^2))/W^2
diag(d4Q2_D2iD2j)<-0
d5Q2_D3iD2j<-24*crossprod(t(U^2*d1fD),t(wt*U))+120*crossprod(t(U*wt*d1fD),t(wt^2))/W^2-48*crossprod(t(wt^2*U),t(U*d1fD))/W-48*crossprod(t(wt^3),t(wt*d1fD))/W^3
diag(d5Q2_D3iD2j)<-0
d6Q2_D4iD2j=(48/W^4)*
(-2*W^3*crossprod(t(U^2*d1fD^2),t(wt))+8*W^2*crossprod(t(U*d1fD^2),t(wt^2))-
18*W*crossprod(t(U*wt*d1fD^2),t(wt^2))+W^4*crossprod(t(U*d2fD),t(wt)) -
W^3*crossprod(t(U*wt*d2fD),t(wt))- W^3*crossprod(t(U*d2fD),t(wt^2)) +
6*W^2*crossprod(t(U*wt*d2fD),t(wt^2))-8*W^3*crossprod(t(U^2*wt*d1fD),t(d1fD)) +
8*W^2*crossprod(t(U*wt*d1fD),t(wt*d1fD))-24*W*crossprod(t(U*wt^2*d1fD),t(wt*d1fD))-
2*W*crossprod(t(wt^3),t(d1fD^2))+3*crossprod(t(wt^4),t(d1fD^2)) +W^2*crossprod(t(U*wt^3),t(d2fD)))
diag(d6Q2_D4iD2j)<-0
d6Q2_D2iD2jD2k<-(-16/W^4)*(W*crossprod(t(d1fD^2),t(wt^2))%o%wt +
W*crossprod(t(wt^2),t(d1fD^2))%o%wt+W*crossprod(t(wt^2),t(wt))%o%(d1fD^2) +
W*crossprod(t(d1fD^2),t(wt))%o%(wt^2)+W*crossprod(t(wt),t(d1fD^2))%o%(wt^2) +
W*crossprod(t(wt),t(wt^2))%o%(d1fD^2)-9*crossprod(t(d1fD^2),t(wt^2))%o%(wt^2) -
9*crossprod(t(wt^2),t(d1fD^2))%o%(wt^2)-9*crossprod(t(wt^2), t(wt^2))%o%(d1fD^2)) +
(8/W^3)*(W*crossprod(t(d2fD),t(wt^2))%o%wt +
W*crossprod(t(wt^2),t(d2fD))%o%wt +
W*crossprod(t(wt^2),t(wt))%o%d2fD +
W*crossprod(t(d2fD),t(wt))%o%(wt^2) +
W*crossprod(t(wt),t(d2fD))%o%(wt^2) +
W*crossprod(t(wt),t(wt^2))%o%d2fD -
6*crossprod(t(d2fD),t(wt^2))%o%(wt^2) -
6*crossprod(t(wt^2),t(d2fD))%o%(wt^2) -
6*crossprod(t(wt^2),t(wt^2))%o%d2fD) -
(32/W^2)*(crossprod(t(U*d1fD),t(U*d1fD))%o%(wt*W) +
crossprod(t(U*d1fD),t(wt*W))%o%(U*d1fD) +
crossprod(t(wt*W),t(U*d1fD))%o%(U*d1fD) -
6*crossprod(t(U*d1fD),t(U*d1fD))%o%(wt^2) -
6*crossprod(t(U*d1fD),t(wt^2))%o%(U*d1fD) -
6*crossprod(t(wt^2),t(U*d1fD))%o%(U*d1fD) +
crossprod(t(wt*d1fD),t(wt*d1fD))%o%(wt/W) +
crossprod(t(wt*d1fD),t(wt/W))%o%(wt*d1fD) +
crossprod(t(wt/W),t(wt*d1fD))%o%(wt*d1fD) -
12*crossprod(t(wt*d1fD),t(wt*d1fD))%o%(wt^2/W^2) -
12*crossprod(t(wt*d1fD),t(wt^2/W^2))%o%(wt*d1fD) -
12*crossprod(t(wt^2/W^2),t(wt*d1fD))%o%(wt*d1fD) +
3*crossprod(t(d1fD),t(d1fD))%o%(wt^2) +
3*crossprod(t(d1fD),t(wt^2))%o%d1fD +
3*crossprod(t(wt^2),t(d1fD))%o%d1fD)

#### MIXED DERIVATIVES
d5Q2_D4izi<-48*wt*U^3*d1fz
d5Q2_D3iDjzj<- -24*crossprod(t(wt^2*U),t(U*d1fz))/W-24*crossprod(t(wt^3),t(wt*d1fz))/W^3
diag(d5Q2_D3iDjzj)<-0
d5Q2_D2iD2jzi<- 8*crossprod(t(U^2*d1fz),t(wt*U))+40*crossprod(t(U*wt*d1fz),t(wt^2))/W^2
diag(d5Q2_D2iD2jzi)<-0
d6Q2_D5z<-240*U^3*((U-2*wt/W)*d1fD*d1fz+wt*d2fDz)
d6Q2_D4z2<-48*U^3*((U-2*wt/W)*d1fz^2+wt*d2fz)
d6Q2_D4iDjzj<-(-192/W^3)*(crossprod(t(U*wt*d1fD),t(d1fz))*W^2-crossprod(t(U*wt^2*d1fD),t(d1fz))*W -
crossprod(t(U*wt*d1fD),t(d1fz*wt))*W+3*crossprod(t(U*wt^2*d1fD),t(d1fz*wt))) -
(48/W^4)*crossprod(t(2*wt^3*W-3*wt^4),t(d1fz*d1fD)) +
(48/W^2)*crossprod(t(U*wt^3),t(d2fDz))
diag(d6Q2_D4iDjzj)<-0
d6Q2_D4iz2j<--(48/W^4)*crossprod(t(2*wt^3*W-3*wt^4),t(d1fz^2)) +
(48/W^2)*crossprod(t(U*wt^3),t(d2fz))
diag(d6Q2_D4iz2j)<-0
d6Q2_D3iD2jzi<-(-48/W^3)*(crossprod(t(U*d1fD*d1fz),t(wt))*W^2-crossprod(t(wt*U*d1fD*d1fz),t(wt))*W -
4*crossprod(t(U*d1fD*d1fz),t(wt^2))*W+9*crossprod(t(wt*U*d1fD*d1fz),t(wt^2))) +
(-96/W^3)*(crossprod(t(U*wt*d1fz),t(d1fD))*W^2-crossprod(t(wt^2*U*d1fz),t(d1fD))*W -
crossprod(t(wt*U*d1fz),t(wt*d1fD))*W+3*crossprod(t(wt^2*U*d1fz),t(wt*d1fD))) +
(24/W^2)*(crossprod(t(U*d2fDz),t(wt))*W^2-crossprod(t(wt*U*d2fDz),t(wt))*W -
crossprod(t(U*d2fDz),t(wt^2))*W+6*crossprod(t(wt*U*d2fDz),t(wt^2)))
diag(d6Q2_D3iD2jzi)<-0
d6Q2_D3iDjzizj<-(-48/W^3)*(crossprod(t(U*wt*d1fz),t(d1fz))*W^2-crossprod(t(wt^2*U*d1fz),t(d1fz))*W -
crossprod(t(wt*U*d1fz),t(wt*d1fz))*W+3*crossprod(t(wt^2*U*d1fz),t(wt*d1fz)))
diag(d6Q2_D3iDjzizj)<-0
d6Q2_D2iD2jz2i<-((-16/W^3)*(crossprod(t(U*d1fz^2),t(wt))*W^2-crossprod(t(wt*U*d1fz^2),t(wt))*W -
4*crossprod(t(U*d1fz^2),t(wt^2))*W+9*crossprod(t(wt*U*d1fz^2),t(wt^2))) +
(8/W^2)*(crossprod(t(U*d2fz),t(wt))*W^2-crossprod(t(wt*U*d2fz),t(wt))*W -
crossprod(t(U*d2fz),t(wt^2))*W+6*crossprod(t(wt*U*d2fz),t(wt^2))))
diag(d6Q2_D2iD2jz2i)<-0
d6Q2_DiziD2jD2k<-((-16/W^4)*(W*crossprod(t(d1fz*d1fD),t(wt^2))%o%wt +
W*crossprod(t(d1fz*d1fD),t(wt))%o%wt^2-9*crossprod(t(d1fz*d1fD),t(wt^2))%o%wt^2) +
(8/W^3)*(W*crossprod(t(d2fDz),t(wt^2))%o%wt +
W*crossprod(t(d2fDz),t(wt))%o%wt^2-6*crossprod(t(d2fDz),t(wt^2))%o%wt^2) +
(-16/W^2)*(crossprod(t(U*d1fz),t(U*d1fD))%o%(W*wt-6*wt^2) +
crossprod(t(wt*d1fz),t(wt*d1fD))%o%(W*wt-12*wt^2)/W^2 +
3*crossprod(t(d1fz),t(d1fD))%o%wt^2) -
(16/W^2)*(crossprod(t(U*d1fz),t(wt*W-6*wt^2))%o%(U*d1fD)+crossprod(t(wt*d1fz),t(wt*W-12*wt^2))%o%(wt*d1fD)/W^2 +
3*crossprod(t(d1fz),t(wt^2))%o%d1fD))
d6Q2_z2iD2jD2k<-((-16/W^4)*(W*crossprod(t(d1fz^2),t(wt^2))%o%wt +
 W*crossprod(t(d1fz^2),t(wt))%o%wt^2 -
9*crossprod(t(d1fz^2),t(wt^2))%o%wt^2) +
(8/W^3)*(W*crossprod(t(d2fz),t(wt^2))%o%wt +
W*crossprod(t(d2fz),t(wt))%o%wt^2 -
6*crossprod(t(d2fz),t(wt^2))%o%wt^2))
d6Q2_DiziDjzjD2k<-((-8/W^2)*(crossprod(t(U*d1fz),t(U*d1fz))%o%(W*wt-6*wt^2) +
crossprod(t(wt*d1fz),t(wt*d1fz))%o%(W*wt-12*wt^2)/W^2 +
3*crossprod(t(d1fz),t(d1fz))%o%wt^2))
for (i in 1:K)
{ diag(d6Q2_D2iD2jD2k[i,,])<-0
  diag(d6Q2_D2iD2jD2k[,i,])<-0
  diag(d6Q2_D2iD2jD2k[,,i])<-0
  diag(d6Q2_DiziD2jD2k[i,,])<-0
  diag(d6Q2_DiziD2jD2k[,i,])<-0
  diag(d6Q2_DiziD2jD2k[,,i])<-0
  diag(d6Q2_z2iD2jD2k[i,,])<-0
  diag(d6Q2_z2iD2jD2k[,i,])<-0
  diag(d6Q2_z2iD2jD2k[,,i])<-0
  diag(d6Q2_DiziDjzjD2k[i,,])<-0
  diag(d6Q2_DiziDjzjD2k[,i,])<-0
  diag(d6Q2_DiziDjzjD2k[,,i])<-0
 }

EQ2<-sum(d4Q2_D4*E4D)/24+sum(d5Q2_D5*E5D)/120+sum(d6Q2_D6*E6D)/720+t(E2D)%*%d4Q2_D2iD2j%*%E2D/8 +
t(E3D)%*%d5Q2_D3iD2j%*%E2D/12+t(E4D)%*%d6Q2_D4iD2j%*%E2D/48 +
sum(d5Q2_D4izi*ED4z)/24+sum(d6Q2_D5z*ED5z)/120+sum(d6Q2_D4z2*ED4z2)/48 +
t(E3D)%*%d5Q2_D3iDjzj%*%EDz/6+t(ED2z)%*%d5Q2_D2iD2jzi%*%E2D/4+t(E4D)%*%d6Q2_D4iDjzj%*%EDz/24 +
t(E4D)%*%d6Q2_D4iz2j%*%E2z/48+t(ED3z)%*%d6Q2_D3iD2jzi%*%E2D/12 +
t(ED3z)%*%d6Q2_D3iDjzizj%*%EDz/6+t(ED2z2)%*%d6Q2_D2iD2jz2i%*%E2D/8

R<-0
for (i in 1:K)
  {for (j in 1:K)
  {for (k in 1:K)
   R<-R+d6Q2_D2iD2jD2k[i,j,k]*E2D[i]*E2D[j]*E2D[k]/48 +
   d6Q2_DiziD2jD2k[i,j,k]*EDz[i]*E2D[j]*E2D[k]/8+
   d6Q2_DiziDjzjD2k[i,j,k]*EDz[i]*EDz[j]*E2D[k]/4+
   d6Q2_z2iD2jD2k[i,j,k]*E2z[i]*E2D[j]*E2D[k]/16
}}
EQ2<-EQ2+R
return(drop(EQ2))
}


######################################################################
# Function to perform the Breslow and Day (1980) test including
# the corrected test by Tarone
# Uses the equations in Lachin (2000) p. 124-125.
#
# Programmed by Michael Hoehle http://www-m4.ma.tum.de/pers/hoehle
#corrected by Elena Kulinskaya
# Note that the results of the Tarone corrected test do
# not correspond to the numbers in the Lachin book...
#
# Params:
#  x - a 2x2xK contingency table
#
# Returns:
#  a vector with three values
#   1st value is the Breslow and Day test statistic
#   2nd value is the correct test by Tarone
#   3rd value - p value based on the Tarone test statistic
#               using a \chi^2(K-1) distribution
######################################################################

breslowday.test <- function(x) {
  #Find the common OR based on Mantel-Haenszel
  or.hat.mh <- mantelhaen.test(x)$estimate
  #Number of strata
  K <- dim(x)[3]
  #Value of the Statistic
  X2.HBD <- 0
  #Value of aj, tildeaj and Var.aj
  a <- tildea <- Var.a <- numeric(K)
  
  for (j in 1:K) {
    #Find marginals of table j
    mj <- apply(x[,,j], MARGIN=1, sum)
    nj <- apply(x[,,j], MARGIN=2, sum)

    #Solve for tilde(a)_j
    coef <- c(-mj[1]*nj[1] * or.hat.mh, nj[2]-mj[1]+or.hat.mh*(nj[1]+mj[1]),
                 1-or.hat.mh)
    sols <- Re(polyroot(coef))
    #Take the root, which fulfills 0 < tilde(a)_j <= min(n1_j, m1_j)
    tildeaj <- sols[(0 < sols) &  (sols <= min(nj[1],mj[1]))]
    #Observed value
    aj <- x[1,1,j]
    
    #Determine other expected cell entries
    tildebj <- mj[1] - tildeaj
    tildecj <- nj[1] - tildeaj
    tildedj <- mj[2] - tildecj

    #Compute \hat{\Var}(a_j | \widehat{\OR}_MH)
    Var.aj <- (1/tildeaj + 1/tildebj + 1/tildecj + 1/tildedj)^(-1)

    #Compute contribution
    X2.HBD <- X2.HBD + as.numeric((aj - tildeaj)^2 / Var.aj)

    #Assign found value for later computations
    a[j] <- aj ;  tildea[j] <- tildeaj ; Var.a[j] <- Var.aj
  }

  #Compute Tarone corrected test
  X2.HBDT <-as.numeric( X2.HBD -  (sum(a) - sum(tildea))^2/sum(Var.a) )

  #Compute p-value based on the Tarone corrected test
  p1 <- 1-pchisq(X2.HBD, df=K-1)
 
 p2 <- 1-pchisq(X2.HBDT, df=K-1)

  res <- list(X2.HBD=X2.HBD,X2.HBDT=X2.HBDT,p1=p1,p2=p2)
  class(res) <- "bdtest"
  return(res)
}