#
# Evaluation of the expectations and the standard deviations in Table  2
##################################################

#The n=8 case
# The seven marginal totals that are fixed
n<-8  # sample size
np11<-4  # m_4 the number of units with x_1=x_2=1
n1p1<-3  # sum y_ix_2i
n11p<-2 # sum y_ix_1i
n1pp<-4  # sum y_i
np1p<-5  # sum x_1i
npp1<-6  #sum x_2i

# Calculation of the predicted probabilities \pi_k in Table 2
x1<-c(rep(1,5),rep(0,3))
x2<-c(rep(1,4), rep(0,2),rep(1,2))
y<-c(rep(1,2),rep(0,3),rep(1,1),rep(0,1),rep(1,1))
xx<-glm(y~x1+x2,family = binomial)
 unique(predict(xx,type = "response"))[c(3,2,4,1)]
 # 0.6372508 0.3627492 0.6813746 0.4093127



#Calculations for the general case with n=8*m
resu<-matrix(0,4,40)
for (m in (1:20)){
n<-8*m
np11<-4*m
n1p1<-3*m
n11p<-2*m
n1pp<-4*m
np1p<-5*m
npp1<-6*m
tabdon<-array(0,c(2,2,2))
prob<-rep(0,m+1)
for(x in(m:(2*m))){
  tabdon[2,2,2]<-x
  tabdon[1,2,2]<-np11-x
  tabdon[2,1,2]<-n1p1-x
  tabdon[2,2,1]<-n11p-x
  tabdon[2,1,1]<-n1pp-n1p1-n11p+x
  tabdon[1,2,1]<-np1p-n11p-np11+x
  tabdon[1,1,2]<-npp1-np11-n1p1+x
  tabdon[1,1,1]<-n-x-n1pp-np1p-npp1+n11p+n1p1+np11
  marge<-apply(tabdon,c(2,3),sum)
  prob[x-m+1]<-(choose(marge[1,1],tabdon[1,1,1])*
                  choose(marge[1,2],tabdon[1,1,2])*
                  choose(marge[2,1],tabdon[1,2,1])*
                  choose(marge[2,2],tabdon[1,2,2]))
}
p11<-sum((m:(2*m))*prob)/(4*m*sum(prob)) 
p10<-sum((n1p1-(m:(2*m)))*prob)/(2*m*sum(prob)) 
p01<-sum((n11p-(m:(2*m)))*prob)/(m*sum(prob)) 
p00<-sum((n1pp-n1p1-n11p+(m:(2*m)))*prob)/(m*sum(prob))
sd11<-sqrt(sum((m:(2*m))^2*prob)/(4^2*m^2*sum(prob))-p11^2)
sd10<-sqrt(sum((n1p1-(m:(2*m)))^2*prob)/(2^2*m^2*sum(prob))-p10^2)
sd01<-sqrt(sum((n11p-(m:(2*m)))^2*prob)/(m^2*sum(prob)) -p01^2)
sd00<-sqrt(sum((n1pp-n1p1-n11p+(m:(2*m)))^2*prob)/(m^2*sum(prob)) -p00^2)
resu[,c((2*m-1),(2*m))]<-cbind(c(p00,p01,p10,p11),c(sd00,sd01,sd10,sd11))
}
row.names(resu)<-c("00","01","10","11")

 colnames(resu) <-paste(rep(c("E","SD"),2),rep(1:20,each=2),sep="")
 resu<-round(resu,3)
 resu
