.packageName <- "concor"
"concor" <-
function(x,y,py,r) {
# INITIALISATIONS 
n<-dim(x)[1]
p<-dim(x)[2]
q<-dim(y)[2]

if (sum(py) != q ) stop("py IS NOT SUITABLE")
if (r > min(c(min(py),q,n))) stop("r IS TOO HIGH")

ky<-length(py)
cri<-matrix(0,ky,r)
cumuly=cumsum(c(0,py))
u<-matrix(0,p,r)
V<-matrix(0,q,r)
v<-V

for (i in 1:r) {
  s<-svd(t(x)%*%y)
  u[,i]<-s$u[,1]
  V[,i]<-s$v[,1]
  c1=s$d[1]^2
   for (k in 1:ky) {
ay<-(cumuly[k]+1):cumuly[k+1]
ny<-t(V[ay,i])%*%V[ay,i]
cri[k,i]<-ny*c1 
        if (ny > 1e-8) {
 v[ay,i]<-V[ay,i]/sqrt(ny)
         y[,ay]<-y[,ay]-y[,ay]%*%(v[ay,i]%*%t(v[ay,i]))
        }
   }
}
list(u=u,v=v,V=V,cov2=cri/n^2)
}

"concorcano" <-
function(x,y,py,r) {
# INITIALISATIONS 

n<-dim(x)[1]
q<-dim(y)[2]
if (sum(py) != q ) stop("py IS NOT SUITABLE")

s<-svd(x);rk<-sum(s$d > max(dim(x))*s$d[1]*1e-8)
P<-matrix(s$u[,1:rk]*sqrt(n),ncol=rk)

ky<-length(py)
ry<-matrix(0,1,ky)

Py<-NULL
cuy=c(0,cumsum(py))
for (j in 1:ky) {
 s<-svd(y[,(cuy[j]+1):cuy[j+1]])
 ry[j]<-sum(s$d > max(c(n,py[j]))*s$d[1]*1e-8)
 Py<-cbind(Py,s$u[,1:ry[j]])
}

if (r > min(c(min(ry),rk,n))) stop("r IS TOO HIGH")
Py<-matrix(Py,ncol=sum(ry))*sqrt(n)
s<-concor(P,Py,ry,r);
cumuly<-cumsum(c(0,ry))
cy<-matrix(0,ky*n,r)
   for (k in 1:ky) {
ay<-(cumuly[k]+1):cumuly[k+1]
cy[(n*(k-1)+1):(n*k),]<-matrix(Py[,ay],ncol=ry[k])%*%s$v[ay,]
   }
list(cx=P%*%s$u,cy=cy,rho2=s$cov2)
}

"concoreg" <-
function(x,y,py,r) { 
n<-dim(x)[1]
q<-dim(y)[2]
if (sum(py) != q ) stop("py IS NOT SUITABLE")

# rk here is a maximal value given for the rank of x. 
# you may modify the tolerance 1e-8
s<-svd(x);rk<-sum(s$d > max(dim(x))*s$d[1]*1e-8)
if (r > min(c(min(py),rk,n))) stop("r IS TOO HIGH")

P=matrix(s$u[,1:rk]*sqrt(n),ncol=rk)
s<-concor(P,y,py,r)
list(cx=P%*%s$u,v=s$v,V=s$V,varexp=s$cov2)
}

"concorgm" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
s<-svdbip(t(x)%*%y,px,py,r)
list(u=s$u,v=s$v,cov2=s$s2/dim(x)[1]^2)
}

"concorgmcano" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
n<-dim(x)[1]
kx<-length(px)
rx<-matrix(0,1,kx)
Px<-NULL
cux=c(0,cumsum(px))
 for (j in 1:kx) {
  s<-svd(x[,(cux[j]+1):cux[j+1]])
  rx[j]<-sum(s$d > max(c(n,px[j]))*s$d[1]*1e-8)
  Px<-cbind(Px,s$u[,1:rx[j]]*sqrt(n))
 }
