.packageName <- "sampling"
HTestimator<-function(y,pik,s)
{crossprod(y[s==1],s[s==1]/pik[s==1])}

"UPMEpik2frompikw" <-
function(pik,w)
{
n=sum(pik)
N=length(pik)
M=array(0,c(N,N))
for(k in 1:N) for(l in 1:N)
  if(pik[k]!=pik[l] & k!=l) M[k,l]= (pik[k]*w[l]-pik[l]*w[k])/(w[l]-w[k]) else M[k,l]=-1
for(i in 1:N) M[i,i]=pik[i]
for(k in 1:N)
  {
  tt=0
  comp=0
  for(l in 1:N)
        {if(M[k,l]!=-1) tt=tt+M[k,l]
         else comp=comp+1;
        }
        cc=(n*pik[k]-tt)/comp
for(l in 1:N)  if(M[k,l]==-1) M[k,l]=cc
  }
M
}

"UPMEpikfromq" <-
function(q) 
{ 
n=ncol(q)
N=nrow(q)
pro=array(0,c(N,n))
pro[1,n]=1 
for(i in 2:N) 
for(j in 2:n) 
{ 
pro[i,j]=pro[i,j]+pro[i-1,j]*(1-q[i-1,j]) 
pro[i,j-1]=pro[i,j-1]+pro[i-1,j]*(q[i-1,j]) 
}; 
for(i in 2:N) 
{ 
pro[i,1]=pro[i,1]+pro[i-1,1]*(1-q[i-1,1]) 
} 
rowSums(pro*q) 
}

"UPMEpiktildefrompik" <-
function(pik,eps=1e-6) 
{ 
N=length(pik)
n=sum(pik) 
pikt=pik 
arr=1 
while(arr>eps) 
{ 
w=(pikt)/(1-pikt) 
q=UPMEqfromw(w,n)
pikt1=pikt+pik-UPMEpikfromq(q) 
arr=sum(abs(pikt-pikt1)) 
pikt=pikt1 
} 
pikt
}

"UPMEqfromw" <-
function(w,n)
{
N=length(w)
expa=array(0,c(N,n))
for(i in 1:N) expa[i,1]= sum(w[i:N]) 
for(i in (N-n+1):N) expa[i,N-i+1]=exp(sum(log(w[i:N]))) 
for(i in (N-2):1) 
for(z in 2:min(N-i,n)) 
{ 
expa[i,z]=w[i]*expa[i+1,z-1]+expa[i+1,z] 
} 
q=array(0,c(N,n))
for(i in N:1) q[i,1]= w[i]/expa[i,1]
for(i in N:(N-n+1)) q[i,N-i+1]=1
for(i in (N-2):1) 
for(z in 2:min(N-i,n)) 
q[i,z] = w[i]*expa[i+1,z-1]/expa[i,z]
q
}

"UPMEsfromq" <-
function(q)
{
n=ncol(q)
N=nrow(q)
s=rep(0,times=N) 
for(k in 1:N) 
if(n!=0) if(runif(1)<q[k,n]) {s[k]=1;n=n-1} 
s 
}

"UPbrewer" <-
function(pik, eps = 1e-06)
{
liste = pik > eps & pik < 1 - eps
pikb = pik[liste]
N = length(pikb)
n = sum(pikb)
sb=rep(0,times=N)
for(i in 1:n)
{
n=sum(pikb)
a=sum(pikb*sb)
p=(1-sb)*pikb*(n-a-pikb)/(n-a-pikb*(n-(i-1)))
p=p/sum(p)
for(i in 2:N) p[i]=p[i]+p[i-1]
u=runif(1)
j=1
while(u>=p[j]) j=j+1
sb[j]=1
}
s = pik
s[liste] = sb
round(s)
}

"UPmaxentropy" <-
function(pik) 
{ 
n=sum(pik)
if(n>=2)
{
pik2=pik[pik!=1]
n=sum(pik2)
piktilde=UPMEpiktildefrompik(pik2) 
w=piktilde/(1-piktilde) 
q=UPMEqfromw(w,n)
s2=UPMEsfromq(q)
s=rep(0,times=length(pik))
s[pik==1]=1
s[pik!=1][s2==1]=1
}
if(n==0) s=rep(0,times=length(pik))
if(n==1) s=as.vector(rmultinom(1, 1,pik)) 
s
}

