.packageName <- "amap"
Kmeans <-
function(x, centers, iter.max = 10, nstart = 1,
         method = "euclidean")
{
  dokmeans <- function()
    {
      Z <- .C("kmeans_Lloyd2", as.double(x), as.integer(m),
              as.integer(ncol(x)),
              centers = as.double(centers), as.integer(k),
              c1 = integer(m), iter = as.integer(iter.max),
              nc = integer(k), wss = double(k),
              method=as.integer(method),
              PACKAGE="amap")
      if (Z$iter > iter.max) 
        warning("did not converge in ", iter.max, " iterations", 
                call. = FALSE)
      if (any(Z$nc == 0)) 
        warning("empty cluster: try a better set of initial centers", 
                call. = FALSE)
      Z
    }


  
  METHODS <- c("euclidean", "maximum", "manhattan", "canberra", 
               "binary","pearson","correlation","spearman","kendall")
  method <- pmatch(method, METHODS)
  if (is.na(method)) 
    stop("invalid distance method")
  if (method == -1) 
    stop("ambiguous distance method")
  
  if(class(x) == "exprSet")
      x <- exprs(x)
  

  x <- as.matrix(x)
  m <- nrow(x)
  if(missing(centers))
    stop("'centers' must be a number or a matrix")
  if(length(centers) == 1) {
    k <- centers
    ## we need to avoid duplicates here
    if(nstart == 1)
      centers <- x[sample(1 : m, k), , drop = FALSE]
    if(nstart >= 2 || any(duplicated(centers))) {
      cn <- unique(x)
      mm <- nrow(cn)
      if(mm < k)
        stop("more cluster centers than distinct data points.")
      centers <- cn[sample(1:mm, k), , drop=FALSE]
    }
  } else {
    centers <- as.matrix(centers)
    if(any(duplicated(centers)))
      stop("initial centers are not distinct")
    cn <- NULL
    k <- nrow(centers)
    if(m < k)
      stop("more cluster centers than data points")
  }
  if(iter.max < 1) stop("'iter.max' must be positive")
  if(ncol(x) != ncol(centers))
    stop("must have same number of columns in 'x' and 'centers'")
  
  
  Z <- .C("kmeans_Lloyd2", as.double(x), as.integer(m),
          as.integer(ncol(x)),
          centers = as.double(centers), as.integer(k),
          c1 = integer(m), iter = as.integer(iter.max),
          nc = integer(k), wss = double(k),
          method=as.integer(method),
          PACKAGE="amap")
  if(Z$iter > iter.max)
    warning("did not converge in ",
            iter.max, " iterations", call.=FALSE)
  if(any(Z$nc == 0))
    warning("empty cluster: try a better set of initial centers", call.=FALSE)
    
  if(nstart >= 2 && !is.null(cn)) {
    best <- sum(Z$wss)
    for(i in 2:nstart) {
      centers <- cn[sample(1:mm, k), , drop=FALSE]
      ZZ <- dokmeans()
      if((z <- sum(ZZ$wss)) < best) {
        Z <- ZZ
        best <- z
      }
    }
  }
  centers <- matrix(Z$centers, k)
  dimnames(centers) <- list(1:k, dimnames(x)[[2]])
  cluster <- Z$c1
  if(!is.null(rn <- rownames(x)))
    names(cluster) <- rn
  
  out <- list(cluster = cluster, centers = centers, withinss = Z$wss,
                size = Z$nc)
  class(out) <- "kmeans"
  out
}

#-------------------------------------------------------
#
#  Created       : 29/10/02
#  Last Modified : Time-stamp: <2007-10-02 19:07:26 antoine>
#
#  Description   : Principal component analysis
#                  
#  Author        : Antoine Lucas
#                  lucas@toulouse.inra.fr
#
#  Licence       : GPL 
#
#-------------------------------------------------------