cux<-c(0,cumsum(rx))
Px<-matrix(Px,nrow=n)
ky<-length(py)
ry<-matrix(0,1,ky)
Py<-NULL
cuy=c(0,cumsum(py))
 for (j in 1:ky) {
  s<-svd(y[,(cuy[j]+1):cuy[j+1]])
  ry[j]<-sum(s$d > max(c(n,py[j]))*s$d[1]*1e-8)
  Py<-cbind(Py,s$u[,1:ry[j]]*sqrt(n))
 }
if (r > min(c(min(ry),min(rx),n))) stop("r IS TOO HIGH")
cuy<-c(0,cumsum(ry))
Py<-matrix(Py,nrow=n)
s<-concorgm(Px,rx,Py,ry,r)
cy<-matrix(0,n*ky,r)
cx<-matrix(0,n*kx,r)

for  (j in 1:kx) {
cx[((j-1)*n+1):(j*n),]<-matrix(Px[,(cux[j]+1):cux[j+1]],nrow=n)%*%s$u[(cux[j]+1):cux[j+1],]
}
for  (j in 1:ky) cy[((j-1)*n+1):(j*n),]<-matrix(Py[,(cuy[j]+1):cuy[j+1]],nrow=n)%*%s$v[(cuy[j]+1):cuy[j+1],]

list(cx=cx,cy=cy,rho2=s$cov2)
}

"concorgmreg" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
n<-dim(x)[1]
kx<-length(px)
rx<-matrix(0,1,kx)
Px<-NULL
cux=c(0,cumsum(px))
 for (j in 1:kx) {
  s<-svd(x[,(cux[j]+1):cux[j+1]])
  rx[j]<-sum(s$d > max(c(n,px[j]))*s$d[1]*1e-8)
  Px<-cbind(Px,s$u[,1:rx[j]])
 }
Px<-Px*sqrt(n)
if (r > min(c(min(py),min(rx),n))) stop("r IS TOO HIGH")

cux<-c(0,cumsum(rx))
Px<-matrix(Px,ncol=cux[kx+1])
s<-concorgm(Px,rx,y,py,r)
cx<-matrix(0,n*kx,r)
for  (j in 1:kx) cx[((j-1)*n+1):(j*n),]<-matrix(Px[,(cux[j]+1):cux[j+1]],nrow=n)%*%s$u[(cux[j]+1):cux[j+1],]
list(cx=cx,v=s$v,varexp=s$cov2)
}

"concors" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
s<-svdbips(t(x)%*%y,px,py,r)
list(u=s$u,v=s$v,cov2=s$s2/dim(x)[1]^2)
}

"concorscano" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
n<-dim(x)[1]
kx<-length(px)
rx<-matrix(0,1,kx)
Px<-NULL
cux=c(0,cumsum(px))
 for (j in 1:kx) {
  s<-svd(x[,(cux[j]+1):cux[j+1]])
  rx[j]<-sum(s$d > max(c(n,px[j]))*s$d[1]*1e-8)
  Px<-cbind(Px,s$u[,1:rx[j]]*sqrt(n))
 }
cux<-c(0,cumsum(rx))
Px<-matrix(Px,nrow=n)
ky<-length(py)
ry<-matrix(0,1,ky)
Py<-NULL
cuy=c(0,cumsum(py))
 for (j in 1:ky) {
  s<-svd(y[,(cuy[j]+1):cuy[j+1]])
  ry[j]<-sum(s$d > max(c(n,py[j]))*s$d[1]*1e-8)
  Py<-cbind(Py,s$u[,1:ry[j]]*sqrt(n))
 }
if (r > min(c(min(ry),min(rx),n))) stop("r IS TOO HIGH")
cuy<-c(0,cumsum(ry))
Py<-matrix(Py,nrow=n)
s<-concors(Px,rx,Py,ry,r)
cy<-matrix(0,n*ky,r)
cx<-matrix(0,n*kx,r)