"UPmaxentropypi2" <-
function(pik)
{
n=sum(pik)
N=length(pik)
M=array(0,c(N,N))
if(n>=2)
{
pik2=pik[pik>0 & pik<1]
pikt=UPMEpiktildefrompik(pik2)
w=pikt/(1-pikt)
M[pik>0 & pik<1,pik>0 & pik<1]=UPMEpik2frompikw(pik2,w)
M[,pik==1]=pik
for(k in 1:N) if(pik[k]==1)  M[k,]=pik
}
if(n==1) for(k in 1:N) M[k,k]=pik[k];
M
}

"UPmidzuno" <-
function(pik) 1-UPtille(1-pik)

"UPmidzunopi2" <-
function(pik) 
{
N=length(pik)
UN=rep(1,times=N)
b=1-pik%*%t(UN)
1-b-t(b)+UPtillepi2(1-pik)
}

"UPminimalsupport" <-
function(pik)
{
basicsplit<-function(pik)
{
N=length(pik)
n=sum(pik)
A=(1:N)[pik==0]
B=(1:N)[pik==1]
C=setdiff(setdiff(1:N,A),B)
D=C[sample(length(C), round(n-length(B)))]
s1v=rep(0,times=N)
s1v[c(B,D)]=1
alpha=min(1-max(pik[setdiff(C,D)]),min(pik[D]))
pikb= (pik-alpha*s1v)/(1-alpha)
if(runif(1,0,1)<alpha) s=s1v else s=pikb
s
}
is.a.sample<-function(s,EPS=sqrt(.Machine$double.eps)) if(sum(abs(s-round(s)))<EPS) TRUE else FALSE
while(!is.a.sample(pik))pik=basicsplit(pik) 
round(pik)
}

"UPmultinomial" <-
function(pik) 
as.vector(rmultinom(1,sum(pik),pik/sum(pik)))

"UPpivotal" <-
function(pik,eps=1e-6)
{
N<-length(pik)
s<-rep(0,times=N)
a<-pik[1]
b<-pik[2]
i<-1
j<-2
k<-3
while(k<=N)
{
u<-runif(1)
if(a>=eps & a<= 1-eps & b>=eps & b<= 1-eps)
if(a+b>1)
	{
		if(u<(1-b)/(2-a-b)) 
			{b<-a+b-1;a<-1} 
		else {a<-a+b-1;b<-1} 
      }
	else{ if(u< b/(a+b)) 
			{b<- a+b;a<-0} 
            else {a<- a+b;b<-0} 
           }
      if( (a<eps | a > 1-eps)& (k<=N)) 
                {s[i]=a;a=pik[k];i=k;k=k+1;} 
      if( (b<eps | b > 1-eps)& (k<=N) ) 
                  {s[j]=b;b=pik[k];j=k;k=k+1;} 
}
u<-runif(1)
if(a>=eps & a<= 1-eps & b>=eps & b<= 1-eps)
if(a+b>1)
          {
            if(u<(1-b)/(2-a-b)) {b<-a+b-1;a<-1} 
            else {a<-a+b-1;b<-1} 
          }
 else{ if(u< b/(a+b)) 
                 		{b<- a+b;a<-0} 
       else {a<- a+b;b<-0} 
       } 
s[i]=a; s[j]=b;
round(s)
}

"UPpoisson" <-
function(pik) as.integer(runif(length(pik))<pik)

"UPrandompivotal" <-
function(pik)
{
N=length(pik)
v=sample(c(N),N)
s=numeric(N)
s[v]=UPpivotal(pik[v])
s
}

"UPrandomsystematic" <-
function(pik)
{
N=length(pik)
v=sample(N,N)
s=numeric(N)
s[v]=UPsystematic(pik[v])
s
}

