.packageName <- "calibrate"
"calibrate" <-
function(g,y,tm,Fr,tmlab=tm,tl=0.05,dt=TRUE,dp=FALSE,lm=TRUE,verb=TRUE,axislab="",reverse=FALSE,shift=0,alpha=NULL,labpos=1,weights=diag(rep(1,length(y))),axiscol="blue",cex.axislab=0.75,graphics=TRUE,where=3,laboffset=c(0,0),m=matrix(c(0,0),nrow=1),markerpos=3,showlabel=TRUE) {

   if (is.matrix(weights))
      Dw <- weights
   else 
      if (is.vector(weights))
         Dw <- diag(weights)
      else
         stop("calibrate: weights is not a vector or matrix")

   if (verb>1)
      print(Dw)

   d<-matrix(c(0,0),nrow=1) # by default shift vector (0,0)

   if (shift!=0) {
      if(g[1]==0) {
         d2<-0
         d1<-1*abs(shift)
         d<-sign(shift)*matrix(c(d1,d2),nrow=1)
      } else {
      d2 <- sqrt(abs(shift)/(1+(g[2]/g[1])^2))
      d1 <- -d2*g[2]/g[1]
      d<-sign(shift)*matrix(c(d1,d2),nrow=1)
      }
      if (verb>1) {
         print(d)
         print(d%*%t(d))
      }
   }

   optalpha <- t(g)%*%t(Fr)%*%Dw%*%Fr%*%g / ((t(y)%*%Dw%*%Fr%*%g) * (t(g)%*%g)) # the optimal alpha
   optalpha <- optalpha[1,1]

   useralpha <- NULL

   if(is.null(alpha)) {
      alpha <- optalpha
   }
   else {
      useralpha <- alpha
   }

   Mmean <- matrix(rep(1,length(tm)),ncol=1)%*%m  # matrix of means

   M <- alpha*(tm)%*%t(g) + Mmean # tick marker positions

   nrM<-nrow(M)

   M <- M + matrix(rep(1,nrM),ncol=1)%*%d

   di <- 1/(alpha * t(g)%*%g)
   yt <- di[1,1]*Fr%*%g               # fitted values
   e <- y - yt                        # errors
   Q <- t(e)%*%Dw%*%e
   gos <- 1-Q/(t(y)%*%Dw%*%y)         # goodness of scale (a scale-dependent goodness of fit)

   odi <- 1/(optalpha * t(g)%*%g)
   oyt <- odi[1,1]*Fr%*%g             # optimal fitted values
   oe <- y - oyt                      # regression errors
   oQ <- t(oe)%*%Dw%*%oe
   gof <- 1-oQ/(t(y)%*%Dw%*%y)       # regression goodness of fit

   ang <- atan(g[2]/g[1])*180/pi
   lengthoneunit <- alpha*sqrt(t(g)%*%g)

   if(verb) {
       cat("---------- Calibration Results for ",axislab," ")
       for (i in 1:(60 - (38 + nchar(axislab)))) cat("-")
       cat("\n")
       cat("Length of 1 unit of the original variable = ",round(lengthoneunit,digits=4)," \n")
       cat("Angle                                     = ",round(ang,digits=2),"degrees\n")
       cat("Optimal calibration factor                = ",round(optalpha,digits=4)," \n")
       cat("Used calibration factor                   = ",round(alpha,digits=4)," \n")
       cat("Goodness-of-fit                           = ",round(gof,digits=4)," \n")
       cat("Goodness-of-scale                         = ",round(gos,digits=4)," \n")
       cat("------------------------------------------------------------\n")
   }

   Fr2 <- Fr[,1:2]
   nn<-t(g)%*%g
   scal <- (Fr2%*%g)/nn[1,1]                     # set of scaling factors
   Dscal <- diag(as.vector(scal))
   Fpr<-Dscal%*%matrix(rep(1,nrow(Fr)),ncol=1)%*%t(g)        # coordinates of projections onto the axis   

   deltax <- tl*sin(ang*pi/180)
   deltay <- tl*cos(ang*pi/180)

   if(reverse==TRUE) 
      Mn <- cbind(M[,1]-deltax,M[,2]+deltay)           # above
   else
      Mn <- cbind(M[,1]+deltax,M[,2]-deltay)           #  end of the tick mark

   if(graphics) {

#      lines(M,col=axiscol)                                 # draw the ax

      lines(rbind(M[1,],M[nrM,]),col=axiscol)

      if(lm) {                                            # label the markers
         if (reverse==TRUE)
            text(Mn[,1],Mn[,2],tmlab,pos=markerpos,offset=0.2,cex=cex.axislab,srt=ang)
         else
            if (markerpos > 2) 
               text(Mn[,1],Mn[,2],tmlab,pos=markerpos-2,offset=0.2,cex=cex.axislab,srt=ang)
            else 
               text(Mn[,1],Mn[,2],tmlab,pos=markerpos+2,offset=0.2,cex=cex.axislab,srt=ang)
      }

      nm<-nrow(M)

      if(dt==TRUE) {
         for(i in 1:nm) lines(rbind(M[i,1:2],Mn[i,1:2]),col=axiscol)   # draw tick marks
      }


      if (dp) { 
         nrFpr <- nrow(Fpr)
         dlines(Fr2+matrix(rep(1,nrFpr),ncol=1)%*%m,
                Fpr+matrix(rep(1,nrFpr),ncol=1)%*%m+matrix(rep(1,nrFpr),ncol=1)%*%d)           
         # draw perpendiculars onto the variable ax
      }

      # label the vector at beginning, middle or end of the scale. 

      if (showlabel) {
         switch(where,
         text(M[1,1]+laboffset[1],M[1,2]+laboffset[2],axislab,cex=cex.axislab,srt=ang,pos=labpos,offset=0.5),
         text(M[round(nrow(M)/2),1]+laboffset[1],M[round(nrow(M)/2),2]+laboffset[2],axislab,cex=cex.axislab,srt=ang,pos=labpos,offset=0.5),
         text(M[nrow(M),1]+laboffset[1],M[nrow(M),2]+laboffset[2],axislab,cex=cex.axislab,srt=ang,pos=labpos,offset=0.5))
      }
   }
      # M marker coordinates
      # yt fitted values.

   return(list(useralpha=useralpha,gos=gos,optalpha=optalpha,gof=gof,lengthoneunit=lengthoneunit,M=M,Q=Q,ang=ang,yt=yt,e=e,Fpr=Fpr,Mn=Mn))
}
"canocor" <-
function (X, Y) 
{
    Xs <- scale(X)
    Ys <- scale(Y)
    Rxx <- cor(X)
    Ryy <- cor(Y)
    Rxy <- cor(X, Y)
    d <- diag(eigen(Rxx)$values)
    v <- eigen(Rxx)$vectors
    Rxxmh <- v %*% sqrt(solve(d)) %*% t(v)
    d <- diag(eigen(Ryy)$values)
    v <- eigen(Ryy)$vectors
    Ryymh <- v %*% sqrt(solve(d)) %*% t(v)
    K <- Rxxmh %*% Rxy %*% Ryymh
    D <- diag(svd(K)$d)
    Ah <- svd(K)$u
    Bh <- svd(K)$v
    A <- Rxxmh %*% Ah
    B <- Ryymh %*% Bh
    U <- Xs %*% A
    V <- Ys %*% B
    Fs <- Rxx %*% A
    Fp <- Rxx %*% A %*% D
    Gs <- Ryy %*% B
    Gp <- Ryy %*% B %*% D
    Rxu <- Fs
    Rxv <- Fp
    Ryv <- Gs
    Ryu <- Gp
    lamb <- diag(D^2)
    frac <- lamb/sum(lamb)
    cumu <- cumsum(frac)
    fitRxy <- rbind(lamb, frac, cumu)
    AdeX <- apply(Rxu * Rxu, 2, mean)
    AdeY <- apply(Ryv * Ryv, 2, mean)
    RedX <- apply(Rxv * Rxv, 2, mean)
    RedY <- apply(Ryu * Ryu, 2, mean)
    cAdeX <- cumsum(AdeX)
    cAdeY <- cumsum(AdeY)
    cRedX <- cumsum(RedX)
    cRedY <- cumsum(RedY)
    fitXs <- rbind(AdeX, cAdeX)
    fitXp <- rbind(RedX, cRedX)
    fitYs <- rbind(AdeY, cAdeY)
    fitYp <- rbind(RedY, cRedY)
    return(list(ccor = D, A = A, B = B, U = U, V = V, Fs = Fs, Gs = Gs, 
        Fp = Fp, Gp = Gp, fitRxy = fitRxy, fitXs = fitXs, fitXp = fitXp, 
        fitYs = fitYs, fitYp = fitYp))
}
"circle" <-
function(radius=1) {
  x<-seq(-radius,radius,by=0.01)
  y<-sqrt(radius^2-x^2);
  lines(x,y)
  lines(x,-y)
  return(NULL)
}