acp <- function(x,center=TRUE,reduce=TRUE,wI=rep(1,nrow(x)),wV=rep(1,ncol(x)))
{   
    x    <- as.matrix(x)
    if(center)
      x <- t(t(x) - as.vector(( wI %*% x)/sum(wI)))
##    x    <- scale(x ,center = center, scale = FALSE)
    if (reduce) 
      x    <- apply(x,2,function(u) { u/sd(u)}) 

    ##              Di.X'.Dv.X
    EIG  <- eigen( (t(x)* wI) %*% (x * wV) ,symmetric=FALSE) 
    V    <- EIG$vector    # ou bien: V=svd(x)$v

    EIG$values <- Re(EIG$values)
    V    <- V %*% diag(sign(EIG$values))
    val  <- sqrt(abs(EIG$values))

    scores <- x %*% V

    V      <- as.matrix(Re(V))
    scores <- as.matrix(Re(scores))

    dimnames(V)[[2]] <- paste("Comp",1:dim(x)[2])
    if(!is.null( dimnames(x)[[2]] ))
      dimnames(V)[[1]] <- dimnames(x)[[2]]
    if(!is.null(dimnames(x)[[1]]))
      dimnames(scores)[[1]] <- dimnames(x)[[1]]
    dimnames(scores)[[2]] <- paste("Comp",1:dim(x)[2])

    ##cmpr <- x %*% (sqrt(wV) * as.matrix(V))
    
    sdev   <- apply(scores,2,sd)    
    res  <- list(eig=val,sdev=sdev,scores=scores,loadings=V)
    class(res) <- "acp"
    res
}
pca <- acp


print.acp <- function(x, ...)
{
    #cat("Call:\n"); dput(x$call)
    cat("\nStandard deviations:\n")
    print(x$sdev, ...)
    cat("\nEigen values:\n")
    print(x$eig, ...)
    invisible(x)
}


# 
#   SECTION GRAPHIQUES
#

plot.acp <- function(x,i=1,j=2,text=TRUE,label='Composants',col='darkblue',main='Individuals PCA',variables=TRUE,labels=NULL,...)
{
    U    <- x$scores
    XLAB <- paste(label,i)
    YLAB <- paste(label,j)
    plot.new()
    plot.window(range(U[,i]),range(U[,j]))
    axis(1,label=TRUE,tick=TRUE)
    axis(2,label=TRUE,tick=TRUE)
    box()
    
    title(xlab=XLAB,ylab=YLAB,main=main)
    if(text){
      if(is.null(labels))
        {
          labels=dimnames(x$scores)[[1]]
        }
        text(labels=labels,U[,i],U[,j],col=col,...)   
    }
    else{
        points(U[,i],U[,j],col=col,...) 
    }
    if(variables)
      {
         par(new=TRUE)
         biplot.acp(x,circle=FALSE,label="",main="")
       }

}

biplot.acp <- function(x,i=1,j=2,label='Composants',col='darkblue',length=0.1,main='Variables PCA',circle=TRUE,...)
{
    U    <- x$loadings
    LIM  <- c(-1.3,1.3)
    XLAB <- paste(label,i)
    YLAB <- paste(label,j)

    # PLOT DES AXES
    plot.new()
    plot.window(LIM,LIM)
    axis(1,label=TRUE,tick=TRUE)
    axis(2,label=TRUE,tick=TRUE)
    box()
    title(xlab=XLAB,ylab=YLAB,main=main)


    # PLOT DU NOM DES FLECHES
    text(U[,i]*1.3,U[,j]*1.3,labels=dimnames(U)[[1]],col=col)   

    # PLOT DES FLECHES
    arrows(0,0,U[,i],U[,j],length = length,col=col)

    # CERCLE
    if(circle)
      {
        t2p <- 2 * pi * seq(0,1, length = 200)
        xc <- cos(t2p)
        yc <- sin(t2p)
        lines(xc,yc,col='darkblue')
      }
}

# Graphique: Eboulis des valeurs propres
plot2 <- function(x,pourcent=FALSE,eigen=TRUE,label='Comp.',col='lightgrey',main='Scree Graph',ylab='Eigen Values')
{
    if(eigen){ U <- x$eig }
    else { U <- x$sdev }

    if(pourcent){U <- U/sum(U) }
    n     <- length(U)
    names <- paste(label,1:n)
    barplot(U,main=main,ylab=ylab,col=col,names.arg=names)
}


plotAll <- function(x)
  {
    par(mfrow=c(2,2))
    plot2(x)
    ##    boxplot(as.list(as.data.frame(x$cmpr)))
    plot(x,variables=FALSE)
    biplot(x)
    plot(x,main="Both",variables=TRUE)
  }
#-------------------------------------------------------
#
#  Created       : 30/10/02
#  Last Modified : Time-stamp: <2003-04-02 09:52:47 lucas>
#
#  Description   : Robust principal component analysis
#                  
#  Author        : Antoine Lucas
#                  lucas@toulouse.inra.fr
#
#  Licence       : GPL 
#
#-------------------------------------------------------

