library(nleqslv)
#####f1 is the likelihood function.
f1<-function(data,para)
{
  alpha<-para[1]
  pi<-para[2]
  tau<-para[3]
  data<-data+.5
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  sum1<-sum(data[1:4])
  sum2<-sum(data[5:8])
  -(sum1*(-log(1+exp(alpha+pi+tau)+exp(alpha-pi-tau)+exp(2*alpha)))+sum2*(-log(1+exp(alpha+pi-tau)+exp(alpha-pi+tau)+exp(2*alpha)))+(x011+x101+x012+x102+2*x111+2*x112)*alpha+(x011-x101+x012-x102)*pi+(x011-x101+x102-x012)*tau)
}


#####f2 is the likelihood under null (odds ratio=phai0=0.5)
f2<-function(data,para)
{
  para1<-c(para,log(phai0)/4)
  f1(data,para1)
}


#####g1, g2 and g3 are three partial derivative functions to the likelihood function, they are used to get the estimates of MLE and RMLE of alpha, pi and tau. 

g1<-function(alpha,pi,tau)
{
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  sum(data[1:4])*(exp(alpha+pi+tau)+exp(alpha-pi-tau)+2*exp(2*alpha))/(1+exp(alpha+pi+tau)+exp(alpha-pi-tau)+exp(2*alpha))+sum(data[5:8])*(exp(alpha+pi-tau)+exp(alpha-pi+tau)+2*exp(2*alpha))/(1+exp(alpha+pi-tau)+exp(alpha-pi+tau)+exp(2*alpha))-(x011+x101+2*x111+x012+x102+2*x112)
}

g2<-function(alpha,pi,tau)
{
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  sum(data[1:4])*(exp(alpha+pi+tau)-exp(alpha-pi-tau))/(1+exp(alpha+pi+tau)+exp(alpha-pi-tau)+exp(2*alpha))+sum(data[5:8])*(exp(alpha+pi-tau)-exp(alpha-pi+tau))/(1+exp(alpha+pi-tau)+exp(alpha-pi+tau)+exp(2*alpha))-(x011-x101+x012-x102)
}


g3<-function(alpha,pi,tau)
{
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  sum(data[1:4])*(exp(alpha+pi+tau)-exp(alpha-pi-tau))/(1+exp(alpha+pi+tau)+exp(alpha-pi-tau)+exp(2*alpha))+sum(data[5:8])*(-exp(alpha+pi-tau)+exp(alpha-pi+tau))/(1+exp(alpha+pi-tau)+exp(alpha-pi+tau)+exp(2*alpha))-(x011-x101+x102-x012)
}

g<-function(para)
{
  alpha=para[1]
  pi=para[2]
  tau=para[3]
  y=numeric(3)
  y[1]=g1(alpha,pi,tau)
  y[2]=g2(alpha,pi,tau)
  y[3]=g3(alpha,pi,tau)
  y
}


gg<-function(para)
{
  alpha=para[1]
  pi=para[2]
  y=numeric(2)
  y[1]=g1(alpha,pi,log(phai0)/4)
  y[2]=g2(alpha,pi,log(phai0)/4)
  y
}

#####get_lrt is to get the p-value of the likelihood ratio test based on the log linear model (LRT_M).
get_lrt<-function(data)
{
  data<-data+.5
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  phai_hat<-x011*x102/x101/x012
  data<-data-.5  
  ini<-nleqslv(c(0,0,0),g, jacobian=TRUE,control=list(btol=.01))$x
  ini2<-nleqslv(c(0,0),gg, jacobian=TRUE,control=list(btol=.01))$x
  l<--2*(f1(data,c(ini[1],ini[2],ini[3]))
         -f2(data,c(ini2[1],ini2[2])))
  if (phai_hat<=phai0) l<-0
  if(l<=0)   pp1<-1
  if (l>0)   pp1<-0.5*pchisq(l,1,lower.tail=FALSE)
  pp1
}

#####################

get_root<-function(a,b,c) list((-b-sqrt(b^2-4*a*c))/2/a,(-b+sqrt(b^2-4*a*c))/2/a)
get_l2<-function(data,p) sum(data*log(p))