"dlines" <-
function(SetA,SetB,lin="dotted") {
# 
# Function DLINES connects the rows of SetA to the rows of SetB with lines
# 
# Jan Graffelman
# Universitat Politecnica de Catalunya
# January 2004
#
np<-nrow(SetA)
for(i in 1:np) lines(rbind(SetA[i,1:2],SetB[i,1:2]),lty=lin) 
return(NULL)
}

"ones" <-
function(n,p=n) {
   matrix(rep(1,n*p),nrow=n,ncol=p)
}

"origin" <-
function (m = c(0, 0)) 
{
   abline(h = m[2])
   abline(v = m[1])
   return(NULL)
}
"rda" <-
function(X,Y,scaling=1) {
# 
# Function RDA performs a redundancy analysis of the data in X
# and Y.
#
# scaling = 0 : use centred variables (X and Y)
# scaling = 1 : use centred and standardized variables (X and Y)
#
# Jan Graffelman
# Universitat Politecnica de Catalunya
# January 2004
#

n<-nrow(X)               # determine # of cases
p<-ncol(X)               # determine # of variables

nY<-nrow(Y)
q<-ncol(Y)

if (scaling==0) {
   Xa <- scale(X,scale=FALSE)
   Ya <- scale(Y,scale=FALSE)
}
else {
   if (scaling==1) {
      Xa<-scale(X)  
      Ya<-scale(Y)
   }
   else
      stop("rda: improper scaling parameter")
}

Rxx <- cor(X)
Ryy <- cor(Y)

B<-solve(t(Xa)%*%Xa)%*%t(Xa)%*%Ya

Yh<-Xa%*%B

pca.results <- princomp(Yh,cor=FALSE)
Fp <- pca.results$scores
Ds <- diag(sqrt(diag(var(Fp))))
Fs <- Fp%*%solve(Ds)
Gs <- pca.results$loadings
Gp <- Gs%*%Ds

la <- diag(var(Fp))
laf <- la/sum(la)
lac <- cumsum(laf)

decom <- rbind(la,laf,lac)

# It is important not to standardize Yh, and not to use cor=T. This will inflate the
# variance of Yh, and give different eigenvalues.

# Fs, Gp' biplot of fitted values

Fs <- Fs[,1:min(p,q)]
Fp <- Fp[,1:min(p,q)]
Gs <- Gs[,1:min(p,q)]
Gp <- Gp[,1:min(p,q)]

Gxs <- solve(t(Xa)%*%Xa)%*%t(Xa)%*%Fs
Gxp <- solve(t(Xa)%*%Xa)%*%t(Xa)%*%Fp

Gyp <- Gp
Gys <- Gs

# Gxs Gyp', Gxp Gys'  biplots of B (regression coefficients)

# goodness of fit of regression coefficients

decom <- decom[,1:min(p,q)]

# alternative computations doing SVD of B.

#W<-t(Xa)%*%Xa

#result <- svd(1/(sqrt(n-1))*half(W)%*%B)
#Gxxs <- sqrt(n-1)*mhalf(W)%*%result$u                    # = Gxs
#Gyyp <- result$v%*%diag(result$d)                        # = Gyp
#Gxxp <- sqrt(n-1)*mhalf(W)%*%result$u%*%diag(result$d)   # = Gxp
#Gyys <- result$v                                         # = Gys

#dd <- result$d*result$d
#dds <- cumsum(dd)
#ddf <- dd/sum(dd)
#ddc <- cumsum(ddf)

#decB <- rbind(dd,dds,ddf,ddc)

#res<-t(Gyyp)%*%Gyyp # =	D^2
#res<-t(Gyys)%*%Gyys # =	I
#res<-t(Gxxp)%*%Rxx%*%Gxxp # = D^2
#res<-t(Gxxs)%*%Rxx%*%Gxxs # = I

return(list(Yh=Yh,B=B,decom=decom,Fs=Fs,Gyp=Gyp,Fp=Fp,Gys=Gys,Gxs=Gxs,Gxp=Gxp))
}

"textxy" <-
function (X, Y, labs, cx = 0.5, dcol = "black", m = c(0, 0)) 
{
    posXposY <- ((X >= m[1]) & ((Y >= m[2])))
    posXnegY <- ((X >= m[1]) & ((Y < m[2])))
    negXposY <- ((X < m[1]) & ((Y >= m[2])))
    negXnegY <- ((X < m[1]) & ((Y < m[2])))
    if (sum(posXposY) > 0) 
        text(X[posXposY], Y[posXposY], labs[posXposY], adj = c(-0.3, 
            -0.3), cex = cx, col = dcol)
    if (sum(posXnegY) > 0) 
        text(X[posXnegY], Y[posXnegY], labs[posXnegY], adj = c(-0.3, 
            1.3), cex = cx, col = dcol)
    if (sum(negXposY) > 0) 
        text(X[negXposY], Y[negXposY], labs[negXposY], adj = c(1.3, 
            -0.3), cex = cx, col = dcol)
    if (sum(negXnegY) > 0) 
        text(X[negXnegY], Y[negXnegY], labs[negXnegY], adj = c(1.3, 
            1.3), cex = cx, col = dcol)
    return(NULL)
}