"UPsampford" <-
function(pik,eps=1e-6)
{
liste= pik>eps & pik < 1-eps
pikb=pik[liste]
n=sum(pikb)
N=length(pikb)
sb=rep(2,times=N)
y=pikb/(1-pikb)/sum(pikb/(1-pikb))
while(sum(sb<=1)!=N)
	sb=as.vector(rmultinom(1,1,pikb/sum(pikb))+rmultinom(1,n-1,y))
s=pik
s[liste]=sb
s
}

"UPsystematic" <-
function (pik) 
{
pik1=pik[pik>0 & pik< 1]
N=length(pik1)
a=(c(0,cumsum(pik1))-runif(1,0,1)) %% 1
s1=as.integer(a[1:N]>a[2:(N+1)])
s=pik
s[pik>0 & pik< 1]=s1
s
}

"UPsystematicpi2" <-
function (pik) 
{
pik1=pik[pik>0 & pik< 1]
N=length(pik1)
Vk=cumsum(pik1)
r=c(sort(Vk %% 1),1)
cent= (r[1:N]+r[2:(N+1)])/2
p=r[2:(N+1)]-r[1:N]
A=matrix(c(0,Vk),nrow=N+1,ncol=N)-t(matrix(cent,nrow=N,ncol=N+1)) 
A = A %% 1
M=matrix(as.integer(A[1:N,]>A[2:(N+1),]),N,N)
pi21=M%*%diag(p)%*%t(M)
pi2=pik%*%t(pik)
pi2[pik>0 & pik< 1,pik>0 & pik< 1]=pi21
pi2
}

"UPtille" <-
function(pik,eps=1e-6)
{
liste= pik>eps & pik < 1-eps
pikb=pik[liste]
N=length(pikb)
n=sum(pikb)
sb=rep(1,times=N)
b=rep(1,times=N)
for(i in 1:(N-n))
{a=inclusionprobabilities(pikb,N-i)
v=1-a/b
b=a
p=v*sb
for(i in 2:N) p[i]=p[i]+p[i-1]
u=runif(1)
j=1
while( u>=p[j] ) j=j+1
sb[j]=0
}
s=pik
s[liste]=sb
s
}

"UPtillepi2" <-
function(pik,eps=1e-6)
{
liste= pik>eps & pik < 1-eps
pikb=pik[liste]
N=length(pikb)
n=sum(pikb)
pp=1
UN=rep(1,times=N)
b=rep(1,times=N)
for(i in 1:(N-n))
{
a=inclusionprobabilities(pikb,N-i)
vv=1-a/b
b=a
d=vv %*% t(UN)
pp=pp*(1-d-t(d))
}
for(i in 1:N) pp[i,i]=pikb[i]
ppf=pik%*%t(pik)
ppf[liste,liste]=pp
ppf
}

"balancedcluster" <-
function(X,m,cluster,selection=1,comment=TRUE,method=1)
{
cluster=cleanstrata(cluster)
if(comment==TRUE) cat("\nSELECTION OF A SAMPLE OF CLUSTERS\n")
p=dim(X)[2]
N=dim(X)[1]
H=max(cluster)
XC=array(0,c(H,p))
Ni=rep(0,times=H)
for(h in 1:H)
   { Ni[h]=sum(as.integer(cluster==h)) 
    for(j in 1:p)  XC[h,j]=sum(X[cluster==h,j]) 
   }
if(selection==1) pik=inclusionprobabilities(Ni,m) else pik=rep(m/H,times=H)
s=samplecube(cbind(pik,XC),pik,1,TRUE,method) 
res=array(0,c(N,2))
for(h in 1:H) 
    {
     res[cluster==h,1]=s[h] 
     res[cluster==h,2]=pik[h]
     }
res
}