for  (j in 1:kx) {
cx[((j-1)*n+1):(j*n),]<-matrix(Px[,(cux[j]+1):cux[j+1]],nrow=n)%*%s$u[(cux[j]+1):cux[j+1],]
}
for  (j in 1:ky) cy[((j-1)*n+1):(j*n),]<-matrix(Py[,(cuy[j]+1):cuy[j+1]],nrow=n)%*%s$v[(cuy[j]+1):cuy[j+1],]

list(cx=cx,cy=cy,rho2=s$cov2)
}

"concorsreg" <-
function(x,px,y,py,r) { 
if (sum(px) != dim(x)[2] | sum(py) != dim(y)[2] ) stop("px or py IS NOT SUITABLE")
n<-dim(x)[1]
kx<-length(px)
rx<-matrix(0,1,kx)
Px<-NULL
cux=c(0,cumsum(px))
 for (j in 1:kx) {
  s<-svd(x[,(cux[j]+1):cux[j+1]])
  rx[j]<-sum(s$d > max(c(n,px[j]))*s$d[1]*1e-8)
  Px<-cbind(Px,s$u[,1:rx[j]]*sqrt(n))
 }
if (r > min(c(min(py),min(rx),n))) stop("r IS TOO HIGH")

cux<-c(0,cumsum(rx))
Px<-matrix(Px,ncol=cux[kx+1])
s<-concors(Px,rx,y,py,r)
cx<-matrix(0,n*kx,r)
for  (j in 1:kx) cx[((j-1)*n+1):(j*n),]<-matrix(Px[,(cux[j]+1):cux[j+1]],nrow=n)%*%s$u[(cux[j]+1):cux[j+1],]
list(cx=cx,v=s$v,varexp=s$cov2)
}

"svdbip" <-
function(x,K,H,r) {
# INITIALISATIONS 
p<-dim(x)[1]
q<-dim(x)[2]

if (sum(H) != q | sum(K) != p) stop("K or H IS NOT SUITABLE")
if (r > min(c(K,H))) stop("r IS NOT SUITABLE")
M<-length(K)
N<-length(H)
u<-matrix(0,p,r)
v<-matrix(0,q,r)
ck<-cumsum(c(0,K))
ch<-cumsum(c(0,H))
A<-matrix(0,p,N)
B<-matrix(0,q,M)
s2<-array(0,c(M,N,r))

# ALGORITHM
for (k in 1:r) {

 #PROPOSED INITIALISATION OF THE ALGORITHM with u
    for (i in 1:M) {
      ak<-(ck[i]+1):ck[i+1]
     s<-svd(matrix(x[ak,],nrow=length(ak)))
      u[ak,k]<-s$u[,1]
    }


 cc<-s$d[1];cc1<-0;
 #comp<-0;

 while (abs(cc-cc1) > 1e-8) {
  #aa^2 and bb^2 are converging to the optimized criterion
  aa<-0;bb<-0;
  cc1<-cc;

  #comp<-comp+1;

   for (j in 1:N) {
    ah<-(ch[j]+1):ch[j+1]
     for (i in 1:M) {
      ak<-(ck[i]+1):ck[i+1]
      B[ah,i]<-t(matrix(x[ak,ah],nrow=length(ak)))%*%u[ak,k]
     }
    s<-svd(matrix(B[ah,],nrow=length(ah)))
    if (s$d[1] > 1e-8) { v[ah,k]<-s$u[,1]; aa<-aa+s$d[1] }
   }


   for (i in 1:M) {
     ak<-(ck[i]+1):ck[i+1]
       for (j in 1:N) {
        ah<-(ch[j]+1):ch[j+1]
      A[ak,j]<- matrix(x[ak,ah],nrow=length(ak))%*%v[ah,k]
       }
    s<-svd(matrix(A[ak,],nrow=length(ak)))
       if (s$d[1] > 1e-8) {u[ak,k]<-s$u[,1];bb<-bb+s$d[1]}
   }

  cc<-(aa+bb)/2
 }
 
   for (i in 1:M) {
    ak<-(ck[i]+1):ck[i+1]
     for (j in 1:N) {
     ah<-(ch[j]+1):ch[j+1]
     c<-t(u[ak,k])%*%x[ak,ah]%*%v[ah,k]
x[ak,ah]<-x[ak,ah]-u[ak,k]%*%t(u[ak,k])%*%x[ak,ah]-x[ak,ah]%*%(v[ah,k]%*%t(v[ah,k]))+u[ak,k]%*%c%*%t(v[ah,k])   
     s2[i,j,k]<-c^2
     }
   }
 #comp
}
list(u=u,v=v,s2=s2)
}