K <- function(u,kernel="gaussien") {
    switch(kernel,
        gaussien = (2*pi)^(-1/2) * exp(-u^2/2),
        quartic   = 15/16 * (1-u^2)^2 * (abs(u)<1),
        triweight = 35/32 * (1-u^2)^3 * (abs(u)<1),
        epanechikov = 3/4 * (1-u^2) *   (abs(u)<1),
        cosinus = pi/4 * cos (u*pi/2) * (abs(u)<1),
        uniform = 1/2 * (abs(u)<1),
    )
}

# Variance locale
W <- function(x,h,D=NULL,kernel="gaussien")
{
    x   <- as.matrix(x)
    n   <- dim(x)[1]
    p   <- dim(x)[2]
    if (is.null(D)) {
        D <- diag(1,p)
    }
    x <- as.vector(x)
    D <- as.vector(D)
    kernel <- substr(kernel,1,1)

    VarLoc <- .C(
                 "W",
                 as.double(x),
                 as.double(h),
                 as.double(D),
                 as.integer(n),
                 as.integer(p),
                 as.character(kernel),
                 res=double(p*p),
                 result = as.integer(1),
                 PACKAGE= "amap"
                 )

    if(VarLoc$result == 2)
      stop("Cannot allocate memory")
    if(VarLoc$result == 1)
      stop("Error")

    matrix(VarLoc$res,p)
}


varrob <- function(x,h,D=NULL,kernel="gaussien")
{
    x   <- as.matrix(x)
    x   <- scale(x, center = TRUE, scale = FALSE)
    n   <- dim(x)[1]
    p   <- dim(x)[2]
    if (is.null(D)) {
        D <- diag(1,p)
    }
    x <- as.vector(x)
    D <- as.vector(D)
    kernel <- substr(kernel,1,1)

    Calcul <- .C(
                 "VarRob",
                 as.double(x),
                 as.double(h),
                 as.double(D),
                 as.integer(n),
                 as.integer(p),
                 as.character(kernel),
                 res=double(p*p),
                 result = as.integer(1),
                 PACKAGE= "amap")

    if(Calcul$result == 2)
      stop("Cannot allocate memory")
    if(Calcul$result == 1)
      stop("Error")

    S <- matrix(Calcul$res,p)
    Sinv <- solve(S)
    solve ( Sinv - D / h)
}


acpgen <- function(x,h1,h2,center=TRUE,reduce=TRUE,kernel="gaussien")
{
    # CENTRONS, ET REDUISONS
    x    <- as.matrix(x)
    x    <- scale(x ,center = center, scale = FALSE)
    if (reduce == TRUE)
         {
          x    <- apply(x,2,function(u) { u/sd(u)}) 
         }

    # ESTIMATION DE W et VarRob
    n <- dim(x)[1]
    VarInv   <- solve(var(x)*(n-1)/n) # solve= inverser
    leU    <- varrob(x,h1,D=VarInv,kernel=kernel)
    leW    <- W(x,h2,D=VarInv,kernel=kernel)
    Winv   <- solve(leW) 


    # anal. spec de Var.W^-1 :
    EIG    <- eigen(leU %*% Winv)  
    V      <- EIG$vector

    #EIG    <- eigen( x %*% Winv %*% t(x)  )
    #U      <- EIG$vector
    #n      <- dim(x)[1]
    #p      <- dim(x)[2]
    #S      <- diag(Re(EIG$values),n)   
    #S1     <- diag(Re(1/EIG$values),n)
    #S      <- sqrt(S[,1:p])
    #S1     <- sqrt(S1[,1:p])
    #V      <- t(x)%*% U%*% S1
    # X=U.S.V' -> V = X' U S^-1
    

    # AFFICHAGE DES RESULTATS


    scores <- x %*% Winv %*% V

    V      <- as.matrix(V)
    scores <- as.matrix(scores)
    dimnames(V)[[2]] <- paste("Comp",1:dim(x)[2])
    if(!is.null( dimnames(x)[[2]] ))
      dimnames(V)[[1]] <- dimnames(x)[[2]]
    if(!is.null( dimnames(x)[[1]] ))
      dimnames(scores)[[1]] <- dimnames(x)[[1]]
    dimnames(scores)[[2]] <- paste("Comp",1:dim(x)[2])
    eig    <- sqrt(EIG$values)
    sdev   <- apply(scores,2,sd)    
    res    <- list(eig=eig,sdev=sdev,scores=scores,loadings=V)
    class(res) <- "acp"
    res
}