"balancedstratification" <-
function(X,strat,pik,comment=TRUE,method=1)
{
strat=cleanstrata(strat)
H=max(strat)
N=dim(X)[1]
pikstar=rep(0,times=N)
for(h in 1:H) 
{
if(comment==TRUE) cat("\nFLIGHT PHASE OF STRATUM",h)
pikstar[strat==h]=fastflightcube(cbind(X[strat==h,],pik[strat==h]),pik[strat==h],1,comment) 
}
if(comment==TRUE) cat("\nFINAL TREATMENT")
XN=cbind(disjunctive(strat)*pik,X)/pik*pikstar
if(is.null(colnames(X))==FALSE)
    colnames(XN)<-c(paste("Stratum", 1:H, sep = ""),colnames(X))
samplecube(XN,pikstar,1,comment,method) 
}

"balancedtwostage" <-
function(X,selection,m,n,PU,comment=TRUE,method=1)
{
N=dim(X)[1]
p=dim(X)[2]
str=cleanstrata(PU)
M=max(PU)
res1=balancedcluster(X,m,PU,method,TRUE)
if(selection==2) 
        {
         pik2=rep(n/N*M/m,times=N);
         if(n/N*M/m>1) cat("Error : at the second stage, inclusion probabilities larger than 1");
         }
if(selection==1) 
        {
        pik2=inclusionprobastrata(str,rep(n/m ,times=max(str)));
        if(max(pik2)>1) cat("Error : at the second stage, inclusion probabilities larger than 1");
        }
liste=(res1[,1]==1)
sf=rep(0,times=N)
sf[liste]=balancedstratification(array(X[liste,]/res1[,2][liste],c(sum(as.integer(liste)),p)),cleanstrata(str[liste]),pik2[liste],TRUE,method)
x=cbind(sf,res1[,2]*pik2,res1[,1],res1[,2],pik2)
colnames(x)=c("second-stage","final_pik", "primary","pik_first_stage", "pik_second_stage")
x 
}

"boundedrakingratio" <-
function(Xs,piks,t,q=rep(1,times=length(piks)),LOW=0,UP=10)
{
library(MASS)
n=length(piks)
np=length(Xs)
p=np/n
Xs=array(Xs,c(n,p));
g=rakingratio(Xs,piks,t,q)
if(checkcalibration(Xs,piks,t,g))
  {
   p=dim(Xs)[2]
   n=length(piks)
   arret1=-1;
   arret=0;
   flag=rep(0,times=n);
   while(arret1!=arret &  (n-length(piks[flag!=0]))>0 )
       {
       flag=rep(0,times=n)
       for(i in 1:n)
         {
         if(g[i]<=LOW) {flag[i]=-1;g[i]=LOW;}
         if(g[i]>=UP)  {flag[i]= 1;g[i]=UP ;}
         }
       enl=rep(0,times=p)
       nr=length(piks[flag!=0])
       if(nr>0) 
             for(j in 1:p) enl[j]=sum(array((Xs*(g/piks))[flag!=0,],c(nr,p))[,j])
       tn=t-enl
       g1=rakingratio(Xs[flag==0,],piks[flag==0],tn,q[flag==0])
       g[flag==0]= g1
       if(checkcalibration(Xs,piks,t,g))
          {
          arret1=arret 
          arret=n-length(g[flag==0])
          } else
          {
          cat("\nError : Impossible to find calibration weights with these bounds\n")
          arret1=0
          arret=0
          }
        } 
   }
   else
   {
   cat("\nError : Impossible to find calibration weights\n")
   arret1=0
   arret=0
   }
g
}

"boundedregressionestimator" <-
function(Xs,piks,t,q=rep(1,times=length(piks)),LOW=0,UP=10)
{
library(MASS)
n=length(piks)
np=length(Xs)
p=np/n
Xs=array(Xs,c(n,p));
g=regressionestimator(Xs,piks,t,q)
if(checkcalibration(Xs,piks,t,g))
  {
   p=dim(Xs)[2]
   n=length(piks)
   arret1=-1;
   arret=0;
   flag=rep(0,times=n);
   while(arret1!=arret &  (n-length(piks[flag!=0]))>0 )
       {
       flag=rep(0,times=n)
       for(i in 1:n)
         {
         if(g[i]<=LOW) {flag[i]=-1;g[i]=LOW;}
         if(g[i]>=UP)  {flag[i]= 1;g[i]=UP ;}
         }
       enl=rep(0,times=p)
       nr=length(piks[flag!=0])
       if(nr>0) 
             for(j in 1:p) enl[j]=sum(array((Xs*(g/piks))[flag!=0,],c(nr,p))  [,j])
       tn=t-enl
       g1=regressionestimator(Xs[flag==0,],piks[flag==0],tn,q[flag==0])
       g[flag==0]= g1
       if(checkcalibration(Xs,piks,t,g))
          {
          arret1=arret 
          arret=n-length(g[flag==0])
          } else
          {
          cat("\nError : Impossible to find calibration weights with these bounds\n")
          arret1=0
          arret=0
          }
        } 
   }
   else
   {
   cat("\nError : Impossible to find calibration weights\n")
   arret1=0
   arret=0
   }
g
}