"svdbip2" <-
function(x,K,H,r) {
# INITIALISATIONS 
p<-dim(x)[1]
q<-dim(x)[2]

if (sum(H) != q | sum(K) != p) stop("K or H IS NOT SUITABLE")
if (r > min(c(K,H))) stop("r IS NOT SUITABLE")
M<-length(K)
N<-length(H)
u<-matrix(0,p,r);u1<-u
v<-matrix(0,q,r);v1<-v
ck<-cumsum(c(0,K))
ch<-cumsum(c(0,H))
s2<-array(0,c(M,N,r))

# INITIALISATIONS 

# ALGORITHM
for (k in 1:r) {
 a<-2
 #comp<-0

# PROPOSED INITIALISATION OF THE ALGORITHM, for u and v
 for (i in 1:M) {
   for (j in 1:N) {
    ak<-(ck[i]+1):ck[i+1]
    ah<-(ch[j]+1):ch[j+1]
    s<-svd(matrix(x[ak,ah],nrow=length(ak)))
    u[ak,k]<-s$u[,1];v[ah,k]<-s$v[,1]
   }
 }
a<-2;b<-0
 while (abs(a-b) > 1e-8) {
 #a^2 converge to the optimized criterion
 b<-a
  #comp<-comp+1
   a<-0
    v2<-matrix(0,q,1)
   for (j in 1:N) {
     ah<-(ch[j]+1):ch[j+1]
      for (i in 1:M) {
       ak<-(ck[i]+1):ck[i+1]
       v2[ah]<-v2[ah]+ t(matrix(x[ak,ah],nrow=length(ak)))%*%(u[ak,k]%*%t(u[ak,k])%*%x[ak,ah]%*%v[ah,k])
      }
     a2<-sqrt(t(v2[ah])%*%v2[ah]);
     if (a2 > 1e-8) v[ah,k]<-v2[ah]/a2 else v[ah,k]<-v2[ah]
   }

    u2<-matrix(0,p,1)
   for (i in 1:M) {
       ak<-(ck[i]+1):ck[i+1]
       for (j in 1:N) {
         ah<-(ch[j]+1):ch[j+1]
        u2[ak]=u2[ak]+ matrix(x[ak,ah],nrow=length(ak))%*%v[ah,k]%*%t(v[ah,k])%*%t(matrix(x[ak,ah],nrow=length(ak)))%*%u[ak,k]
       }
     a2<-sqrt(t(u2[ak])%*%u2[ak]);a<-a+a2
     if (a2 > 1e-8) u[ak,k]<-u2[ak]/a2  else u[ak,k]<-u2[ak]
   }

   a<-sqrt(a)
 }
 
   for (i in 1:M) {
    ak<-(ck[i]+1):ck[i+1]
     for (j in 1:N) {
     ah<-(ch[j]+1):ch[j+1]
     c<-t(u[ak,k])%*%x[ak,ah]%*%v[ah,k]    
    
x[ak,ah]<-x[ak,ah]-u[ak,k]%*%t(u[ak,k])%*%x[ak,ah]-x[ak,ah]%*%(v[ah,k]%*%t(v[ah,k]))+u[ak,k]%*%c%*%t(v[ah,k])   
     s2[i,j,k]<-c^2
     }
   }
 #comp
}
list(u=u,v=v,s2=s2)
}