acprob <- function(x,h=1,center=TRUE,reduce=TRUE,kernel="gaussien")
{   
    x    <- as.matrix(x)
    x    <- scale(x ,center = center, scale = FALSE)
    if (reduce == TRUE)
         {
          x    <- apply(x,2,function(u) { u/sd(u)}) 
         }
    EIG  <- eigen( varrob(x,h),symmetric=TRUE) 
    V    <- EIG$vector    # ou bien: V=svd(x)$v

    val  <- sqrt(EIG$values)

    scores <- x %*% V

    V      <- as.matrix(V)
    scores <- as.matrix(scores)
    dimnames(V)[[2]] <- paste("Comp",1:dim(x)[2])
    if(!is.null( dimnames(x)[[2]] ))
      dimnames(V)[[1]] <- dimnames(x)[[2]]
    if(!is.null( dimnames(x)[[1]] ))
      dimnames(scores)[[1]] <- dimnames(x)[[1]]
    dimnames(scores)[[2]] <- paste("Comp",1:dim(x)[2])
    sdev   <- apply(scores,2,sd)    
    res  <- list(eig=val,sdev=sdev,scores=scores,loadings=V)
    class(res) <- "acp"
    res
}

##
matlogic <- function(x)
{
  n=nrow(x)
  m=ncol(x)
  nblev <- apply(x,2,function(u){nlevels(as.factor(u))})

  ## Keep names....
  rownames <- rownames(x)
  colnames <- colnames(x)
  i <- 0
  colnamesnew <- c(apply(x,2,function(u){ i<<- i+1;paste(colnames[i],levels(as.factor(u)),sep=".")}),recursive=TRUE)
  

  k <- sum(nblev)
  res <- as.integer(matrix(0,ncol=k,nrow=n))
  x <- c(x,recursive=TRUE)
  
  result <- .C("matind",
               as.integer(nblev),
               as.integer(x),
               res=res,
               as.integer(n),
               as.integer(m),
               as.integer(k),
               PACKAGE="amap")

  result <- matrix(result$res,ncol=k)
  rownames(result) <- rownames
  colnames(result) <- colnamesnew
  result
  
}


burt <- function(x)
  {
    ind <- matlogic(x)
    t(ind) %*% ind

  }



## x: table de burt, ou table
afc <- function (x)
  {
    f  <- as.matrix(x/sum(x))
    fi <- apply(f,1,sum)
    fj <- apply(f,2,sum)
    ##    Dr = diag(fi)
    ##    Dc = diag(fj)
    f  <- (1/fi) * t(t(f)/fj)
    acp(f,wI=fi,wV=fj,center=TRUE,reduce=FALSE)
  }
diss <- function (x, w=rep(1,ncol(x)))
  {
    n <- nrow(x)
    p <- ncol(x)
    if(length(w) != p)
      {
        warning("Error in dimention on either w or x")
        return(NULL)
      }
    
    res <- .C("diss",
              as.integer(x),
              double(n*n),
              n,p,
              as.double(w),
              PACKAGE="amap")

    matrix(res[[2]],n)

  }
Dist <- function(x, method="euclidean", nbproc = 1, diag=FALSE, upper=FALSE)
{

  if(class(x) == "exprSet")
      x <- exprs(x)

      
  ## account for possible spellings of euclidean
  if(!is.na(pmatch(method, "euclidian")))
	method <- "euclidean"

    METHODS <- c("euclidean", "maximum", "manhattan", "canberra",
                 "binary","pearson","correlation","spearman","kendall")
    method <- pmatch(method, METHODS)
    if(is.na(method))
	stop("invalid distance method")
    if(method == -1)
	stop("ambiguous distance method")

    N <- nrow(x <- as.matrix(x))
    d <- .C("R_distance",
	    x = as.double(x),
	    nr= N,
	    nc= ncol(x),
	    d = double(N*(N - 1)/2),
	    diag  = as.integer(FALSE),
	    method= as.integer(method),
            nbproc = as.integer(nbproc),
            ierr=as.integer(0),
	    DUP = FALSE,
            NAOK=TRUE,
            PACKAGE="amap"
            )$d
    attr(d, "Size") <- N
    attr(d, "Labels") <- dimnames(x)[[1]]
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
}
## Hierarchical clustering
##
## Created       : 18/11/02
## Last Modified : Time-stamp: <2005-10-01 20:14:25 antoine>
##
## This function is a "mix" of function dist and function hclust.
##
## Author : Antoine Lucas
##