######get_pvals is to get the p-values of LRT and Score tests
get_pvals<-function(data,phai0)
{
  data<-data+.5
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  phai_hat<-x011*x102/x101/x012
  A<-x102-x011+phai0*(x101-x012)
  B<--x011-x012
  C<-phai0*(x101+x102)
  M2<-(x012+x102)/N2
  a1<--A+B+C
  b1<-A*M2-2*C*M2
  c1<-C*M2^2
  pi102<-get_root(a1,b1,c1)[[1]]
  M1<-(x011+x101)/N1
  #the following are the rmle of the pi's
  pi011<-phai0*(M2-pi102)*M1/(pi102+phai0*(M2-pi102))
  pi101<-pi102*M1/(pi102+phai0*(M2-pi102))
  pi001<-x001/N1
  pi111<-x111/N1
  pi012<-M2-pi102
  pi002<-x002/N2
  pi112<-x112/N2
  ##the LRT test 
  l1<-get_l2(c(x011,x101,x012,x102),c(pi011,pi101,pi012,pi102))
  l2<-get_l2(data[c(2,3)],data[c(2,3)]/N1)+get_l2(data[c(6,7)],data[c(6,7)]/N2)
  l<-2*(l2-l1)
  if (phai_hat<=phai0) l<-0
  if(l<=0)  pp1<-1
  if (l>0) pp1<-0.5*pchisq(l,1,lower.tail=FALSE)
  #the following is the Score test 
  tmp1<-pi102+phai0*pi012
  tmp2<-N1*(pi011+pi101)
  M<-matrix(0,nrow=6,ncol=6)
  M[1,1]<-N1*pi011/phai0^2-tmp2*pi012^2/tmp1^2
  M[1,2]<-M[2,1]<--tmp2*M2/tmp1^2
  M[1,5]<-M[5,1]<-M[1,6]<-M[6,1]<--tmp2*pi102/tmp1^2
  M[2,2]<-(N1*pi011+N2*pi012)/pi012^2-(1-phai0)^2*tmp2/tmp1^2+(N1*pi101+N2*pi102)/pi102^2
  M[2,5]<-M[5,2]<-M[2,6]<-M[6,2]<-(N1*pi011+N2*pi012)/pi012^2+phai0*(1-phai0)*tmp2/tmp1^2
  M[3,3]<-N1/pi001+tmp2/M1^2
  M[3,4]<-M[4,3]<-tmp2/M1^2
  M[4,4]<-N1/pi111+tmp2/M1^2
  M[5,5]<-N2/pi002+(N1*pi011+N2*pi012)/pi012^2-tmp2*phai0^2/tmp1^2
  M[5,6]<-M[6,5]<-(N1*pi011+N2*pi012)/pi012^2-tmp2*phai0^2/tmp1^2
  M[6,6]<-N2/pi112+(N1*pi011+N2*pi012)/pi012^2-tmp2*phai0^2/tmp1^2
  M22<-M[2:6,2:6]
  M12<-M[1,2:6]
  M21<-matrix(M[2:6,1],nrow=5,ncol=1)
  tmp3<-M[1,1]-M12%*%solve(M22)%*%M21
  s<-x011/phai0-(x011+x101)*pi012/tmp1
  pp2<-1-pnorm(s/sqrt(tmp3))
  list(p_LRT=pp1,p_Score=pp2)
}


######the asymptotic method in Lui and Chang's paper
get_p_asy<-function(data,phai0)
{
  data<-data+0.5
  x001<-data[1]
  x011<-data[2]
  x101<-data[3]
  x111<-data[4]
  x002<-data[5]
  x012<-data[6]
  x102<-data[7]
  x112<-data[8]
  phai_ba<-sqrt((x011)*(x102)/(x101)/(x012))
  var<-(1/(x011)+1/(x102)+1/(x101)+1/(x012))/4
  Z<-(log(phai_ba)-log(sqrt(phai0)))/sqrt(var)
  1-pnorm(Z)
}

#######the conditional method in Lui and Chang's paper
get_p_cond<-function(n1,n2,x1,x,phai0)
{
  tmp1<-max(0,x-n2)
  tmp2<-min(n1,x)
  sum1<-0
  sum2<-0  
  for (i in x1:tmp2) sum1<-sum1+choose(n1,i)*choose(n2,x-i)*(phai0)^i
  for (i in tmp1:tmp2) sum2<-sum2+choose(n1,i)*choose(n2,x-i)*(phai0)^i
  sum1/sum2
}