"svdbips" <-
function(x,K,H,r) {
# INITIALISATIONS 
p<-dim(x)[1]
q<-dim(x)[2]
if (sum(H) != q | sum(K) != p) stop("K or H IS NOT SUITABLE")
if (r > min(c(K,H))) stop("r IS NOT SUITABLE")
M<-length(K)
N<-length(H)
u<-matrix(0,p,r)
v<-matrix(0,q,r)
ck<-cumsum(c(0,K))
ch<-cumsum(c(0,H))
s2<-array(0,c(M,N,r))

 #PROPOSED INITIALISATION OF THE ALGORITHM with u and v
    for (i in 1:M) {
      ak<-(ck[i]+1):ck[i+1]
      s<-svd(matrix(x[ak,],nrow=length(ak)))
      u[ak,]<-s$u[,1:r]
    }

    for (j in 1:N) {
      ah<-(ch[j]+1):ch[j+1]
      s<-svd(matrix(x[,ah],ncol=length(ah)))
      v[ah,]<-s$v[,1:r]
    }
cc<-2;cc1<-0

#ALGORITHM
while (abs(cc-cc1) > 1e-8) {
  #aa and bb are converging to the optimized criterion
 aa=0;bb=0;
 cc1=cc;
 A<-matrix(0,p,r)
 B<-matrix(0,r,q)

for (i in 1:M) {
ak<-(ck[i]+1):ck[i+1]
  for (j in 1:N) {
          ah<-(ch[j]+1):ch[j+1]
  d<-diag(t(u[ak,])%*%x[ak,ah]%*%v[ah,]);l<-length(d)
  A[ak,]<-A[ak,]+matrix(x[ak,ah],nrow=K[i])%*%v[ah,]%*%diag(d,nrow=l)
  }
s<-svd(A[ak,]);u[ak,]<-s$u[,1:r]%*%t(s$v)
        aa<-aa+sum(s$d)
}

  for (j in 1:N) {
ah<-(ch[j]+1):ch[j+1]
  for (i in 1:M) {
          ak<-(ck[i]+1):ck[i+1]
          d<-diag(t(u[ak,])%*%x[ak,ah]%*%v[ah,]);l<-length(d)
  B[,ah]<-B[,ah]+diag(d,nrow=l)%*%t(u[ak,])%*%x[ak,ah]
  } 
s<-svd(t(B[,ah]));v[ah,]<-s$u[,1:r]%*%t(s$v)
        bb<-bb+sum(s$d)
}

 cc<-(sqrt(aa)+sqrt(bb))/2
}

 for (k in 1:r) {
   for (i in 1:M) {
    ak<-(ck[i]+1):ck[i+1]
     for (j in 1:N) {
     ah<-(ch[j]+1):ch[j+1]
    s2[i,j,k]<-(t(u[ak,k])%*%x[ak,ah]%*%v[ah,k])^2
     }
   }
 }
list(u=u,v=v,s2=s2)
}

"svdcp" <-
function(x,H,r) { 
# Initialisations 
q<-dim(x)[2]
if (sum(H) != q) print("YOUR H IS NOT SUITABLE")

k<-length(H)
s2<-matrix(0,k,r)
u<-matrix(0,dim(x)[1],r);
v<-matrix(0,q,r);
kx<-cumsum(c(0,H));

# Calculus
 for (i in 1:r) {
  s<-svd(x)
  u[,i]<-s$u[,1]
    for (j in 1:k) {
ax <- (kx[j]+1):kx[j+1]
norm2 <- t(s$v[ax,1]) %*% s$v[ax,1]
      s2[j,i]<-norm2 * s$d[1]^2 
      if (s2[j,i] > 1e-8) {
v[ax,i]<-s$v[ax,1]/sqrt(norm2)
x[,ax] <- x[,ax]-x[,ax]%*%(v[ax,i]%*%t(v[ax,i]))
       }

    }
 }

list(u=u,v=v,s2=s2)
}