hclusterpar <- hcluster <- function (x, method = "euclidean", diag = FALSE, upper = FALSE, link = "complete", members = NULL, nbproc = 2, doubleprecision = TRUE)
{

  if(class(x) == "exprSet")
    x <- exprs(x)

  ## take from dist
  if (!is.na(pmatch(method, "euclidian"))) 
    method <- "euclidean"
  METHODS <- c("euclidean", "maximum", "manhattan", "canberra", 
               "binary","pearson","correlation","spearman","kendall")
  method <- pmatch(method, METHODS)
  if (is.na(method)) 
    stop("invalid distance method")
  if (method == -1) 
    stop("ambiguous distance method")
  N <- nrow(x <- as.matrix(x))
  

  
                                        #take from hclust
  METHODSLINKS <- c("ward", "single", "complete", "average", "mcquitty", 
                    "median", "centroid")
  
  link <- pmatch(link, METHODSLINKS)
  if (is.na(link)) 
    stop("invalid clustering method")
  if (link == -1) 
    stop("ambiguous clustering method")
    if (N < 2) 
        stop("Must have n >= 2 objects to cluster")
  if (is.null(members)) 
    members <- rep(1, N)
  if (length(members) != N) 
    stop("Invalid length of members")
  n <- N

  precision <- 1
  if(doubleprecision)
    precision <- 2
  
  hcl <- .C("hcluster",
            x = as.double(x),
            nr = as.integer(n),
            nc = as.integer(ncol(x)),
            diag = as.integer(FALSE),
            method = as.integer(method), 
            iopt = as.integer(link),
            ia = integer(n),
            ib = integer(n),
            order = integer(n),
            crit = double(n),
            members = as.double(members),
            nbprocess  = as.integer(nbproc),
            precision  = as.integer(precision),
            res  = as.integer (1),
            DUP = FALSE,
            NAOK=TRUE,
            PACKAGE= "amap")

  if(hcl$res == 2)
    stop("Cannot allocate memory")
  if(hcl$res == 3)
    stop("Missing values in distance Matrix")
  if(hcl$res == 1)
    stop("Error")


  tree <- list(merge = cbind(hcl$ia[1:(N - 1)],
                 hcl$ib[1:(N -  1)]),
               height = hcl$crit[1:(N - 1)],
               order = hcl$order, 
               labels = dimnames(x)[[1]],
               method = METHODSLINKS[link],
               call = match.call(),
               dist.method = METHODS[method]
               )


  class(tree) <- "hclust"
  tree
}
pop <- function(x,fmbvr=TRUE,triabs=TRUE,allsol=TRUE)
  {
    couts <- as.matrix(x)

    n <- as.integer(nrow(couts))

    ysave <-  as.integer(matrix(0,nrow=n,ncol=n))
    renum <- y <- ysave

    
    
    bornth <- z0 <- z <- as.double(0)
    
    res <- .Fortran("pnkfmb",
                    as.integer(fmbvr),
                    as.integer(triabs),
                    as.integer(allsol),
                    n = as.integer(n),
                    couts = as.double(couts),
                    ysave = ysave,
                    y = ysave,
                    renum= renum,
                    bornth = bornth,
                    nbcl0 = as.integer(0),
                    z0 = z0 ,
                    nbcl = as.integer(0),
                    z = z,
                    nbemp = as.integer(0),
                    nbdep = as.integer(0),
                    nbsol = as.integer(0),
                    nap = as.integer(0),
                    PACKAGE="amap")


    class(res) <- "pop"
    return(res)
    
  }


print.pop <- function(x,...)
  {
    i <- 1:x$n
    classes <- x$y[i+(i-1)*x$n]
    cat("Upper bound     (half cost)   :",x$bornth,'\n')
    cat("Final partition (half cost)   :",x$z,'\n')
    cat("Number of classes             :",x$nbcl,"\n")
    cat("Forward move count            :",x$nbemp,"\n")
    cat("Backward move count           :",x$nbdep,"\n")
    cat("Constraints evaluations count :",x$nap,"\n")
    cat("Number of local optima        :",x$nbsol,"\n\n")
    print(data.frame(Individual=i,class=classes))
  }

.noGenerics <- TRUE
.conflicts.OK <- TRUE

.onLoad <- .First.lib <- function(lib, pkg)
{
    library.dynam("amap", pkg, lib)

    have.stats <- "package:stats" %in% search()
    if(!have.stats)   require("stats")
  

    if("Biobase" %in% .packages(all=TRUE))
      require("Biobase")
    else
        exprs <<- function(x)
            stop("You need to install Biobase package to use this object")
  }