"checkcalibration" <-
function(Xs,pik,t,g)
{
EPS=1e-6
tr=crossprod(Xs,g/pik)
ee=t(tr-t)%*% (tr-t)
(ee<EPS)[1] 
}

"cleanstrata" <-
function(strata)
{
a=sort(unique(strata)) 
b=1:length(a) 
names(b)=a 
as.vector(b[as.character(strata)]) 
}

"disjunctive" <-
function(strata)
{ss=cleanstrata(strata)
m=matrix(0,length(strata),length(unique(strata)))
for(i in 1:length(ss)) m[i,ss[i]]=1
m
}

"fastflightcube" <-
function(X,pik,order=1,comment=TRUE) 
{ 
EPS = 1e-11
"algofastflightcube" <-
function(X,pik) 
{ 

"jump" <-
function(X,pik){ 
N = length(pik)
p = round(length(X)/length(pik))
X<-array(X,c(N,p))
X1=cbind(X,rep(0,times=N)) 
kern<-svd(X1)$u[,p+1] 
listek=abs(kern)>EPS
buff1<-(1-pik[listek])/kern[listek]
buff2<- -pik[listek]/kern[listek]
la1<-min( c(buff1[(buff1>0)] , buff2[(buff2>0)]) ) 
pik1<- pik+la1*kern 
buff1<- -(1-pik[listek])/kern[listek] 
buff2<- pik[listek]/kern[listek]
la2<-min(c(buff1[(buff1>0)] , buff2[(buff2>0)])) 
pik2<- pik-la2*kern 
q<-la2/(la1+la2)  
if (runif(1)<q) pikn<-pik1 else pikn<-pik2 
pikn 
}

N = length(pik)
p = round(length(X)/length(pik))
X<-array(X,c(N,p));
A<- X/pik; 
B<-A[1:(p+1),]; 
psik <- pik[1:(p+1)]; 
ind<-seq(1,p+1,1); 
pp=p+2; 
B<-array(B,c(p+1,p)); 
while(pp<=N) 
{ 
psik <- jump(B,psik); 
liste<- (psik>(1-EPS) | psik<EPS); 
i<- 0; 
while(i <=(p) & pp<=N) 
{ i=i+1;if(liste[i]==TRUE) 
{pik[ind[i]]=psik[i]; 
psik[i]=pik[pp] ; 
B[i,]=A[pp,];B<-array(B,c(p+1,p)); 
ind[i]=pp; 
pp=pp+1 } 
} 
} 
if(length(pik[(pik>EPS & pik<(1-EPS))])==(p+1)) psik <- jump(B,psik); 
pik[ind]=psik; 
pik 
}

"reduc" <-
function(X)
{
EPS=0.0000000001
N=dim(X)[1]
Re=svd(X)
array(Re$u[,(Re$d>EPS)] , c(N,sum(as.integer(Re$d>EPS))))
}

N = length(pik);
p = round(length(X)/length(pik));
X<-array(X,c(N,p));
if (order==1) o<-sample(N,N)  else
   {
   if(order==2) o<-seq(1,N,1) 
    else o<-order(pik,decreasing=TRUE)
    }
liste<-o[(pik[o]>EPS & pik[o]<(1-EPS))];
if(comment==TRUE){
cat("\nBEGINNING OF THE FLIGHT PHASE\n");
cat("The matrix of balanced variable has",p," variables and ",N," units\n");
cat("The size of the inclusion probability vector is ",length(pik),"\n");
cat("The sum of the inclusion probability vector is ",sum(pik),"\n");
cat("The inclusion probability vector has ",length(liste)," non-integer elements\n");
} 
pikbon<-pik[liste]; 
Nbon=length(pikbon); 
Xbon<-array(X[liste,] ,c(Nbon,p)); 
pikstar<-pik; 
flag=0;
if(Nbon>p){if(comment==TRUE) cat("Step 1  ");
           pikstarbon<-algofastflightcube(Xbon,pikbon); 
           pikstar[liste]=pikstarbon; 
           flag=1
           }
liste<-o[(pikstar[o]>EPS & pikstar[o]<(1-EPS))];
pikbon<-pikstar[liste]; 
Nbon=length(pikbon); 
Xbon<-array(X[liste,] ,c(Nbon,p)); 
pbon=dim(Xbon)[2]
if(Nbon>0){
          Xbon=reduc(Xbon)
          pbon=dim(Xbon)[2]
          }
k=2
while(Nbon>pbon & Nbon>0){
           if(comment==TRUE) cat("Step ",k,",  ");
           k=k+1;
           pikstarbon<-algofastflightcube(Xbon/pik[liste]*pikbon,pikbon); 
           pikstar[liste]=pikstarbon; 
           liste<-o[(pikstar[o]>EPS & pikstar[o]<(1-EPS))];
           pikbon<-pikstar[liste]; 
           Nbon=length(pikbon); 
           Xbon<-array(X[liste,] ,c(Nbon,p)); 
           if(Nbon>0)
               {
               Xbon=reduc(Xbon)
               pbon=dim(Xbon)[2]
               }
           flag=1
           }
if(comment==TRUE) if(flag==0) cat("NO FLIGHT PHASE");
if(comment==TRUE) cat("\n")
pikstar 
}