#
#  R-code for the cube algorithm of Section 3.2
#
 if (!require(sampling)) install.packages('sampling')
 if (!require(BalancedSampling)) install.packages('BalancedSampling')
 library(BalancedSampling)
 library(sampling)
 exact<-function(y,Xexp,tol=.001,B=500){
    # y is a vector of length n of the 0-1 dependent variable
    # Xexp is the matrix of x-explanatory variables (without the intercept)
    # The output is a list containing containing 5 items:
    # (i) reglog the logistic regression fit under H0: gamma=0,
    # (ii) pichap the selection probties hat pi_i 
    # (iii) resu a Bxn  matrix of simulated 0-1 vectors
    # (iv)  suff the sufficient statistic for the parameters in the model 
    # (v) nb_essai the number of  runs of the algorithm needed to generate B  simulated 
    #	vectors y^{(b)} satisfying the tolerence criterion
    xx<-glm(y ~ Xexp, family=binomial)  
    # Predictec values
    pistar<-predict(xx,type = "response")
    # balancing variables for the cube method
    matbal<-as.matrix(cbind(rep(1,length(y)),Xexp))*outer(pistar,rep(1,(dim(Xexp)[2]+1)))
    # The sufficent statistics (total of the balancing variables)
    matbal1<-as.matrix(cbind(rep(1,length(y)),Xexp))*outer(y,rep(1,(dim(Xexp)[2]+1)))
    const<-colSums(matbal1)
    ii<-kk<-1
    resu<-matrix(0,nrow=B, ncol=length(y))
    while (ii <=B){
       #Fight phase for the cube method
       xx1<-flightphase(pistar,matbal)
       #  Dectection of the undecided units
       EPS=0.0001 
       T=(xx1>EPS) & (xx1 < 1-EPS)
       #  Calculation of the new balancing variables for the undecided units
       mat.inter<-cbind(xx1[T],(xx1[T]/pistar[T])*matbal[T,])
       xx3<-samplecube((xx1[T]/pistar[T])*matbal[T,],xx1[T],order=2,comment = FALSE)
       xx1[T]<-xx3
       #  Test whether the simulated xx1 meets the contraints
       matbal2<-cbind(rep(1,length(y)),Xexp)*outer(xx1,rep(1,(dim(Xexp)[2]+1)))
       const2<-colSums(matbal2)
       diff=sum(abs(const2-const))
       if (diff<tol) {resu[ii,]<-round(xx1,0)}
       if (diff<tol) {ii<-ii+1}
       kk<-kk+1
    }
    output=list(reglog=xx, pichap=pistar, resu=resu,nb_essai=kk, suff=const)
    output
 }
#
# Evaluation of the cube method rows in Table 3
# As elmr is no longer on the CRAN, a csv file for the 
# the urinary tract data set is provided with the supplementary material
# 
 utiDat<-read.csv(file="urinary.csv", row.names = 1)
#  Creation of the desagregated data set
 uti1<-uti2<-uti3<-uti4<-uti5<-uti6<-uti7<-uti8<-uti9<-y.uti<-numeric(0)
 for (i in (1:nrow(utiDat))){
   y.uti<-c(y.uti,rep(1,utiDat$uti[i]),rep(0,(utiDat$n[i]-utiDat$uti[i])) )
   uti1<-c(uti1,rep(utiDat$current[i],utiDat$n[i]))
   uti2<-c(uti2,rep(utiDat$age[i],utiDat$n[i]))
   uti3<-c(uti3,rep(utiDat$dia[i],utiDat$n[i]))
   uti4<-c(uti4,rep(utiDat$oc[i],utiDat$n[i]))
   uti5<-c(uti5,rep(utiDat$pastyr[i],utiDat$n[i]))
   uti6<-c(uti6,rep(utiDat$vi[i],utiDat$n[i]))
   uti7<-c(uti7,rep(utiDat$vic[i],utiDat$n[i]))
   uti8<-c(uti8,rep(utiDat$vicl[i],utiDat$n[i]))
   uti9<-c(uti9,rep(utiDat$vis[i],utiDat$n[i]))
 }
 uti.var=cbind(uti1,uti2,uti3,uti4,uti5,uti6,uti7,uti8,uti9)
 #  Standard logistic regression analysis of the data
 summary(glm(y.uti ~ uti.var, family=binomial))

 # the Z-variable dia is uti3


 set.seed(2900)
 start<-Sys.time()
 utiDat.simul_equi = exact(y.uti,uti.var[,-3], tol=0.1,B=10000)
 end<-Sys.time()
 end-start
 #  the simulation of 10 000 samples requested about 1.00 minute
 
 # Evaluation of Z^Ty
dia_test<-as.vector(utiDat.simul_equi$resu%*%uti3)
cub<-table(dia_test)/10000
cub
 #  The conditional distribution of the sufficient statistics for DIA is
 #0      1      2      3      4      5      6      7 
 #0.00 0.0032 0.0352 0.1396 0.2983 0.3317 0.1632 0.0288 
# The cube p-value is .0032+.0288 =.0320




#  Success rate
10000/utiDat.simul_equi$nb_essai  #  64%