"inclusionprobabilities" <-
function(a,n)
{
nnull=length(a[(a==0)])
nneg=length(a[(a<0)])
if(nnull>0) cat("WARNING : There are ",null," null values\n")
if(nneg>0){
             cat("WARNING : There are ",nneg," negative value(s)")
             cat(" shifted to zero\n")
             a[(a<0)]=0
            }
pik=n*a/sum(a)
lll1=-1
list=(pik>=1)
lll=length(list[list==TRUE])
while(lll!=lll1 )
     {
     pik[(!list)]=(n-lll)*pik[(!list)]/sum(pik[(!list)])
     pik[(list)]=1
     lll1=lll
     list=(pik>=1)
     lll=length(list[list==TRUE])
     }
pik
}

"inclusionprobastrata" <-
function(strat,nh)
{
EPS=1e-6
N=length(strat)
v=unique(strat)
ma=max(v)
if(min(v)<1) cat("Error : the stratification variable has incorect values (less than 1)\n")
Nh=rep(0,times=ma)
for(i in 1:N) Nh[strat[i]]=Nh[strat[i]]+1
for(i in 1:ma) 
    if(nh[i]/Nh[i]>1+EPS) 
        cat("Error : in stratum ",i," the sample size is larger than the population size\n")
pik=rep(0,times=max(v))
for(i in 1:N)  pik[i]=nh[strat[i]]/Nh[strat[i]]
pik
}

"landingcube" <-
function(X,pikstar,pik,comment=TRUE) 
#
# landing phase of the cube method
#
######################################################
{ 
# 
# extraction of the non-integer values for the landing phase 
# 
library(MASS)
library(lpSolve)
EPS=0.00000000001;
p=dim(X)[2];
N=dim(X)[1];
liste=(pikstar>EPS & pikstar<(1-EPS)) 
pikland=pikstar[liste] 
Nland=length(pikland) 
Xland<- array(X[liste,] ,c(Nland,p)); 
nland=sum(pikland) 
FLAGI=(abs(nland-round(nland))<EPS);
# construction of the list of possible samples 
if(comment==TRUE){
cat("\n\nBEGINNING OF THE LANDING PHASE\n");
cat("At the end of the flight phase, there remain ",Nland,"non integer probabilities","\n");
cat("The sum of these probabilities is ",nland,"\n");
cat("This sum is "); 
if(FLAGI)  cat(" integer\n") else cat(" non-integer\n");
}
if(FLAGI) 
     {
      pikland=round(nland)*pikland/nland;
      nland=round(nland);
      SSS= writesample(nland,Nland) 
      }
else 
      SSS= rbind( writesample(trunc(nland),Nland), 
           writesample(trunc(nland)+1,Nland) ); 
lll=nrow(SSS);
if(comment==TRUE){
cat("The linear program will consider ",lll," possible samples\n")
} 
# computation of the cost 
Asmp=matrix(0,p,lll);
for(i in 1:lll)  {Asmp[,i]=t(Xland/pik[liste]) %*% (SSS[i,]-pikland) }
A<- X[pik>EPS,]/pik[pik>EPS]; 
cost=rep(0,times=lll) 
for(i in 1:lll) 
cost[i]=t(Asmp[,i]) %*% ginv(t(A) %*% A) %*% Asmp[,i] 
# linear programming
V = t(cbind(SSS,rep(1,times=lll)))
b=c(pikland,1)
constdir=rep("==",times=(Nland+1))
x=lp("min",cost,V,constdir,b)$solution
# choice of the sample
u=runif(1,0,1)
i=0
ccc=0
while(ccc<u) {i=i+1;ccc=ccc+x[i]}
if(comment==TRUE)
    {
     cat("The mean cost is ",mean(cost),"\n")
     cat("The smallest cost is ",min(cost),"\n")
     cat("The largest cost is ",max(cost),"\n")
     cat("The cost of the selected sample is",cost[i])
     }
pikfin=pikstar
pikfin[liste]=SSS[i,];
pikfin
}

"rakingratio" <-
function(Xs,piks,t,q=rep(1,times=length(piks)))
{
library(MASS)
ITERATIONS=300
EPS=.Machine$double.eps	
tol=.Machine$double.eps
#####################################################
n=length(piks)
np=length(Xs)
p=np/n
Xs=matrix(Xs,n,p)
Xs1=Xs[q!=0,];
piks1=piks[q!=0];
q1=q[q!=0];
n1=length(piks1)
if(n1!=n) t1= t-colSums(array((Xs/piks)[q==0,],c(n-n1,p))) else t1=t;
tc1=c( t(1/piks1) %*% Xs1);
########################################################
d1=1/piks1
tc1=c(d1%*%Xs1)
#####################################################
# definition of the exponential rakingratio function
#####################################################
Fcal<-function(u,v)   F=exp(u*v)
#####################################################
# definition of the derivative of
# the exponential rakingratio function
#####################################################
Fcalprime<-function(u,v)   v*exp(u*v)
###################################################
#
# phi is the function to solve
#
###################################################
phi<-function(lambda)
{
TT=0
for(k in 1:n1) TT=TT+d1[k]*Xs1[k,]*(Fcal(Xs1[k,]%*% lambda,q1[k])-1);
TT
}
###################################################
#
# phiprime is the derivative of phi
#
###################################################
phiprime<-function(lambda)
{
TT=0
for(k in 1:n1) TT=TT+(d1[k]*Xs1[k,]*Fcalprime(Xs1[k,]%*% lambda,q1[k]))%*%t(Xs1[k,])
TT
}
#####################################################
#
# solving the rakingratio equation 
#
#####################################################
lambda=rep(0,times=p);
lambda1=rep(1,times=p);
z=lambda-lambda1;
for(i in 1:ITERATIONS)
{
lambda1=lambda-ginv(phiprime(lambda),tol)%*%c(phi(lambda)-t1+tc1)
z=lambda-lambda1
if( (t(z)%*%z<EPS)) break
lambda=lambda1
}
if(i==ITERATIONS) cat("\nImpossible to solve the program\n")
###########################################################
g1=rep(0,times=n1)
for(k in 1:n1) g1[k]=Fcal(t(lambda)%*%Xs1[k,],q1[k])
g=rep(1,times=n)
g[q!=0]=g1
g
}

"regressionestimator" <-
function(Xs,piks,tot,q=rep(1,times=length(piks)))
{   library(MASS)
    tol=.Machine$double.eps
    n = length(piks)
    np = length(Xs)
    p = np/n
    Xs = matrix(Xs,n,p)
    Xs1 = Xs[q != 0, ]
    piks1 = piks[q != 0]
    q1 = q[q != 0]
    if (length(piks1)!= n) t1=tot-colSums((Xs/piks)[q==0,])
    else t1 = tot
w=1/piks1
tc1=c(t(w) %*% Xs1)
A=t(Xs1*q1*w)%*%Xs1
g1=1+q1*c(Xs1%*%ginv(A,tol)%*%(t1-tc1))
g=rep(1, times = n)
g[q != 0]=g1
g
}

"samplecube" <-
function(X,pik,order=1,comment=TRUE,method=1) 
{
EPS = 1e-11
N=length(pik)
if(is.array(X)!=TRUE) X=array(X,c(N,length(X)/N)) 
if(method==1)
{
    if (length(pik[pik > EPS & pik < (1 - EPS)]) > 0) 
        pikstar = fastflightcube(X, pik, order, comment)
    else {
        if (comment == TRUE) 
            cat("\nNO FLIGHT PHASE")
        pikstar = pik
    }
    if (length(pikstar[pikstar > EPS & pikstar < (1 - EPS)]) > 
        0) 
        pikfin = landingcube(X, pikstar, pik, comment)
    else {
        if (comment == TRUE) 
            cat("\nNO LANDING PHASE")
        pikfin = pikstar
    }
}
else
{   p=length(X)/length(pik)
    pikstar=pik
    for(i in 0:(p-1))
      {
      if (length(pikstar[pikstar > EPS & pikstar < (1 - EPS)]) > 0) 
      pikstar = fastflightcube(X[,1:(p-i)]/pik*pikstar, pikstar, order, comment)
      }
      pikfin = pikstar
      for(i in 1:N) if(runif(1)<pikfin[i]) pikfin[i]=1
}
if (comment == TRUE) {
        A <- X[pik > EPS, ]/pik[pik > EPS]
        TOT = t(A) %*% pik[pik > EPS]
        EST = t(A) %*% pikfin[pik > EPS]
        DEV = 100 * (EST - TOT)/TOT
        cat("\n\nQUALITY OF BALANCING\n")
        if(is.null(colnames(X)))  Vn = as.character(1:length(TOT)) else Vn=colnames(X);
        for(i in 1:length(TOT)) if(Vn[i]=="") Vn[i]=as.character(i)
	d = data.frame(TOTALS = c(TOT), 
        HorvitzThompson_estimators = c(EST), Relative_deviation = c(DEV))
        rownames(d)<-Vn
        print(d)
    }
    round(pikfin)
}

"srswor" <-
function(n,N)
{s<-rep(0,times=N);s[sample(N,n)]<-1;s}

"srswor1" <-
function(n,N)
{j=0
 s=numeric(N)
 for(k in 1:N) if(runif(1)<(n-j)/(N-k+1)) {j=j+1;s[k]=1;}
 s
}

"srswr" <-
function(n,N) as.vector(rmultinom(1,n,rep(n/N,times=N)))

"writesample" <-
function(n,N) 
{
if(n==N) samples= rep(1,times=N) 
else{ 
x=numeric(N) 
row=1 
for(i in (n+1):N) row=row*i 
k=1 
for(i in 1:(N-n)) k=k*i 
row=row/k 
samples=matrix(0,row,N) 
k=1 
sol=0 
x[1]=-1 
while(k<=N && k>0) 
{ 
while(x[k]<1) 
{ 
x[k]=x[k]+1 
s=0 
for(i in 1:N) 
s=s+x[i] 
if(s==n) { 
sol=sol+1 
samples[sol,]=x 
} 
else 
if(k<N){k=k+1 
x[k]=-1 
} 
} 
k=k-1 
} 
} 
samples
}

