.packageName <- "ade4"
"PI2newick" <- function(x){
# cette fonction permet de convertir les fichiers d'entre du logiciel PI 
# d'Abouheif au format newick (on rcupre galement les valeurs associes
# aux feuilles)
# x est une matrice qui vient de la lecture des fichiers .txt: x <- read.table("PI1.txt", h = FALSE)
# il a autant de lignes qu'il y a de feuilles-1; dans le cas d'une phylognie rsolue, c'est le nombre de noeuds
# il y a 6 colonnes: Contrast value/ Left tip value/ Right tip value/ Left node name/ Right node name/ Unresolved nodes group

# on prpare le terrain
nodes.group <- as.factor(x[, 6])
nodes.character <- as.character(x[,6])
x <- x[, -c(1,6)]
x[,c(3,4)] <-x[,c(3,4)] + 1
x[x == -99] <- 0
nleaves <- nrow(x) + 1 
nnodes <- sum(nodes.group==0)+length(levels(nodes.group))-1
leaves.names <- paste("Ext", 1:nleaves, sep="")
nodes.names <- c("Root", paste("I", 2:nnodes-1, sep=""))

# on rcuupre les valeurs associes aux feuilles
values <- as.vector(t(as.matrix(x[,c(1,2)])))
values <- values[values!=0]
for (i in 1:nleaves) 
    x[x==values[i]] <- i
#print(x)

# on construit la chaine de charactre au format newick
names(x) <- c("Ext", "Ext", "I", "I")
tre <- NULL
if (nodes.group[1]==0){
    u <- x[1,]
    v <- names(x)[u!=0]
    w <- u[u!=0]
    u <- paste(v, w, sep="")
    tre <- paste("(", u[1], ",", u[2], ")Root;", sep="")
    }
    else 
        stop("the Root must be resolved: will be programmed later")  # le cas ou il y a plusieurs feuilles et un noeud reste  faire  
j <- 2   
for (i in 2:nnodes){
    if (nodes.group[j]==0){
        u <- x[j,]
        v <- names(x)[u!=0]
        w <- u[u!=0]
        u <- paste(v, w, sep="")
        u <- paste("(", u[1], ",", u[2], ")", paste("I", i,sep=""), sep="")
        tre <- gsub(paste("I", j,sep=""), u, tre)
        j <- j + 1
        }
        else{
            u <- nodes.group[j]
            v <- sum(nodes.group==u)
            w <- x[j:(j+v-1), 1:2]
            w <- as.vector(as.matrix(w))
            w <- w[w!=0]
            w <- sort(w)
            y <- paste(rep("Ext", v+1), w, sep="")
            z <- y[1]
            for (i in 2:(v+1)) z <- paste(z, y[i], sep=",")
            z <- paste("(", z, ")", paste("I", j,sep=""), sep="") 
            tre <- gsub(paste("I", j,sep=""), z, tre)
            j <- j + v
            } 
    }
    
return(res <- list(tre = tre, trait = values))
}
"RV.rtest" <- function (df1, df2, nrepet = 99) {
    if (!is.data.frame(df1)) 
        stop("data.frame expected")
    if (!is.data.frame(df2)) 
        stop("data.frame expected")
    l1 <- nrow(df1)
    if (nrow(df2) != l1) 
        stop("Row numbers are different")
    if (any(row.names(df2) != row.names(df1))) 
        stop("row names are different")
    c1 <- ncol(df1)
    c2 <- ncol(df2)
    X <- scale(df1, scale = FALSE)
    Y <- scale(df2, scale = FALSE)
    X <- X/(sum(svd(X)$d^4)^0.25)
    Y <- Y/(sum(svd(Y)$d^4)^0.25)
    X <- as.matrix(X)
    Y <- as.matrix(Y)
    obs <- sum(svd(t(X) %*% Y)$d^2)
    if (nrepet == 0) 
        return(obs)
    perm <- matrix(0, nrow = nrepet, ncol = 1)
    perm <- apply(perm, 1, function(x) sum(svd(t(X) %*% Y[sample(l1), 
        ])$d^2))
    w <- as.rtest(obs = obs, sim = perm, call = match.call())
    return(w)
}
"RVdist.randtest" <- function (m1, m2, nrepet=999) {
    if (!inherits(m1, "dist")) 
        stop("Object of class 'dist' expected")
    if (!inherits(m2, "dist")) 
        stop("Object of class 'dist' expected")
    if (!is.euclid(m1)) stop ("Euclidean matrices expected")
    if (!is.euclid(m2)) stop ("Euclidean matrices expected")
    n <- attr(m1, "Size")
    if (n != attr(m2, "Size")) 
        stop("Non convenient dimension")
    m1 <- dist2mat(m1)
    m2 <- dist2mat(m2)
    col <- ncol(m1)
    res <- .C("testdistRV", as.integer(nrepet), as.integer (n), as.double(m1),
        as.double(m2), RV=double(nrepet+1),PACKAGE="ade4")$RV
    obs=res[1]
    return(as.randtest(res[-1],obs))
}

.First.lib <- function(lib, pkg) {
  library.dynam("ade4", pkg, lib)
}
 "Rtoade4" <-
function (x) {
    if (!is.data.frame(x)) 
        stop("x is not a data.frame")
    nombase <- deparse(substitute(x))


  # Si il n'y a que des variables qualitatives
  
   if (all(unlist(lapply(x, is.factor)))) {
        z <- matrix(0, nrow(x), ncol(x))
        for (j in 1:(ncol(x))) {
            toto <- x[, j]
            z[, j] <- unlist(lapply(toto, function(x, fac) which(x == 
                levels(fac)), fac = toto))
        }
        nomfic <- paste(nombase, ".txt", sep = "")
        write.table(z, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "-999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
        if (!is.null(attr(x, "names"))) {
            y <- attr(x, "names")
            nomfic <- paste(nombase, "_var_lab.txt", sep = "")
            write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
                eol = "\n", na = "999", row.names = FALSE, col.names = FALSE, 
                qmethod = c("escape", "double"))
            cat("File creation", nomfic, "\n")
        }
        nommoda <- NULL
        for (j in 1:(ncol(x))) {
            toto <- x[, j]
            nommoda <- c(nommoda, levels(toto))
        }
        nomfic <- paste(nombase, "_moda_lab.txt", sep = "")
        write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
        return(invisible())
    }

    # Le cas gnral
    nomfic <- paste(nombase, ".txt", sep = "")
    write.table(x, file = nomfic, quote = FALSE, sep = "    ", eol = "\n", 
        na = "-999", row.names = FALSE, col.names = FALSE, qmethod = c("escape", 
            "double"))
    cat("File creation", nomfic, "\n")
    if (!is.null(attr(x, "names"))) {
        y <- attr(x, "names")
        nomfic <- paste(nombase, "_col_lab.txt", sep = "")
        write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "-999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
    }
    if (!is.null(attr(x, "row.names"))) {
        y <- attr(x, "row.names")
        nomfic <- paste(nombase, "_row_lab.txt", sep = "")
        write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "-999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
    }
    if (!is.null(attr(x, "col.blocks"))) {
        y <- as.vector(attr(x, "col.blocks"))
        nomfic <- paste(nombase, "_col_bloc.txt", sep = "")
        write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "-999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
        y <- names(attr(x, "col.blocks"))
        nomfic <- paste(nombase, "_col_bloc_lab.txt", sep = "")
        write.table(y, file = nomfic, quote = FALSE, sep = "    ", 
            eol = "\n", na = "-999", row.names = FALSE, col.names = FALSE, 
            qmethod = c("escape", "double"))
        cat("File creation", nomfic, "\n")
    }
}

"ade4toR" <- function (fictab, ficcolnames = NULL, ficrownames = NULL) {
    if (!file.exists(fictab)) 
        stop(paste("file", fictab, "not found"))
    if (!is.null(ficrownames) && !file.exists(ficrownames)) 
        stop(paste("file", ficrownames, "not found"))
    if (!is.null(ficcolnames) && !file.exists(ficcolnames)) 
        stop(paste("file", ficcolnames, "not found"))
    w <- read.table(fictab, h = FALSE)
    nl <- nrow(w)
    nc <- ncol(w)
    if (!is.null(ficcolnames)) 
        provicol <- as.character((read.table(ficcolnames, h = FALSE))$V1)
    else provicol <- as.character(1:nc)
    if ((length(provicol)) != nc) {
        stop(paste("Non convenient row number in file", ficcolnames, 
            "- Expected:", nc, "- Input:", length(provicol)))
    }
    if (is.null(ficcolnames)) 
        names(w) <- paste("v", provicol, sep = "")
    else names(w) <- provicol
    if (!is.null(ficrownames)) 
        provirow <- as.character((read.table(ficrownames, h = FALSE))$V1)
    else provirow <- as.character(1:nl)
    if ((length(provirow)) != nl) {
        stop(paste("Non convenient row number in file", ficrownames, 
            "- Expected:", nl, "- Input:", length(provirow)))
    }
    row.names(w) <- provirow
    return(w)
}


amova <- function(samples, distances = NULL, structures = NULL) {
    # checking of user's data and initialization.
    if (!inherits(samples, "data.frame")) stop("Non convenient samples")
    if (any(samples < 0)) stop("Negative value in samples")
    nhap <- nrow(samples) ; nsam <- ncol(samples)
    if (!is.null(distances)) {
        if (!inherits(distances, "dist")) stop("Object of class 'dist' expected for distances")
        if (!is.euclid(distances)) stop("Euclidean property is expected for distances")
        distances <- as.matrix(distances)^2
        if (nrow(samples)!= nrow(distances)) stop("Non convenient samples")
    }
    if (is.null(distances)) distances <- (matrix(1, nhap, nhap) - diag(rep(1, nhap))) * 2
    if (!is.null(structures)) {
        if (!inherits(structures, "data.frame")) stop("Non convenient structures")
        m <- match(apply(structures, 2, function(x) length(x)), ncol(samples), 0)
        if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
        m <- match(tapply(1:ncol(structures), as.factor(1:ncol(structures)), function(x) is.factor(structures[, x])), TRUE , 0)
        if (length(m[m == 1]) != ncol(structures)) stop("Non convenient structures")
    }        
    # intern functions (computations of the sums of squares and mean squares) :
    Diversity <- function(d2, nbhaplotypes, freq) {
    # diversity index according to Rao s quadratic entropy
        div <- nbhaplotypes / 2 * (t(freq) %*% d2 %*% freq)
    }      
    Ssd.util <- function(dp2, Np, unit) {
    # Deductions of the distances between two groups.
    # Deductions of the weight and composition of a group.
        if (!is.null(unit)) {
            modunit <- model.matrix(~ -1 + unit)
            sumcol <- apply(Np, 2, sum)
            Ng <- modunit * sumcol
            lesnoms <- levels(unit)
        }
        else {
            Ng <- as.matrix(Np)
            lesnoms <- colnames(Np)
        }
        sumcol <- apply(Ng, 2, sum)
        Lg <- t(t(Ng)/sumcol)
        colnames(Lg) <- lesnoms
        Pg <- as.matrix(apply(Ng, 2, sum) / nbhaplotypes)
        rownames(Pg) <- lesnoms
        deltag <- as.matrix(apply(Lg, 2, function(x) t(x) %*% dp2 %*% x))
        ug <- matrix(1, ncol(Lg), 1)
        dg2 <- t(Lg) %*% dp2 %*% Lg - 1 / 2 * (deltag %*% t(ug) + ug %*% t(deltag))
        colnames(dg2) <- lesnoms
        rownames(dg2) <- lesnoms
        return(list(dg2 = dg2, Ng = Ng, Pg = Pg))
    }
    Ssd <- function(distances, nbhaplotypes, samples, structures) {
    # Computation of the sum of squared deviation.
        Ph <- as.matrix(apply(samples, 1, sum) / nbhaplotypes)
        ssdt <- nbhaplotypes / 2 * t(Ph) %*% distances %*% Ph
        ssdutil <- list(0)
        ssdutil[[1]] <- Ssd.util(dp2 = distances, Np = samples, NULL)
        if (!is.null(structures)) {
            for (i in 1:length(structures)) {
                if (i != 1) {
                    unit <- structures[(1:length(structures[, i])) [!duplicated(structures[, i - 1])], i]
                    unit <- factor(unit, levels = unique(unit))
                }
                else unit <- factor(structures[, i], levels = unique(structures[, i]))
                ssdutil[[i + 1]] <- Ssd.util(ssdutil[[i]]$dg2, ssdutil[[i]]$Ng, unit)        
            }
        }    
        diversity <- c(ssdt, unlist(lapply(ssdutil, function(x) nbhaplotypes / 2 * t(x$Pg) %*% x$dg2 %*% x$Pg)))
        diversity2 <- c(diversity[-1], 0)
                ssdtemp <- diversity - diversity2
                ssd <- c(ssdtemp[length(ssdtemp):1], ssdt)     
                return(ssd)
    }
    Nbunits <- function(structures2) {
        # nb of units in each levels.
        return(apply(structures2, 2, function(x) length(levels(as.factor(x)))))
    }
    Ddl <- function(nbunits, nbhaplotypes) {
        # degrees of freedom.
        ddl1 <- c(nbunits, nbhaplotypes, nbhaplotypes)
        ddl2 <- c(1, nbunits, 1)
        ddl <- ddl1 - ddl2
        return(as.vector(ddl))
    }
    N <- function(structures, samples, nbhaplotypes, ddl) {
        # n values.
        nbind1temp <- apply(samples, 2, sum)
        nbind1 <- rep(nbind1temp, nbind1temp)
        nbhapl <- rep(nbhaplotypes, nbhaplotypes)
        if (!is.null(structures)) {
            nbind <- lapply(as.list(structures), function(x) tapply(nbind1temp, x, sum)[as.numeric(x)])
            nbind <- lapply(nbind, function(x) rep(x, nbind1temp))
            nbind <- c(list(nbhapl), nbind[length(nbind):1], list(nbind1))
        }
        else nbind <- c(list(nbhapl), list(nbind1))
        n1 <- as.vector(tapply((2:length(nbind)), as.factor(2:length(nbind)), function(x) (nbhaplotypes - (sum((nbind[[x]]) / nbind[[x-1]])))))
        ddlutil <- ddl[(length(ddl) - 2):1]        
        if (!is.null(structures)) {
            N2 <- function(x) {
                tapply((x + 1):length(nbind), as.factor((x + 1):length(nbind)), function(i) sum(nbind[[i]] * (1 / nbind[[x]] - 1 / nbind[[x - 1]])))
            }
            n <- rep(0, sum(1:(dim(structures)[2] + 1)))
            n1 <- n1[length(n1):1]
            n[cumsum(1:(dim(structures)[2] + 1))] <- n1        
            if ((length(nbind) - 1) >= 2) {
                n2 <- as.vector(unlist(tapply(2:(length(nbind) - 1), as.factor(2:(length(nbind) - 1)), N2)))
                n2 <- n2[length(n2):1]
                n[-(cumsum(1:(dim(structures)[2] + 1)))] <- n2
            }
            ddlutil <- ddlutil[rep(1:(dim(structures)[2] + 1), 1:(dim(structures)[2] + 1))]
        }            
        else n <- n1                
        n <- n / ddlutil
        return(n)
    }
    Cm <- function(ssd, ddl) {
        # mean squares.
        return(c(ssd / ddl))
    }
    Sigma <- function(cm, n) {
        # covariance components.
        cmutil <- cm[(length(cm) - 1):1]
        sigma2W <- cmutil[1]
        res <- rep(0, length(cm) - 1)
        res[1] <- sigma2W
        res[2] <- (cmutil[2] - sigma2W) / n[1]
        if (length(res) > 2) {
            for (i in 3:(length(cm) - 1)) {
                index <- cumsum(c(2, (2:(length(cm) - 1))))
                ni <- n[index[i - 2]:(index[i - 1] - 2)]
                nj <- n[index[i - 1] - 1]
                si <- ni * res[2:(i - 1)]
                res[i] <- (cmutil[i] - sigma2W - sum(si)) / nj
           }
        }
        sigma2t <- sum(res)
        return(c(res[length(res):1], sigma2t))
    }
    Pourcent <- function(sigma) {
        # covariance percentages.
        return(sigma / sigma[length(sigma)] * 100)
    }
    Procedure <- function(distances, nbhaplotypes, samples, structures, ddl) {
        ssd <- Ssd(distances, nbhaplotypes, samples, structures)
        cm <- Cm(ssd, ddl)
        n <- N(structures, samples, nbhaplotypes, ddl)
        sigma <- Sigma(cm, n)
        return(list(ssd = ssd, cm = cm, sigma = sigma, n = n))
    }
    Statphi <- function(sigma) {
        # Phi-statistics.
        f <- rep(0, length(sigma) - 1)
        if (length(sigma) == 3) {
            f <- rep(0, 1)
        }
        f[1] <- (sigma[length(sigma)] - sigma[length(sigma) - 1]) / sigma[length(sigma)]
        if (length(f) > 1) {
            s1 <- cumsum(sigma[(length(sigma) - 1):2])[-1]
            s2 <- sigma[(length(sigma) - 2):2]
            f[length(f)] <- sigma[1] / sigma[length(sigma)]        
            f[2:(length(f) - 1)] <- s2 / s1
        }
        return(f)
    }        
    # main procedure.
    nbhaplotypes <- sum(samples)
    if (!is.null(structures)) {
        structures2 <- cbind.data.frame(structures[length(structures):1], as.factor(colnames(samples, do = FALSE)))
    }
    else structures2 <- as.data.frame(as.factor(colnames(samples, do = FALSE)))
    nbunits <- Nbunits(structures2)
    ddl <- Ddl(nbunits, nbhaplotypes)
    proc <- Procedure(distances, nbhaplotypes, samples, structures, ddl)
    ssd <- proc$ssd
    cm <- proc$cm
    sigma <- proc$sigma
    n <- proc$n
    # Interface.
    if (!is.null(structures)) {
        lesnoms1 <- rep("Between", ncol(structures) + 1)
        lesnoms2 <- c(names(structures)[ncol(structures):1], "samples")
        lesnoms3 <- c("", rep("Within", ncol(structures)))
        lesnoms4 <- c("", names(structures)[ncol(structures):1])
        lesnoms <- c(paste(lesnoms1, lesnoms2, lesnoms3, lesnoms4), "Within samples", "Total")
    }
    else lesnoms <- c("Between samples", "Within samples", "Total")
    pourcent <- Pourcent(sigma)        
    results <- data.frame(ddl, ssd, cm)
    names(results) <- c("Df", "Sum Sq", "Mean Sq")
    rownames(results) <- lesnoms
    sourceofvariation <- c(paste("Variations ", rownames(results)[1:(nrow(results) - 1)]), "Total variations")
    componentsofcovariance <- data.frame(sigma, pourcent)
    names(componentsofcovariance) <- c("Sigma", "%")
    rownames(componentsofcovariance) <- sourceofvariation
    call <- match.call()
    res <- list(call = call, results = results, componentsofcovariance = componentsofcovariance, distances = as.dist(distances), samples = samples, structures = structures)
    f <- Statphi(sigma)
    statphi <- as.data.frame(f)
    names(statphi) <- "Phi"
    lesnoms1 <- c(rep("Phi", length(f)))
    if (length(f) == 1) {
        lesnoms2 <- c("samples")
        lesnoms3 <- c("total")
    }
    else {
        lesnoms2 <- c(rep("samples", 2), names(structures))
        lesnoms3 <- c("total", names(structures), "total")
    }
    rownames(statphi) <- paste(lesnoms1, lesnoms2, lesnoms3, sep = "-")
    res <- list(call = call, results = results, componentsofcovariance = componentsofcovariance, statphi = statphi, distances = as.dist(distances), samples = samples, structures = structures)
    class(res) <- "amova"
    return(res)
}

print.amova <- function(x, full = FALSE, ...) {
    if (full == TRUE) print(x)
    else print(x[-((length(x) - 2):length(x))])
}
########### area.plot         ################
########### area.util.contour ################
########### area.util.xy      ################
########### area2poly         ################
########### poly2area         ################
########### area2link         ################

"area.plot" <- function (x, center= NULL, values = NULL, graph = NULL, lwdgraph = 2, nclasslegend = 8,
    clegend = 0.75, sub = "", csub = 1, possub = "topleft", cpoint = 0, 
    label = NULL, clabel = 0, ...) 
{
    # modif vendredi, mars 28, 2003 at 07:35 ajout de l'argument center
    # doit contenir les centres des polygones (autant de coordonnes que de classes dans area[,1])
    # si il est nul et utilis il est calcul comme centre de gravit des sommets du polygones
    # avec area.util.xy(x)
    # si il est non nul, doit tre de dimensions (nombre de niveaux de x[,1] , 2) et
    # contenir les coordonnes dans l'ordre de unique(x[,1])
    x.area <- x
    if(dev.cur() == 1) plot.new()
    opar <- par(mar = par("mar")) #, new = par("new")
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    if (!is.factor(x.area[, 1])) 
        stop("Factor expected in x.area[1,]")
    fac <- x.area[, 1]
    lev.poly <- unique(fac)
    nlev <- nlevels(lev.poly)
    label.poly <- as.character(unique(x.area[, 1]))
    x1 <- x.area[, 2]
    x2 <- x.area[, 3]
    r1 <- range(x1)
    r2 <- range(x2)
    plot(r1, r2, type = "n", asp = 1, xlab = "", ylab = "", xaxt = "n", 
        yaxt = "n", frame.plot = FALSE)
    if (!is.null(values)) {
        if (!is.vector(values)) 
            values <- as.vector(values)
        if (length(values) != nlev) 
            values <- rep(values, le = nlev)
        br0 <- pretty(values, 6)
        nborn <- length(br0)
        h <- diff(range(x1))/20
        numclass <- cut.default(values, br0, include = TRUE, 
            lab = FALSE, right = TRUE)
        valgris <- seq(1, 0, le = (nborn - 1))
    }
    if (!is.null(graph)) {
        if (class(graph) != "neig") 
            stop("graph need an object of class 'ng'")
    }
    if (cpoint != 0) 
        points(x1, x2, pch = 20, cex = par("cex") * cpoint)
    for (i in 1:nlev) {
        a1 <- x1[fac == lev.poly[i]]
        a2 <- x2[fac == lev.poly[i]]
        if (!is.null(values)) 
            polygon(a1, a2, col = grey(valgris[numclass[i]]))
        else polygon(a1, a2)
    }
    if (!is.null(graph) | (clabel > 0)) {
        if (!is.null(center)) {
            center = as.matrix(center)
            if (ncol(center)!=2) center <- NULL
            if (nrow(center)!=length(lev.poly)) center <-NULL
        }
        if (!is.null(center)) w=list(x=center[,1],y=center[,2]) else
        w <- area.util.xy(x.area)
     }
    if (!is.null(graph)) {
        for (i in 1:nrow(graph)) {
            segments(w$x[graph[i, 1]], w$y[graph[i, 1]], w$x[graph[i, 
                2]], w$y[graph[i, 2]], lwd = lwdgraph)
        }
    }
    if (clabel > 0) {
        if (is.null(label)) 
            label <- as.character(unique(x.area[,1]))
        scatterutil.eti(w$x, w$y, label, clabel = clabel)
    }
    scatterutil.sub(sub, csub, possub)
    if (!is.null(values)) 
        scatterutil.legend.square.grey(br0, valgris, h, clegend)
}

"area.util.contour" <- function (area) {
    poly <- area[, 1]
    x <- area[, 2]
    y <- area[, 3]
    res <- NULL
    f1 <- function(x) {
        if (x[1] > x[3]) {
            s <- x[1]
            x[1] <- x[3]
            x[3] <- s
            s <- x[2]
            x[2] <- x[4]
            x[4] <- s
        }
        if (x[1] == x[3]) {
            if (x[2] > x[4]) {
                s <- x[2]
                x[2] <- x[4]
                x[4] <- s
            }
        }
        return(paste(x[1], x[2], x[3], x[4], sep = "A"))
    }
    for (i in 1:(nlevels(poly))) {
        xx <- x[poly == levels(poly)[i]]
        yy <- y[poly == levels(poly)[i]]
        n0 <- length(xx)
        xx <- c(xx, xx[1])
        yy <- c(yy, yy[1])
        z <- cbind(xx[1:n0], yy[1:n0], xx[2:(n0 + 1)], yy[2:(n0 + 
            1)])
        z <- apply(z, 1, f1)
        res <- c(res, z)
    }
    res <- res[table(res)[res] < 2]
    res <- unlist(lapply(res, function(x) as.numeric(unlist(strsplit(x, 
        "A")))))
    res <- matrix(res, ncol = 4, byr = TRUE)
    res <- data.frame(res)
    names(res) <- c("x1", "y1", "x2", "y2")
    return(res)
}

"area.util.xy" <- function (area) {
    fac <- area[, 1]
    lev.poly <- unique(fac)
    npoly <- length(lev.poly)
    x <- rep(0, npoly)
    y <- rep(0, npoly)
    for (i in 1:npoly) {
        lev <- lev.poly[i]
        a1 <- area[fac == lev, 2]
        a2 <- area[fac == lev, 3]
        x[i] <- mean(a1)
        y[i] <- mean(a2)
    }
    cbind.data.frame(x = x, y = y, row.names = as.character(lev.poly))
}

"area2poly" <- function (area) {
    if (!is.factor(area[, 1])) 
        stop("Factor expected in area[,1]")
    fac <- area[, 1]
    lev.poly <- unique(fac)
    nlev <- nlevels(lev.poly)
    label.poly <- as.character(lev.poly)
    x1 <- area[, 2]
    x2 <- area[, 3]
    res <- list()
    for (i in 1:nlev) {
        a1 <- x1[fac == lev.poly[i]]
        a2 <- x2[fac == lev.poly[i]]
        res <- c(res, list(as.matrix(cbind(a1, a2))))
    }
    r0 <- matrix(0, nlev, 4)
    r0[, 1] <- tapply(x1, fac, min)
    r0[, 2] <- tapply(x2, fac, min)
    r0[, 3] <- tapply(x1, fac, max)
    r0[, 4] <- tapply(x2, fac, max)
    class(res) <- "polylist"
    attr(res, "region.id") <- label.poly
    attr(res, "region.rect") <- r0
    # message de Stphane Dray du 06/02/2004
    attr(res,"maplim") <- list(x=range(x1),y=range(x2))
    return(res)
} 

"poly2area" <- function (polys) {
    if (!inherits(polys, "polylist")) 
        stop("Non convenient data")
    if (!is.null(attr(polys, "region.id"))) 
        reg.names <- attr(polys, "region.id")
    else reg.names <- paste("R", 1:length(polys), sep = "")
    area <- data.frame(polys[[1]])
    area <- cbind(rep(reg.names[1], nrow(area)), area)
    names(area) <- c("reg", "x", "y")
    for (i in 2:length(polys)) {
        provi <- data.frame(polys[[i]])
        provi <- cbind(rep(reg.names[i], nrow(provi)), provi)
        names(provi) <- c("reg", "x", "y")
        area <- rbind.data.frame(area, provi)
    }
    area$reg <- factor(area$reg)
    return(area)
}

"area2link" <- function(area) {
    # cration vendredi, mars 28, 2003 at 14:49
    if (!is.factor(area[, 1])) 
        stop("Factor expected in area[,1]")
    fac <- area[, 1]
    levpoly <- unique(fac)
    npoly <- length(levpoly)
    res <- matrix(0,npoly,npoly)
    dimnames(res) <- list(as.character(levpoly),as.character(levpoly))
    fun1 <- function(niv) {
        # X est un n-2 systme de coordonnes xy
        # On vrifie que c'est une boucle (sommaire)
        X <- area[fac == niv, 2:3]
        n <- nrow(X)
        if (any(X[1,]!=X[n,])) X <- rbind(X,X[1,])
        n <- nrow(X)
        w <- paste(X[1:(n-1),1],X[1:(n-1),2],X[2:(n),1],X[2:(n),2],sep="/")
        w <- c(w,paste(X[2:(n),1],X[2:(n),2],X[1:(n-1),1],X[1:(n-1),2],sep="/"))
    }
    w <- lapply(levpoly,fun1)
    # w est une liste de vecteurs qui donnent les artes des polygones en charactres
    # du type x1/y1/x2/y2
    fun2 <- function (cha) {
        w <- as.numeric(strsplit(cha,"/")[[1]])
        res <- sqrt((w[1]-w[3])^2+(w[2]-w[4])^2)
        res
    }
    res <- matrix(0,npoly,npoly)
    x1 <- col(res)[col(res) < row(res)]
    x2 <- row(res)[col(res) < row(res)]
    lw <- cbind(x1,x2)
    fun3 <- function (x) {
        a <- w[[x[1]]]
        b <- w[[x[2]]]
        wd <- 0
        wab <- unlist(lapply(a, function(x) x%in%b))
        if (sum(wab)>0)  wd <- sum(unlist(lapply(a[wab], fun2)))
        wd/2
    }
    w <- apply(lw,1,fun3)
    res[col(res) < row(res) ] <- w
    res <- res+t(res)
    dimnames(res)=list(as.character(levpoly),as.character(levpoly))
    res
}
"as.taxo" <-                                                             
function (df)                                                            
{                                                                        
    if (!inherits(df, "data.frame"))                                     
        stop("df is not a data.frame")                                   
    nr <- nrow(df)                                                       
    nc <- ncol(df)                                                       
    for (i in 1:nc) if (!is.factor(df[, i]))                             
        stop(paste("column", i, "of 'df' is not a factor"))              
    for (i in 1:(nc - 1)) {                                              
        t <- table(df[, c(i, i + 1)])                                    
        w <- apply(t, 1, function(x) sum(x != 0))                        
        if (any(w != 1)) {
            print(w)                                                 
            stop(paste("non hierarchical design", i, "in", i +           
                1))   
        }                                                   
    }                                                                    
    fac <- df[, nc]                                                      
    for (i in (nc - 1):1) fac <- fac:df[, i]                             
    df <- df[order(fac), ]                                               
    class(df) <- c("data.frame", "taxo")                                 
    return(df)                                                           
}                                      
                                                                                                                                                                                                                    
"between" <- function (dudi, fac, scannf = TRUE, nf = 2) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class dudi expected")
    if (!is.factor(fac)) 
        stop("factor expected")
    lig <- nrow(dudi$tab)
    col <- ncol(dudi$tab)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    cla.w <- tapply(dudi$lw, fac, sum)
    mean.w <- function(x, w, fac, cla.w) {
        z <- x * w
        z <- tapply(z, fac, sum)/cla.w
        return(z)
    }
    tabmoy <- apply(dudi$tab, 2, mean.w, w = dudi$lw, fac = fac, 
        cla.w = cla.w)
    tabmoy <- data.frame(tabmoy)
    row.names(tabmoy) <- levels(fac)
    names(tabmoy) <- names(dudi$tab)
    X <- as.dudi(tabmoy, dudi$cw, as.vector(cla.w), scannf = scannf, 
        nf = nf, call = match.call(), type = "bet")
    X$ratio <- sum(X$eig)/sum(dudi$eig)
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(as.matrix(dudi$tab) %*% U)
    row.names(U) <- row.names(dudi$tab)
    names(U) <- names(X$c1)
    X$ls <- U
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
    row.names(U) <- names(dudi$li)
    names(U) <- names(X$li)
    X$as <- U
    class(X) <- c("between", "dudi")
    return(X)
}

"plot.between" <- function (x, xax = 1, yax = 2, ...) {
    bet <- x
    if (!inherits(bet, "between")) 
        stop("Use only with 'between' objects")
    if ((bet$nf == 1) || (xax == yax)) {
        appel <- as.list(bet$call)
        dudi <- eval(appel$dudi, sys.frame(0))
        fac <- eval(appel$fac, sys.frame(0))
        lig <- nrow(dudi$tab)
        if (length(fac) != lig) 
            stop("Non convenient dimension")
        sco.quant(bet$ls[, 1], dudi$tab, fac = fac)
        return(invisible())
    }
    if (xax > bet$nf) 
        stop("Non convenient xax")
    if (yax > bet$nf) 
        stop("Non convenient yax")
    fac <- eval(as.list(bet$call)$fac, sys.frame(0))
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.2, 0.2, 0.2, 0.2))
    s.arrow(bet$c1, xax = xax, yax = yax, sub = "Canonical weights", 
        csub = 2, clab = 1.25)
    s.arrow(bet$co, xax = xax, yax = yax, sub = "Variables", 
        csub = 2, cgrid = 0, clab = 1.25)
    scatterutil.eigen(bet$eig, wsel = c(xax, yax))
    s.class(bet$ls, fac, xax = xax, yax = yax, sub = "Scores and classes", 
        csub = 2, clab = 1.25)
    s.corcircle(bet$as, xax = xax, yax = yax, sub = "Inertia axes", 
        csub = 2, cgrid = 0, clab = 1.25)
    s.label(bet$li, xax = xax, yax = yax, sub = "Classes", 
        csub = 2, clab = 1.25)
}

"print.between" <- function (x, ...) {
    if (!inherits(x, "between")) 
        stop("to be used with 'between' object")
    cat("Between analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n$rank: ", x$rank)
    cat("\n$ratio: ", x$ratio)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(3, 4), list(1:3, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "group weigths")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "class coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "class normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "row coordinates")
    sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto between axis")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"bicenter.wt" <- function (X, row.wt = rep(1, nrow(X)), col.wt = rep(1, ncol(X))) {
    X <- as.matrix(X)
    n <- nrow(X)
    p <- ncol(X)
    if (length(row.wt) != n) 
        stop("length of row.wt must equal the number of rows in x")
    if (any(row.wt < 0) || (sr <- sum(row.wt)) == 0) 
        stop("weights must be non-negative and not all zero")
    row.wt <- row.wt/sr
    if (length(col.wt) != p) 
        stop("length of col.wt must equal the number of columns in x")
    if (any(col.wt < 0) || (st <- sum(col.wt)) == 0) 
        stop("weights must be non-negative and not all zero")
    col.wt <- col.wt/st
    row.mean <- apply(row.wt * X, 2, sum)
    col.mean <- apply(col.wt * t(X), 2, sum)
    col.mean <- col.mean - sum(row.mean * col.wt)
    X <- sweep(X, 2, row.mean)
    X <- t(sweep(t(X), 2, col.mean))
    return(X)
}
"cailliez" <- function (distmat, print = FALSE) {
    if (is.euclid(distmat)) {
        warning("Euclidean distance found : no correction need")
        return(distmat)
    }
    distmat <- dist2mat(distmat)
    size <- ncol(distmat)
    m1 <- matrix(0, size, size)
    m1 <- rbind(m1, -diag(size))
    m2 <- -bicenter.wt(distmat * distmat)
    m2 <- rbind(m2, 2 * bicenter.wt(distmat))
    m1 <- cbind(m1, m2)
    lambda <- eigen(m1, only = TRUE)$values
    c <- max(Re(lambda)[Im(lambda) < 1e-08])
    if (print) 
        cat(paste("Cailliez constant =", round(c, dig = 5), "\n"))
    distmat <- mat2dist(distmat + c)
    attr(distmat, "call") <- match.call()
    attr(distmat, "method") <- "Cailliez"
    return(distmat)
}
"cca" <- function (sitspe, sitenv, scannf = TRUE, nf = 2) {
    sitenv <- data.frame(sitenv)
    if (!inherits(sitspe, "data.frame")) 
        stop("data.frame expected")
    if (!inherits(sitenv, "data.frame")) 
        stop("data.frame expected")
    coa1 <- dudi.coa(sitspe, scannf = FALSE, nf = 8)
    x <- pcaiv(coa1, sitenv, scannf = scannf, nf = nf)
    class(x) <- c("cca", "pcaiv", "dudi")
    x$call <- match.call()
    return(x)
}
"coinertia" <- function (dudiX, dudiY, scannf = TRUE, nf = 2) {
    normalise.w <- function(X, w) {
        f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
        norm <- apply(X, 2, f2)
        X <- sweep(X, 2, norm, "/")
        return(X)
    }
    if (!inherits(dudiX, "dudi")) 
        stop("Object of class dudi expected")
    lig1 <- nrow(dudiX$tab)
    col1 <- ncol(dudiX$tab)
    if (!inherits(dudiY, "dudi")) 
        stop("Object of class dudi expected")
    lig2 <- nrow(dudiY$tab)
    col2 <- ncol(dudiY$tab)
    if (lig1 != lig2) 
        stop("Non equal row numbers")
    if (any((dudiX$lw - dudiY$lw)^2 > 1e-07)) 
        stop("Non equal row weights")
    tabcoiner <- t(as.matrix(dudiY$tab)) %*% (as.matrix(dudiX$tab) * 
        dudiX$lw)
    tabcoiner <- data.frame(tabcoiner)
    names(tabcoiner) <- names(dudiX$tab)
    row.names(tabcoiner) <- names(dudiY$tab)
    if (nf > dudiX$nf) 
        nf <- dudiX$nf
    if (nf > dudiY$nf) 
        nf <- dudiY$nf
    coi <- as.dudi(tabcoiner, dudiX$cw, dudiY$cw, scannf = scannf, 
        nf = nf, call = match.call(), type = "coinertia")
    U <- as.matrix(coi$c1) * unlist(coi$cw)
    U <- data.frame(as.matrix(dudiX$tab) %*% U)
    row.names(U) <- row.names(dudiX$tab)
    names(U) <- paste("AxcX", (1:coi$nf), sep = "")
    coi$lX <- U
    U <- normalise.w(U, dudiX$lw)
    names(U) <- paste("NorS", (1:coi$nf), sep = "")
    coi$mX <- U
    U <- as.matrix(coi$l1) * unlist(coi$lw)
    U <- data.frame(as.matrix(dudiY$tab) %*% U)
    row.names(U) <- row.names(dudiY$tab)
    names(U) <- paste("AxcY", (1:coi$nf), sep = "")
    coi$lY <- U
    U <- normalise.w(U, dudiY$lw)
    names(U) <- paste("NorS", (1:coi$nf), sep = "")
    coi$mY <- U
    U <- as.matrix(coi$c1) * unlist(coi$cw)
    U <- data.frame(t(as.matrix(dudiX$c1)) %*% U)
    row.names(U) <- paste("Ax", (1:dudiX$nf), sep = "")
    names(U) <- paste("AxcX", (1:coi$nf), sep = "")
    coi$aX <- U
    U <- as.matrix(coi$l1) * unlist(coi$lw)
    U <- data.frame(t(as.matrix(dudiY$c1)) %*% U)
    row.names(U) <- paste("Ax", (1:dudiY$nf), sep = "")
    names(U) <- paste("AxcY", (1:coi$nf), sep = "")
    coi$aY <- U
    RV <- sum(coi$eig)/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
    coi$RV <- RV
    return(coi)
}

"plot.coinertia" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "coinertia")) 
        stop("Use only with 'coinertia' objects")
    if (x$nf == 1) {
        warnings("One axis only : not yet implemented")
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    s.corcircle(x$aX, xax, yax, sub = "X axes", csub = 2, 
        clab = 1.25)
    s.corcircle(x$aY, xax, yax, sub = "Y axes", csub = 2, 
        clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
    s.match(x$mX, x$mY, xax, yax, clab = 1.5)
    s.arrow(x$l1, xax = xax, yax = yax, sub = "Y Canonical weights", 
        csub = 2, clab = 1.25)
    s.arrow(x$c1, xax = xax, yax = yax, sub = "X Canonical weights", 
        csub = 2, clab = 1.25)
}

"print.coinertia" <- function (x, ...) {
    if (!inherits(x, "coinertia")) 
        stop("to be used with 'coinertia' object")
    cat("Coinertia analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$rank (rank)     :", x$rank)
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n$RV (RV coeff)   :", x$RV)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(3, 4), list(1:3, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (CA)")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "Y col = CA row: coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "Y col = CA row: normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "X col = CA column: coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "X col = CA column: normed scores")
    sumry[6, ] <- c("$lX", nrow(x$lX), ncol(x$lX), "row coordinates (X)")
    sumry[7, ] <- c("$mX", nrow(x$mX), ncol(x$mX), "normed row scores (X)")
    sumry[8, ] <- c("$lY", nrow(x$lY), ncol(x$lY), "row coordinates (Y)")
    sumry[9, ] <- c("$mY", nrow(x$mY), ncol(x$mY), "normed row scores (Y)")
    sumry[10, ] <- c("$aX", nrow(x$aX), ncol(x$aX), "axis onto co-inertia axis (X)")
    sumry[11, ] <- c("$aY", nrow(x$aY), ncol(x$aY), "axis onto co-inertia axis (Y)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}

"summary.coinertia" <- function (object, ...) {
    if (!inherits(object, "coinertia")) 
        stop("to be used with 'coinertia' object")
    appel <- as.list(object$call)
    dudiX <- eval(appel$dudiX, sys.frame(0))
    dudiY <- eval(appel$dudiY, sys.frame(0))
    norm.w <- function(X, w) {
        f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
        norm <- apply(X, 2, f2)
        return(norm)
    }
    util <- function(n) {
        x <- "1"
        for (i in 2:n) x[i] <- paste(x[i - 1], i, sep = "")
        return(x)
    }
    eig <- object$eig[1:object$nf]
    covar <- sqrt(eig)
    sdX <- norm.w(object$lX, dudiX$lw)
    sdY <- norm.w(object$lY, dudiX$lw)
    corr <- covar/sdX/sdY
    U <- cbind.data.frame(eig, covar, sdX, sdY, corr)
    row.names(U) <- as.character(1:object$nf)
    cat("\nEigenvalues decomposition:\n")
    print(U)
    cat("\nInertia & coinertia X:\n")
    inertia <- cumsum(sdX^2)
    max <- cumsum(dudiX$eig[1:object$nf])
    ratio <- inertia/max
    U <- cbind.data.frame(inertia, max, ratio)
    row.names(U) <- util(object$nf)
    print(U)
    cat("\nInertia & coinertia Y:\n")
    inertia <- cumsum(sdY^2)
    max <- cumsum(dudiY$eig[1:object$nf])
    ratio <- inertia/max
    U <- cbind.data.frame(inertia, max, ratio)
    row.names(U) <- util(object$nf)
    print(U)
    RV <- sum(object$eig)/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
    cat("\nRV:\n", RV, "\n")
}
########## mantelkdist ###############
########## RVkdist ###################
########## print.corkdist ############
########## summary.corkdist ##########
########## plot.corkdist #############

"mantelkdist" <- function(kd, nrepet = 999) {
    if (!inherits(kd,"kdist")) stop ("Object of class 'kdist' expected")
    res=list()
    ndist <- length(kd)
    nind <- attr(kd, "size")
    if (nrepet<=99) nrepet <- 99
    n <- attr(kd,"size")
    ncouple <- ndist*(ndist-1)/2
    w <- matrix(0,ndist,ndist)
    numrow <- row(w)[row(w)>col(w)]
    numcol <- col(w)[row(w)>col(w)]
    w <- cbind.data.frame(I = numrow,J = numcol)
    numrow <- attr(kd, "names")[numrow]
    numcol <- attr(kd, "names")[numcol]
    cha <- paste(numrow,numcol,sep="-")
    row.names(w) <- cha
    attr(res,"design") <- w
    
    kdistelem2dist    <- function (i) {
        m1 <- matrix(0, nind, nind)
        m1[row(m1) > col(m1)] <- kd[[i]]
        m1 <- m1 + t(m1)
        m1 <- mat2dist(m1)
        m1
    }
    k <- 0
    for(i in 1:(ndist-1)) {
        m1 <- kdistelem2dist(i)
        for(j in (i+1):ndist) {
            m2 <- kdistelem2dist(j)
            k <- k+1
            w <- mantel.randtest (m1, m2, nrepet)
            w$call <- match.call()
            res[[k]] <- w
        }
    }    
    names (res) <- cha
    attr (res,"call") <- match.call()
    attr (res,"test") <- "Mantel's tests"
    class(res) <- c("corkdist","list")
    return(res)
}

"RVkdist" <- function(kd, nrepet = 999) {
    if (!inherits(kd,"kdist")) stop ("Object of class 'kdist' expected")
    if (any(!attr(kd,"euclid"))) stop ("Euclidean matrices expected")
    res=list()
    ndist <- length(kd)
    nind <- attr(kd, "size")
    if (nrepet<=99) nrepet <- 99
    n <- attr(kd,"size")
    ncouple <- ndist*(ndist-1)/2
    w <- matrix(0,ndist,ndist)
    numrow <- row(w)[row(w)>col(w)]
    numcol <- col(w)[row(w)>col(w)]
    w <- cbind.data.frame(I = numrow,J = numcol)
    numrow <- attr(kd, "names")[numrow]
    numcol <- attr(kd, "names")[numcol]
    cha <- paste(numrow,numcol,sep="-")
    row.names(w) <- cha
    attr(res,"design") <- w
    
    kdistelem2dist    <- function (i) {
        m1 <- matrix(0, nind, nind)
        m1[row(m1) > col(m1)] <- kd[[i]]
        m1 <- m1 + t(m1)
        m1 <- mat2dist(m1)
        m1
    }
    k <- 0
    for(i in 1:(ndist-1)) {
        m1 <- kdistelem2dist(i)
        for(j in (i+1):ndist) {
            m2 <- kdistelem2dist(j)
            k <- k+1
            w <- RVdist.randtest (m1, m2, nrepet)
            w$call <- match.call()
            res[[k]] <- w
        }
    }    
    names (res) <- cha
    attr (res,"call") <- match.call()
    attr (res,"test") <- "RV tests"
    class(res) <- c("corkdist","list")
    return(res)
}

"print.corkdist" <- function (x, ...) {
    if (!inherits(x,"corkdist")) stop ("Object 'corkdist' expected")
    cat(attr (x,"test"),"for 'kdist' object\n")
    cat("class: ") ; cat(class(x),"\n")
    cat ("Call: ") ; print(attr (x,"call"))
    cat("\n") ; cat(names(x)[1],"\n")
    print.randtest (x[[1]])
    if (length(x)>2) {
        cat("\n") ; cat(names(x)[2],"\n")
        print.randtest (x[[2]])
     }
     if (length(x)==3) {
        cat("\n") ; cat(names(x)[3],"\n")
        print.randtest (x[[3]])
     }
     if (length(x)>33) {
        cat("...\n")
     }
   cat("list of",length (x), "'randtest' objects\n")
}

summary.corkdist <- function (object, ...) {
    if (!inherits(object,"corkdist")) stop ("Object 'corkdist' expected")
    design <- attr(object, "design")
    cat(attr (object,"test"),"for 'kdist' object\n")  
    cat ("Call: ") ; print(attr (object,"call"))
    ndig0 <- nchar(as.character(as.integer(object[[1]]$rep)))
    pval <- round(unlist(lapply(object, function(x) x$pvalue)),dig=ndig0)
    ndist <- max(design$I)
    res=matrix(0,ndist,ndist)
    res[row(res) <= col(res)] <- NA
    dist.names <- names(eval(as.list(attr(object,"call"))$kd, sys.frame(0)))
    dimnames(res) <- list(dist.names, as.character(1:length(dist.names)))
    res[row(res) > col(res)] <- pval
    cat("Simulated p-values:\n")
    print(res, na = "-", ...)
}


plot.corkdist <- function (x, whichinrow=NULL, whichincol=NULL, gap=4, nclass = 10, coeff = 1, ...) {
    "hist.simul.util" <- function(sim, obs, nclass, coeff, title="") {
        r0 <- c(sim, obs)
        h0 <- hist(sim, plot = FALSE, nclass = nclass, xlim = xlim0)
        y0 <- max(h0$counts)
        l0 <- max(sim) - min(sim)
        w0 <- l0/(log(length(sim), base = 2) + 1)
        w0 <- w0 * coeff
        xlim0 <- range(r0) + c( - w0, w0)
        hist(sim, plot = TRUE, nclass = nclass, xlim = xlim0, main=title, col=grey(0.9))
        lines(c(obs, obs), c(y0/2, 0))
        points(obs, y0/2, pch = 18, cex = 2)
    }
    kdistelem2delta    <- function (i) {
        m1 <- matrix(0, nind, nind)
        m1[row(m1) > col(m1)] <- kd[[i]]
        m1 <- m1 + t(m1)
        m1 <- -m1*m1/2
        m1 <- bicenter.wt(m1)
        return(m1[row(m1) > col(m1)])
    }

    if (!inherits(x,"corkdist")) stop ("Object of class 'corkdist' expected")
    kd <- eval(as.list(attr(x,"call"))$kd, sys.frame(0))
    design <- attr(x, "design")
    ndist <- length (kd)
    if (is.null(whichinrow)) whichinrow <- 1:ndist
    if (is.null(whichincol)) whichincol <- 1:ndist
    labels = names(kd)
    nind <- attr(kd, "size")
    old.par <- par(no.readonly = TRUE)
    on.exit(par(old.par))
    oma <- c(2, 2, 1, 1)
    par(mfrow = c(length(whichinrow), length(whichincol)), mar = rep(gap/2, 4), oma = oma)
    index <- 0
    for (i in whichinrow) {
        for (j in whichincol) {
            if (i==j) {
                plot.default(0,0,type="n",asp=1, xlab="", ylab="",xaxt="n",yaxt="n",
                xlim=c(0,1), ylim=c(0,1), xaxs="i", yaxs="i", frame.plot=FALSE)
                l.wid <- strwidth(labels, "user")
                cex.labels <- max(0.8, min(2, 0.9/max(l.wid)))
                text(0.5, 0.5, labels[i], cex = cex.labels, font = 1)
            } else if (i>j) {
                n0 <- (1:nrow(design))[design$I==i & design$J==j]
                sim <- x[[n0]]$sim
                obs <- x[[n0]]$obs
                titre <- row.names(design)[n0]
                hist.simul.util(sim,obs,title=titre,nclass=nclass,coeff=coeff)
            } else if (j>i) {
                if (attr(x,"test")=="Mantel's tests")
                    plot(kd[[i]],kd[[j]])
                else {
                    plot(kdistelem2delta(i),kdistelem2delta(j))
                    
                }
            }
        }
    }
}


disc <- function(samples, dis = NULL, structures=NULL){
    # checking of user's data and initialization.
    if (!inherits(samples, "data.frame")) stop("Non convenient samples")
    if (any(samples < 0)) stop("Negative value in samples")
    if (!is.null(dis)) {
        if (!inherits(dis, "dist")) stop("Object of class 'dist' expected for distance")
        if (!is.euclid(dis)) stop("Euclidean property is expected for distance")
        dis <- as.matrix(dis)
        if (nrow(samples)!= nrow(dis)) stop("Non convenient samples")
    }
    if (is.null(dis)) dis <- (matrix(1, nrow(samples), nrow(samples)) - diag(rep(1, nrow(samples)))) * sqrt(2)
    if (!is.null(structures)){
        if (!inherits(structures, "data.frame")) stop("Non convenient structures")
        m <- match(apply(structures, 2, function(x) length(x)), ncol(samples), 0 )
        if (length(m[m == 1]) != ncol(structures)) stop ("Non convenient structures")
        m <- match(tapply(1:ncol(structures), as.factor(1:ncol(structures)), function(x) is.factor(structures[, x])), TRUE , 0)
        if(length(m[m == 1]) != ncol(structures)) stop ("Non convenient structures")
    }
    # Intern functions :
    Diversity <- function(d2, nbhaplotypes, freq) {
        div <- nbhaplotypes/2*(t(freq)%*%d2%*%freq)
    }
    Structutil <- function(dp2, Np, unit){    
        if (!is.null(unit)) {
            modunit <- model.matrix(~ -1 + unit)
            sumcol <- apply(Np, 2, sum)
            Ng <- modunit * sumcol
            lesnoms <- levels(unit)
        }
        else{
            Ng <- as.matrix(Np)
            lesnoms <- colnames(Np)
        }
        sumcol <- apply(Ng, 2, sum)
        Lg <- t(t(Ng) / sumcol)
        colnames(Lg) <- lesnoms
        Pg <- as.matrix(apply(Ng, 2, sum) / nbhaplotypes)
        rownames(Pg) <- lesnoms
        deltag <- as.matrix(apply(Lg, 2, function(x) t(x) %*% dp2 %*% x))
        ug <- matrix(1, ncol(Lg), 1)
        dg2 <- t(Lg) %*% dp2 %*% Lg - 1 / 2 * (deltag %*% t(ug) + ug %*% t(deltag))
        colnames(dg2) <- lesnoms
        rownames(dg2) <- lesnoms
        return(list(dg2 = dg2, Ng = Ng, Pg = Pg))
    }
    Diss <- function(dis, nbhaplotypes, samples, structures){
        structutil <- list(0)
        structutil[[1]] <- Structutil(dp2 = dis, Np = samples, NULL)
        diss <- list(sqrt(as.dist(structutil[[1]]$dg2)))
        if(!is.null(structures)){
            for(i in 1:length(structures)){
                structutil[[i+1]] <- Structutil(structutil[[1]]$dg2, structutil[[1]]$Ng, structures[,i])    
            }
            diss <- c(diss, tapply(1:length(structures), factor(1:length(structures)), function(x) sqrt(as.dist(structutil[[x + 1]]$dg2))))
        }
        return(diss)
    }
    # main procedure.
    nbhaplotypes <- sum(samples)    
    diss <- Diss(dis^2, nbhaplotypes, samples, structures)
    names(diss) <- c("samples", names(structures))
    # Interface.
    if (!is.null(structures)) {
        return(diss)
    }
    return(diss$samples)
}
"discrimin" <- function (dudi, fac, scannf = TRUE, nf = 2) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class dudi expected")
    if (!is.factor(fac)) 
        stop("factor expected")
    lig <- nrow(dudi$tab)
    col <- ncol(dudi$tab)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    rank <- dudi$rank
    dudi <- redo.dudi(dudi, rank)
    deminorm <- as.matrix(dudi$c1) * dudi$cw
    deminorm <- t(t(deminorm)/sqrt(dudi$eig))
    cla.w <- tapply(dudi$lw, fac, sum)
    mean.w <- function(x) {
        z <- x * dudi$lw
        z <- tapply(z, fac, sum)/cla.w
        return(z)
    }
    tabmoy <- apply(dudi$l1, 2, mean.w)
    tabmoy <- data.frame(tabmoy)
    row.names(tabmoy) <- levels(fac)
    cla.w <- cla.w/sum(cla.w)
    X <- as.dudi(tabmoy, rep(1, rank), as.vector(cla.w), scannf = scannf, 
        nf = nf, call = match.call(), type = "dis")
    res <- list()
    res$eig <- X$eig
    res$nf <- X$nf
    res$fa <- deminorm %*% as.matrix(X$c1)
    res$li <- as.matrix(dudi$tab) %*% res$fa
    w <- scalewt(dudi$tab, dudi$lw)
    res$va <- t(as.matrix(w)) %*% (res$li * dudi$lw)
    res$cp <- t(as.matrix(dudi$l1)) %*% (dudi$lw * res$li)
    res$fa <- data.frame(res$fa)
    row.names(res$fa) <- names(dudi$tab)
    names(res$fa) <- paste("DS", 1:X$nf, sep = "")
    res$li <- data.frame(res$li)
    row.names(res$li) <- row.names(dudi$tab)
    names(res$li) <- names(res$fa)
    w <- apply(res$li, 2, mean.w)
    res$gc <- data.frame(w)
    row.names(res$gc) <- as.character(levels(fac))
    names(res$gc) <- names(res$fa)
    res$cp <- data.frame(res$cp)
    row.names(res$cp) <- names(dudi$l1)
    names(res$cp) <- names(res$fa)
    res$call <- match.call()
    class(res) <- "discrimin"
    return(res)
}

"plot.discrimin" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "discrimin")) 
        stop("Use only with 'discrimin' objects")
    if ((x$nf == 1) || (xax == yax)) {
        if (inherits(x, "coadisc")) {
            appel <- as.list(x$call)
            df <- eval(appel$df, sys.frame(0))
            fac <- eval(appel$fac, sys.frame(0))
            lig <- nrow(df)
            if (length(fac) != lig) 
                stop("Non convenient dimension")
            lig.w <- apply(df, 1, sum)
            lig.w <- lig.w/sum(lig.w)
            cla.w <- as.vector(tapply(lig.w, fac, sum))
            mean.w <- function(x) {
                z <- x * lig.w
                z <- tapply(z, fac, sum)/cla.w
                return(z)
            }
            w <- apply(df, 2, mean.w)
            w <- data.frame(t(w))
            sco.distri(x$fa[, xax], w, clabel = 1, xlim = NULL, 
                grid = TRUE, cgrid = 1, include.origin = TRUE, origin = 0, 
                sub = NULL, csub = 1)
            return(invisible())
        }
        appel <- as.list(x$call)
        dudi <- eval(appel$dudi, sys.frame(0))
        fac <- eval(appel$fac, sys.frame(0))
        lig <- nrow(dudi$tab)
        if (length(fac) != lig) 
            stop("Non convenient dimension")
        sco.quant(x$li[, 1], dudi$tab, fac = fac)
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    fac <- eval(as.list(x$call)$fac, sys.frame(0))
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.2, 0.2, 0.2, 0.2))
    s.arrow(x$fa, xax = xax, yax = yax, sub = "Canonical weights", 
        csub = 2, clab = 1.25)
    s.corcircle(x$va, xax = xax, yax = yax, sub = "Cos(variates,canonical variates)", 
        csub = 2, cgrid = 0, clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
    s.class(x$li, fac, xax = xax, yax = yax, sub = "Scores and classes", 
        csub = 2, clab = 1.5)
    s.corcircle(x$cp, xax = xax, yax = yax, sub = "Cos(components,canonical variates)", 
        csub = 2, cgrid = 0, clab = 1.25)
    s.label(x$gc, xax = xax, yax = yax, sub = "Class scores", 
        csub = 2, clab = 1.25)
}

"print.discrimin" <- function (x, ...) {
    if (!inherits(x, "discrimin")) 
        stop("to be used with 'discrimin' object")
    cat("Discriminant analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$fa", nrow(x$fa), ncol(x$fa), "loadings / canonical weights")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "canonical scores")
    sumry[3, ] <- c("$va", nrow(x$va), ncol(x$va), "cos(variables, canonical scores)")
    sumry[4, ] <- c("$cp", nrow(x$cp), ncol(x$cp), "cos(components, canonical scores)")
    sumry[5, ] <- c("$gc", nrow(x$gc), ncol(x$gc), "class scores")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"discrimin.coa" <- function (df, fac, scannf = TRUE, nf = 2) {
    if (!is.factor(fac)) 
        stop("factor expected")
    lig <- nrow(df)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    dudi.coarp <- function(df) {
        if (!is.data.frame(df)) 
            stop("data.frame expected")
        lig <- nrow(df)
        col <- ncol(df)
        if (any(df < 0)) 
            stop("negative entries in table")
        if ((N <- sum(df)) == 0) 
            stop("all frequencies are zero")
        df <- df/N
        row.w <- apply(df, 1, sum)
        col.w <- apply(df, 2, sum)
        if (any(col.w == 0)) 
            stop("null column found in data")
        df <- df/row.w
        df <- sweep(df, 2, col.w)
        X <- as.dudi(df, 1/col.w, row.w, scannf = FALSE, nf = 2, 
            call = match.call(), type = "coarp", full = TRUE)
        X$N <- N
        class(X) <- "dudi"
        return(X)
    }
    dudi <- dudi.coarp(df)
    rank <- dudi$rank
    deminorm <- as.matrix(dudi$c1) * dudi$cw
    deminorm <- t(t(deminorm)/sqrt(dudi$eig))
    cla.w <- as.vector(tapply(dudi$lw, fac, sum))
    mean.w <- function(x) {
        z <- x * dudi$lw
        z <- tapply(z, fac, sum)/cla.w
        return(z)
    }
    tabmoy <- apply(dudi$l1, 2, mean.w)
    tabmoy <- data.frame(tabmoy)
    row.names(tabmoy) <- levels(fac)
    X <- as.dudi(tabmoy, rep(1, rank), cla.w, scannf = scannf, 
        nf = nf, call = match.call(), type = "dis")
    res <- list(eig = X$eig)
    res$nf <- X$nf
    res$fa <- deminorm %*% as.matrix(X$c1)
    res$li <- as.matrix(dudi$tab) %*% res$fa
    w <- scalewt(dudi$tab, dudi$lw)
    res$va <- t(as.matrix(w)) %*% (res$li * dudi$lw)
    res$cp <- t(as.matrix(dudi$l1)) %*% (dudi$lw * res$li)
    res$fa <- data.frame(res$fa)
    row.names(res$fa) <- names(dudi$tab)
    names(res$fa) <- paste("DS", 1:X$nf, sep = "")
    res$li <- data.frame(res$li)
    row.names(res$li) <- row.names(dudi$tab)
    names(res$li) <- names(res$fa)
    w <- apply(res$li, 2, mean.w)
    res$gc <- data.frame(w)
    row.names(res$gc) <- as.character(levels(fac))
    names(res$gc) <- names(res$fa)
    res$va <- data.frame(res$va)
    row.names(res$va) <- names(dudi$tab)
    names(res$va) <- names(res$fa)
    res$cp <- data.frame(res$cp)
    row.names(res$cp) <- names(dudi$l1)
    names(res$cp) <- names(res$fa)
    res$call <- match.call()
    class(res) <- c("coadisc", "discrimin")
    return(res)
}
"dist.binary" <- function (df, method = NULL, diag = FALSE, upper = FALSE) {
    METHODS <- c("JACCARD S3", "SOCKAL & MICHENER S4", "SOCKAL & SNEATH S5", 
        "ROGERS & TANIMOTO S6", "CZEKANOWSKI S7", "GOWER & LEGENDRE S9", "OCHIAI S12", "SOKAL & SNEATH S13", 
        "Phi of PEARSON S14", "GOWER & LEGENDRE S2")
    if (!inherits(df, "data.frame")) 
        stop("df is not a data.frame")
    if (any(df < 0)) 
        stop("non negative value expected in df")
    d.names <- row.names(df)
    nlig <- nrow(df)
    df <- as.matrix(1 * (df > 0))
    if (is.null(method)) {
        cat("1 = JACCARD index (1901) S3 coefficient of GOWER & LEGENDRE\n")
        cat("s1 = a/(a+b+c) --> d = sqrt(1 - s)\n")
        cat("2 = SOCKAL & MICHENER index (1958) S4 coefficient of GOWER & LEGENDRE \n")
        cat("s2 = (a+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
        cat("3 = SOCKAL & SNEATH(1963) S5 coefficient of GOWER & LEGENDRE\n")
        cat("s3 = a/(a+2(b+c)) --> d = sqrt(1 - s)\n")
        cat("4 = ROGERS & TANIMOTO (1960) S6 coefficient of GOWER & LEGENDRE\n")
        cat("s4 = (a+d)/(a+2(b+c)+d) --> d = sqrt(1 - s)\n")
        cat("5 = CZEKANOWSKI (1913) or SORENSEN (1948) S7 coefficient of GOWER & LEGENDRE\n")
        cat("s5 = 2*a/(2*a+b+c) --> d = sqrt(1 - s)\n")
        cat("6 = S9 index of GOWER & LEGENDRE (1986)\n")
        cat("s6 = (a-(b+c)+d)/(a+b+c+d) --> d = sqrt(1 - s)\n")
        cat("7 = OCHIAI (1957) S12 coefficient of GOWER & LEGENDRE\n")
        cat("s7 = a/sqrt((a+b)(a+c)) --> d = sqrt(1 - s)\n")
        cat("8 = SOKAL & SNEATH (1963) S13 coefficient of GOWER & LEGENDRE\n")
        cat("s8 = ad/sqrt((a+b)(a+c)(d+b)(d+c)) --> d = sqrt(1 - s)\n")
        cat("9 = Phi of PEARSON = S14 coefficient of GOWER & LEGENDRE\n")
        cat("s9 = ad-bc)/sqrt((a+b)(a+c)(b+d)(d+c)) --> d = sqrt(1 - s)\n")
        cat("10 = S2 coefficient of GOWER & LEGENDRE\n")
        cat("s10 =  a/(a+b+c+d) --> d = sqrt(1 - s) and unit self-similarity\n")
        cat("Select an integer (1-10): ")
        method <- as.integer(readLines(n = 1))
    }
    df <- as.matrix(df)
    a <- df %*% t(df)
    b <- df %*% (1 - t(df))
    c <- (1 - df) %*% t(df)
    d <- ncol(df) - a - b - c

    if (method == 1) {
        d <- a/(a + b + c)
    }
    else if (method == 2) {
        d <- (a + d)/(a + b + c + d)
    }
    else if (method == 3) {
        d <- a/(a + 2 * (b + c))
    }
    else if (method == 4) {
        d <- (a + d)/(a + 2 * (b + c) + d)
    }
    # correction d'un bug signal par Christian Dring <c.duering@web.de>
    else if (method == 5) {
        d <- 2*a/(2 * a + b + c)
    }
    else if (method == 6) {
        d <- (a - (b + c) + d)/(a + b + c + d)
        
    }
    else if (method == 7) {
        d <- a/sqrt((a+b)*(a+c))
    }
    else if (method == 8) {
        d <- a * d/sqrt((a + b) * (a + c) * (d + b) * (d + c))
    }
    else if (method == 9) {
        d <- (a * d - b * c)/sqrt((a + b) * (a + c) * (b + d) * 
            (d + c))
    }
    else if (method == 10) {
        d <- a/(a + b + c + d)
        diag(d) <- 1
    }
    else stop("Non convenient method")
    d <- sqrt(1 - d)
    # if (sum(diag(d)^2)>0) stop("diagonale non nulle")
    d <- mat2dist(d)
    attr(d, "Size") <- nlig
    attr(d, "Labels") <- d.names
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
}
"dist.dudi" <- function (dudi, amongrow = TRUE) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class 'dudi' expected")
    nr <- nrow(dudi$tab)
    nc <- ncol(dudi$tab)
    lw <- dudi$lw
    cw <- dudi$cw
    if (amongrow) {
        x <- t(t(dudi$tab) * sqrt(dudi$cw))
        x <- x %*% t(x)
        y <- diag(x)
        x <- (-2) * x + y
        x <- t(t(x) + y)
        x <- (x + t(x))/2
        diag(x) <- 0
        x <- mat2dist(sqrt(x))
        attr(x, "Labels") <- row.names(dudi$tab)
        attr(x, "method") <- "DUDI"
        return(x)
    }
    else {
        x <- as.matrix(dudi$tab) * sqrt(dudi$lw)
        x <- t(x) %*% x
        y <- diag(x)
        x <- (-2) * x + y
        x <- t(t(x) + y)
        x <- (x + t(x))/2
        diag(x) <- 0
        x <- mat2dist(sqrt(x))
        attr(x, "Labels") <- names(dudi$tab)
        attr(x, "method") <- "DUDI"
        return(x)
    }
}
"dist.genet" <- function (genet, method = 1, diag = FALSE, upper = FALSE) { 
    METHODS = c("Nei","Edwards","Reynolds","Rodgers","Provesti")
    if (all((1:5)!=method)) {
        cat("1 = Nei 1972\n")
        cat("2 = Edwards 1971\n")
        cat("3 = Reynolds, Weir and Coockerman 1983\n")
        cat("4 = Rodgers 1972\n")
        cat("5 = Provesti 1975\n")
        cat("Select an integer (1-5): ")
        method <- as.integer(readLines(n = 1))
    }
    if (all((1:5)!=method)) (stop ("Non convenient method number"))
    if (!inherits(genet,"genet"))  
        stop("list of class 'genet' expected")
    df <- genet$tab
    col.blocks <- genet$loc.blocks
    nloci <- length(col.blocks)
    d.names <- genet$pop.names
    nallel= sum(col.blocks)
    nlig <- nrow(df)

    if (is.null(names(col.blocks))) {
        names(col.blocks) <- paste("L", as.character(1:nloci), sep = "")
    }
    f1 <- function(x) {
        a <- sum(x)
        if (is.na(a)) 
            return(rep(0, length(x)))
        if (a == 0) 
            return(rep(0, length(x)))
        return(x/a)
    }
    k2 <- 0
    for (k in 1:nloci) {
        k1 <- k2 + 1
        k2 <- k2 + col.blocks[k]
        X <- df[, k1:k2]
        X <- t(apply(X, 1, f1))
        X.marge <- apply(X, 1, sum)
        if (any(sum(X.marge)==0)) stop ("Null row found")
        X.marge <- X.marge/sum(X.marge)
        X.mean <- apply(X * X.marge, 2, sum)
        nr <- sum(X.marge == 0)
        df[, k1:k2] <- X
    }
    # df contient un tableau de frquence
    df <- as.matrix(df)    
    if (method == 1) {
        d <- df%*%t(df)
        vec <- sqrt(diag(d))
        d <- d/vec[col(d)]
        d <- d/vec[row(d)]
        d <- -log(d)
        d <- mat2dist(d)
    } else if (method == 2) {
        df <- sqrt(df)
        d <- df%*%t(df)
        d <- 1-d/nloci
        diag(d) <- 0
        d <- sqrt(d)
        d <- mat2dist(d)
    } else if (method == 3) {
       denomi <- df%*%t(df)
       vec <- apply(df,1,function(x) sum(x*x))
       d <- -2*denomi + vec[col(denomi)] + vec[row(denomi)]
       diag(d) <- 0
       denomi <- 2*nloci - 2*denomi
       diag(denomi) <- 1
       d <- d/denomi
       d <- sqrt(d)
       d <- mat2dist(d)
    } else if (method == 4) {
        loci.fac <- rep( names(col.blocks),col.blocks)
        loci.fac <- as.factor(loci.fac)
        ltab <- lapply(split(df,loci.fac[col(df)]),matrix,nrow=nlig)
        "dcano" <- function (mat) {
            daux <- mat%*%t(mat)
            vec <- diag(daux)
            daux <- -2*daux+vec[col(daux)]
            daux <- daux + vec[row(daux)]
            diag(daux) <- 0
            daux <- sqrt(daux/2)
            d <<- d+daux
        }
        d <- matrix(0,nlig,nlig)
        lapply(ltab, dcano)
        d <- d/length(ltab)
        d <- mat2dist(d)
    } else if (method ==5) {
        w0 <- 1:(nlig-1)
        "loca" <- function (k) {
            w1 <- (k+1):nlig
            resloc <- unlist(lapply(w1, function(x) sum(abs(df[k,]-df[x,]))))
            return(resloc/2/nloci)
        }
        d <- unlist(lapply(w0,loca))
    } 
    attr(d, "Size") <- nlig
    attr(d, "Labels") <- d.names
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
    
}
"dist.neig" <- function (neig) {
    if (!inherits(neig, "neig")) 
        stop("Object of class 'neig' expected")
    res <- neig.util.LtoG(neig)
    n <- nrow(res)
    auxi1 <- res
    auxi2 <- res
    for (itour in 2:n) {
        auxi2 <- auxi2 %*% auxi1
        auxi2[res != 0] <- 0
        diag(auxi2) <- 0
        auxi2 <- (auxi2 > 0) * itour
        if (sum(auxi2) == 0) 
            break
        res <- res + auxi2
    }
    return(mat2dist(res))
}
"dist.prop" <- function (df, method = NULL, diag = FALSE, upper = FALSE) {
    METHODS <- c("d1 Manly", "Overlap index Manly", "Rogers 1972", 
        "Nei 1972", "Edwards 1971")
    if (!inherits(df, "data.frame")) 
        stop("df is not a data.frame")
    if (any(df < 0)) 
        stop("non negative value expected in df")
    dfs <- apply(df, 1, sum)
    if (any(dfs == 0)) 
        stop("row with all zero value")
    df <- df/dfs
    if (is.null(method)) {
        cat("1 = d1 Manly\n")
        cat("d1 = Sum|p(i)-q(i)|/2\n")
        cat("2 = Overlap index Manly\n")
        cat("d2=1-Sum(p(i)q(i))/sqrt(Sum(p(i)^2)/sqrt(Sum(q(i)^2)\n")
        cat("3 = Rogers 1972 (one locus)\n")
        cat("d3=sqrt(0.5*Sum(p(i)-q(i)^2))\n")
        cat("4 = Nei 1972 (one locus)\n")
        cat("d4=-ln(Sum(p(i)q(i)/sqrt(Sum(p(i)^2)/sqrt(Sum(q(i)^2))\n")
        cat("5 = Edwards 1971 (one locus)\n")
        cat("d5= sqrt (1 - (Sum(sqrt(p(i)q(i))))\n")
        cat("Selec an integer (1-5): ")
        method <- as.integer(readLines(n = 1))
    }
    nlig <- nrow(df)
    d <- matrix(0, nlig, nlig)
    d.names <- row.names(df)
    df <- as.matrix(df)
    fun1 <- function(x) {
        p <- df[x[1], ]
        q <- df[x[2], ]
        w <- sum(abs(p - q))/2
        return(w)
    }
    fun2 <- function(x) {
        p <- df[x[1], ]
        q <- df[x[2], ]
        w <- 1 - sum(p * q)/sqrt(sum(p * p))/sqrt(sum(q * q))
        return(w)
    }
    fun3 <- function(x) {
        p <- df[x[1], ]
        q <- df[x[2], ]
        w <- sqrt(0.5 * sum((p - q)^2))
        return(w)
    }
    fun4 <- function(x) {
        p <- df[x[1], ]
        q <- df[x[2], ]
        if (sum(p * q) == 0) 
            stop("sum(p*q)==0 -> non convenient data")
        w <- -log(sum(p * q)/sqrt(sum(p * p))/sqrt(sum(q * q)))
        return(w)
    }
    fun5 <- function(x) {
        p <- df[x[1], ]
        q <- df[x[2], ]
        w <- sqrt(1 - sum(sqrt(p * q)))
        return(w)
    }
    index <- cbind(col(d)[col(d) < row(d)], row(d)[col(d) < row(d)])
    method <- method[1]
    if (method == 1) 
        d <- unlist(apply(index, 1, fun1))
    else if (method == 2) 
        d <- unlist(apply(index, 1, fun2))
    else if (method == 3) 
        d <- unlist(apply(index, 1, fun3))
    else if (method == 4) 
        d <- unlist(apply(index, 1, fun4))
    else if (method == 5) 
        d <- unlist(apply(index, 1, fun5))
    else stop("Non convenient method")
    attr(d, "Size") <- nlig
    attr(d, "Labels") <- d.names
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
}
"dist.quant" <- function (df, method = NULL, diag = FALSE, upper = FALSE, tol = 1e-07) {
    METHODS <- c("Canonical", "Joreskog", "Mahalanobis")
    df <- data.frame(df)
    if (!inherits(df, "data.frame")) 
        stop("df is not a data.frame")
    if (is.null(method)) {
        cat("1 = Canonical\n")
        cat("d1 = ||x-y|| A=Identity\n")
        cat("2 = Joreskog\n")
        cat("d2=d2 = ||x-y|| A=1/diag(cov)\n")
        cat("3 = Mahalanobis\n")
        cat("d3 = ||x-y|| A=inv(cov)\n")
        cat("Selec an integer (1-3): ")
        method <- as.integer(readLines(n = 1))
    }
    nlig <- nrow(df)
    d <- matrix(0, nlig, nlig)
    d.names <- row.names(df)
    fun1 <- function(x) {
        sqrt(sum((df[x[1], ] - df[x[2], ])^2))
    }
    df <- as.matrix(df)
    index <- cbind(col(d)[col(d) < row(d)], row(d)[col(d) < row(d)])
    method <- method[1]
    if (method == 1) {
        d <- unlist(apply(index, 1, fun1))
    }
    else if (method == 2) {
        dfcov <- cov(df) * (nlig - 1)/nlig
        jor <- diag(dfcov)
        jor[jor == 0] <- 1
        jor <- 1/sqrt(jor)
        df <- t(t(df) * jor)
        d <- unlist(apply(index, 1, fun1))
    }
    else if (method == 3) {
        dfcov <- cov(df) * (nlig - 1)/nlig
        maha <- eigen(dfcov, sym = TRUE)
        maha.r <- sum(maha$values > (maha$values[1] * tol))
        maha.e <- 1/sqrt(maha$values[1:maha.r])
        maha.v <- maha$vectors[, 1:maha.r]
        maha.v <- t(t(maha.v) * maha.e)
        df <- df %*% maha.v
        d <- unlist(apply(index, 1, fun1))
    }
    else stop("Non convenient method")
    attr(d, "Size") <- nlig
    attr(d, "Labels") <- d.names
    attr(d, "Diag") <- diag
    attr(d, "Upper") <- upper
    attr(d, "method") <- METHODS[method]
    attr(d, "call") <- match.call()
    class(d) <- "dist"
    return(d)
}
divc <- function(df, dis = NULL){
    # checking of user's data and initialization.
    if (!inherits(df, "data.frame")) stop("Non convenient df")
    if (any(df < 0)) stop("Negative value in df")
    if (!is.null(dis)) {
        if (!inherits(dis, "dist")) stop("Object of class 'dist' expected for distance")
        if (!is.euclid(dis)) stop("Euclidean property is expected for distance")
        dis <- as.matrix(dis)
        if (nrow(df)!= nrow(dis)) stop("Non convenient df")
    }
    if (is.null(dis)) dis <- (matrix(1, nrow(df), nrow(df)) - diag(rep(1, nrow(df)))) * sqrt(2)
    div <- as.data.frame(rep(0, ncol(df)))
    names(div) <- "diversity"
    rownames(div) <- names(df)
    for (i in 1:ncol(df)) {
        div[i, ] <- (t(df[, i]) %*% (as.matrix(dis)^2) %*% df[, i]) / 2 / (sum(df[, i])^2)
    }
    return(div)
}
"dotcircle" <- function (z,alpha0=pi/2,xlim=range(pretty(z)),labels=names(z),clabel=1,cleg=1) {
    if (!is.numeric(z)) stop("z is not numeric")
    n <- length(z)
    if (n<=2) stop ("length(z)<3")
    if (is.null (labels)) clab <- 0
    if (length(labels)!=length(z)) clab <- 0
    alpha <- alpha0-(1:n)*2*pi/n
    leg <- xlim
    leg0 <- (leg-min(leg))/(max(leg)-min(leg))*0.8+0.2
    z0 <- (z-min(leg))/(max(leg)-min(leg))*0.8+0.2
    opar <- par(mar = par("mar"),srt=par("srt"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    x <- z0*cos(alpha)
    y <- z0*sin(alpha)

    plot( c(0,0), type = "n", ylab = "", asp = 1, xaxt = "n", 
        yaxt = "n", frame.plot = FALSE, xlim=c(-1.2,1.2), ylim=c(-1.2,1.2))
   # if (clabel > 0) scatter.util.eti.circ(x, y, label, clabel)
   # if (csub > 0) scatter.util.sub(sub, csub, possub)
   # if (box) box()
    
    symbols(0, 0, cir=0.2,inc=FALSE,add=TRUE)
    for (i in 1:2) {
        symbols(0, 0, cir=leg0[i],inc=FALSE,add=TRUE,fg=grey(0.5))
    }
    points(x,y,type="o",pch=20,cex=2)
    segments(x[n],y[n],x[1],y[1])
    segments(0.2*cos(alpha),0.2*sin(alpha),x,y)
    if (clabel>0) {
        for (i in 1:n) {
            par(srt=alpha[i]*360/2/pi)
            text(1.1*cos(alpha[i]),1.1*sin(alpha[i]),labels[i],adj=0,cex=par("cex")*clabel)
            segments(cos(alpha[i]),sin(alpha[i]),1.1*cos(alpha[i]),1.1*sin(alpha[i]),col=grey(0.5))
        }
    }
    par(srt=0)
    if (cleg>0) {
        s.label(cbind.data.frame(c(0.2,0,-0.2,0),c(0,-0.2,0,0.2)),
            lab=as.character(rep(leg[1],4)),add.p=TRUE,clab=cleg)
        s.label(cbind.data.frame(c(1,0,-1,0),c(0,-1,0,1)),
            lab=as.character(rep(leg[2],4)),clab=cleg, add.p=TRUE)
    }
}
dpcoa <- function(df, dis = NULL, scannf = TRUE, nf = 2, full = FALSE, tol = 1e-07)
{
    if (!inherits(df, "data.frame")) stop("df is not a data.frame")
    if (any(df < 0)) stop("Negative value in df")
    nesp <- nrow(df) ; nrel<-ncol(df)
    if (!is.null(dis)) {
        if (!inherits(dis, "dist")) stop("dis is not an object 'dist'")
        n1 <- attr(dis, "Size")
        if (nesp != n1) stop("Non convenient dimensions nrow(df)!= attr(dis, 'Size')")
        if (!is.euclid(dis)) stop("an Euclidean matrix is needed")
    }
    if (is.null(dis)) {
        dis <- (matrix(1, nrow(df), nrow(df)) - diag(rep(1, nrow(df)))) * sqrt(2)
        rownames(dis) <- colnames(dis) <- rownames(df)
        dis <- as.dist(dis)
    }
    #####################
    # Use 1/2 dij^2 #
    #####################
    d <- dist2mat(dis)
    d <- d * d / 2
    result <- list()
    w.rel <- apply(df, 2, sum)
    w.rel <- w.rel / sum(w.rel)
    names.rel <- names(df)
    w.esp <- apply(df, 1, sum)
    w.esp <- w.esp / sum(w.esp)
    if (is.null(attr(dis, "Labels"))) attr(dis, "Labels") <- 1:nesp
    names.esp <- attr(dis, "Labels")
    z <- apply(df, 2, sum)
    z[z == 0] <- 1
    z <- t(t(df) / z) # column pattern in table df    
    # Rao's RaoDivC
    fun <- function(x) sum(t(d * x) * x)
    df2 <- sweep(df, 2, apply(df, 2, sum), "/")
    w <- unlist(apply(df2, 2, fun))
    names(w) <- names.rel
    result$RaoDiv <- w
    # Rao's DiSC
    fun1 <- function(x) {
        p <- z[, x[1]] - z[, x[2]]
        w <- -sum(t(d * p) * p)
        return(sqrt(w))
    }
    dnew <- matrix(0, nrel, nrel)
    index <- cbind(col(dnew)[col(dnew) < row(dnew)], row(dnew)[col(dnew) < row(dnew)])
    dnew <- unlist(apply(index, 1, fun1))
    # Rao's DISC computation
    # That provides exactly the previous results
    # with Euclidean matrix
    # fun2 <- function(x) {
    #     p <- w[x[1], ] - w[x[2], ]
    #     w <- sum(p^2)
    #     return(sqrt(w))
    # }
    # dnew <- matrix(0, nrel, nrel)
    # index <- cbind(col(dnew)[col(dnew) < row(dnew)], row(dnew)[col(dnew) < row(dnew)])
    # w <- as.matrix(dudi.pco(dis, w.esp, full=T)$li)
    # w <- t(z) %*% w
    # dnew <- unlist(apply(index, 1, fun2))
    attr(dnew, "Size") <- nrel
    attr(dnew, "Labels") <- names.rel
    attr(dnew, "Diag") <- TRUE
    attr(dnew, "Upper") <- FALSE
    attr(dnew, "method") <- "dis"
    attr(dnew, "call") <- match.call()
    class(dnew) <- "dist"
    result$RaoDis <- dnew
    Bdiv <- t(apply(df, 2, sum) / sum(df)) %*% (as.matrix(dnew)^2 / 2) %*% (apply(df, 2, sum) / sum(df))
    Tdiv <- t(apply(df, 1, sum) / sum(df)) %*% d %*% (apply(df, 1, sum) / sum(df))
    Wdiv <- Tdiv - Bdiv
    divdec <- data.frame(c(Bdiv, Wdiv, Tdiv))
    names(divdec) <- "Diversity"
    rownames(divdec) <- c("Between-samples diversity",
        "Within-samples diversity", "Total diversity")
    result$RaoDecodiv <- divdec
    # two-level PCO
    pco1 <- dudi.pco(dis, w.esp, full = TRUE)
    wesp <- as.matrix(pco1$li)
    wrel <- t(z) %*% wesp
    wrel <- data.frame(wrel)
    row.names(wrel) <- names.rel
    # check on the centring of the two scatters of weighted points
    # print(apply(wrel * w.rel, 2, sum))
    # print(apply(wesp * w.esp, 2, sum))
    dudi1 <- as.dudi (wrel, rep(1, ncol(wrel)), w.rel, scannf = scannf,
        nf = nf, call = match.call(), type = "dpcoa", tol = tol, full = full)
    result$w1 <- w.esp
    result$w2 <- w.rel
    result$eig <- dudi1$eig
    result$nf <- dudi1$nf
    result$l2 <- dudi1$li
    w <- wesp %*% as.matrix(dudi1$c1)
    w <- data.frame(w)
    row.names(w) <- names.esp
    result$l1 <- w
    result$c1 <- dudi1$c1
    result$call <- match.call()
    class(result) <- "dpcoa"
    return(result)
}

plot.dpcoa <- function(x, xax = 1, yax = 2, option = 1:4, csize = 2, ...) {
	if (!inherits(x, "dpcoa")) stop("Object of type 'dpcoa' expected")
	nf <- x$nf
	if (xax > nf) stop("Non convenient xax")
	if (yax > nf) stop("Non convenient yax")
	opar <- par(mar = par("mar"),  mfrow = par("mfrow"), xpd = par("xpd"))
	on.exit (par(opar))
	mfrow <- n2mfrow(length(option))
	par(mfrow = mfrow)
	for (j in option) {
		if (j == 1) { #
			s.corcircle(x$c1[, c(xax, yax)], cgrid = 0, 
				sub = "Base", csub = 1.5, possub = "topleft", full = TRUE)
			l0 <- length(x$eig)
			add.scatter.eig(x$eig, l0, xax, yax, posi = "bottom", ratio = 1/4)
		}
		if (j == 2) { #
			X <- as.list(x$call)[[2]]
			X <- eval(X, sys.frame(0))
			s.label(x$l1[, c(xax, yax)], clab = 0, cpoi = 2)
			s.distri(x$l1[, c(xax, yax)], X, add.plot = TRUE, cell = 1, cstar = 0, 
				axesell = 0, lab = names(X), cpo = 0, clab = 1)
			#add.scatter.eig(x$eig, l0, xax, yax, posi = "bottom", ratio = 1 / 5)
		}
		if (j == 3) { #
			s.label(x$l2[, c(xax, yax)], clab = 1, cpoi = 0)
		}
		if (j == 4) { #
			s.value(x$l2[, c(xax, yax)], x$RaoDiv, csi = csize, 
				sub = "Rao Divcs", possub = "topright", csub = 1.5)
		}
	}		
}

print.dpcoa <- function (x, ...)
{
    cat("double principal coordinate analysis\n")
    cat("class: ")
    cat(class(x))
    cat("\n$call: ")
    print(x$call)
    cat("\n$nf:", x$nf, "axis-components saved")
    cat("\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    sumry <- array("", c(4, 4), list(1:4, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$w1", length(x$w1), mode(x$w1), "weights of species")
    sumry[2, ] <- c("$w2", length(x$w2), mode(x$w2), "weights of communities")
    sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[4, ] <- c("$RaoDiv", length(x$RaoDiv), mode(x$RaoDiv),
        "diversity coefficients within communities")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(1, 3), list(1:1, c("dist", "Size", 
        "content")))
    sumry[1, ] <- c("$RaoDis", attributes(x$RaoDis)$Size,
        "dissimilarities among communities")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(4, 4), list(1:4, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$RaoDecodiv", 3, 1, "decomposition of diversity")
    sumry[2, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "coordinates of the species")
    sumry[3, ] <- c("$l2", nrow(x$l2), ncol(x$l2), "coordinates of the species")
    sumry[4, ] <- c("$c1", nrow(x$c1), ncol(x$c1),
        "scores of the principal axes of the species")
    class(sumry) <- "table"
    print(sumry)
}
"as.dudi" <- function (df, col.w, row.w, scannf, nf, call, type, tol = 1e-07,
    full = FALSE) 
{
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    lig <- nrow(df)
    col <- ncol(df)
    if (length(col.w) != col) 
        stop("Non convenient col weights")
    if (length(row.w) != lig) 
        stop("Non convenient row weights")
    if (any(col.w) < 0) 
        stop("col weight < 0")
    if (any(row.w) < 0) 
        stop("row weight < 0")
    if (full) 
        scannf <- FALSE
    res <- list(tab = df, cw = col.w, lw = row.w)
    df <- as.matrix(df)
    df <- df * sqrt(row.w)
    df <- sweep(df, 2, sqrt(col.w), "*")
    svd1 <- svd(df)
    eig <- svd1$d^2
    rank <- sum((eig/eig[1]) > tol)
    if (scannf) {
        barplot(eig[1:rank])
        cat("Select the number of axes: ")
        nf <- as.integer(readLines(n = 1))
    }
    if (nf <= 0) 
        nf <- 2
    if (nf > rank) 
        nf <- rank
    if (full) 
        nf <- rank
    res$eig <- eig[1:rank]
    res$rank <- rank
    res$nf <- nf
    col.w[which(col.w == 0)] <- 1
    col.w <- 1/sqrt(col.w)
    auxi <- data.frame(svd1$v[, 1:nf] * col.w)
    names(auxi) <- paste("CS", (1:nf), sep = "")
    row.names(auxi) <- names(res$tab)
    res$c1 <- auxi
    row.w[which(row.w == 0)] <- 1
    row.w <- 1/sqrt(row.w)
    auxi <- data.frame(svd1$u[, 1:nf] * row.w)
    names(auxi) <- paste("RS", (1:nf), sep = "")
    row.names(auxi) <- row.names(res$tab)
    res$l1 <- auxi
    w <- matrix(svd1$d[1:nf], col, nf, byr = TRUE)
    auxi <- data.frame(as.matrix(res$c1) * w)
    names(auxi) <- paste("Comp", (1:nf), sep = "")
    row.names(auxi) <- names(res$tab)
    res$co <- auxi
    w <- matrix(svd1$d[1:nf], lig, nf, byr = TRUE)
    auxi <- data.frame(as.matrix(res$l1) * w)
    names(auxi) <- paste("Axis", (1:nf), sep = "")
    row.names(auxi) <- row.names(res$tab)
    res$li <- auxi
    res$call <- call
    class(res) <- c(type, "dudi")
    return(res)
}


"is.dudi" <- function (x) {
    inherits(x, "dudi")
}

"print.dudi" <- function (x, ...) {
    cat("Duality diagramm\n")
    cat("class: ")
    cat(class(x))
    cat("\n$call: ")
    print(x$call)
    cat("\n$nf:", x$nf, "axis-components saved")
    cat("\n$rank: ")
    cat(x$rank)
    cat("\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    sumry <- array("", c(3, 4), list(1:3, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
    sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    class(sumry) <- "table"
    print(sumry)
    cat("other elements: ")
    if (length(names(x)) > 11) 
        cat(names(x)[12:(length(x))], "\n")
    else cat("NULL\n")
}

"t.dudi" <- function (x) {
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    res <- list()
    res$tab <- data.frame(t(x$tab))
    res$cw <- x$lw
    res$lw <- x$cw
    res$eig <- x$eig
    res$rank <- x$rank
    res$nf <- x$nf
    res$c1 <- x$l1
    res$l1 <- x$c1
    res$co <- x$li
    res$li <- x$co
    res$call <- match.call()
    class(res) <- c("transpo", "dudi")
    return(res)
}

"redo.dudi" <- function (dudi, newnf = 2) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class 'dudi' expected")
    appel <- as.list(dudi$call)
    if (appel[[1]] == "t.dudi") {
        dudiold <- eval(appel[[2]], sys.frame(0))
        appel <- as.list(dudiold$call)
        appel$nf <- newnf
        appel$scannf <- FALSE
        dudinew <- eval(as.call(appel), sys.frame(0))
        return(t.dudi(dudinew))
    }
    appel$nf <- newnf
    appel$scannf <- FALSE
    eval(as.call(appel), sys.frame(0))
}

"dudi.acm" <- function (df, row.w = rep(1, nrow(df)), scannf = TRUE, nf = 2) {
    if (!all(unlist(lapply(df, is.factor)))) 
        stop("All variables must be factors")
    X <- acm.disjonctif(df)
    lig <- nrow(X)
    col <- ncol(X)
    var <- ncol(df)
    if (length(row.w) != lig) 
        stop("Non convenient row weights")
    if (any(row.w) < 0) 
        stop("row weight < 0")
    row.w <- row.w/sum(row.w)
    col.w <- apply(X, 2, function(x) sum(x*row.w))
    if (any(col.w) == 0) 
        stop("One category with null weight")
    X <- t(t(X)/col.w) - 1
    col.w <- col.w/var
    X <- as.dudi(data.frame(X), col.w, row.w, scannf = scannf, 
        nf = nf, call = match.call(), type = "acm")
    rcor <- matrix(0, ncol(df), X$nf)
    rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
    floc <- function(x) {
        i <- Re(x)
        j <- Im(x)
        x <- X$l1[, j] * X$lw
        qual <- df[, i]
        poicla <- unlist(tapply(X$lw, qual, sum))
        z <- unlist(tapply(x, qual, sum))/poicla
        return(sum(poicla * z * z))
    }
    rcor <- apply(rcor, c(1, 2), floc)
    rcor <- data.frame(rcor)
    row.names(rcor) <- names(df)
    names(rcor) <- names(X$l1)
    X$cr <- rcor
    return(X)
}

"boxplot.acm" <- function (x, xax = 1, ...) {
    if (!inherits(x, "acm")) 
        stop("Object of class 'acm' expected")
    if ((xax < 1) || (xax > x$nf)) 
        stop("non convenient axe number")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    nvar <- ncol(oritab)
    if (nvar <= 7) 
        sco.boxplot(x$l1[, xax], oritab[, 1:nvar], clab = 1)
    else if (nvar <= 14) {
        par(mfrow = c(1, 2))
        sco.boxplot(x$l1[, 1], oritab[, 1:(nvar%/%2)], clab = 1.3)
        sco.boxplot(x$l1[, 1], oritab[, (nvar%/%2 + 1):nvar], 
            clab = 1.3)
    }
    else {
        par(mfrow = c(1, 3))
        if ((a0 <- nvar%/%3) < nvar/3) 
            a0 <- a0 + 1
        sco.boxplot(x$l1[, 1], oritab[, 1:a0], clab = 1.6)
        sco.boxplot(x$l1[, 1], oritab[, (a0 + 1):(2 * a0)], 
            clab = 1.6)
        sco.boxplot(x$l1[, 1], oritab[, (2 * a0 + 1):nvar], 
            clab = 1.6)
    }
}

"acm.burt" <- function (df1, df2, counts = rep(1, nrow(df1))) {
    if (!all(unlist(lapply(df1, is.factor)))) 
        stop("All variables must be factors")
    if (!all(unlist(lapply(df2, is.factor)))) 
        stop("All variables must be factors")
    if (nrow(df1) != nrow(df2)) 
        stop("non convenient row numbers")
    if (length(counts) != nrow(df2)) 
        stop("non convenient row numbers")
    g1 <- acm.disjonctif(df1)
    g1 <- g1 * counts
    g2 <- acm.disjonctif(df2)
    burt <- as.matrix(t(g1)) %*% as.matrix(g2)
    burt <- data.frame(burt)
    names(burt) <- names(g2)
    row.names(burt) <- names(g1)
    return(burt)
} 

"acm.disjonctif" <- function (df) {
    acm.util <- function(i) {
        cl <- df[,i]
        cha <- names(df)[i] 
        n <- length(cl)
        cl <- as.factor(cl)
        x <- matrix(0, n, length(levels(cl)))
        x[(1:n) + n * (unclass(cl) - 1)] <- 1
        dimnames(x) <- list(row.names(df), paste(cha,levels(cl),sep="."))
        return(x)
    }
    G <- lapply(1:ncol(df), acm.util)
    G <- data.frame (G, check.names = FALSE)
    return(G)
}
"dudi.coa" <- function (df, scannf = TRUE, nf = 2) {
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    lig <- nrow(df)
    col <- ncol(df)
    if (any(df < 0)) 
        stop("negative entries in table")
    if ((N <- sum(df)) == 0) 
        stop("all frequencies are zero")
    df <- df/N
    row.w <- apply(df, 1, sum)
    col.w <- apply(df, 2, sum)
    df <- df/row.w
    df <- sweep(df, 2, col.w, "/") - 1
    if (any(is.na(df))) {
        fun1 <- function(x) {
            if (is.na(x)) 
                return(0)
            else return(x)
        }
        df <- apply(df, c(1, 2), fun1)
        df <- data.frame(df)
    }
    X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "coa")
    X$N <- N
    return(X)
}
"dudi.dec" <- function (df, eff, scannf = TRUE, nf = 2) {
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    lig <- nrow(df)
    col <- ncol(df)
    if (any(df < 0)) 
        stop("negative entries in table")
    if ((N <- sum(df)) == 0) 
        stop("all frequencies are zero")
    if (length(eff) != lig) 
        stop("non convenient dimension")
    if (any(eff) <= 0) 
        stop("non convenient vector eff")
    rtot <- sum(eff)
    row.w <- eff/rtot
    col.w <- apply(df, 2, sum)
    col.w <- col.w/rtot
    df <- sweep(df, 1, eff, "/")
    df <- sweep(df, 2, col.w, "/") - 1
    if (any(is.na(df))) {
        fun1 <- function(x) {
            if (is.na(x)) 
                return(0)
            else return(x)
        }
        df <- apply(df, c(1, 2), fun1)
        df <- data.frame(df)
    }
    X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "dec")
    X$R <- rtot
    return(X)
}
"dudi.fca" <- function (df, scannf = TRUE, nf = 2) {
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    if (is.null(attr(df, "col.blocks"))) 
        stop("attribute 'col.blocks' expected for df")
    if (is.null(attr(df, "row.w"))) 
        stop("attribute 'row.w' expected for df")
    bloc <- attr(df, "col.blocks")
    row.w <- attr(df, "row.w")
    indica <- attr(df, "col.num")
    nvar <- length(bloc)
    col.w <- apply(df * row.w, 2, sum)
    df <- sweep(df, 2, col.w, "/") - 1
    col.w <- col.w/length(bloc)
    X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "fca")
    rcor <- matrix(0, nvar, X$nf)
    rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
    floc <- function(x) {
        i <- Re(x)
        j <- Im(x)
        if (i == 1) 
            k1 <- 0
        else k1 <- cumsum(bloc)[i - 1]
        k2 <- k1 + bloc[i]
        k1 <- k1 + 1
        z <- X$co[k1:k2, j]
        poicla <- X$cw[k1:k2] * nvar
        return(sum(poicla * z * z))
    }
    rcor <- apply(rcor, c(1, 2), floc)
    rcor <- data.frame(rcor)
    row.names(rcor) <- names(bloc)
    names(rcor) <- names(X$l1)
    X$cr <- rcor
    X$blo <- bloc
    X$indica <- indica
    return(X)
}

"prep.fuzzy.var" <- function (df, col.blocks, row.w = rep(1, nrow(df))) {
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    if (!is.null(row.w)) {
        if (length(row.w) != nrow(df)) 
            stop("non convenient dimension")
    }
    if (sum(col.blocks) != ncol(df)) {
        stop("non convenient data in col.blocks")
    }
    if (is.null(row.w)) 
        row.w <- rep(1, nrow(df))/nrow(df)
    row.w <- row.w/sum(row.w)
    if (is.null(names(col.blocks))) {
        names(col.blocks) <- paste("FV", as.character(1:length(col.blocks)), 
            sep = "")
    }
    f1 <- function(x) {
        a <- sum(x)
        if (is.na(a)) 
            return(rep(0, length(x)))
        if (a == 0) 
            return(rep(0, length(x)))
        return(x/a)
    }
    k2 <- 0
    col.w <- rep(1, ncol(df))
    for (k in 1:(length(col.blocks))) {
        k1 <- k2 + 1
        k2 <- k2 + col.blocks[k]
        X <- df[, k1:k2]
        X <- t(apply(X, 1, f1))
        X.marge <- apply(X, 1, sum)
        X.marge <- X.marge * row.w
        X.marge <- X.marge/sum(X.marge)
        X.mean <- apply(X * X.marge, 2, sum)
        nr <- sum(X.marge == 0)
        if (nr > 0) {
            nc <- col.blocks[k]
            X[X.marge == 0, ] <- rep(X.mean, rep(nr, nc))
            cat(nr, "missing data found in block", k, "\n")
        }
        df[, k1:k2] <- X
        col.w[k1:k2] <- X.mean
    }
    attr(df, "col.blocks") <- col.blocks
    attr(df, "row.w") <- row.w
    attr(df, "col.freq") <- col.w
    col.num <- factor(rep((1:length(col.blocks)), col.blocks))
    attr(df, "col.num") <- col.num
    return(df)
}
"dudi.mix" <- function (df, add.square = FALSE, scannf = TRUE, nf = 2) {
    if (!is.data.frame(df)) 
        stop("data.frame expected")
    row.w <- rep(1, nrow(df))/nrow(df)
    acm.util <- function(cl) {
        n <- length(cl)
        cl <- as.factor(cl)
        x <- matrix(0, n, length(levels(cl)))
        x[(1:n) + n * (unclass(cl) - 1)] <- 1
        dimnames(x) <- list(names(cl), as.character(levels(cl)))
        data.frame(x)
    }
    f1 <- function(v) {
        moy <- sum(v)/length(v)
        v <- v - moy
        et <- sqrt(sum(v * v)/length(v))
        return(v/et)
    }
    df <- data.frame(df)
    nc <- ncol(df)
    nl <- nrow(df)
    if (any(is.na(df))) 
        stop("na entries in table")
    index <- rep("", nc)
    for (j in 1:nc) {
        w1 <- "q"
        if (is.factor(df[, j])) 
            w1 <- "f"
        if (is.ordered(df[, j])) 
            w1 <- "o"
        index[j] <- w1
    }
    res <- matrix(0, nl, 1)
    provinames <- "0"
    col.w <- NULL
    col.assign <- NULL
    k <- 0
    for (j in 1:nc) {
        if (index[j] == "q") {
            if (!add.square) {
                res <- cbind(res, f1(df[, j]))
                provinames <- c(provinames, names(df)[j])
                col.w <- c(col.w, 1)
                k <- k + 1
                col.assign <- c(col.assign, k)
            }
            else {
                w <- df[, j]
                deg.poly <- 2
                w <- sqrt(nl - 1) * poly(w, deg.poly)
                cha <- paste(names(df)[j], c(".L", ".Q"), sep = "")
                res <- cbind(res, as.matrix(w))
                provinames <- c(provinames, cha)
                col.w <- c(col.w, rep(1, deg.poly))
                k <- k + 1
                col.assign <- c(col.assign, rep(k, deg.poly))
            }
        }
        else if (index[j] == "o") {
            w <- as.numeric(df[, j])
            deg.poly <- min(nlevels(df[, j]) - 1, 2)
            w <- sqrt(nl - 1) * poly(w, deg.poly)
            if (deg.poly == 1) 
                cha <- names(df)[j]
            else cha <- paste(names(df)[j], c(".L", ".Q"), sep = "")
            res <- cbind(res, as.matrix(w))
            provinames <- c(provinames, cha)
            col.w <- c(col.w, rep(1, deg.poly))
            k <- k + 1
            col.assign <- c(col.assign, rep(k, deg.poly))
        }
        else if (index[j] == "f") {
            w <- acm.util(factor(df[, j]))
            cha <- paste(substr(names(df)[j], 1, 5), ".", names(w), 
                sep = "")
            col.w.provi <- apply(w, 2, function(x) sum(x*row.w))
            w <- t(t(w)/col.w.provi) - 1
            col.w <- c(col.w, col.w.provi)
            res <- cbind(res, w)
            provinames <- c(provinames, cha)
            k <- k + 1
            col.assign <- c(col.assign, rep(k, length(cha)))
        }
    }
    res <- data.frame(res)
    names(res) <- make.names(provinames, unique = TRUE)
    res <- res[, -1]
    names(col.w) <- provinames[-1]
    X <- as.dudi(res, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "mix")
    X$assign <- factor(col.assign)
    X$index <- factor(index)
    rcor <- matrix(0, nc, X$nf)
    rcor <- row(rcor) + 0 + (0+1i) * col(rcor)
    floc <- function(x) {
        i <- Re(x)
        j <- Im(x)
        if (index[i] == "q") {
            if (sum(col.assign == i)) {
                w <- X$l1[, j] * X$lw * X$tab[, col.assign == 
                  i]
                return(sum(w)^2)
            }
            else {
                w <- X$lw * X$l1[, j]
                w <- X$tab[, col.assign == i] * w
                w <- apply(w, 2, sum)
                return(sum(w^2))
            }
        }
        else if (index[i] == "o") {
            w <- X$lw * X$l1[, j]
            w <- X$tab[, col.assign == i] * w
            w <- apply(w, 2, sum)
            return(sum(w^2))
        }
        else if (index[i] == "f") {
            x <- X$l1[, j] * X$lw
            qual <- df[, i]
            poicla <- unlist(tapply(X$lw, qual, sum))
            z <- unlist(tapply(x, qual, sum))/poicla
            return(sum(poicla * z * z))
        }
        else return(NA)
    }
    rcor <- apply(rcor, c(1, 2), floc)
    rcor <- data.frame(rcor)
    row.names(rcor) <- names(df)
    names(rcor) <- names(X$l1)
    X$cr <- rcor
    X
}
"dudi.nsc" <- function (df, scannf = TRUE, nf = 2) {
    df <- data.frame(df)
    lig <- nrow(df)
    col <- ncol(df)
    if (any(df < 0)) 
        stop("negative entries in table")
    if ((N <- sum(df)) == 0) 
        stop("all frequencies are zero")
    row.w <- apply(df, 1, sum)/N
    col.w <- apply(df, 2, sum)/N
    df <- t(apply(df, 1, function(x) if (sum(x) == 0) 
        col.w
    else x/sum(x)))
    df <- sweep(df, 2, col.w)
    df <- data.frame(col * df)
    X <- as.dudi(df, rep(1, col)/col, row.w, scannf = scannf, 
        nf = nf, call = match.call(), type = "nsc")
    X$N <- N
    return(X)
}
"dudi.pca" <- function (df, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1,
    ncol(df)), center = TRUE, scale = TRUE, scannf = TRUE, nf = 2) 
{
    df <- data.frame(df)
    nc <- ncol(df)
    if (any(is.na(df))) 
        stop("na entries in table")
    f1 <- function(v) sum(v * row.w)/sum(row.w)
    f2 <- function(v) sqrt(sum(v * v * row.w)/sum(row.w))
    if (is.logical(center)) {
        if (center) {
            center <- apply(df, 2, f1)
            df <- sweep(df, 2, center)
        }
        else center <- rep(0, nc)
    }
    else if (is.numeric(center) && (length(center) == nc)) 
        df <- sweep(df, 2, center)
    else stop("Non convenient selection for center")
    if (scale) {
        norm <- apply(df, 2, f2)
        norm[norm < 1e-08] <- 1
        df <- sweep(df, 2, norm, "/")
    }
    else norm <- rep(1, nc)
    X <- as.dudi(df, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "pca")
    X$cent <- center
    X$norm <- norm
    X
}

"dudi.pco" <- function (d, row.w = "uniform", scannf = TRUE, nf = 2, full = FALSE,
    tol = 1e-07) 
{
    if (!inherits(d, "dist")) 
        stop("Distance matrix expected")
    if (full) 
        scannf <- FALSE
    distmat <- dist2mat(d)
    n <- ncol(distmat)
    rownames <- attr(d, "Labels")
    if (any(is.na(d))) 
        stop("missing value in d")
    if (is.null(rownames)) 
        rownames <- as.character(1:n)
    if (any(row.w == "uniform")) {
        row.w <- rep(1, n)
    }
    else {
        if (length(row.w) != n) 
            stop("Non convenient length(row.w)")
        if (any(row.w < 0)) 
            stop("Non convenient row.w (p<0)")
        if (any(row.w == 0)) 
            stop("Non convenient row.w (p=0)")
    }
    row.w <- row.w/sum(row.w)
    delta <- -0.5 * bicenter.wt(distmat * distmat, row.wt = row.w, 
        col.wt = row.w)
    wsqrt <- sqrt(row.w)
    delta <- delta * wsqrt
    delta <- t(t(delta) * wsqrt)
    eig <- eigen(delta, symmetric = TRUE)
    lambda <- eig$values
    w0 <- lambda[n]/lambda[1]
    if (w0 < -tol) 
        warning("Non euclidean distance")
    r <- sum(lambda > (lambda[1] * tol))
    if (scannf) {
        barplot(lambda)
        cat("Select the number of axes: ")
        nf <- as.integer(readLines(n = 1))
    }
    if (nf <= 0) 
        nf <- 2
    if (nf > r) 
        nf <- r
    if (full) 
        nf <- r
    res <- list()
    res$eig <- lambda[1:r]
    res$rank <- r
    res$nf <- nf
    res$cw <- rep(1, r)
    w <- t(t(eig$vectors[, 1:r]) * sqrt(lambda[1:r]))/wsqrt
    w <- data.frame(w)
    names(w) <- paste("A", 1:r, sep = "")
    row.names(w) <- rownames
    res$tab <- w
    res$li <- w[, 1:nf]
    w <- t(t(eig$vectors[, 1:nf])/wsqrt)
    w <- data.frame(w)
    names(w) <- paste("RS", 1:nf, sep = "")
    row.names(w) <- rownames
    res$l1 <- w
    w <- data.frame(diag(1, r))
    names(w) <- paste("CS", (1:r), sep = "")
    row.names(w) <- names(res$tab)
    res$c1 <- w[, 1:nf]
    w <- data.frame(matrix(0, r, nf))
    w[1:nf, 1:nf] <- diag(sqrt(lambda[1:nf]))
    names(w) <- paste("Comp", (1:nf), sep = "")
    row.names(w) <- names(res$tab)
    res$co <- w
    res$lw <- row.w
    res$call <- match.call()
    class(res) <- c("pco", "dudi")
    return(res)
}

"scatter.pco" <- function (x, xax = 1, yax = 2, clab.row = 1, posieig = "top",
    sub = NULL, csub = 2, ...) 
{
    if (!inherits(x, "pco")) 
        stop("Object of class 'pco' expected")
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    coolig <- x$li[, c(xax, yax)]
    s.label(coolig, clab = clab.row)
    add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
}
"foucart" <- function (X, scannf = TRUE, nf = 2) {
    if (!is.list(X)) 
        stop("X is not a list")
    nblo <- length(X)
    if (!all(unlist(lapply(X, is.data.frame)))) 
        stop("a component of X is not a data.frame")
    # vrification que chaque tableau de la liste a les 
    # mmes dimensions
    blocks <- unlist(lapply(X, ncol))
    if (length(unique(blocks)) != 1) 
        stop("non equal col numbers among array")
    blocks <- unlist(lapply(X, nrow))
    if (length(unique(blocks)) != 1) 
        stop("non equal row numbers among array")
    r.n <- row.names(X[[1]])
    for (i in 1:nblo) {
        r.new <- row.names(X[[i]])
        if (any(r.new != r.n)) 
            stop("non equal row.names among array")
    }
    # vrification que chaque tableau de la liste a les 
    # mmes noms
    unique.col.names <- names(X[[1]])
    for (i in 1:nblo) {
        c.new <- names(X[[i]])
        if (any(c.new != unique.col.names)) 
            stop
        ("non equal col.names among array")
    }
    # vrification que chaque tableau de la liste supporte 
    # une analyse des correspondances
    for (i in 1:nblo) {
        if (any(X[[i]] < 0)) 
            stop(paste("negative entries in data.frame", i))
        if (sum(X[[i]]) <= 0) 
            stop(paste("Non convenient sum in data.frame", i))
    }
    X <- ktab.list.df(X)
    auxinames <- ktab.util.names(X)
    blocks <- X$blo
    nblo <- length(blocks)
    tnames <- tab.names(X)
    tabm <- X[[1]]/sum(X[[1]])
    for (k in 2:nblo) tabm <- tabm + X[[k]]/sum(X[[k]])
    tabm <- tabm/nblo
    row.names(tabm) <- row.names(X)
    names(tabm) <- unique.col.names
    fouc <- dudi.coa(tabm, scannf = scannf, nf = nf)
    fouc$call <- match.call()
    class(fouc) <- c("foucart", "coa", "dudi")
    cooli <- suprow(fouc, X[[1]])$lisup
    for (k in 2:nblo) {
        cooli <- rbind(cooli, suprow(fouc, X[[k]])$lisup)
    }
    row.names(cooli) <- auxinames$row
    fouc$Tli <- cooli
    cooco <- supcol(fouc, X[[1]])$cosup
    for (k in 2:nblo) {
        cooco <- rbind(cooco, supcol(fouc, X[[k]])$cosup)
    }
    row.names(cooco) <- auxinames$col
    fouc$Tco <- cooco
    fouc$TL <- X$TL
    fouc$TC <- X$TC
    fouc$blocks <- blocks
    fouc$tab.names <- tnames
    fouc$call <- match.call()
    return(fouc)
}

"kplot.foucart" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
    clab.r = 1, clab.c = 1.25, csub = 2, possub = "bottomright", ...) 
{
    if (!inherits(object, "foucart")) 
        stop("Object of type 'foucart' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    nblo <- length(object$blo)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nblo, object$rank))
    nf <- ncol(object$li)
    coolig <- object$Tli[, c(xax, yax)]
    coocol <- object$Tco[, c(xax, yax)]
    names(coocol) <- names(coolig)
    cootot <- rbind.data.frame(coocol, coolig)
    if (clab.r > 0) 
        cpoi <- 0
    else cpoi <- 2
    for (ianal in which.tab) {
        coolig <- object$Tli[object$TL[, 1] == ianal, c(xax, yax)]
        coocol <- object$Tco[object$TC[, 1] == ianal, c(xax, yax)]
        s.label(cootot, clab = 0, cpoi = 0, sub = object$tab.names[ianal], 
            csub = csub, possub = possub)
        s.label(coolig, clab = clab.r, cpoi = cpoi, add.p = TRUE)
        s.label(coocol, clab = clab.c, add.p = TRUE)
    }
}

"plot.foucart" <- function (x, xax = 1, yax = 2, clab = 1, csub = 2, possub = "bottomright", ...) {
    if (!inherits(x, "foucart")) 
        stop("Object of type 'foucart' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    par(mfrow = c(2, 2))
    nf <- ncol(x$li)
    cootot <- x$li[, c(xax, yax)]
    auxi <- x$li[, c(xax, yax)]
    names(auxi) <- names(cootot)
    cootot <- rbind.data.frame(cootot, auxi)
    auxi <- x$Tli[, c(xax, yax)]
    names(auxi) <- names(cootot)
    cootot <- rbind.data.frame(cootot, auxi)
    auxi <- x$Tco[, c(xax, yax)]
    names(auxi) <- names(cootot)
    cootot <- rbind.data.frame(cootot, auxi)
    s.label(cootot, clab = 0, cpoi = 0, sub = "Rows (Base)", 
        csub = csub, possub = possub)
    s.label(x$li, xax, yax, clab = clab, add.p = TRUE)
    s.label(cootot, clab = 0, cpoi = 0, sub = "Columns (Base)", 
        csub = csub, possub = possub)
    s.label(x$co, xax, yax, clab = clab, add.p = TRUE)
    s.label(cootot, clab = 0, cpoi = 0, sub = "Rows", csub = csub, 
        possub = possub)
    s.class(x$Tli, x$TL[, 2], xax = xax, yax = yax, 
        axesell = FALSE, clab = clab, add.p = TRUE)
    s.label(cootot, clab = 0, cpoi = 0, sub = "Columns", 
        csub = csub, possub = possub)
    s.class(x$Tco, x$TC[, 2], xax = xax, yax = yax, 
        axesell = FALSE, clab = clab, add.p = TRUE)
}

"print.foucart" <- function (x, ...) {
    cat("Foucart's  COA\n")
    cat("class: ")
    cat(class(x))
    cat("\n$call: ")
    print(x$call)
    cat("table  number:", length(x$blo), "\n")
    cat("\n$nf:", x$nf, "axis-components saved")
    cat("\n$rank: ")
    cat(x$rank)
    cat("\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("blo    vector      ", length(x$blo), "     blocks\n")
    sumry <- array("", c(3, 4), list(rep("", 3), c("vector", 
        "length", "mode", "content")))
    sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
    sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(5, 4), list(rep("", 5), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    class(sumry) <- "table"
    print(sumry)
    cat("\n     **** Intrastructure ****\n\n")
    sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "row coordinates (each table)")
    sumry[2, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "col coordinates (each table)")
    sumry[3, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli")
    sumry[4, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"gearymoran" <- function (bilis, X, nrepet=999) {
    # bilis doit tre une matrice
    bilis <- as.matrix(bilis)
    nobs <- ncol(bilis)
    # bilis doit tre carre
    if (nrow(bilis) != nobs) stop ("'bilis' is not squared")
    # bilis doit tre symtrique
    bilis <- (bilis + t(bilis))/2
    # bilis doit tre  termes positifs (voisinages)
    if (any(bilis<0)) stop ("term <0 found in 'bilis'")
    test.names <- names(X)
    X <- data.matrix(X)
    if (nrow(X) != nobs) stop ("non convenient dimension")
    nvar <- ncol(X)
    res <- .C("gearymoran",
        param = as.integer(c(nobs,nvar,nrepet)),
        data = as.double(X),
        bilis = as.double(bilis),
        obs = double(nvar),
        result = double (nrepet*nvar),
        obstot = double(1),
        restot = double (nrepet),
        PACKAGE="ade4"
    )
    res <- c(res$obs,res$result)
    res <- matrix(res, ncol=nvar, byr=TRUE)
    res <- as.data.frame(res)
    names(res) <- test.names
    res <- as.list(res)
    class(res) <- "krandtest"
    return(res)       
}
"char2genet" <- function(X,pop,complete=FALSE) {
    if (!inherits(X, "data.frame")) stop ("X is not a data.frame")
    if (!is.factor(pop)) stop("pop is not a factor")
    nind <- length(pop)
    if (nrow(X) != nind) stop ("pop & X have non convenient dimension")
    # tri des lignes par ordre alphabtique des noms de population
    # tri par ordre alphabtique des noms de loci
    X <- X[order(pop),]
    X <- X[,sort(names(X))]
    pop <- sort(pop) # comme pop[order(pop)]
    ####################################################################################
    "codred" <- function(base, n) {
        # fonction qui fait des codes de noms ordonns par ordre
        # alphabtique de longueur constante le plus simples possibles
        # base est une chane de charactres, n le nombre qu'on veut
        w <- as.character(1:n)
        max0 <- max(nchar(w))
        "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",w[x],sep="")
        lapply(1:n, fun1)
        return(paste(base,w,sep="")) 
    }
    ####################################################################################
    # Ce qui touche aux populations
    npop <- nlevels(pop)
    pop.names <- as.character(levels(pop))
    pop.codes <- codred("P", npop)
    names(pop.names) <- pop.codes
    levels(pop) <- pop.codes    
    ####################################################################################
    # Ce qui touche aux individus
    nind <- nrow(X)
    ind.names <- row.names(X)
    ind.codes <- codred("", nind)
    names(ind.names) <- ind.codes
    ###################################################################################
    # ce qui touche au loci
    loc.names <- names(X)
    nloc <- ncol(X)
    loc.codes <- codred("L",nloc)
    names(loc.names) <- loc.codes
    names(X) <- loc.codes
    "cha6car" <- function(cha) {
        # pour complter les chanes de caratres par des zros devant
        n0 <- nchar(cha)
        if (n0 == 6) return (cha)
        if (n0 >6) stop ("More than 6 characters")
        cha = paste("0",cha,sep="")
        cha = cha6car(cha)
     }
     X <- apply(X,c(1,2),cha6car)
     
     # Toutes les chanes sont de 6 charactres suppose que le codage est complet
     # ou qu'il ne manque des zros qu'au dbut
     "enumallel" <- function (x) {
        w <- as.character(x)
        w1 <- substr(w,1,3)
        w2 <- substr(w,4,6)
        w3 <- sort(unique (c(w1,w2)))
        return(w3)
    }
    all.util <- apply(X,2,enumallel)
    # all.util est une liste dont les composantes sont les noms des allles ordonns
    # peut comprendre 000 pour un non typ
    # on conserve le nombre d'individus typs par locus et par populations
    "compter" <- function(x) {
        num0 <- x!="000000"
        num0 <- split(num0,pop)
        num0 <- as.numeric(unlist(lapply(num0,sum)))
        return(num0)
    }
    Z <- unlist(apply(X,2, compter))
    Z <- data.frame(matrix(Z,ncol=nloc))
    names(Z) <- loc.codes
    row.names(Z) <- pop.codes
    # Z est un data.frame populations-locus des effectifs d'individus
    ind.full <- apply(X,1,function (x) !any(x == "000000"))
    "polymor" <- function(x) {
        if (any(x=="000")) return(x[x!="000"])
        return(x)
    }
    "nallel" <- function(x) {
        l0 <- length(x)
        if (any(x=="000")) return(l0-1)
        return(l0)
    }
    loc.blocks  <-  unlist(lapply(all.util, nallel))
    names(loc.blocks) <- names(all.util)
    all.names  <-  unlist(lapply(all.util, polymor))
    w1 <- rep(loc.codes,loc.blocks)
    w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
    all.codes <- paste(w1,w2,sep="")
    all.names <- paste(rep(loc.names, loc.blocks),all.names,sep=".")
    names(all.names) <- all.codes
    w1 <- as.factor(w1)
    names(w1) <- all.codes
    loc.fac <- w1
    "manq"<- function(x) {
        if (any(x=="000")) return(TRUE)
        return(FALSE)
    }
    missingdata <- unlist(lapply(all.util, manq))
    "enumindiv" <- function (x) {
        x <- as.character(x)
        n <- length(x)
        w1 <- substr(x, 1, 3)
        w2 <- substr(x, 4, 6)
        "funloc1" <- function (k) {
            w0 <- rep(0,length(all.util[[k]]))
            names(w0) <- all.util[[k]]
            w0[w1[k]] <- w0[w1[k]]+1
            w0[w2[k]] <- w0[w2[k]]+1
            # ce locus n'a pas de donnes manquantes
            if (!missingdata[k]) return(w0)
            # ce locus a des donnes manquantes mais pas cet individu
            if (w0["000"]==0) return(w0[names(w0)!="000"])
            #cet individus a deux donnes manquantes
            if (w0["000"]==2) {
                w0 <- rep(NA, length(w0)-1)
                return(w0)
            }
            # il doit y avoir une seule donne manquante
            stop( paste("a1 =",w1[k],"a2 =",w2[k], "Non implemented case"))
        }
        w  <-  as.numeric(unlist(lapply(1:n, funloc1)))
        return(w)
    }
    ind.all <- apply(X,1,enumindiv)
    ind.all <- data.frame(t(ind.all))
    names(ind.all) <- all.codes
    nallels <- length(all.codes)
    
    # ind.all contient un tableau individus - alleles cod 
    # ******* pour NA pour les manquants
    # 010010 pour les htrozygotes
    # 000200 pour les homozygotes
    ind.all <- split(ind.all, pop)
     "remplacer" <- function (a,b) {
        if (all(!is.na(a))) return(a)
        if (all(is.na(a))) return(b)
        a[is.na(a)] <- b[is.na(a)]
        return(a)
    }
    
    "sommer"<- function (x){
        apply(x,2,function(x) sum(na.omit(x)))
    }
    all.pop <- matrix(unlist(lapply(ind.all,sommer)),nrow = nallels)
    all.pop = as.data.frame(all.pop)
    names(all.pop) <- pop.codes
    row.names(all.pop) <- all.codes

    center <- apply(all.pop,1,sum)
    center <- split(center, loc.fac)
    center <- unlist(lapply(center, function(x) x/sum(x)))
    names(center) <- all.codes
    "completer" <- function (x) {
        moy0  <-  apply(x,2,mean, na.rm=TRUE)
        y <- apply(x, 1, function(a) remplacer(a,moy0))
        return(y/2)
    }
    ind.all <- lapply(ind.all, completer)
    res <- list()
    pop.all <- unlist(lapply(ind.all,function(x) apply(x,1,mean)))
    pop.all <- matrix(pop.all, ncol=nallels, byrow=TRUE)
    pop.all <- data.frame(pop.all)
    names(pop.all) <- all.codes
    row.names(pop.all) <- pop.codes
    # 1) tableau de frquences allliques popualations-lignes
    # allles-colonnes indispensable pour la classe genet
    res$tab <- pop.all
    # 2) marge du prcdent calcul sur l'ensemble des individus typs par locus
    res$center <- center
    # 3) noms des populations renumrotes P001 ... P999
    # le vecteur contient les noms d'origine
    res$pop.names <- pop.names
    # 4) noms des allles recod L01.1, L01.2, ...
    # le vecteurs contient les noms d'origine.
    res$all.names <- all.names
    # 5) le vecteur du nombre d'allles par loci
    res$loc.blocks <- loc.blocks
    # 6) le facteur rpartissant les allles par loci
    res$loc.fac <- loc.fac
    # 7) noms des loci renumrotes L01 ... L99
    # le vecteur contient les noms d'origine
    res$loc.names <- loc.names
    # 8) le nombre de gnes qui ont permis les calculs de frquences
    res$pop.loc <- Z
    # 9) le nombre d'occurences de chaque forme alllique dans chaque population
    # allles eln lignes, populations en colonnes
    res$all.pop <- all.pop
    #######################################################
    if (complete) {
        n0 <- length(all.codes) # nrow(ind.all[[1]])
        ind.all <- unlist(ind.all)
        ind.all <- matrix(ind.all, ncol=n0, byrow=TRUE)
        ind.all <- data.frame(ind.all)
        ind.all <- ind.all[ind.full,]
        pop.red <- pop[ind.full]
        names(ind.all) <- all.codes
        row.names(ind.all) <- ind.codes[ind.full]
        ind.all <- 2*ind.all
        # ind.all <- split(ind.all,pop.red)
        # ind.all <- lapply(ind.all,t)
        # 10) les typages d'individus complets
        # ind.all est une liste de matrices allles-individus
        # ne contenant que les individus compltement typs
        # avec le codage 02000 ou 01001
        
        res$comp <- ind.all
        res$comp.pop <- pop.red
    }
     class(res) <- c("genet", "list")
    return(res)
}

"count2genet" <- function (PopAllCount) {
    # PopAllCount est un data.frame qui contient des dnombrements
     ####################################################################################
    "codred" <- function(base, n) {
        # fonction qui fait des codes de noms ordonns par ordre
        # alphabtique de longueur constante le plus simples possibles
        # base est une chane de charactres, n le nombre qu'on veut
        w <- as.character(1:n)
        max0 <- max(nchar(w))
        "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",x,sep="")
        lapply(1:n, fun1)
        return(paste(base,w,sep="")) 
    }
  
    if (!inherits(PopAllCount,"data.frame")) stop ("data frame expected")
    if (!all(apply(PopAllCount,2,function(x) all(x==as.integer(x)))))
        stop("For integer values only")
    PopAllCount <- PopAllCount[sort(row.names(PopAllCount)),]
    PopAllCount <- PopAllCount[,sort(names(PopAllCount))]
    npop <- nrow(PopAllCount)
    nall <- ncol(PopAllCount)
    w1 <- strsplit(names(PopAllCount),"[.]")
    loc.fac <- as.factor(unlist(lapply(w1, function(x) x[1])))
    loc.blocks <- as.numeric(table(loc.fac))
    nloc <- nlevels(loc.fac)    
    loc.names <- as.character(levels(loc.fac))
    pop.codes <- codred("P", npop)
    loc.codes <- codred("L",nloc)
    names(loc.blocks) <- loc.codes 
    pop.names <- row.names(PopAllCount)
    names(pop.names) <- pop.codes
    
    w1 <- rep(loc.codes,loc.blocks)
    w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
    all.codes <- paste(w1,w2,sep="")
    all.names <- names(PopAllCount)
    names(all.names) <- all.codes
    names(loc.names) <- loc.codes
    all.pop <- as.data.frame(t(PopAllCount))
    names(all.pop) <- pop.codes
    row.names(all.pop) <- all.codes
    
    center <- apply(all.pop,1,sum)
    center <- split(center,loc.fac)
    center <- unlist(lapply(center, function(x) x/sum(x)))
    names(center) <- all.codes
    
    PopAllCount <- split(all.pop,loc.fac)
    "pourcent" <- function(x) {
        x <- t(x)
        w <- apply(x,1,sum)
        w[w==0] <- 1
        x <- x/w
        return(x)
        # retourne un tableau populations-allles
    }
    PopAllCount <- lapply(PopAllCount,pourcent)
    tab <- data.frame(provi=rep(1,npop))
    lapply(PopAllCount, function(x) tab <<- cbind.data.frame(tab,x))
    tab <- tab[,-1]
    names(tab) <- all.codes
    row.names(tab) <- pop.codes
    res <- list()
    res$tab <- tab
    res$center <- center
    res$pop.names <- pop.names
    res$all.names <- all.names
    res$loc.blocks <- loc.blocks
    res$loc.fac <- loc.fac
    res$loc.names <- loc.names
    res$pop.loc <- NULL
    res$all.pop <- all.pop
    res$complet <- NULL
    class(res) <- c("genet","list")
    return(res)
}

"freq2genet" <- function (PopAllFreq) {
    # PopAllFreq est un data.frame qui contient des frquences allliques
     ####################################################################################
    "codred" <- function(base, n) {
        # fonction qui fait des codes de noms ordonns par ordre
        # alphabtique de longueur constante le plus simples possibles
        # base est une chane de charactres, n le nombre qu'on veut
        w <- as.character(1:n)
        max0 <- max(nchar(w))
        "fun1" <- function(x) while ( nchar(w[x]) < max0) w[x] <<- paste("0",x,sep="")
        lapply(1:n, fun1)
        return(paste(base,w,sep="")) 
    }
  
    if (!inherits(PopAllFreq,"data.frame")) stop ("data frame expected")
    if (!all(apply(PopAllFreq,2,function(x) all(x>=0))))
        stop("Data >= 0 expected")
    if (!all(apply(PopAllFreq,2,function(x) all(x<=1))))
        stop("Data <= 1 expected")
    PopAllFreq <- PopAllFreq[sort(row.names(PopAllFreq)),]
    PopAllFreq <- PopAllFreq[,sort(names(PopAllFreq))]
    npop <- nrow(PopAllFreq)
    nall <- ncol(PopAllFreq)
    w1 <- strsplit(names(PopAllFreq),"[.]")
    loc.fac <- as.factor(unlist(lapply(w1, function(x) x[1])))
    loc.blocks <- as.numeric(table(loc.fac))
    nloc <- nlevels(loc.fac)    
    loc.names <- as.character(levels(loc.fac))
    pop.codes <- codred("P", npop)
    loc.codes <- codred("L",nloc)
    names(loc.blocks) <- loc.codes 
    pop.names <- row.names(PopAllFreq)
    names(pop.names) <- pop.codes
    
    w1 <- rep(loc.codes,loc.blocks)
    w2 <- unlist(lapply(loc.blocks, function(n) codred(".",n)))
    all.codes <- paste(w1,w2,sep="")
    all.names <- names(PopAllFreq)
    names(all.names) <- all.codes
    names(loc.names) <- loc.codes
    all.pop <- as.data.frame(t(PopAllFreq))
    names(all.pop) <- pop.codes
    row.names(all.pop) <- all.codes
    
    center <- apply(all.pop,1,mean)
    center <- split(center,loc.fac)
    center <- unlist(lapply(center, function(x) x/sum(x)))
    names(center) <- all.codes
    
    PopAllFreq <- split(all.pop,loc.fac)
    "pourcent" <- function(x) {
        x <- t(x)
        w <- apply(x,1,sum)
        w[w==0] <- 1
        x <- x/w
        return(x)
        # retourne un tableau populations-allles
    }
    PopAllFreq <- lapply(PopAllFreq,pourcent)
    tab <- data.frame(provi=rep(1,npop))
    lapply(PopAllFreq, function(x) tab <<- cbind.data.frame(tab,x))
    tab <- tab[,-1]
    names(tab) <- all.codes
    row.names(tab) <- pop.codes
    res <- list()
    res$tab <- tab
    res$center <- center
    res$pop.names <- pop.names
    res$all.names <- all.names
    res$loc.blocks <- loc.blocks
    res$loc.fac <- loc.fac
    res$loc.names <- loc.names
    res$pop.loc <- NULL
    res$all.pop <- all.pop
    res$complet <- NULL
    class(res) <- c("genet","list")
    return(res)
}

"gridrowcol" <- function (nrow,ncol, cell.names=NULL) { 
    # Rsultats utiliss dans le thse de Cornillon p. 15 
    # corrections de 2 coquilles bas de p. 15
    nrow <- as.integer(nrow)
    if (nrow < 1) stop("nrow nonpositive")
    ncol <- as.integer(ncol)
    if (ncol < 1)  stop("ncol nonpositive")
    ncell <- nrow*ncol
    xy<-matrix(0,nrow,ncol)
    xy <- cbind(as.numeric(t(col(xy))),as.numeric(t(row(xy))))
    if (!is.null(cell.names)) {
        if (length(cell.names)!=nrow*ncol) names <- NULL
    }
    if (is.null (cell.names)) {
        cell.names <- paste("R",xy[,2],"C",xy[,1],sep="")
    }
 
    xy <- data.frame(xy)
    names(xy)=c("x","y")
    row.names(xy) = cell.names
    xy$"y" <- nrow+1-xy$"y"
    res<- list(xy=xy)
    area <- rep(row.names(xy),rep(4,ncell))
    area <- as.factor(area)
    w <- cbind(xy$"x"-0.5,xy$"x"-0.5,xy$"x"+0.5,xy$"x"+0.5)
    w <- as.numeric(t(w))
    area <- cbind.data.frame(area,w)
    w <- cbind(xy$"y"-0.5,xy$"y"+0.5,xy$"y"+0.5,xy$"y"-0.5)
    w <- as.numeric(t(w))
    area <- cbind.data.frame(area,w)
    names(area) <- c("cell","x","y")
    res$area <- area
    d0 <- dist2mat(dist.quant(xy,1))
    d0 <- 1*(d0<1.2)
    diag(d0) <-0
    pvoisi <- unlist(apply(d0,1,sum))
    naret <- sum(pvoisi)
    pvoisi <- pvoisi/naret
    d0 <- neig(mat01=d0)
    res$neig <- d0

    xy$"y" <- nrow+1-xy$"y"
    # numero de colonne en x et numero de ligne en y
    "glin" <- function (n) {
        n<-n
        "vecpro" <- function(k) {
            x <- cos(k*pi*((1:n)-0.5)/n)
            x <- x/sqrt(sum(x*x))
            # print(x)
        }
        w <- unlist(lapply(0:(n-1),vecpro))
        w <- matrix(w,n)
    }
    
    orthobasis <- glin(nrow)%x%glin(ncol)
    
    # ce paragrahe calcule les valeurs de xtEx pour les vecteurs de orthobasis
    # et permet de vrifier qu'il s'agit bien des vecteurs propres
    # et que les valeurs propres sont bien celles qui sont calcules
    # d0=neig2mat(d0)
    # d1=apply(d0,1,sum)
    # d0=diag(d1)-d0
    # fun2 <- function(x) {
    #     w=d0*x
    #     return(sum(t(w)*x))
    # }
    # lambda <- unlist(apply(orthobasis,2,fun2))
    # print(lambda)
    # res$lambda <- lambda
    
    pirow <- pi/nrow
    picol<- pi/ncol
    salpha <- (sin((0:(nrow-1))*pirow/2))^2
    sbeta <- (sin((0:(ncol-1))*picol/2))^2
    z <- rep(sbeta,nrow)+rep(salpha,rep(ncol,nrow))
    z <- 4*z/nrow/ncol
    w <- order(z)[-1]
    z <- z[w]
    orthobasis <- sqrt(ncell)*orthobasis[,w]
    orthobasis <- data.frame(orthobasis)
    val <- unlist(lapply(orthobasis,function(x) sum(x*x*pvoisi)))
    val <- val - z*ncell*ncell/naret
    ord <- rev(order(val))
    orthobasis <- orthobasis[,ord]
    val <- val[ord]
    names(orthobasis) = paste("S",1:(ncell-1),sep="")
    row.names(orthobasis) = row.names(res$xy)
    # Les valeurs sont calcules  partir des valeurs propres de l'oprateur de lissage
    # Ce sont des valeurs de l'indice de Moran xtFx/v(x) v en 1/n
    # print(unlist(lapply(orthobasis,function(x) sum(x*x*pvoisi))))
    attr(orthobasis,"values") <- val
    attr(orthobasis,"weights") <- rep(1/ncell,ncell)
    attr(orthobasis,"call") <- match.call()
    attr(orthobasis,"class") <- c("orthobasis","data.frame")
    res$orthobasis <- orthobasis
    # ces ordres vrifient qu'on a bien trouv les indices de Moran
    # d0 = neig2mat(d0)
    # d0 = d0/sum(d0) # Moran type W
    # moran <- unlist(lapply(orthobasis,function(x) sum(t(d0*x)*x)))
    # print(moran)
    # plot(moran,attr(orthobasis,"values"))
    # abline(lm(attr(orthobasis,"values")~moran))
    # print(summary(lm(attr(orthobasis,"values")~moran)))
    return(res)
}

    
"inertia.dudi" <- function (dudi, row.inertia = FALSE, col.inertia = FALSE) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class 'dudi' expected")
    app <- function(x) {
        if (is.na(x)) 
            return(x)
        if (is.infinite(x)) 
            return(NA)
        if ((ceiling(x) - x) > (x - floor(x))) 
            return(floor(x))
        else return(ceiling(x))
    }
    nf <- dudi$nf
    inertia <- dudi$eig
    cum <- cumsum(inertia)
    ratio <- cum/sum(inertia)
    TOT <- cbind.data.frame(inertia, cum, ratio)
    listing <- list(TOT = TOT)
    if (row.inertia) {
        w <- dudi$tab * sqrt(dudi$lw)
        w <- sweep(w, 2, sqrt(dudi$cw), "*")
        w <- w * w
        con.tra <- apply(w, 1, sum)/sum(w)
        w <- dudi$li * dudi$li * dudi$lw
        w <- sweep(w, 2, dudi$eig[1:nf], "/")
        listing$row.abs <- apply(10000 * w, c(1, 2), app)
        w <- dudi$tab
        w <- sweep(w, 2, sqrt(dudi$cw), "*")
        d2 <- apply(w * w, 1, sum)
        w <- dudi$li * dudi$li
        w <- sweep(w, 1, d2, "/")
        w <- w * sign(dudi$li)
        names(w) <- names(dudi$li)
        w <- cbind.data.frame(w, con.tra)
        listing$row.rel <- apply(10000 * w, c(1, 2), app)
        w <- dudi$li * dudi$li
        w <- sweep(w, 1, d2, "/")
        w <- data.frame(t(apply(w, 1, cumsum)))
        names(w) <- names(dudi$li)
        remain <- 1 - w[, ncol(w)]
        w <- cbind.data.frame(w, remain)
        listing$row.cum <- apply(10000 * w, c(1, 2), app)
    }
    if (col.inertia) {
        w <- dudi$tab * sqrt(dudi$lw)
        w <- sweep(w, 2, sqrt(dudi$cw), "*")
        w <- w * w
        con.tra <- apply(w, 2, sum)/sum(w)
        w <- dudi$co * dudi$co * dudi$cw
        w <- sweep(w, 2, dudi$eig[1:nf], "/")
        listing$col.abs <- apply(10000 * w, c(1, 2), app)
        w <- dudi$tab
        w <- sweep(w, 1, sqrt(dudi$lw), "*")
        d2 <- apply(w * w, 2, sum)
        w <- dudi$co * dudi$co
        w <- sweep(w, 1, d2, "/")
        w <- w * sign(dudi$co)
        names(w) <- names(dudi$co)
        w <- cbind.data.frame(w, con.tra)
        listing$col.rel <- apply(10000 * w, c(1, 2), app)
        w <- dudi$co * dudi$co
        w <- sweep(w, 1, d2, "/")
        w <- data.frame(t(apply(w, 1, cumsum)))
        names(w) <- names(dudi$co)
        remain <- 1 - w[, ncol(w)]
        w <- cbind.data.frame(w, remain)
        listing$col.cum <- apply(10000 * w, c(1, 2), app)
    }
    return(listing)
}
"is.euclid" <- function (distmat, plot = FALSE, print = FALSE, tol = 1e-07) {
    if (!inherits(distmat, "dist")) 
        stop("Object of class 'dist' expected")
    distmat <- dist2mat(distmat)
    n <- ncol(distmat)
    delta <- -0.5 * bicenter.wt(distmat * distmat)
    lambda <- eigen(delta, symmetric = TRUE, only = TRUE)$values
    w0 <- lambda[n]/lambda[1]
    if (plot) 
        barplot(lambda)
    if (print) 
        print(lambda)
    return((w0 > -tol))
}

"summary.dist" <- function (object, ...) {
    if (!inherits(object, "dist")) 
        stop("For use on the class 'dist'")
    cat("Class: ")
    cat(class(object), "\n")
    cat("Distance matrix by lower triangle : d21, d22, ..., d2n, d32, ...\n")
    cat("Size:", attr(object, "Size"), "\n")
    cat("Labels:", attr(object, "Labels"), "\n")
    cat("call: ")
    print(attr(object, "call"))
    cat("method:", attr(object, "method"), "\n")
    cat("Euclidean matrix (Gower 1966):", is.euclid(object), "\n")
}

"mat2dist" <- function (m, diag = FALSE, upper = FALSE) {
    m <- as.matrix(m)
    retval <- m[row(m) > col(m)]
    attributes(retval) <- NULL
    attr(retval, "Labels") <- as.character(1:nrow(m))
    if (!is.null(rownames(m))) 
        attr(retval, "Labels") <- rownames(m)
    else if (!is.null(colnames(m))) 
        attr(retval, "Labels") <- colnames(m)
    attr(retval, "Size") <- nrow(m)
    attr(retval, "Diag") <- diag
    attr(retval, "Upper") <- upper
    attr(retval, "call") <- match.call()
    class(retval) <- "dist"
    retval
}

"dist2mat" <- function (x) {
    size <- attr(x, "Size")
    df <- matrix(0, size, size)
    df[row(df) > col(df)] <- x
    df <- df + t(df)
    labels <- attr(x, "Labels")
    dimnames(df) <- if (is.null(labels)) 
        list(1:size, 1:size)
    else list(labels, labels)
    df
}
# kdist #                cration jeudi, avril 3, 2003 at 13:57
# as.data.frame.kdist #  cration jeudi, avril 3, 2003 at 13:57
# print.kdist #          cration jeudi, avril 3, 2003 at 13:57
# [.kdist #              cration jeudi, avril 3, 2003 at 13:57
# c.kdist #              cration jeudi, avril 3, 2003 at 13:57
#################### kdist #################################
"kdist" <- function (..., epsi = 1e-07, upper=FALSE) {
    is.dist <- function(x) {
        if (!inherits(x,"dist")) return (FALSE)
        else return (TRUE)
    }
    is.matrix.dist <- function(m) {
        m <- as.matrix(m)
        n <- ncol(m) ; p <- nrow(m)
        if (any(is.na(m))) return ("NA values not allowed in m")
            if (n != p) return  ("Square matrix expected")
            if (sum(diag(m)^2) != 0) return ("0 in diagonal expected")
            if (min(m) < 0) return ("non negative value expected")
            if (sum((t(m) - m)^2) != 0) return ("Symetric matrice expected")
            return (NULL)
    }

    triinftodist <- function(x) {
        n0 <- length(x)
        n <- sqrt(1 + 8 * n0)
        n <- (1 + n)/2
        a <- matrix(0, ncol = n, nrow = n)
        a[row(a) > col(a)] <- x
        a <- a+t(a)
        return(a)
    } 
    trisuptodist <- function(x) {
        n0 <- length(x)
        n <- sqrt(1 + 8 * n0)
        n <- (1 + n)/2
        a <- matrix(0, ncol = n, nrow = n)
        a[row(a) < col(a)] <- x
        a <- a+t(a)
        return(a)
    }
    vecttovect <- function(x,upper) {
        attributes(x) <- NULL
        if (upper) {
            m <- trisuptodist(x)
            return(m[row(m) > col(m)])
        } else {
           return (x)
        }
    }

    as.kdist.dist <- function(list.obj) {
        # une liste d'objets de la classe dist
        f1 <- function(x) {
            attributes(x) <- NULL
            return(as.vector(x))
        }
        n <- length(list.obj)
        res <- lapply(list.obj,is.dist)
        size <- unlist(lapply(list.obj,function(x) attr(x,"Size")))
        if (any(size!=size[1])) stop ("Non equal dimension")
        size <- unique(size)
        retval <- lapply(list.obj, f1)
        res <- unlist(lapply(list.obj,is.euclid ,tol=epsi))
        if (is.null(names(retval))) {
            names(retval) <- as.character(1:n)
        }
        attr(retval, "size") <- size
        attr(retval, "labels") <- attr(list.obj[[1]],"Labels")
        attr(retval, "euclid") <- res
        return(retval)
    }
        
    as.kdist.matrix <- function(list.obj) {
        # une liste d'objets de la classe matrix
        n <- length(list.obj)
        res <- lapply(list.obj,is.matrix.dist)
        for (i in 1:n) {
            if (!is.null(res[[i]])) 
                stop (paste ("object",i,"(",res[[i]],")"))
        }
        size <- unlist(lapply(list.obj,ncol))
        if (any(size!=size[1])) stop ("Non equal dimension")
        list.obj =lapply(list.obj,mat2dist)
        return (as.kdist.dist(list.obj))
     }

    as.kdist.vector <- function(list.obj,upper=upper) {
        n <- length(list.obj)
        w <- unlist(lapply(list.obj,length))
        if (any(w!=w[1])) stop ("Non equal length")
        w <- unique(w)
        size <- 0.5*(1+sqrt(1+8*w))
        if (size!=as.integer(size)) stop ("Non convenient dimension")
        retval <- lapply(list.obj, vecttovect, upper=upper)
        attr(retval, "size") <- size
        attr(retval, "labels") <- as.character(1:size)
        euclid <- logical(n)
        for (i in 1:n) {
            euclid[i] <- is.euclid(mat2dist(triinftodist(retval[[i]])),tol = epsi)
        }
        if (is.null(names(retval))) {
            names(retval) <- as.character(1:length(list.obj))
        }
        attr(retval, "euclid") <- euclid
        return(retval)
    }

    list.obj <- list(...)
    compo.names <- as.character(substitute(list(...)))[-1]
    for (j in 1:length(list.obj)) {
        X <- list.obj[[j]]
        if (is.data.frame(X)) {
            init.names <- names(X)
            X <- as.matrix(X)
            X <- split(X,col(X))
        } else if (is.list(X)) {
            init.names <- names(X) 
        } else {
            X <- list(X)
            init.names <- compo.names[j]
        }
        if (all(unlist(lapply(X, is.dist)))) 
            list.obj[[j]] <- as.kdist.dist(X)
        else if (all(unlist(lapply(X, is.matrix)))) 
            list.obj[[j]] <- as.kdist.matrix(X)
        else if (all(unlist(lapply(X, is.vector)))) 
            list.obj[[j]] <- as.kdist.vector(X,upper=upper)
        else stop("Non convenient data")
        if (length(list.obj[[j]])==length(init.names) )
            names(list.obj[[j]]) <- init.names
        names(list.obj[[j]]) <- make.names(names(list.obj[[j]]))
    }
    n <- length(list.obj)
    size <- attr(list.obj[[1]],"size")
    compo.eff <- unlist(lapply(list.obj,length))
    dist.names <- unlist(lapply(list.obj,names))
    if (any(unlist(lapply(list.obj,function(x) attr(x,"size")))!=size))
        stop ("arguments imply differing size")
    euclid <-  unlist(lapply(list.obj,function(x) attr(x,"euclid")))
    labels <- attr(list.obj[[1]],"labels")
    retval <- list(NULL)
    k <- 0
    for (i in 1:n) {
        lab <- attr(list.obj[[i]],"labels")
        if( any(lab!=labels) ) stop ("arguments imply differing labels")
        w <- list.obj[[i]]
        attributes(w) <- NULL
        for (j in 1:compo.eff[[i]]) {
            k <- k+1
            retval[[k]] <- w[[j]]
        }
    }
    names(retval) <- dist.names
    attr(retval,"size") <- size
    attr(retval, "labels") <- labels
    attr(retval, "euclid") <- euclid
    attr(retval, "call") <- match.call()
    class(retval) <- "kdist"
    return(retval)
}

############# as.data.frame.kdist ######################
"as.data.frame.kdist" <- function(x, row.names=NULL, optional=FALSE) {
    if (!inherits (x, "kdist")) stop ("object 'kdist' expected")
    res <- as.data.frame(unclass(x))
    nind <- attr(x,"size")
    w <- matrix(0,nind,nind)
    numrow <- row(w)[row(w)>col(w)]
    numcol <- col(w)[row(w)>col(w)]
    numrow <- attr(x, "labels")[numrow]
    numcol <- attr(x, "labels")[numcol]
    cha <- paste(numrow,numcol,sep="-")
    row.names(res) <- cha
    return(res)
}

########## print.kdist #################################
"print.kdist" <- function(x,print.matrix.dist=FALSE,...) 
{
    cat("List of distances matrices\n")
    cat("call: ")
    print(attr(x,"call"))
    cat(paste("class:",class(x)))
    n <- length(x)
    cat(paste("\nnumber of distances:",n))
    npoints <- attr(x,"size")
    cat(paste("\nsize:", npoints))
    cat("\nlabels:\n")
    labels <- attr(x,"labels")
    print(labels)
    euclid <- attr(x,"euclid")
    print1 <- function (x,size,labels,...) # from mva
    {
        df <- matrix(NA, size, size,labels)
        df[row(df) > col(df)] <- x
        #df <- df + t(df)
        diag(df) <- 0
        dimnames(df) <- list(labels, labels)
        print(df, na = "",...)
    }
    for (i in 1:n) {
        w <- x[[i]]
        cat(names(x)[i])
        if (euclid[i]) cat(": euclidean distance\n")
        else cat(": non euclidean distance\n")
        if (print.matrix.dist) {
            print1(w,npoints,labels,...)
            cat("\n")
        }
    }
}
######################## [.kdist #######################
"[.kdist" <- function(object,selection) {
    retval <- unclass(object)[selection]
    n <- attr(object,"size")
    labels <- attr(object,"labels")
    euclid <- attr(object,"euclid")
    euclid <- euclid[selection]
    attr(retval, "size") <- n
    attr(retval, "labels") <- labels
      attr(retval, "euclid") <- euclid
    attr(retval, "call") <- match.call()
    class(retval) <- "kdist"
    return(retval)
}
######################## c.kdist ###########################
c.kdist <- function(...) {
    x <- list(...)
    n <- length(x)
    compo.names <- as.character(substitute(list(...)))[-1]
    compo.eff <- unlist(lapply(x,length))
    dist.names <- unlist(lapply(x,names))
    rep.names <- paste(rep(compo.names,compo.eff),dist.names,sep=".")
    
       if (any(lapply(x,class)!="kdist")) 
           stop ("arguments imply object without 'kdist' class")
    size <- attr(x[[1]],"size")
       if (any(unlist(lapply(x,function(x) attr(x,"size")))!=size))
           stop ("arguments imply differing size")
    euclid <-  unlist(lapply(x,function(x) attr(x,"euclid")))
    labels <- attr(x[[1]],"labels")
    if (length(unique(dist.names))!=length(dist.names))
        dist.names <- rep.names
    names(euclid) <- dist.names
    retval <- list(NULL)
    k <- 0
    for (i in 1:n) {
        lab <- attr(x[[i]],"labels")
        if( any(lab!=labels) ) stop ("arguments imply differing labels")
        w <- x[[i]]
        attributes(w) <- NULL
        for (j in 1:compo.eff[[i]]) {
            k <- k+1
            retval[[k]] <- w[[j]]
           }
       }
    attr(retval,"names") <- dist.names
    attr(retval,"size") <- size
    attr(retval, "labels") <- labels
    attr(retval, "euclid") <- euclid
    attr(retval, "call") <- match.call()
    class(retval) <- "kdist" 
    return(retval)
}

"kdist2ktab" <- function (kd, scale = TRUE, tol=1e-07) {
    if (!inherits(kd,"kdist")) stop ("objet 'kdist' expected")
    if (!all(attr(kd,"euclid"))) stop ("Euclidean distances expected")
    ndist <- length(kd)
    nind <- attributes(kd)$size
    distnames <- attributes(kd)$names
    if(is.null(distnames)) distnames <- paste("D", 1:ndist, sep = "")
    rnames <-attributes(kd)$label
    if(is.null(rnames)) rnames <- as.character(1:nind)
    
    "representationeuclidienne" <- function (x) {
        # x est un vecteur demi-matrice du kdist
        d <- matrix(0,nind,nind)
        d[col(d)<row(d)] <- x
        d <- d+t(d)
        d <- (-0.5)*bicenter.wt(d*d)
        # d est une matrice de produits scalaires
        eig <- eigen(d, symmetric = TRUE)
        ncomp <- sum(eig$values > (eig$values[1] * tol))
        d <- eig$vectors[, 1:ncomp]
        variances <- eig$values[1:ncomp]
        d <- t(apply(d, 1, "*", sqrt(variances)))
        # d est une reprsentation euclidienne
        if (scale) {
            inertot <- sum(variances)
            d <- d/sqrt(inertot)
            d = d*sqrt(nrow(d))
        }
        d <- data.frame(d)
        row.names(d) <- rnames
        names(d) <- paste("C", 1:ncomp, sep = "")
        return(d)
    }
    res <- lapply(kd, representationeuclidienne)
    names (res) <- distnames
    for (k in 1:ndist) {
        cha <- distnames[k]
        ncomp <- ncol(res[[k]])
        names(res[[k]]) <- paste(substring (cha,1,4), 1:ncomp,sep="")
    }
    w.row <- rep(1,nind)/nind
    w.col <- lapply(res, function(x) rep(1, ncol(x)))
    res <- ktab.list.df (res, w.row=w.row,w.col=w.col )
    return(res)

}

kdisteuclid <- function(obj,method=c("lingoes","cailliez","quasi")) {

    if (is.null(class(obj))) stop ("Object of class 'kdist' expected")
    if (class(obj)!="kdist") stop ("Object of class 'kdist' expected")
    selectinlist.util <- function(w, ref) {
        choi <- regexpr(w, ref,ext=FALSE)
        if (is.na(choi)) stop(paste("invalid selection for",w,"in",ref))
        return(ref[choi!=-1])
    }
    choice <- selectinlist.util(method, c("lingoes","cailliez","quasi"))
    if (length(choice)==0) stop ("unknown method")

    lingo.1 <- function(x,size) {
        mat <- matrix(0, size, size)
        mat[row(mat) > col(mat)] <- x
        mat <- mat + t(mat)
        delta <- -0.5 * bicenter.wt(mat*mat)
        lambda <- eigen(delta, sym = TRUE)$values
        lder <- lambda[ncol(mat)]
        mat <- sqrt(mat * mat + 2 * abs(lder))
        mat <- unclass(mat[row(mat) > col(mat)])
        print(paste("Lingoes constant =", abs(lder)))
        return(mat)
    }

    quasi.1 <- function(x,size) {
        mat <- matrix(0, size, size)
        mat[row(mat) > col(mat)] <- x
        mat <- mat + t(mat)
        delta <- -0.5 * bicenter.wt(mat*mat)
        eig <- eigen(delta, sym = TRUE)
        ncompo <- sum(eig$value>0)
        tabnew <- t( t(eig$vectors[,1:ncompo])*sqrt(eig$values[1:ncompo]) )
        mat <- unclass(dist.quant(tabnew,1))
        print(paste("First ev =", eig$value[1], "Last ev =", eig$value[size]))
        return(mat)
    }
    
    cailliez.1 <- function(x,size) {
        mat <- matrix(0, size, size)
            mat[row(mat) > col(mat)] <- x
            mat <- mat + t(mat)
            m1 <- matrix(0,size,size)
            m1 <- rbind(m1,-diag(size))
        m2 <- -bicenter.wt(mat*mat)
            m2 <- rbind(m2, 2*bicenter.wt(mat))
            m1 <- cbind(m1,m2)
            lambda <- eigen(m1,only=TRUE)$values
        c <- max(Re(lambda)[Im(lambda)<1e-08])
        print(paste("Cailliez constant =", c))
        return(x+c)
    }

    n <- attr(obj,"size")
    ndist <- length(obj)
    euclid <- attr(obj,"euclid")
    for (i in 1:ndist) {
        if (!euclid[i]) {
        if (choice=="lingoes") obj[[i]] <- lingo.1(obj[[i]],n) 
            else if (choice=="cailliez") obj[[i]] <- cailliez.1(obj[[i]],n)
            else if (choice=="quasi") obj[[i]] <- quasi.1(obj[[i]],n)
            else (stop ("unknown method"))
        }
    }
    attr(obj, "euclid") <- rep(TRUE, ndist)
    attr(obj, "call") <- match.call()
    return(obj)
}

"kplot" <- function (object, ...) {
    UseMethod("kplot")
}
"kplot.foucart" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
    clab.r = 1, clab.c = 1.25, csub = 2, possub = "bottomright", ...) 
{
    if (!inherits(object, "foucart")) 
        stop("Object of type 'foucart' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    nblo <- length(object$blo)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nblo, object$rank))
    nf <- ncol(object$li)
    coolig <- object$Tli[, c(xax, yax)]
    coocol <- object$Tco[, c(xax, yax)]
    names(coocol) <- names(coolig)
    cootot <- rbind.data.frame(coocol, coolig)
    if (clab.r > 0) 
        cpoi <- 0
    else cpoi <- 2
    for (ianal in which.tab) {
        coolig <- object$Tli[object$TL[, 1] == ianal, c(xax, yax)]
        coocol <- object$Tco[object$TC[, 1] == ianal, c(xax, yax)]
        s.label(cootot, clab = 0, cpoi = 0, sub = object$tab.names[ianal], 
            csub = csub, possub = possub)
        s.label(coolig, clab = clab.r, cpoi = cpoi, add.p = TRUE)
        s.label(coocol, clab = clab.c, add.p = TRUE)
    }
}
"kplot.mcoa" <- function (object, xax = 1, yax = 2, which.tab = 1:nrow(object$cov2),
    mfrow = NULL, option = c("points", "axis", "columns"), clab = 1, 
    cpoint = 2, csub = 2, possub = "bottomright", ...) 
{
    if (!inherits(object, "mcoa")) 
        stop("Object of type 'mcoa' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    option <- option[1]
    if (option == "points") {
        if (is.null(mfrow)) 
            mfrow <- n2mfrow(length(which.tab) + 1)
        par(mfrow = mfrow)
        if (length(which.tab) > prod(mfrow) - 1) 
            par(ask = TRUE)
        par(mar = c(0.1, 0.1, 0.1, 0.1))
        coo1 <- object$SynVar[, c(xax, yax)]
        cootot <- object$Tl1[, c(xax, yax)]
        names(cootot) <- names(coo1)
        coofull <- coo1
        for (i in which.tab) coofull <- rbind.data.frame(coofull, 
            cootot[object$TL[, 1] == i, ])
        s.label(coo1, clab = clab, sub = "Reference", possub = "bottomright", 
            csub = csub)
        for (ianal in which.tab) {
            scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL, 
                grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE, 
                origin = c(0, 0), sub = row.names(object$cov2)[ianal], 
                csub = csub, possub = possub, pixmap = NULL, 
                contour = NULL, area = NULL, add.plot = FALSE)
            coo2 <- cootot[object$TL[, 1] == ianal, 1:2]
            s.match(coo1, coo2, clab = 0, add.p = TRUE)
            s.label(coo1, clab = 0, cpoi = cpoint, add.p = TRUE)
        }
        return(invisible())
    }
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    if (option == "axis") {
        if (length(which.tab) > prod(mfrow)) 
            par(ask = TRUE)
        for (ianal in which.tab) {
            coo2 <- object$Tax[object$T4[, 1] == ianal, c(xax, yax)]
            row.names(coo2) <- as.character(1:4)
            s.corcircle(coo2, clab = clab, sub = row.names(object$cov2)[ianal], 
                csub = csub, possub = possub)
        }
        return(invisible())
    }
    if (option == "columns") {
        if (length(which.tab) > prod(mfrow)) 
            par(ask = TRUE)
        for (ianal in which.tab) {
            coo2 <- object$Tco[object$TC[, 1] == ianal, c(xax, yax)]
            s.arrow(coo2, clab = clab, sub = row.names(object$cov2)[ianal], 
                csub = csub, possub = possub)
        }
        return(invisible())
    }
}
"kplot.mfa" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$blo),
    row.names = FALSE, col.names = TRUE, traject = FALSE, permute.row.col = FALSE, 
    clab = 1, csub = 2, possub = "bottomright", ...) 
{
    if (!inherits(object, "mfa")) 
        stop("Object of type 'mfa' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    nbloc <- length(object$blo)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nbloc, object$rank))
    nf <- ncol(object$li)
    for (ianal in which.tab) {
        coolig <- object$lisup[object$TL[, 1] == ianal, c(xax, yax)]
        coocol <- object$co[object$TC[, 1] == ianal, c(xax, yax)]
        if (permute.row.col) {
            auxi <- coolig
            coolig <- coocol
            coocol <- auxi
        }
        cl <- clab * row.names
        if (cl > 0) 
            cpoi <- 0
        else cpoi <- 2
        s.label(coolig, clab = cl, cpoi = cpoi)
        if (traject) 
            s.traject(coolig, clab = 0, add.p = TRUE)
        born <- par("usr")
        k1 <- min(coocol[, 1])/born[1]
        k2 <- max(coocol[, 1])/born[2]
        k3 <- min(coocol[, 2])/born[3]
        k4 <- max(coocol[, 2])/born[4]
        k <- c(k1, k2, k3, k4)
        coocol <- 0.7 * coocol/max(k)
        s.arrow(coocol, clab = clab * col.names, add.p = TRUE, 
            sub = object$tab.names[ianal], possub = possub, csub = csub)
    }
}
"kplot.pta" <- function (object, xax = 1, yax = 2, which.tab = 1:nrow(object$RV),
    mfrow = NULL, which.graph = 1:4, clab = 1, cpoint = 2, csub = 2, 
    possub = "bottomright", ask = par("ask"), ...) 
{
    if (!inherits(object, "pta")) 
        stop("Object of type 'pta' expected")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    show <- rep(FALSE, 4)
    if (!is.numeric(which.graph) || any(which.graph < 1) || any(which.graph > 
        4)) 
        stop("`which' must be in 1:4")
    show[which.graph] <- TRUE
    if (is.null(mfrow)) {
        mfcol <- c(length(which.tab), length(which.graph))
        par(mfcol = mfcol)
    }
    else par(mfrow = mfrow)
    par(ask = ask)
    if (show[1]) {
        for (ianal in which.tab) {
            coo2 <- object$Tax[object$T4[, 1] == ianal, c(xax, yax)]
            row.names(coo2) <- as.character(1:4)
            s.corcircle(coo2, clab = clab, cgrid = 0, sub = row.names(object$RV)[ianal], 
                csub = csub, possub = possub)
        }
    }
    if (show[2]) {
        par(mar = c(0.1, 0.1, 0.1, 0.1))
        coo1 <- object$li[, c(xax, yax)]
        cootot <- object$Tli[, c(xax, yax)]
        names(cootot) <- names(coo1)
        coofull <- coo1
        for (i in which.tab) coofull <- rbind.data.frame(coofull, 
            cootot[object$TL[, 1] == i, ])
        for (ianal in which.tab) {
            scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL, 
                grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE, 
                origin = c(0, 0), sub = row.names(object$RV)[ianal], 
                csub = csub, possub = possub, pixmap = NULL, 
                contour = NULL, area = NULL, add.plot = FALSE)
            coo2 <- cootot[object$TL[, 1] == ianal, 1:2]
            s.label(coo2, add.p = TRUE, clab = clab, label = row.names(object$Tli)[object$TL[, 
                1] == ianal])
        }
    }
    if (show[3]) {
        par(mar = c(0.1, 0.1, 0.1, 0.1))
        coo1 <- object$co[, c(xax, yax)]
        cootot <- object$Tco[, c(xax, yax)]
        names(cootot) <- names(coo1)
        coofull <- coo1
        for (i in which.tab) coofull <- rbind.data.frame(coofull, 
            cootot[object$TC[, 1] == i, ])
        for (ianal in which.tab) {
            scatterutil.base(coofull, 1, 2, xlim = NULL, ylim = NULL, 
                grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE, 
                origin = c(0, 0), sub = row.names(object$RV)[ianal], 
                csub = csub, possub = possub, pixmap = NULL, 
                contour = NULL, area = NULL, add.plot = FALSE)
            coo2 <- object$Tco[object$TC[, 1] == ianal, c(xax, yax)]
            s.arrow(coo2, add.p = TRUE, clab = clab, sub = row.names(object$RV)[ianal], 
                csub = csub, possub = possub)
        }
    }
    if (show[4]) {
        for (ianal in which.tab) {
            coo2 <- object$Tcomp[object$T4[, 1] == ianal, c(xax, yax)]
            row.names(coo2) <- as.character(1:4)
            s.corcircle(coo2, clab = clab, cgrid = 0, sub = row.names(object$RV)[ianal], 
                csub = csub, possub = possub)
        }
    }
}
"kplot.sepan" <- function (object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
    mfrow = NULL, permute.row.col = FALSE, clab.row = 1, clab.col = 1.25, 
    traject.row = FALSE, csub = 2, possub = "bottomright", show.eigen.value = TRUE, ...) 
{
    if (!inherits(object, "sepan")) 
        stop("Object of type 'sepan' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    nbloc <- length(object$blo)
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nbloc, object$rank))
    nf <- ncol(object$Li)
    neig <- max(object$rank)
    appel <- as.list(object$call)
    X <- eval(appel$X, sys.frame(0))
    names.li <- row.names(X[[1]])
    for (ianal in which.tab) {
        coolig <- object$Li[object$TL[, 1] == ianal, c(xax, yax)]
        row.names(coolig) <- names.li
        coocol <- object$Co[object$TC[, 1] == ianal, c(xax, yax)]
        row.names(coocol) <- names(X[[ianal]])
        if (permute.row.col) {
            auxi <- coolig
            coolig <- coocol
            coocol <- auxi
        }
        if (clab.row > 0) 
            cpoi <- 0
        else cpoi <- 2
        if (!traject.row) 
            s.label(coolig, clab = clab.row, cpoi = cpoi)
        else s.traject(coolig, clab = 0, cpoi = 2)
        born <- par("usr")
        k1 <- min(coocol[, 1])/born[1]
        k2 <- max(coocol[, 1])/born[2]
        k3 <- min(coocol[, 2])/born[3]
        k4 <- max(coocol[, 2])/born[4]
        k <- c(k1, k2, k3, k4)
        coocol <- 0.7 * coocol/max(k)
        s.arrow(coocol, clab = clab.col, add.p = TRUE, sub = object$tab.names[ianal], 
            csub = csub, possub = possub)
        w <- object$Eig[rank.fac == ianal]
        if (length(w) < neig) 
            w <- c(w, rep(0, neig - length(w)))
        if (show.eigen.value) 
            add.scatter.eig(w, nf, xax, yax, posi = c("bottom", 
                "top"), ratio = 1/4)
    }
} 


"kplot.sepan.coa" <- function (object, xax = 1, yax = 2, which.tab = 1:length(object$blo),
    mfrow = NULL, permute.row.col = FALSE, clab.row = 1, clab.col = 1.25, 
    csub = 2, possub = "bottomright", show.eigen.value = TRUE, 
    poseig = c("bottom", "top"), ...) 
{
    if (!inherits(object, "sepan")) 
        stop("Object of type 'sepan' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    nbloc <- length(object$blo)
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nbloc, object$rank))
    nf <- ncol(object$Li)
    neig <- max(object$rank)
    appel <- as.list(object$call)
    X <- eval(appel$X, sys.frame(0))
    names.li <- row.names(X[[1]])
    for (ianal in which.tab) {
        coocol <- object$C1[object$TC[, 1] == ianal, c(xax, yax)]
        row.names(coocol) <- names(X[[ianal]])
        coolig <- object$Li[object$TL[, 1] == ianal, c(xax, yax)]
        row.names(coolig) <- names.li
        if (permute.row.col) {
            auxi <- coolig
            coolig <- coocol
            coocol <- auxi
        }
        if (clab.col > 0) 
            cpoi <- 0
        else cpoi <- 3
        s.label(coocol, clab = 0, cpoi = 0, sub = object$tab.names[ianal], 
            csub = csub, possub = possub)
        s.label(coocol, clab = clab.col, cpoi = cpoi, add.p = TRUE)
        s.label(coolig, clab = clab.row, add.p = TRUE)
        if (permute.row.col) {
            auxi <- coolig
            coolig <- coocol
            coocol <- auxi
        }
        w <- object$Eig[rank.fac == ianal]
        if (length(w) < neig) 
            w <- c(w, rep(0, neig - length(w)))
        if (show.eigen.value) 
            add.scatter.eig(w, nf, xax, yax, posi = poseig, ratio = 1/4)
    }
}
"kplot.statis" <- function (object, xax = 1, yax = 2, mfrow = NULL, which.tab = 1:length(object$tab.names),
    clab = 1.5, cpoi = 2, traject = FALSE, arrow = TRUE, class = NULL, 
    unique.scale = FALSE, csub = 2, possub = "bottomright", ...) 
{
    if (!inherits(object, "statis")) 
        stop("Object of type 'statis' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.tab))
    par(mfrow = mfrow)
    if (length(which.tab) > prod(mfrow)) 
        par(ask = TRUE)
    nbloc <- length(object$RV.tabw)
    nf <- ncol(object$C.Co)
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
    cootot <- object$C.Co[, c(xax, yax)]
    label <- TRUE
    if (!is.null(class)) {
        class <- factor(class)
        if (length(class) != length(object$TC[, 1])) 
            class <- NULL
        else label <- FALSE
    }
    for (ianal in which.tab) {
        coocol <- cootot[object$TC[, 1] == ianal, ]
        if (unique.scale) 
            s.label(cootot, clab = 0, cpoi = 0, sub = object$tab.names[ianal], 
                possub = possub, csub = csub)
        else s.label(coocol, clab = 0, cpoi = 0, sub = object$tab.names[ianal], 
            possub = possub, csub = csub)
        if (arrow) {
            s.arrow(coocol, clab = clab, add.p = TRUE)
            label <- FALSE
        }
        if (label) 
            s.label(coocol, clab = clab, cpoi = cpoi, add.p = TRUE)
        if (traject) 
            s.traject(coocol, clab = 0, add.p = TRUE)
        if (!is.null(class)) {
            f1 <- as.factor(class[object$TC[, 1] == ianal])
            s.class(coocol, f1, clab = clab, cpoi = 2, 
                pch = 20, axese = FALSE, cell = 0, add.plot = TRUE)
        }
    }
}
"plot.krandtest" <- function (x, mfrow=NULL, nclass= NULL, main.title = names(x), ...) {
    if (!inherits(x, "krandtest")) 
        stop("to be used with 'krandtest' object")
    ntest <- length(x)
    nrepet <- length(x[[1]])-1
    if (is.null(mfrow)) mfrow=n2mfrow(ntest)
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    par(mfrow=mfrow)
    par(mar = c(3.1, 2.5, 2.1, 2.1))
    if (length(main.title)!=length(names(x))) 
        main.title <- names(x)
    for (k in 1:ntest) {
        y <- x[[k]]
        plot.randtest (as.randtest (y[-1],y[1],call=match.call()),main = main.title[k],nclass=nclass)
    }
}

"print.krandtest" <- function (x, ...) {
    if (!inherits(x, "krandtest")) 
        stop("to be used with 'krandtest' object")
    cat("class:", class(x), "\n")
    ntest <- length(x)
    nrepet <- length(x[[1]])-1
    dig0 =ceiling (log(nrepet)/log(10))
    cat("test number:  ", ntest, "\n")
    cat("permutation number:  ", nrepet, "\n")
    sumry <- array("", c(ntest, 4), list(1:ntest, c("test", 
        "obs", "P(X<=obs)", "P(X>=obs)")))
    for (i in 1:ntest) {
        y <- x[[i]]
        obs <- y[1]
        y <- y[-1]
        sumry[i,1] <- names(x)[i]
        sumry[i,2] <- round(obs,dig=dig0)
        n <- (sum(y <= obs) + 1)/nrepet
        if (n>1) n <- 1
        if (n<0) n <- 0
        sumry[i,3] <- round(n, dig=dig0)
        n <- (sum(y >= obs) + 1)/nrepet
        if (n>1) n <- 1
        if (n<0) n <- 0
        sumry[i,4] <- round(n, dig=dig0)
     }
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}

########### is.ktab ###########
"is.ktab" <- function (x)
    inherits(x, "ktab")

########### [.ktab" ########### 
"[.ktab" <- function (object, selection) {
    blocks <- object$blo
    nblo <- length(blocks)
    if (is.logical(selection)) 
        selection <- which(selection)
    if (any(selection > nblo)) 
        stop("Non convenient selection")
    indica <- as.factor(rep(1:nblo, blocks))
    res <- unclass(object)[selection]
    cw <- object$cw
    cw <- split(cw, indica)
    cw <- unlist(cw[selection])
    res$cw <- cw
    res$lw <- object$lw
    nr <- length(res$lw)
    blocks <- unlist(lapply(res, function(x) ncol(x)))
    nblo <- length(blocks)
    res$blo <- blocks
    ktab.util.addfactor(res) <- list(blocks, length(res$lw))
    res$call <- match.call()
    class(res) <- "ktab"
    return(res)
}


########### print.ktab ########### 
"print.ktab" <- function (x, ...) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    cat("class:", class(x), "\n")
    ntab <- length(x$blo)
    cat("\ntab number:  ", ntab, "\n")
    sumry <- array("", c(ntab, 3), list(1:ntab, c("data.frame", 
        "nrow", "ncol")))
    for (i in 1:ntab) {
        sumry[i, ] <- c(names(x)[i], nrow(x[[i]]), ncol(x[[i]]))
    }
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(4, 4), list((ntab + 1):(ntab + 4), c("vector", 
        "length", "mode", "content")))
    sumry[1, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
    sumry[2, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
    sumry[3, ] <- c("$blo", length(x$blo), mode(x$blo), "column numbers")
    sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "array weights")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(3, 4), list((ntab + 5):(ntab + 7), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "Factors Table number Line number")
    sumry[2, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "Factors Table number Col number")
    sumry[3, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "Factors Table number 1234")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    cat((ntab + 8), "$call: ")
    print(x$call)
    cat("\n")
    cat("names :\n")
    for (i in 1:ntab) {
        cat(names(x)[i], ":", names(x[[i]]), "\n")
    }
    cat("\n")
    indica <- as.factor(rep(1:ntab, x$blo))
    w <- split(x$cw, indica)
    cat("Col weigths :\n")
    for (i in 1:ntab) {
        cat(names(x)[i], ":", w[[i]], "\n")
    }
    cat("\n")
    cat("Row weigths :\n")
    cat(x$lw)
    cat("\n")
}
########### c.ktab" ########### 
"c.ktab" <- function (...) {
    x <- list(...)
    n <- length(x)
    if (any(lapply(x, class) != "ktab")) 
        stop("arguments imply object without 'ktab' class")
    nr <- unlist(lapply(x, function(x) nrow(x[[1]])))
    if (length(unique(nr)) != 1) 
        stop("arguments imply object with non constant row numbers")
    lw <- x[[1]]$lw
    nr <- length(lw)
    noms <- row.names(x[[1]][[1]])
    res <- NULL
    cw <- NULL
    blocks <- NULL
    for (i in 1:n) {
        if (any(x[[i]]$lw != lw)) 
            stop("arguments imply object with non constant row weights")
        if (any(row.names(x[[i]][[1]]) != noms)) 
            stop("arguments imply object with non constant row.names")
        blo.i <- x[[i]]$blo
        nblo.i <- length(blo.i)
        res <- c(res, unclass(x[[i]])[1:nblo.i])
        cw <- c(cw, x[[i]]$cw)
        blocks <- c(blocks, blo.i)
    }
    names(res) <- make.names(names(res), TRUE)
    res$lw <- lw
    res$cw <- cw
    res$blo <- blocks
    nblo <- length(blocks)
    ktab.util.addfactor(res) <- list(blocks, length(lw))
    res$call <- match.call()
    class(res) <- "ktab"
    return(res)
}

########### t.ktab" ########### 
"t.ktab" <- function (x) {
    if (!inherits(x, "ktab")) 
        stop("object 'ktab' expected")
    blocks <- x$blo
    nblo <- length(blocks)
    res <- x
    r.n <- row.names(x[[1]])
    for (i in 1:nblo) {
        r.new <- row.names(x[[i]])
        if (any(r.new != r.n)) 
            stop("non equal row.names among array")
    }
    if (length(unique(blocks)) != 1) 
        stop("non equal col numbers among array")
    c.n <- names(x[[1]])
    for (i in 1:nblo) {
        c.new <- names(x[[i]])
        if (any(c.new != c.n)) 
            stop("non equal col.names among array")
    }
    nr <- blocks[1]
    new.row.names <- names(x[[1]])
    indica <- as.factor(rep(1:nblo, blocks))
    w <- split(x$cw, indica)
    col.w <- w[[1]]
    for (i in 1:nblo) {
        col.w.new <- w[[i]]
        if (any(col.w != col.w.new)) 
            stop("non equal column weights among array")
    }
    for (j in 1:nblo) {
        w <- x[[j]]
        w <- data.frame(t(w))
        row.names(w) <- new.row.names
        res[[j]] <- w
        blocks[j] <- ncol(w)
    }
    res$lw <- col.w
    res$cw <- rep(x$lw, nblo)
    res$blo <- blocks
    ktab.util.addfactor(res) <- list(blocks, length(res$lw))
    res$call <- match.call()
    class(res) <- "ktab"
    return(res)
}

########### row.names.ktab ########### 
"row.names.ktab" <- function (x) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    cha <- attr(x[[1]], "row.names")
    for (i in 1:ntab) {
        if (any(attr(x[[i]], "row.names") != cha)) 
            warnings(paste("array", i, "and array 1 have different row.names"))
    }
    return(cha)
}
########### row.names<-.ktab ########### 
"row.names<-.ktab" <- function (x, value) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    old <- attr(x[[1]], "row.names")
    if (!is.null(old) && length(value) != length(old)) 
        stop("invalid row.names length")
    value <- as.character(value)
    if (any(duplicated(value))) 
        stop("duplicate row.names are not allowed")
    for (i in 1:ntab) {
        attr(x[[i]], "row.names") <- value
    }
    x
}
########### col.names ########### 
"col.names" <- function (x) UseMethod("col.names")

########### col.names<- ########### 
"col.names<-" <- function (x, value) UseMethod("col.names<-")

########### col.names.ktab ########### 
"col.names.ktab" <- function (x) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    cha <- unlist(lapply(1:ntab, function(y) attr(x[[y]], "names")))
    return(cha)
}
########### col.names<-.ktab ########### 
"col.names<-.ktab" <- function (x, value) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    old <- unlist(lapply(1:ntab, function(y) attr(x[[y]], "names")))
    if (!is.null(old) && length(value) != length(old)) 
        stop("invalid col.names length")
    value <- as.character(value)
    indica <- as.factor(rep(1:ntab, x$blo))
    for (i in 1:ntab) {
        if (any(duplicated(value[indica == i]))) 
            stop("duplicate col.names are not allowed in the same array")
        attr(x[[i]], "names") <- value[indica == i]
    }
    x
}


########### tab.names ########### 
# fonction gnrique
"tab.names" <- function (x) UseMethod("tab.names")
########### tab.names.ktab ########### 
# mthode pour ktab
"tab.names.ktab" <- function (x) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    cha <- names(x)[1:ntab]
    return(cha)
}
########### tab.names<- ########### 
# fonction gnrique
"tab.names<-" <- function (x, value) UseMethod("tab.names<-")
########### tab.names<-.ktab ########### 
# mthode pour ktab
# les tab.names d'un ktab est le vecteur des noms des k premires composantes
# ce nombre de tableaux est la longueur de la composante blo
"tab.names<-.ktab" <- function (x, value) {
    if (!inherits(x, "ktab")) 
        stop("to be used with 'ktab' object")
    ntab <- length(x$blo)
    old <- tab.names(x)[1:ntab]
    if (!is.null(old) && length(value) != length(old)) 
        stop("invalid tab.names length")
    value <- as.character(value)
    if (any(duplicated(value))) 
        stop("duplicate tab.names are not allowed")
    names(x)[1:ntab] <- value
    x
}
########### ktab.util.names ###########
# utilitaire qui rcupre dans un ktab
# une liste de 3 lments
# les noms des lignes "." les noms des tableaux
# les noms des colonnes sans duplicats
# les noms des tableaux "." 1234
# pour donner des tiquettes aux TL, TC et T4 dans les graphiques
"ktab.util.names" <- function (x) {
    w <- row.names(x)
    w1 <- paste(w, as.character(x$TL[, 1]), sep = ".")
    w <- col.names(x)
    if (any(dups <- duplicated(w))) 
        w <- paste(w, as.character(x$TC[, 1]), sep = ".")
    w2 <- w
    w <- tab.names(x)
    l0 <- length(w)
    w3 <- paste(rep(w, rep(4, l0)), as.character(1:4), sep = ".")
    return(list(row = w1, col = w2, tab = w3))
}

########### ktab.util.addfactor<- ########### 
# utilitaire utilis dans les ktab
# ajoute les composantes TL TC et T4
# x est un ktab presque achev
# value est une liste contenant le vecteur des blocs de colonnes
# et le nombre de lignes
# on rcupre avec le nombre de tableaux, le nombre de variables par tableaux
# et le nombre de lignes en commun
"ktab.util.addfactor<-" <- function (x, value) {
    blocks <- value[[1]]
    nlig <- value[[2]]
    nblo <- length(blocks)
    w <- cbind.data.frame(gl(nblo, nlig), factor(rep(1:nlig, 
        nblo)))
    names(w) <- c("T", "L")
    x$TL <- w
    w <- NULL
    for (i in 1:nblo) w <- c(w, 1:blocks[i])
    w <- cbind.data.frame(factor(rep(1:nblo, blocks)), factor(w))
    names(w) <- c("T", "C")
    x$TC <- w
    w <- cbind.data.frame(gl(nblo, 4), factor(rep(1:4, nblo)))
    names(w) <- c("T", "4")
    x$T4 <- w
    x
}
"ktab.data.frame" <- function (df, blocks, rownames = NULL, colnames = NULL, tabnames = NULL,
    w.row = rep(1, nrow(df))/nrow(df), w.col = rep(1, ncol(df))) 
{
    if (!inherits(df, "data.frame")) 
        stop("object 'data.frame' expected")
    nblo <- length(blocks)
    if (sum(blocks) != ncol(df)) 
        stop("Non convenient 'blocks' parameter")
    if (is.null(rownames)) 
        rownames <- row.names(df)
    else if (length(rownames) != length(row.names(df))) 
        stop("Non convenient rownames length")
    if (is.null(colnames)) 
        colnames <- names(df)
    else if (length(colnames) != length(names(df))) 
        stop("Non convenient colnames length")
    if (is.null(names(blocks))) 
        tn <- paste("Ana", 1:nblo, sep = "")
    else tn <- names(blocks)
    if (is.null(tabnames)) 
        tabnames <- tn
    else if (length(tabnames) != length(tn)) 
        stop("Non convenient tabnames length")
    for (x in c("lw", "cw", "blo", "TL", "TC", "T4")) tabnames[tabnames == 
        x] <- paste(x, "*", sep = "")
    indica <- as.factor(rep(1:nblo, blocks))
    res <- list()
    for (i in 1:nblo) {
        res[[i]] <- df[, indica == i]
    }
    names(blocks) <- tabnames
    res$lw <- w.row
    res$cw <- w.col
    res$blo <- blocks
    ktab.util.addfactor(res) <- list(blocks, length(res$lw))
    res$call <- match.call()
    class(res) <- "ktab"
    row.names(res) <- rownames
    col.names(res) <- colnames
    tab.names(res) <- tabnames
    return(res)
}
"ktab.list.df" <- function (obj, rownames = NULL, colnames = NULL, tabnames = NULL,
    w.row = rep(1, nrow(obj[[1]])), w.col = lapply(obj, function(x) rep(1/ncol(x), 
        ncol(x)))) 
{
    obj <- as.list(obj)
    if (any(unlist(lapply(obj, function(x) !inherits(x, "data.frame"))))) 
        stop("list of 'data.frame' object expected")
    nblo <- length(obj)
    res <- list()
    nlig <- nrow(obj[[1]])
    blocks <- unlist(lapply(obj, function(x) ncol(x)))
    cn <- unlist(lapply(obj, names))
    if (is.null(rownames)) 
        rownames <- row.names(obj[[1]])
    else if (length(rownames) != length(row.names(obj[[1]]))) 
        stop("Non convenient rownames length")
    if (is.null(colnames)) 
        colnames <- cn
    else if (length(colnames) != length(cn)) 
        stop("Non convenient colnames length")
    if (is.null(names(obj))) 
        tn <- paste("Ana", 1:nblo, sep = "")
    else tn <- names(obj)
    if (is.null(tabnames)) 
        tabnames <- tn
    else if (length(tabnames) != length(tn)) 
        stop("Non convenient tabnames length")
    if (nlig != length(w.row)) 
        stop("Non convenient length for w.row")
    n1 <- unlist(lapply(w.col, length))
    n2 <- unlist(lapply(obj, ncol))
    if (any(n1 != n2)) 
        stop("Non convenient length in  w.col")
    for (i in 1:nblo) {
        res[[i]] <- obj[[i]]
    }
    lw <- w.row
    cw <- unlist(w.col)
    names(cw) <- NULL
    names(blocks) <- tabnames
    res$blo <- blocks
    res$lw <- lw
    res$cw <- cw
    ktab.util.addfactor(res) <- list(blocks, length(lw))
    res$call <- match.call()
    class(res) <- "ktab"
    row.names(res) <- rownames
    col.names(res) <- colnames
    tab.names(res) <- tabnames
    return(res)
}
"ktab.list.dudi" <- function (obj, rownames = NULL, colnames = NULL, tabnames = NULL) {
    obj <- as.list(obj)
    if (any(unlist(lapply(obj, function(x) !inherits(x, "dudi"))))) 
        stop("list of object 'dudi' expected")
    nblo <- length(obj)
    res <- list()
    lw <- obj[[1]]$lw
    cw <- NULL
    nlig <- nrow(obj[[1]]$tab)
    blocks <- unlist(lapply(obj, function(x) ncol(x$tab)))
    for (i in 1:nblo) {
        if (any(obj[[i]]$lw != lw)) 
            stop("Non equal row weights among arrays")
        res[[i]] <- obj[[i]]$tab
        cw <- c(cw, obj[[i]]$cw)
    }
    cn <- unlist(lapply(obj, function(x) names(x$tab)))
    if (is.null(rownames)) 
        rownames <- row.names(obj[[1]]$tab)
    else if (length(rownames) != length(row.names(obj[[1]]$tab))) 
        stop("Non convenient rownames length")
    if (is.null(colnames)) 
        colnames <- cn
    else if (length(colnames) != length(cn)) 
        stop("Non convenient colnames length")
    if (is.null(names(obj))) 
        tn <- paste("Ana", 1:nblo, sep = "")
    else tn <- names(obj)
    if (is.null(tabnames)) 
        tabnames <- tn
    else if (length(tabnames) != length(tn)) 
        stop("Non convenient tabnames length")
    names(blocks) <- tabnames
    res$blo <- blocks
    res$lw <- lw
    res$cw <- cw
    ktab.util.addfactor(res) <- list(blocks, length(lw))
    res$call <- match.call()
    class(res) <- "ktab"
    row.names(res) <- rownames
    col.names(res) <- colnames
    tab.names(res) <- tabnames
    return(res)
}
"ktab.match2ktabs" <- function (KTX, KTY) {
    if (!inherits(KTX, "ktab")) stop("The first argument must be a 'ktab'")
    if (!inherits(KTY, "ktab")) stop("The second argument must be a 'ktab'")
#### crossed ktab
    res <- list()
#### Parameters of first ktab
    lwX <- KTX$lw
    nligX <- length(lwX)
    cwX <- KTX$cw
    ncolX <- length(cwX)
    bloX <- KTX$blo
    ntabX <- length(KTX$blo)
#### Parameters of second ktab
    lwY <- KTY$lw
    nligY <- length(lwY)
    cwY <- KTY$cw
    ncolY <- length(cwY)
    bloY <- KTY$blo
    ntabY <- length(KTY$blo)
#### Tests of coherence of the two ktabs
    if (ncolX != ncolY) stop("The two ktabs must have the same column numbers")
    if (any(cwX != cwY)) stop("The two ktabs must have the same column weights")
    if (ntabX != ntabY) stop("The two ktabs must have the same number of tables")
    if (!all(bloX == bloY)) stop("The two tables of one pair must have the same number of columns")
#### Compute crossed ktab
    ntab <- ntabX
    for (i in 1:ntab) {
	tx <- as.matrix(KTX[[i]])
	ty <- as.matrix(KTY[[i]])
	res[[i]] <- as.data.frame(tx %*% t(ty) * cwX)
    }
#### Complete crossed ktab structure
    res$lw <- rep(1, nligX)/nligX
    res$cw <- rep(rep(1, nligY)/nligY,ntab)
    blo <- rep(nligY,ntab)
    res$blo <- blo
    ktab.util.addfactor(res) <- list(blo, length(res$lw))
    res$call <- match.call()
    class(res) <- c("ktab", "kcoinertia")
    col.names(res) <- rep(row.names(KTY),ntab)
    row.names(res) <- row.names(KTX)
    tab.names(res) <- tab.names(KTX)
    return(res)
}
"ktab.within" <- function (dudiwit, rownames = NULL, colnames = NULL, tabnames = NULL) {
    if (!inherits(dudiwit, "within")) 
        stop("Result from within expected for dudiwit")
    fac <- dudiwit$fac
    res <- list()
    nblo <- nlevels(fac)
    res <- list()
    blocks <- rep(0, nblo)
    if (is.null(rownames)) 
        rownames <- names(dudiwit$tab)
    else if (length(rownames) != length(names(dudiwit$tab))) 
        stop("Non convenient rownames length")
    if (is.null(colnames)) 
        colnames <- row.names(dudiwit$tab)
    else if (length(colnames) != length(row.names(dudiwit$tab))) 
        stop("Non convenient colnames length")
    if (is.null(tabnames)) 
        tabnames <- as.character(unique(fac))
    else if (length(tabnames) != length(as.character(unique(fac)))) 
        stop("Non convenient tabnames length")
    nlig <- ncol(dudiwit$tab)
    cw <- NULL
    for (i in 1:nblo) {
        k <- unique(fac)[i]
        w1 <- dudiwit$lw[fac == k]
        w1 <- w1/sum(w1)
        cw <- c(cw, w1)
        res[[i]] <- data.frame(t(dudiwit$tab[fac == k, ]))
        blocks[i] <- ncol(res[[i]])
    }
    names(blocks) <- tabnames
    res$lw <- dudiwit$cw
    res$cw <- cw
    res$blo <- blocks
    ktab.util.addfactor(res) <- list(blocks, length(res$lw))
    res$call <- match.call()
    res$tabw <- dudiwit$tabw
    class(res) <- "ktab"
    row.names(res) <- rownames
    col.names(res) <- colnames
    tab.names(res) <- tabnames
    return(res)
}
"lingoes" <- function (distmat, print = FALSE) {
    if (is.euclid(distmat)) {
        warning("Euclidean distance found : no correction need")
        return(distmat)
    }
    distmat <- dist2mat(distmat)
    n <- ncol(distmat)
    delta <- -0.5 * bicenter.wt(distmat * distmat)
    lambda <- eigen(delta, sym = TRUE)$values
    lder <- lambda[ncol(distmat)]
    distmat <- sqrt(distmat * distmat + 2 * abs(lder))
    if (print) 
        cat("Lingoes constant =", round(abs(lder), dig = 6), 
            "\n")
    distmat <- mat2dist(distmat)
    attr(distmat, "call") <- match.call()
    attr(distmat, "method") <- "Lingoes"
    return(distmat)
}
"mantel.randtest" <- function(m1, m2, nrepet=999) {
    nrepet <- nrepet +1
    if (!inherits(m1, "dist")) 
        stop("Object of class 'dist' expected")
    if (!inherits(m2, "dist")) 
        stop("Object of class 'dist' expected")
    n <- attr(m1, "Size")
    if (n != attr(m2, "Size")) 
        stop("Non convenient dimension")
    m1 <- dist2mat(m1)
    m2 <- dist2mat(m2)
    col <- ncol(m1)
    isim<-testmantel(nrepet, col, as.matrix(m1), as.matrix(m2))
    obs<-isim[1]
    return(as.randtest(isim[-1],obs,call=match.call()))
}
"mantel.rtest" <- function (m1, m2, nrepet = 99) {
    if (!inherits(m1, "dist")) 
        stop("Object of class 'dist' expected")
    if (!inherits(m2, "dist")) 
        stop("Object of class 'dist' expected")
    n <- attr(m1, "Size")
    if (n != attr(m2, "Size")) 
        stop("Non convenient dimension")
    permutedist <- function(m) {
        permutevec <- function(v, perm) return(v[perm])
        m <- dist2mat(m)
        n <- ncol(m)
        w0 <- sample(n)
        mperm <- apply(m, 1, permutevec, perm = w0)
        mperm <- t(mperm)
        mperm <- apply(mperm, 2, permutevec, perm = w0)
        return(mat2dist(t(mperm)))
    }
    mantelnoneuclid <- function(m1, m2, nrepet) {
        obs <- cor(unclass(m1), unclass(m2))
        if (nrepet == 0) 
            return(obs)
        perm <- matrix(0, nrow = nrepet, ncol = 1)
        perm <- apply(perm, 1, function(x) cor(unclass(m1), unclass(permutedist(m2))))
        w <- as.rtest(obs = obs, sim = perm, , call = match.call())
        return(w)
    }
    if (is.euclid(m1) & is.euclid(m2)) {
        tab1 <- pcoscaled(m1)
        obs <- cor(dist.quant(tab1, 1), m2)
        if (nrepet == 0) 
            return(obs)
        perm <- rep(0, nrepet)
        perm <- unlist(lapply(perm, function(x) cor(dist(tab1[sample(n), 
            ]), m2)))
        w <- as.rtest(obs = obs, sim = perm, call = match.call())
        return(w)
    }
    w <- mantelnoneuclid(m1, m2, nrepet = nrepet)
    return(w)
}
"mcoa" <- function (X, option = c("inertia", "lambda1", "uniform", "internal"),
    scannf = TRUE, nf = 3, tol = 1e-07) 
{
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    option <- option[1]
    if (option == "internal") {
        if (is.null(X$tabw)) {
            warning("Internal weights not found: uniform weigths are used")
            option <- "uniform"
        }
    }
    lw <- X$lw
    nlig <- length(lw)
    cw <- X$cw
    ncol <- length(cw)
    blo <- X$blo
    nbloc <- length(X$blo)
    indicablo <- X$TC[, 1]
    Xsepan <- sepan(X, nf = 4)
    rank.fac <- factor(rep(1:nbloc, Xsepan$rank))
    tabw <- NULL
    auxinames <- ktab.util.names(X)
    if (option == "lambda1") {
        for (i in 1:nbloc) tabw <- c(tabw, 1/Xsepan$Eig[rank.fac == 
            i][1])
    }
    else if (option == "inertia") {
        for (i in 1:nbloc) tabw <- c(tabw, 1/sum(Xsepan$Eig[rank.fac == 
            i]))
    }
    else if (option == "uniform") {
        tabw <- rep(1, nbloc)
    }
    else if (option == "internal") 
        tabw <- X$tabw
    else stop("Unknown option")
    for (i in 1:nbloc) X[[i]] <- X[[i]] * sqrt(tabw[i])
    Xsepan <- sepan(X, nf = 4)
    normaliserparbloc <- function(scorcol) {
        for (i in 1:nbloc) {
            w1 <- scorcol[indicablo == i]
            w2 <- sqrt(sum(w1 * w1))
            if (w2 > tol) 
                w1 <- w1/w2
            scorcol[indicablo == i] <- w1
        }
        return(scorcol)
    }
    recalculer <- function(tab, scorcol) {
        for (k in 1:nbloc) {
            soustabk <- tab[, indicablo == k]
            uk <- scorcol[indicablo == k]
            wk <- cw[indicablo == k]
            soustabk.hat <- t(apply(soustabk, 1, function(x) sum(x * 
                uk) * uk))
            soustabk <- soustabk - soustabk.hat
            tab[, indicablo == k] <- soustabk
        }
        return(tab)
    }
    tab <- as.matrix(X[[1]])
    for (i in 2:nbloc) {
        tab <- cbind(tab, X[[i]])
    }
    names(tab) <- auxinames$col
    tab <- tab * sqrt(lw)
    tab <- t(t(tab) * sqrt(cw))
    compogene <- list()
    uknorme <- list()
    valsing <- NULL
    nfprovi <- min(c(20, nlig, ncol))
    for (i in 1:nfprovi) {
        af <- svd(tab)
        w <- af$u[, 1]
        w <- w/sqrt(lw)
        compogene[[i]] <- w
        w <- af$v[, 1]
        w <- normaliserparbloc(w)
        tab <- recalculer(tab, w)
        w <- w/sqrt(cw)
        uknorme[[i]] <- w
        w <- af$d[1]
        valsing <- c(valsing, w)
    }
    pseudoeig <- valsing^2
    if (scannf) {
        barplot(pseudoeig)
        cat("Select the number of axes: ")
        nf <- as.integer(readLines(n = 1))
    }
    if (nf <= 0) 
        nf <- 2
    acom <- list()
    acom$pseudoeig <- pseudoeig
    w <- matrix(0, nbloc, nf)
    for (i in 1:nbloc) {
        w1 <- Xsepan$Eig[rank.fac == i]
        r0 <- Xsepan$rank[i]
        if (r0 > nf) 
            r0 <- nf
        w[i, 1:r0] <- w1[1:r0]
    }
    w <- data.frame(w)
    row.names(w) <- Xsepan$tab.names
    names(w) <- paste("lam", 1:nf, sep = "")
    acom$lambda <- w
    w <- matrix(0, nlig, nf)
    for (j in 1:nf) w[, j] <- compogene[[j]]
    w <- data.frame(w)
    names(w) <- paste("SynVar", 1:nf, sep = "")
    row.names(w) <- row.names(X)
    acom$SynVar <- w
    w <- matrix(0, ncol, nf)
    for (j in 1:nf) w[, j] <- uknorme[[j]]
    w <- data.frame(w)
    names(w) <- paste("Axis", 1:nf, sep = "")
    row.names(w) <- auxinames$col
    acom$axis <- w
    w <- matrix(0, nlig * nbloc, nf)
    covar <- matrix(0, nbloc, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + nlig
        urk <- as.matrix(acom$axis[indicablo == k, ])
        tab <- as.matrix(X[[k]])
        urk <- urk * cw[indicablo == k]
        urk <- tab %*% urk
        w[i1:i2, ] <- urk
        urk <- urk * acom$SynVar * lw
        covar[k, ] <- apply(urk, 2, sum)
    }
    w <- data.frame(w, row.names = auxinames$row)
    names(w) <- paste("Axis", 1:nf, sep = "")
    acom$Tli <- w
    covar <- data.frame(covar)
    row.names(covar) <- tab.names(X)
    names(covar) <- paste("cov2", 1:nf, sep = "")
    acom$cov2 <- covar^2
    w <- matrix(0, nlig * nbloc, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + nlig
        tab <- acom$Tli[i1:i2, ]
        tab <- scalewt(tab, wt = lw, center = FALSE, scale = TRUE)
        w[i1:i2, ] <- tab
    }
    w <- data.frame(w, row.names = auxinames$row)
    names(w) <- paste("Axis", 1:nf, sep = "")
    acom$Tl1 <- w
    w <- matrix(0, ncol, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + ncol(X[[k]])
        urk <- as.matrix(acom$SynVar)
        tab <- as.matrix(X[[k]])
        urk <- urk * lw
        w[i1:i2, ] <- t(tab) %*% urk
    }
    w <- data.frame(w, row.names = auxinames$col)
    names(w) <- paste("SV", 1:nf, sep = "")
    acom$Tco <- w
    var.names <- NULL
    w <- matrix(0, nbloc * 4, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + 4
        urk <- as.matrix(acom$axis[indicablo == k, ])
        tab <- as.matrix(Xsepan$C1[indicablo == k, ])
        urk <- urk * cw[indicablo == k]
        tab <- t(tab) %*% urk
        for (i in 1:min(nf, 4)) {
            if (tab[i, i] < 0) {
                for (j in 1:nf) tab[i, j] <- -tab[i, j]
            }
        }
        w[i1:i2, ] <- tab
        var.names <- c(var.names, paste(Xsepan$tab.names[k], 
            ".a", 1:4, sep = ""))
    }
    w <- data.frame(w, row.names = auxinames$tab)
    names(w) <- paste("Axis", 1:nf, sep = "")
    acom$Tax <- w
    acom$nf <- nf
    acom$TL <- X$TL
    acom$TC <- X$TC
    acom$T4 <- X$T4
    class(acom) <- "mcoa"
    acom$call <- match.call()
    return(acom)
}

"plot.mcoa" <- function (x, xax = 1, yax = 2, eig.bottom = TRUE, ...) {
    if (!inherits(x, "mcoa")) 
        stop("Object of type 'mcoa' expected")
    nf <- x$nf
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
    opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
    on.exit(par(opar))
    par(mfrow = c(2, 2))
    coolig <- x$SynVar[, c(xax, yax)]
    for (k in 2:nrow(x$cov2)) {
        coolig <- rbind.data.frame(coolig, x$SynVar[, c(xax, 
            yax)])
    }
    names(coolig) <- names(x$Tl1)[c(xax, yax)]
    row.names(coolig) <- row.names(x$Tl1)
    s.match(x$Tl1[, c(xax, yax)], coolig, clab = 0, 
        sub = "Row projection", csub = 1.5, edge = FALSE)
    s.label(x$SynVar[, c(xax, yax)], add.plot = TRUE)
    coocol <- x$Tco[, c(xax, yax)]
    s.arrow(coocol, sub = "Col projection", csub = 1.5)
    valpr <- function(x) {
        opar <- par(mar = par("mar"))
        on.exit(par(opar))
        born <- par("usr")
        w <- x$pseudoeig
        col <- rep(grey(1), length(w))
        col[1:nf] <- grey(0.8)
        col[c(xax, yax)] <- grey(0)
        l0 <- length(w)
        xx <- seq(born[1], born[1] + (born[2] - born[1]) * l0/60, 
            le = l0 + 1)
        w <- w/max(w)
        w <- w * (born[4] - born[3])/4
        par(mar = c(0.1, 0.1, 0.1, 0.1))
        if (eig.bottom) 
            m3 <- born[3]
        else m3 <- born[4] - w[1]
        w <- m3 + w
        rect(xx[1], m3, xx[l0 + 1], w[1], col = grey(1))
        for (i in 1:l0) rect(xx[i], m3, xx[i + 1], w[i], col = col[i])
    }
    s.corcircle(x$Tax[x$T4[, 2] == 1, ], full = FALSE, 
        sub = "First axis projection", possub = "topright", csub = 1.5)
    valpr(x)
    plot(x$cov2[, c(xax, yax)])
    scatterutil.grid(0)
    title(main = "Pseudo-eigen values")
    par(xpd = TRUE)
    scatterutil.eti(x$cov2[, xax], x$cov2[, yax], label = row.names(x$cov2), 
        clabel = 1)
}

"print.mcoa" <- function (x, ...) {
    if (!inherits(x, "mcoa")) 
        stop("non convenient data")
    cat("Multiple Co-inertia Analysis\n")
    cat(paste("list of class", class(x)))
    l0 <- length(x$pseudoeig)
    cat("\n\n$pseudoeig:", l0, "pseudo eigen values\n")
    cat(signif(x$pseudoeig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("\n$call: ")
    print(x$call)
    cat("\n$nf:", x$nf, "axis saved\n\n")
    sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$SynVar", nrow(x$SynVar), ncol(x$SynVar), 
        "synthetic scores")
    sumry[2, ] <- c("$axis", nrow(x$axis), ncol(x$axis), 
        "co-inertia axis")
    sumry[3, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "co-inertia coordinates")
    sumry[4, ] <- c("$Tl1", nrow(x$Tl1), ncol(x$Tl1), "co-inertia normed scores")
    sumry[5, ] <- c("$Tax", nrow(x$Tax), ncol(x$Tax), "inertia axes onto co-inertia axis")
    sumry[6, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "columns onto synthetic scores")
    sumry[7, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli Tl1")
    sumry[8, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
    sumry[9, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for Tax")
    sumry[10, ] <- c("$lambda", nrow(x$lambda), ncol(x$lambda), 
        "eigen values (separate analysis)")
    sumry[11, ] <- c("$cov2", nrow(x$cov2), ncol(x$cov2), 
        "pseudo eigen values (synthetic analysis)")
    class(sumry) <- "table"
    print(sumry)
    cat("other elements: ")
    if (length(names(x)) > 14) 
        cat(names(x)[15:(length(x))], "\n")
    else cat("NULL\n")
}

"summary.mcoa" <- function (object, ...) {
    if (!inherits(object, "mcoa")) 
        stop("non convenient data")
    cat("Multiple Co-inertia Analysis\n")
    appel <- as.list(object$call)
    X <- eval(appel$X, sys.frame(0))
    lw <- sqrt(X$lw)
    nlig <- length(lw)
    cw <- X$cw
    ncol <- length(cw)
    blo <- X$blo
    nbloc <- length(X$blo)
    indicablo <- X$TC[, 1]
    nf <- object$nf
    Xsepan <- sepan(X, nf)
    rank.fac <- factor(rep(1:nbloc, Xsepan$rank))
    for (i in 1:nbloc) {
        cat("Array n", i, names(X)[[i]], "Rows", nrow(X[[i]]), 
            "Cols", ncol(X[[i]]), "\n")
        eigval <- unlist(object$lambda[i, ])
        eigval <- zapsmall(eigval)
        eigvalplus <- zapsmall(cumsum(eigval))
        w <- object$Tli[object$TL[, 1] == i, ]
        w <- w * lw
        varproj <- zapsmall(apply(w * w, 2, sum))
        varprojplus <- zapsmall(cumsum(varproj))
        w1 <- object$SynVar
        w1 <- w1 * lw
        cos2 <- apply(w * w1, 2, sum)
        cos2 <- cos2^2/varproj
        cos2[is.infinite(cos2)] <- NA
        cos2 <- zapsmall(cos2)
        sumry <- array("", c(nf, 6), list(1:nf, c("Iner", "Iner+", 
            "Var", "Var+", "cos2", "cov2")))
        sumry[, 1] <- round(eigval, dig = 3)
        sumry[, 2] <- round(eigvalplus, dig = 3)
        sumry[, 3] <- round(varproj, dig = 3)
        sumry[, 4] <- round(varprojplus, dig = 3)
        sumry[, 5] <- round(cos2, dig = 3)
        sumry[, 6] <- round(object$cov2[i, ], dig = 3)
        class(sumry) <- "table"
        print(sumry)
        cat("\n")
    }
}
"mfa" <- function (X, option = c("lambda1", "inertia", "uniform", "internal"),
    scannf = TRUE, nf = 3) 
{
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    if (option[1] == "internal") {
        if (is.null(X$tabw)) {
            warning("Internal weights not found: uniform weigths are used")
            option <- "uniform"
        }
    }
    lw <- X$lw
    cw <- X$cw
    sepan <- sepan(X, nf = 4)
    nbloc <- length(sepan$blo)
    indicablo <- factor(rep(1:nbloc, sepan$blo))
    rank.fac <- factor(rep(1:nbloc, sepan$rank))
    ncw <- NULL
    tab.names <- names(X)[1:nbloc]
    auxinames <- ktab.util.names(X)
    if (option[1] == "lambda1") {
        for (i in 1:nbloc) {
            ncw <- c(ncw, rep(1/sepan$Eig[rank.fac == i][1], 
                sepan$blo[i]))
        }
    }
    else if (option[1] == "inertia") {
        for (i in 1:nbloc) {
            ncw <- c(ncw, rep(1/sum(sepan$Eig[rank.fac == i]), 
                sepan$blo[i]))
        }
    }
    else if (option[1] == "uniform") 
        ncw <- rep(1, sum(sepan$blo))
    else if (option[1] == "internal") 
        ncw <- rep(X$tabw, sepan$blo)
    else stop("unknown option")
    ncw <- cw * ncw
    tab <- X[[1]]
    for (i in 2:nbloc) {
        tab <- cbind.data.frame(tab, X[[i]])
    }
    names(tab) <- auxinames$col
    anaco <- as.dudi(tab, col.w = ncw, row.w = lw, nf = nf, scannf = scannf, 
        call = match.call(), type = "mfa")
    nf <- anaco$nf
    afm <- list()
    afm$tab.names <- names(X)[1:nbloc]
    afm$blo <- X$blo
    afm$TL <- X$TL
    afm$TC <- X$TC
    afm$T4 <- X$T4
    afm$tab <- anaco$tab
    afm$eig <- anaco$eig
    afm$rank <- anaco$rank
    afm$li <- anaco$li
    afm$l1 <- anaco$l1
    afm$nf <- anaco$nf
    afm$lw <- anaco$lw
    afm$cw <- anaco$cw
    afm$co <- anaco$co
    afm$c1 <- anaco$c1
    projiner <- function(xk, qk, d, z) {
        w7 <- t(as.matrix(xk) * d) %*% as.matrix(z)
        iner <- apply(w7 * w7 * qk, 2, sum)
        return(iner)
    }
    link <- matrix(0, nbloc, nf)
    for (k in 1:nbloc) {
        xk <- X[[k]]
        q <- ncw[indicablo == k]
        link[k, ] <- projiner(xk, q, lw, anaco$l1)
    }
    link <- as.data.frame(link)
    names(link) <- paste("Comp", 1:nf, sep = "")
    row.names(link) <- tab.names
    afm$link <- link
    w <- matrix(0, nbloc * 4, nf)
    i1 <- 0
    i2 <- 0
    matl1 <- as.matrix(afm$l1)
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + 4
        tab <- as.matrix(sepan$L1[sepan$TL[, 1] == k, ])
        if (ncol(tab) > 4) 
            tab <- tab[, 1:4]
        if (ncol(tab) < 4) 
            tab <- cbind(tab, matrix(0, nrow(tab), 4 - ncol(tab)))
        tab <- t(tab * lw) %*% matl1
        for (i in 1:min(nf, 4)) {
            if (tab[i, i] < 0) {
                for (j in 1:nf) tab[i, j] <- -tab[i, j]
            }
        }
        w[i1:i2, ] <- tab
    }
    w <- data.frame(w)
    names(w) <- paste("Comp", 1:nf, sep = "")
    row.names(w) <- auxinames$tab
    afm$T4comp <- w
    w <- matrix(0, nrow(sepan$TL), ncol = nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nbloc) {
        i1 <- i2 + 1
        i2 <- i2 + length(lw)
        qk <- ncw[indicablo == k]
        xk <- as.matrix(X[[k]])
        w[i1:i2, ] <- (xk %*% (qk * t(xk))) %*% (matl1 * lw)
    }
    w <- data.frame(w)
    row.names(w) <- auxinames$row
    names(w) <- paste("Fac", 1:nf, sep = "")
    afm$lisup <- w
    afm$tabw <- X$tabw
    afm$call <- match.call()
    class(afm) <- c("mfa", "list")
    return(afm)
}


"plot.mfa" <- function (x, xax = 1, yax = 2, option.plot = 1:4, ...) {
    if (!inherits(x, "mfa")) 
        stop("Object of type 'mfa' expected")
    nf <- x$nf
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
    opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
    on.exit(par(opar))
    mfrow <- n2mfrow(length(option.plot))
    par(mfrow = mfrow)
    for (j in option.plot) {
        if (j == 1) {
            coolig <- x$lisup[, c(xax, yax)]
            s.class(coolig, fac = as.factor(x$TL[, 2]), 
                label = row.names(x$li), cell = 0, sub = "Row projection", 
                csub = 1.5)
            add.scatter.eig(x$eig, x$nf, xax, yax, posi = "top", 
                ratio = 1/5)
        }
        if (j == 2) {
            coocol <- x$co[, c(xax, yax)]
            s.arrow(coocol, sub = "Col projection", csub = 1.5)
            add.scatter.eig(x$eig, x$nf, xax, yax, posi = "top", 
                ratio = 1/5)
        }
        if (j == 3) {
            s.corcircle(x$T4comp[x$T4[, 2] == 1, ], 
                full = FALSE, sub = "Component projection", possub = "topright", 
                csub = 1.5)
            add.scatter.eig(x$eig, x$nf, xax, yax, posi = "bottom", 
                ratio = 1/5)
        }
        if (j == 4) {
            plot(x$link[, c(xax, yax)])
            scatterutil.grid(0)
            title(main = "Link")
            par(xpd = TRUE)
            scatterutil.eti(x$link[, xax], x$link[, yax], 
                label = row.names(x$link), clabel = 1)
        }
        if (j == 5) {
            scatterutil.eigen(x$eig, wsel = 1:x$nf, sub = "Eigen values", 
                csub = 2, possub = "topright")
        }
    }
}


"print.mfa" <- function (x, ...) {
    if (!inherits(x, "mfa")) 
        stop("non convenient data")
    cat("Multiple Factorial Analysis\n")
    cat(paste("list of class", class(mfa)))
    cat("\n$call: ")
    print(x$call)
    cat("$nf:", x$nf, "axis-components saved\n\n")
    sumry <- array("", c(6, 4), list(1:6, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$tab.names", length(x$tab.names), mode(x$tab.names), 
        "tab names")
    sumry[2, ] <- c("$blo", length(x$blo), mode(x$blo), "column number")
    sumry[3, ] <- c("$rank", length(x$rank), mode(x$rank), 
        "tab rank")
    sumry[4, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[5, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
    sumry[6, ] <- c("$tabw", length(x$tabw), mode(x$tabw), 
        "array weights")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    sumry[6, ] <- c("$lisup", nrow(x$lisup), ncol(x$lisup), 
        "row coordinates from each table")
    sumry[7, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for li l1")
    sumry[8, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for co c1")
    sumry[9, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for T4comp")
    sumry[10, ] <- c("$T4comp", nrow(x$T4comp), ncol(x$T4comp), 
        "component projection")
    sumry[11, ] <- c("$link", nrow(x$link), ncol(x$link), 
        "link array-total")
    class(sumry) <- "table"
    print(sumry)
    cat("other elements: ")
    if (length(names(x)) > 19) 
        cat(names(x)[20:(length(mfa))], "\n")
    else cat("NULL\n")
}

"summary.mfa" <- function (object, ...) {
    if (!inherits(object, "mfa")) 
        stop("non convenient data")
    cat("Multiple Factorial Analysis\n")
    cat("rows:", nrow(object$tab), "columns:", ncol(object$tab))
    l0 <- length(object$eig)
    cat("\n\n$eig:", l0, "eigen values\n")
    cat(signif(object$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
}
"mld"<- function (x, orthobas, level, na.action = c("fail", "mean"), plot=TRUE, dfxy = NULL, phylog = NULL,  ...) 
{

# on fait les vrifications sur x
if (!is.numeric(x)) 
        stop("x is not numeric")
nobs <- length(x)
if (any(is.na(x))) {
        if (na.action == "fail") 
            stop(" missing values in 'x'")
        else if (na.action == "mean") 
            x[is.na(x)] <- mean(na.omit(x))
        else stop("unknown method for 'na.action'")
    }

# on fait les vrifications sur orthobas (class, dimension, orthogonalit, orthonormalit)
if (!inherits(orthobas, "data.frame")) stop ("'orthobas' is not a data.frame")
    if (nrow(orthobas) != nobs) stop ("non convenient dimensions")
    if (ncol(orthobas) != (nobs-1)) stop (paste("'orthobas' has",ncol(orthobas),"columns, expected:",nobs-1))

vecpro <- as.matrix(orthobas)
npro <- ncol(vecpro)

w <- t(vecpro/nobs)%*%vecpro
    if (any(abs(diag(w)-1)>1e-07)) {
        stop("'orthobas' is not orthonormal for uniform weighting")
    }
    
diag(w) <- 0
    if ( any( abs(as.numeric(w))>1e-07) ) stop("'orthobas' is not orthogonal for uniform weighting")

# on calcule les diffrents vecteurs associs  la dcomposition orthonormale de la variable

    # si x n'est pas centre, on la centre pour la pondration uniforme
    if (mean(x)!=0)
            x <- x-mean(x)
    
    # on calcul les coefficients de corrlation entre la variable et les vecteurs de la base
    coeff <- t(vecpro/nobs)%*%as.matrix(x)
    
    # on calcul les vecteurs associs  la dcomposition et au facteur level
    if (!is.factor(level))
            stop("'level' is not a factor")
            if (length(level) != (nobs-1)) 
                    stop (paste("'level' has",length(level),"values, expected:",nobs-1))
    res <- matrix(0, nrow = nobs, ncol = nlevels(level))
    coeff <- split(coeff, level)
    vecpro <- as.data.frame(t(vecpro))
    vecpro <- split(vecpro, level)
    for (i in 1:nlevels(level)) 
        res[,i] <- t(vecpro[[i]])%*%as.matrix(coeff[[i]])
    res <- as.data.frame(res)
    names(res) <- paste("level", levels(level), sep=" ")

 
# on fait les sorties graphiques si elles sont demandes: c'est pas parfait mais c'est pour donner une ide
if (plot==TRUE){
    # rajouter les donnes circulaires
    if (is.ts(x)){
        # pour les sries temporelles
        u <- attributes(x)$tsp
        tab <- ts(res, start = u[1], end = u[2], frequency = u[3])
        tab <- ts.union(x, tab)
        u <- range(tab)
        opar <- par(mfrow = par("mfrow"), mar = par("mar"))
        on.exit(par(opar))
        mfrow <- n2mfrow(nlevels(level)+1)
        par(mfrow = mfrow)
        par(mar = c(2.5, 5, 1.5, 0.6))
        plot.ts(x, ylim = u, ylab = "x", main = "multi-levels decomposition")
        for (i in 1:nlevels(level))
                plot(tab[,i+1], ylim = u, ylab = names(res)[i], main = "")
        }
        
    if (is.vector(x)){
        if (!is.null(dfxy)){
            # pour les donnes 2 D
            opar <- par(mfrow = par("mfrow"), mar = par("mar"))
            on.exit(par(opar))
            mfrow <- n2mfrow(nlevels(level)+1)
            par(mfrow = mfrow)
            par(mar = c(0.6, 2.6, 0.6, 0.6))
            s.value(dfxy, x, sub = "x", ...)
            for (i in 1:nlevels(level))
                if (max((1:(nobs-1))[level == levels(level)[i]])<(nobs/2)){
                    s.image(dfxy, res[,i])
                    s.value(dfxy, res[,i], sub = names(res)[i], add.plot=TRUE, ...)
                    }
                else
                    s.value(dfxy, res[,i], sub = names(res)[i], ...)
            }
        else {
            if (!is.null(phylog)){
                # pour les donnes associes  une phylognie
                tab <- cbind.data.frame(x, res)
                row.names(tab) <- names(phylog$leaves)
                table.phylog(tab, phylog, ...)                
                }
            else {
                # pour les transects
                par(mfrow = c(nlevels(level)+1,1))
                par(mar = c(2, 5, 1.5, 0.6))
                u <- range(cbind(x, res))
                w <- trunc(u)
                w <- c(w[1],0,w[2])
                plot(x, type="h", ylim = u, axes = FALSE, ylab = "x", main = "multi-levels decomposition")
                axis(side = 2, at = w, labels = as.character(w))
                for (i in 1:nlevels(level)){
                    plot(res[,i], type="h", ylim = u, axes = FALSE, ylab = names(res)[i], main = "")
                    axis(side = 2, at = w, labels = as.character(w))
                    }
                v <- seq(0, nobs, by = (nobs/10))
                axis(side=1, at = v, labels = as.character(v))
                }        
            }        
        }
    }
return(res)  
}

#############################################################################
haar2level <- function(x){
# cette fonction calcul le facteur level pour lequel l'analyse mld correspond
#  l'analyse mra de la library(waveslim)

# on vrifie que x=2**a
a <- log(length(x))/log(2)
b <- floor(a)
if ((a-b)^2>1e-10) stop ("Haar is not a power of 2")

#on construit les J niveaux de dcomposition
u <- LETTERS[1:a]
v <- rep(2,a)**(0:(a-1))
level <- rep(u, v)
level <- as.factor(level)
return(level)
}
mstree <- function(xdist, ngmax=1) { 
    if(!inherits (xdist,"dist")) stop ("Object of class 'dist' expected")
    xdist <- dist2mat(xdist)
    nlig=nrow(xdist)
    xdist <- as.double(xdist)
    if (ngmax<=1) ngmax=1
    if (ngmax>=nlig) ngmax=1
    ngmax=as.integer(ngmax)
    voisi=as.double(matrix(0,nlig,nlig))
    #MSTgraph (double *distances, int *nlig, int *ngmax, double *voisi)
    mst = .C("MSTgraph", distances = xdist, nlig = nlig, ngmax = ngmax, voisi = voisi,PACKAGE="ade4")$voisi
    mst = matrix(mst, nlig, nlig)
    mst = neig (mat01=mst)
    return(mst)
}


"multispati" <- function(dudi, listw, scannf=TRUE, nfposi=2, nfnega=0) {
    if(!inherits(dudi,"dudi")) stop ("object of class 'dudi' expected")
    if(!inherits(listw,"listw")) stop ("object of class 'listw' expected") 
    if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected") 
    nvar = ncol (dudi$tab)
    dudi$cw = dudi$cw
    row.w = dudi$lw
    fun = function (x) lag.listw(listw,x,TRUE)
    tablag = apply(dudi$tab,2,fun)
    covar = t(tablag)%*%as.matrix((dudi$tab*dudi$lw))
    covar = (covar+t(covar))/2
    covar <- covar * sqrt(dudi$cw)
    covar <- t(t(covar) * sqrt(dudi$cw))
    covar = eigen(covar, sym=TRUE)  
    if (scannf) {
        barplot(covar$values)
        cat("Select the first number of axes (>=1): ")
        nfposi <- as.integer(readLines(n = 1) )
        cat("Select the second number of axes (>=0): ")
        nfnega <- as.integer(readLines(n = 1))
    }
    if (nfposi <= 0)  nfposi <- 1
    if (nfnega<=0) nfnega = 0       
    res=list()
    res$eig <- covar$values
    res$nfposi <- nfposi
    res$nfnega <- nfnega
    agarder = c(1:nfposi,if (nfnega>0) (nvar-nfnega+1):nvar else NULL)
    agarder = unique (agarder)
    agarder = agarder[which(agarder<=nvar)]
    agarder = agarder[which(agarder>=1)]
    dudi$cw[which(dudi$cw == 0)] <- 1
    auxi <- data.frame(covar$vectors[, agarder] /sqrt(dudi$cw))
    names(auxi) <- paste("CS", agarder, sep = "")
    row.names(auxi) <- names(dudi$tab)
    res$c1 <- auxi                     
  
    auxi = as.matrix(auxi)*dudi$cw
    auxi1 = as.matrix(dudi$tab)%*%auxi
    auxi1 = data.frame(auxi1)
    names(auxi1)=names(res$c1)
    row.names(auxi1) = row.names(dudi$tab)
    res$li = auxi1
    auxi1 = as.matrix(tablag)%*%auxi
    auxi1 = data.frame(auxi1)
    names(auxi1)=names(res$c1)
    row.names(auxi1) = row.names(dudi$tab)    
    res$ls = auxi1
    
    auxi <- as.matrix(res$c1) * unlist(dudi$cw)
    auxi <- data.frame(t(as.matrix(dudi$c1)) %*% auxi)
    row.names(auxi) <- names(dudi$li)
    names(auxi) <- names(res$li)
    res$as <- auxi


    res$call <- match.call()
    class(res) <- "multispati"
    return(res)
}

"summary.multispati" <- function (object, ...) {
    util <- function(n) {
        x <- "1"
        for (i in 2:n) x[i] <- paste(x[i - 1], i, sep = "+")
        return(x)
    }
    norm.w <- function(X, w) {
        f2 <- function(v) sum(v * v * w)/sum(w)
        norm <- apply(X, 2, f2)
        return(norm)
    }

    if (!inherits(object, "multispati")) 
        stop("to be used with 'multispati' object")
    cat("\nMultivariate Spatial Analysis\n")
    cat("Call: ")
    print(object$call)

    appel <- as.list(object$call)
    dudi <- eval(appel$dudi, sys.frame(0))
    listw <- eval(appel$listw, sys.frame(0))
    
    # les scores de l'analyse de base
    nf = dudi$nf
    eig=dudi$eig[1:nf]
    cum=cumsum (dudi$eig) [1:nf]
    ratio = cum/sum(dudi$eig)
    w = apply(dudi$l1,2,lag.listw,x=listw)
    moran = apply(w*as.matrix(dudi$l1)*dudi$lw,2,sum)
    res=data.frame(var=eig,cum=cum,ratio=ratio, moran=moran)
    cat("\nScores from the first duality diagramm:\n")
    print(res)
    
    # les scores de l'analyse spatiale
    nfposi <- object$nfposi
    nfnega <- object$nfnega
    nvar <- nrow(object$c1)
    nf <- nfposi + nfnega
    agarder = c(1:nfposi,if (nfnega>0) (nvar-nfnega+1):nvar else NULL)
    eig = object$eig[agarder]
    varspa=norm.w(object$li,dudi$lw)
    moran = apply(as.matrix(object$li)*as.matrix(object$ls)*dudi$lw,2,sum)
    res=data.frame(eig=eig,var=varspa,moran=moran/varspa)
    
    cat("\nEigenvalues decomposition:\n")
    print(res)
}

"print.multispati" <- function (x, ...) {

}


"plot.multispati" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "multispati")) 
        stop("Use only with 'multispati' objects")
    
    appel <- as.list(x$call)
    dudi <- eval(appel$dudi, sys.frame(0))
    listw <- eval(appel$listw, sys.frame(0))
    nf = x$nfposi + x$nfnega
    if ((nf == 1) || (xax == yax)) {
        sco.quant(x$li[, 1], dudi$tab)
        return(invisible())
    }
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
   f1 <- function () 
    {
        opar <- par(mar = par("mar"))
        on.exit(par(opar))
        m=length(x$eig)
        par(mar = c(0.8, 2.8, 0.8, 0.8))
        col.w = rep (grey(1), m) # elles sont toutes blanches
        col.w[1:x$nfposi] = grey(0.8)
        if (x$nfnega>0) col.w[m:(m-x$nfnega+1)] = grey(0.8)
        j1 = xax
        if (j1>x$nfposi) j1 = j1-x$nfposi +m -x$nfnega
        j2 = yax
        if (j2>x$nfposi) j2 = j2-x$nfposi +m -x$nfnega
        col.w[c(j1,j2)] = grey(0)
         barplot(x$eig, col = col.w)
        scatterutil.sub(cha ="Eigen values", csub = 2, possub = "topright")
    }
    
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(3, 3, 1, 3, 3, 2), 3, 2))
    par(mar = c(0.2, 0.2, 0.2, 0.2))
    f1()
    s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights", 
        csub = 2, clab = 1.25)
    s.match(x$li, x$ls, xax = xax, yax = yax, sub = "Classes", csub = 2, clab = 0.75) 
 
}
"multispati.randtest" <- function (dudi, listw, nrepet = 999) {
    if(!inherits(dudi,"dudi")) stop ("object of class 'dudi' expected") 
    if(!inherits(listw,"listw")) stop ("object of class 'listw' expected") 
    if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected") 
    
    "testmultispati"<- function(nrepet, nr, nc, tab, mat, lw, cw) {
        .C("testmultispati", 
            as.integer(nrepet),
            as.integer(nr),
            as.integer(nc),
            as.double(as.matrix(tab)),
            as.double(mat),
            as.double(lw),
            as.double(cw),
            inersim=double(nrepet+1),
            PACKAGE="ade4")$inersim
    }
 
    tab<- dudi$tab
    nr<-nrow(tab)
    nc<-ncol(tab)
    mat<-listw2mat(listw)
    lw<- dudi$lw
    cw<- dudi$cw
    inersim<- testmultispati(nrepet, nr, nc, tab, mat, lw, cw)
    inertot<- sum(dudi$eig)
    inersim<- inersim/inertot
    obs <- inersim[1]
    w<-as.rtest(inersim[-1], obs, call = match.call())
    return(w)
}

"multispati.rtest" <- function (dudi, listw, nrepet = 99) {
    if(!inherits(listw,"listw")) stop ("object of class 'listw' expected") 
    if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected") 
    n = length(listw$weights)
    fun.lag = function (x) lag.listw(listw,x,TRUE)
    fun <- function (permuter = TRUE) {
        if (permuter) {
            permutation <- sample(n)
            y <- dudi$tab[permutation,]
            yw <- dudi$lw[permutation]
        } else {
            y <-dudi$tab
            yw <- dudi$lw
        }
        y <- as.matrix(y)
        ymoy = apply(y, 2, fun.lag)
        ymoy=ymoy*yw
        y = y*ymoy
        indexmoran <- sum(apply(y,2,sum)*dudi$cw)
        return(indexmoran)
    }
    inertot = sum(dudi$eig)
    obs <- fun (permuter = FALSE)/inertot
    if (nrepet == 0) return(obs)
    perm <- unlist(lapply(1:nrepet, fun))/inertot
    w <- as.rtest(obs = obs, sim = perm, call = match.call())
    return(w)
}


"neig" <- function (list = NULL, mat01 = NULL, edges = NULL, n.line = NULL,
    n.circle = NULL, area = NULL) 
{
    if (!is.null(list)) {
        n <- length(list)
        output <- matrix(0, n, n)
        for (i in 1:n) {
            w <- list[[i]]
            if (length(w) > 0) 
                output[i, w] <- 1
        }
        output <- output + t(output)
        output <- 1 * (output > 0)
        w.output <- as.vector(apply(output, 1, sum))
        names(w.output) <- as.character(1:n)
        if (!is.null(attr(list, "region.id"))) 
            names(w.output) <- attr(list, "region.id")
        output <- neig.util.GtoL(output)
    }
    else if (!is.null(mat01)) {
        output <- neig.util.GtoL(mat01)
        w.output <- as.vector(apply(mat01, 1, sum))
        if (!is.null(rownames(mat01))) 
            names(w.output) <- rownames(mat01)
        else if (!is.null(colnames(mat01))) 
            names(w.output) <- colnames(mat01)
        else names(w.output) <- as.character(1:(nrow(mat01)))
    }
    else if (!is.null(edges)) {
        output <- edges
        G <- neig.util.LtoG(edges)
        w.output <- as.vector(apply(G, 1, sum))
        names(w.output) <- as.character(1:length(w.output))
    }
    else if (!is.null(n.line)) {
        output <- cbind(1:(n.line - 1), 2:n.line)
        G <- neig.util.LtoG(output)
        w.output <- as.vector(apply(G, 1, sum))
        names(w.output) <- as.character(1:n.line)
    }
    else if (!is.null(n.circle)) {
        output <- cbind(1:(n.circle - 1), 2:n.circle)
        output <- rbind(output, c(n.circle, 1))
        G <- neig.util.LtoG(output)
        w.output <- as.vector(apply(G, 1, sum))
        names(w.output) <- as.character(1:n.circle)
    }
    else if (!is.null(area)) {
        fac <- area[, 1]
        levpoly <- unique(fac)
        npoly <- length(levpoly)
        ng1 <- 0
        ng2 <- 0
        k <- 0
        for (i in 1:(npoly - 1)) {
            t1poly <- paste(area[fac == levpoly[i], 2], area[fac == 
                levpoly[i], 3], sep = "000")
            for (j in (i + 1):npoly) {
                t2poly <- paste(area[fac == levpoly[j], 2], area[fac == 
                  levpoly[j], 3], sep = "000")
                if (any(t1poly %in% t2poly)) {
                  k <- k + 1
                  ng1[k] <- i
                  ng2[k] <- j
                }
            }
        }
        output <- cbind(ng1, ng2)
        G <- neig.util.LtoG(output)
        w.output <- as.vector(apply(G, 1, sum))
        names(w.output) <- as.character(levpoly)
    }
    attr(output, "degrees") <- w.output
    attr(output, "call") <- match.call()
    class(output) <- "neig"
    output
}

"nb2neig" <- function (nb) {
    if (!inherits(nb, "nb")) 
        stop("Non convenient data")
    res <- neig(list = nb)
    w <- attr(nb, "region.id")
    if (is.null(w)) 
        w <- as.character(1:length(nb))
    names(attr(res, "degrees")) <- w
    return(res)
}

"neig2nb" <- function (neig) {
    if (!inherits(neig, "neig")) 
        stop("Non convenient data")
    w1 <- attr(neig, "degrees")
    n <- length(w1)
    region.id <- names(w1)
    if (is.null(region.id)) 
        region.id <- as.character(1:n)
    G <- neig.util.LtoG(neig)
    res <- split(G, row(G))
    res <- lapply(res, function(x) which(x > 0))
    attr(res, "region.id") <- region.id
    attr(res, "gal") <- FALSE
    attr(res, "call") <- match.call()
    class(res) <- "nb"
    return(res)
}

"neig2mat" <- function (neig) {
    # synonyme de neig.util.GtoL plus simple de mmorisation
    # donne la matrice d'incidence sommet-sommet en 0-1
    if (!inherits(neig,"neig")) stop ("Object 'neig' expected")
    deg <- attr(neig, "degrees")
    n <- length(deg)
    labels <- names(deg)
    if (is.null(labels)) labels <- paste("P",1:nrow(mat),sep="")
    neig <- unclass(neig)
    G <- matrix(0, n, n)
    for (i in 1:n) {
        w <- neig[neig[, 1] == i, 2]
        if (length(w) > 0) G[i, w] <- 1
    }
    G <- G + t(G)
    G <- 1 * (G > 0)
    dimnames(G) <- list(labels,labels)
    return(G)
}

"neig.util.GtoL" <- function (G) {
    G <- as.matrix(G)
    n <- nrow(G)
    if (ncol(G) != n) 
        stop("Square matrix expected")
    # modif du any samedi, mai 31, 2003 at 16:19
    if (any(t(G) != G))
        stop("Symetric matrix expected")
    if (sum(G == 0 | G == 1) != n * n) 
        stop("0-1 values expected")
    if (sum(diag(G) != 0)) 
        stop("Null diagonal expected")
    G <- G * (row(G) < col(G))
    G <- (row(G) + 0 + (0+1i) * col(G)) * G
    G <- as.vector(G)
    G <- G[G != 0]
    G <- cbind(Re(G), Im(G))
    return(G)
}

"neig.util.LtoG" <- function (L, n = max(L)) {
    L <- unclass(L)
    if (ncol(L) != 2) 
        stop("two col expected")
    no.is.int <- function(x) x != as.integer(x)
    if (any(apply(L, c(1, 2), no.is.int))) 
        stop("Non integer value found")
    if (n < max(L)) 
        stop("Non convenient 'n' parameter")
    G <- matrix(0, n, n)
    for (i in 1:n) {
        w <- L[L[, 1] == i, 2]
        if (length(w) > 0) 
            G[i, w] <- 1
    }
    G <- G + t(G)
    G <- 1 * (G > 0)
    return(G)
}

"print.neig" <- function (x, ...) {
    deg <- attr(x, "degrees")
    n <- length(deg)
    labels <- names(deg)
    df <- neig.util.LtoG(x)
    for (i in 1:n) {
        w <- c(".", "1")[df[i, 1:i] + 1]
        cat(labels[i], " ", w, "\n", sep = "")
    }
    invisible(df)
}

 "summary.neig" <- function (object, ...) {
    cat("Neigbourhood undirected graph\n")
    deg <- attr(object, "degrees")
    size <- length(deg)
    cat("Vertices:", size, "\n")
    cat("Degrees:", deg, "\n")
    m <- sum(deg)/2
    cat("Edges (pairs of vertices):", m, "\n")
}

"scores.neig" <- function (obj) { 
    tol <- 1e-07
    if (!inherits(obj, "neig")) 
        stop("Object of class 'neig' expected")
    b0 <- neig.util.LtoG(obj)
    deg <- attr(obj, "degrees")
    m <- sum(deg)
    n <- length(deg)
    b0 <- -b0/m + diag(deg)/m
    # b0 est la matrice D-P
    eig <- eigen (b0, sym = TRUE)
    w0 <- abs(eig$values)/max(abs(eig$values))
    w0 <- which(w0<tol)
    if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
    if (length(w0)==1) w0 <- (1:n)[-w0]
    else if (length(w0)>1) {
        # on ajoute le vecteur driv de 1n 
        w <- cbind(rep(1,n),eig$vectors[,w0])
        # on orthonormalise l'ensemble
        w <- qr.Q(qr(w))
        # on met les valeurs propres  0
        eig$values[w0] <- 0
        # on remplace les vecteurs du noyau par une base orthonorme contenant 
        # en premire position le parasite
        eig$vectors[,w0] <- w[,-ncol(w)]
        # on enlve la position du parasite
        w0 <- (1:n)[-w0[1]]
    }
    w0=rev(w0)
    rank <- length(w0)
    values <- n-eig$values[w0]*n
    eig <- eig$vectors[,w0]*sqrt(n)
    eig <- data.frame(eig)
    row.names(eig) <- names(deg)
    names(eig) <- paste("V",1:rank,sep="")
    attr(eig,"values")<-values
    eig
}

"newick2phylog" <- function (x.tre, add.tools = TRUE, call =match.call()) {
    complete <- function(x.tre) {
        # Si la chane est en plusieurs morceaux elle est rassemble
        if (length(x.tre) > 1) {
            w <- ""
            for (i in 1:length(x.tre)) w <- paste(w, x.tre[i], 
                sep = "")
            x.tre <- w
        }
        # Si les parenthses gauches et droites ont des effectifs diffrents -> out
        ndroite <- nchar(gsub("[^)]","",x.tre))
        ngauche <- nchar(gsub("[^(]","",x.tre))
        if (ndroite !=ngauche) stop (paste (ngauche,"( versus",ndroite,")"))
        # on doit trouver un ;
        if (regexpr(";", x.tre) == -1) 
            stop("';' not found")
        # Tous les commentaires entre [] sont supprims
        i <- 0
        kint <- 0
        kext <- 0
        arret <- FALSE
        if (regexpr("\\[", x.tre) != -1) {
            x.tre <- gsub("\\[[^\\[]*\\]", "", x.tre, ext = FALSE)
        }
        x.tre <- gsub(" ", "", x.tre, ext = FALSE)
        # On ne peut supprimer les . qui sont dans les distances !
        # x.tre <- gsub("[.]","_", x.tre, ext = FALSE)
        while (!arret) {
            i <- i + 1
            # examen de la chane par couple de charactres
            if (substr(x.tre, i, i) == ";") 
                arret <- TRUE
            # (, c'est une feuille sans label
            if (substr(x.tre, i, i + 1) == "(,") {
                kext <- kext + 1
                add <- paste("Ext", kext, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ,, c'est une feuille sans label
            else if (substr(x.tre, i, i + 1) == ",,") {
                kext <- kext + 1
                add <- paste("Ext", kext, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ,) c'est une feuille sans label
            else if (substr(x.tre, i, i + 1) == ",)") {
                kext <- kext + 1
                add <- paste("Ext", kext, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # (: c'est une feuille sans label avec distance
            else if (substr(x.tre, i, i + 1) == "(:") {
                kext <- kext + 1
                add <- paste("Ext", kext, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ,: c'est une feuille sans label avec distance
            else if (substr(x.tre, i, i + 1) == ",:") {
                kext <- kext + 1
                add <- paste("Ext", kext, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ), c'est un noeud sans label
            else if (substr(x.tre, i, i + 1) == "),") {
                kint <- kint + 1
                add <- paste("I", kint, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # )) c'est un noeud sans label
            else if (substr(x.tre, i, i + 1) == "))") {
                kint <- kint + 1
                add <- paste("I", kint, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ): c'est un noeud sans label avec distance
            else if (substr(x.tre, i, i + 1) == "):") {
                kint <- kint + 1
                add <- paste("I", kint, sep = "")
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
            # ); c'est la racine sans label
            else if (substr(x.tre, i, i + 1) == ");") {
                add <- "Root"
                x.tre <- paste(substring(x.tre, 1, i), add, substring(x.tre, 
                  i + 1), sep = "")
                i <- i + 1
            }
        }
        # extraction de l'information non structurelle
        lab.points <- strsplit(x.tre, "[(),;]")[[1]]
        lab.points <- lab.points[lab.points != ""]
        # recherche de la prsence des longueurs
        no.long <- (regexpr(":", lab.points) == -1)
        # si il n'y avait aucune longueur
        if (all(no.long)) {
            lab.points <- paste(lab.points, ":", c(rep("1", length(no.long) - 
                1), "0.0"), sep = "")
        }
        # si il y en vait partout sauf  la racine
        else if (no.long[length(no.long)]) {
            lab.points[length(lab.points)] <- paste(lab.points[length(lab.points)], 
                ":0.0", sep = "")
        }
        # si il y en a et il n'y en a pas -> out
        else if (any(no.long)) {
            print(x.tre)
            stop("Non convenient data leaves or nodes with and without length")
        }
        w <- strsplit(x.tre, "[(),;]")[[1]]
        w <- w[w != ""]
        leurre <- make.names(w, unique = TRUE)
        leurre <- gsub("[.]","_", leurre, ext = FALSE)
        for (i in 1:length(w)) {
            old <- paste(w[i])
            x.tre <- sub(old, leurre[i], x.tre, ext = FALSE)
        }
        # extraction des labels et des longueurs
        w <- strsplit(lab.points, ":")
        label <- function(x) {
            # ici on peut travailler sur les labels
            lab <- x[1]
            lab <- gsub("[.]","_", lab, ext = FALSE)
            return (lab)
        }
        
        longueur <- function(x) {
            long <- x[2]
            return (long)
        }

        labels <- unlist(lapply(w, label))
        longueurs <- unlist(lapply(w, longueur))
        # ici on peut travailler sur les labels
        labels <- make.names(labels, TRUE)
        labels <- gsub("[.]","_", labels, ext = FALSE)
        w <- labels
        for (i in 1:length(w)) {
            new <- w[i]
            x.tre <- sub(leurre[i], new, x.tre, ext = FALSE)
        }
        # on les a remis  leur place
        cat <- rep("", length(w))
        for (i in 1:length(w)) {
            new <- w[i]
            if (regexpr(paste(")", new, sep = ""), x.tre, ext = FALSE) != 
                -1) 
                cat[i] <- "int"
            else if (regexpr(paste(",", new, sep = ""), x.tre, 
                ext = FALSE) != -1) 
                cat[i] <- "ext"
            else if (regexpr(paste("(", new, sep = ""), x.tre, 
                ext = FALSE) != -1) 
                cat[i] <- "ext"
            else cat[i] <- "unknown"
        }
        return(list(tre = x.tre, noms = labels, poi = as.numeric(longueurs), 
            cat = cat))
    }
    res <- complete(x.tre)
    poi <- res$poi
    nam <- res$noms
    names(poi) <- nam
    cat <- res$cat
    res <- list(tre = res$tre)
    res$leaves <- poi[cat == "ext"]
    names(res$leaves) <- nam[cat == "ext"]
    res$nodes <- poi[cat == "int"]
    names(res$nodes) <- nam[cat == "int"]
    nleaves <- length(res$leaves)
    nnodes <- length(res$nodes)
    listclass <- list()
    dnext <- c(names(res$leaves), names(res$nodes))
    listpath <- as.list(dnext)
    names(listpath) <- dnext
    x.tre <- res$tre
    while (regexpr("[(]", x.tre) != -1) {
        a <- regexpr("([^()]*)", x.tre, ext = FALSE)
        n1 <- a[1] + 1
        n2 <- n1 - 3 + attr(a, "match.length")
        chasans <- substring(x.tre, n1, n2)
        chaavec <- paste("(", chasans, ")", sep = "")
        nam <- unlist(strsplit(chasans, ","))
        w1 <- strsplit(x.tre, chaavec, ext = FALSE)[[1]][2]
        parent <- unlist(strsplit(w1, "[,);]", ext = FALSE))[1]
        listclass[[parent]] <- nam
        x.tre <- gsub(chaavec, "", x.tre, ext = FALSE)
        w2 <- which(unlist(lapply(listpath, function(x) any(x[1] == 
            nam))))
        for (i in w2) {
            listpath[[i]] <- c(parent, listpath[[i]])
        }
    }
    res$parts <- listclass
    res$paths <- listpath
    dnext <- c(res$leaves, res$nodes)
    names(dnext) <- c(names(res$leaves), names(res$nodes))
    res$droot <- unlist(lapply(res$paths, function(x) sum(dnext[x])))
    res$call <- call
    class(res) <- "phylog"
    if (!add.tools) return(res)
    return(newick2phylog.addtools(res))
}


"hclust2phylog" <- function (hc, add.tools = TRUE) {
    if (!inherits(hc, "hclust")) 
        stop("'hclust' object expected")
    labels.leaves <- make.names(hc$labels, TRUE)
    nleaves <- length(labels.leaves)
    nnodes <- nrow(hc$merge)
    labels.nodes <- paste("Int", 1:nnodes, sep = "")
    l.bra <- matrix("$", nnodes, 2)
    for (i in nnodes:1) {
        for (j in 1:2) {
            if (hc$merge[i, j] < 0) 
                l.bra[i, j] <- as.character(hc$height[i])
            else l.bra[i, j] <- as.character(hc$height[i] - hc$height[hc$merge[i, 
                j]])
        }
    }
    l.eti <- matrix("$", nnodes, 2)
    for (i in nnodes:1) {
        for (j in 1:2) {
            if (hc$merge[i, j] > 0) 
                l.eti[i, j] <- labels.nodes[hc$merge[i, j]]
            else l.eti[i, j] <- labels.leaves[-hc$merge[i, j]]
        }
    }
    tre <- paste("(", l.eti[nnodes, 1], ":", l.bra[nnodes, 1], 
        ",", l.eti[nnodes, 2], ":", l.bra[nnodes, 2], ")Root:0.0;", 
        sep = "")
    for (j in (nnodes - 1):1) {
        w <- paste("(", l.eti[j, 1], ":", l.bra[j, 1], ",", l.eti[j, 
            2], ":", l.bra[j, 2], ")", labels.nodes[j], ":", 
            sep = "")
        tre <- gsub(paste(labels.nodes[j], ":", sep = ""), w, 
            tre, ext = FALSE)
    }
    res <- newick2phylog(tre, add.tools, call=match.call())
    return(res)
}


"taxo2phylog" <- function (taxo, add.tools = TRUE) {
    if (!inherits(taxo, "taxo")) 
        stop("Object 'taxo' expected")
    nr <- nrow(taxo)
    nc <- ncol(taxo)  
    leaves.names <- row.names(taxo)
    res <- paste("root;")
    x <- taxo[, nc]
    xred <- as.character(levels(x))
    w <- "("
    for (i in xred) w <- paste(w, i, ",", sep = "")
    res <- paste(w, ")", res, sep = "")
    res <- sub(",)", ")", res, ext = FALSE)  
  
    for (j in nc:2) {
        x <- taxo[, j]
        y <- taxo[, j - 1]
        for (k in 1:nlevels(x)) {
            w <- "("
            old <- as.character(levels(x)[k])
            yred <- unique(y[x == levels(x)[k]])
            yred <- levels(y)[yred]
            for (i in yred) w <- paste(w, i, ",", sep = "")
            w <- paste(w, ")", old, sep = "")
            w <- sub(",)", ")", w, ext = FALSE)
            res <- sub(old, w, res, ext = FALSE)
        }
    }          
    x <- taxo[, 1]
    y <- leaves.names
    for (k in 1:nlevels(x)) {
        w <- "("
        old <- as.character(levels(x)[k])
        yred <- y[x == levels(x)[k]]
        for (i in yred) w <- paste(w, i, ",", sep = "")
        w <- paste(w, ")", old, sep = "")
        w <- sub(",)", ")", w, ext = FALSE)
        res <- sub(old, w, res, ext = FALSE)
    }         
    return(newick2phylog(res, add.tools, call=match.call()))
}

   
"newick2phylog.addtools" <- function(res, tol =1e-07) {
    require(ade4)
    
    nleaves <- length(res$leaves) # nombre de feuilles
    nnodes <- length(res$nodes)    # nombre de noeuds
    node.names <- names(res$nodes) # noms des feuilles
    leave.names <- names(res$leaves) # noms des noeuds    
    dimnodes<-unlist(lapply(res$parts,length)) # nombres de descendants immdiats de chaque noeud
    effnodes <- dimnodes # recevra le nombre de descendants total de chaque noeud
    wnodes <- lgamma(dimnodes+1) 
    # recevra le logarithme du nombre de permuations compatibles
    # avec la sous-arborescence associe  chaque noeud
    


    # les matrices de proximit #
    a <- matrix(0, nleaves, nleaves)
    ia <- as.numeric(col(a))
    ja <- as.numeric(row(a))
    a <- cbind(ia, ja)[ia < ja, ]
    # a contient la liste des couples de feuilles
    floc1 <- function(x) {
        # x est un couple de numros de deux feuilles i, avec i<j
        # Cette fonction renvoie 
        # resw - la distance  la racine du premier anctre commun de deux feuilles
        # resa - l'inverse des produits des nombres de descendants des noeuds 
        # rencontrs sur le plus court chemin entre les deux feuilles
        c1 <- rev(res$paths[[x[1]]])
        c2 <- rev(res$paths[[x[2]]])
        commonnodes <- c1[c1 %in% c2]
        resw <- res$droot[commonnodes[1]]
        d1 <- c1[! (c1 %in% c2)][-1]
        d2 <- c2[! (c2 %in% c1)][-1]
        pathij <- c(d1,d2,commonnodes[1])
        resa <- 1/prod(unlist(dimnodes[pathij]))
        return(c(resw,resa))
    }
    b <- apply(a, 1, floc1)
    names(b) <- NULL
    w <- matrix(0, nleaves, nleaves)
    w[col(w) < row(w)] <- b[1,]
    w <- w + t(w)
    diag(w) <- res$droot[leave.names]
    dimnames(w) <- list(leave.names,1:nleaves)

    res$Wmat <- w
    
    #############################
    # la composante Wmat contient la matrice W des distances racine-premier anctre commun
    #############################
    
    w <- diag(res$Wmat)
    w <- matrix(w, nleaves, nleaves)
    w <- w + t(w) - 2 * res$Wmat
    w <- mat2dist(sqrt(w))
    attr(w, "Labels") <- leave.names
    
    res$Wdist <- w
    #############################
    # la composante Wdist contient la matrice des racines des distances nodales
    # qui forment une distance euclidienne
    #############################
    w <- res$Wmat
    w <- w / sum(w)
    w <- bicenter.wt(w)
    w <- eigen(w,sym=TRUE)
    res$Wvalues <- w$values[-nleaves]*nleaves
    w <- as.data.frame(w$vectors[,-nleaves]*sqrt(nleaves))
    row.names(w) <- leave.names
    names(w) = paste("W",1:(nleaves-1),sep="")
    res$Wscores <- w
    
    
    w <- matrix(0, nleaves, nleaves)
    w[col(w) < row(w)] <- b[2,]
    w <- w + t(w)
    # On rajoute la diagonale pour que A soit bistochastique
    floc1 <- function(x) {
        # cette fonction renvoie pour une feuille la frquence des reprsentations
        # compatibles qui placent cette feuille tout en haut ou tout en bas
        c1 <- rev(res$paths[[x]])
        c1 <- c1[-1] # premier ancetre, second ancetre, ..., racine
        resw <- dimnodes[c1] # ordre des noeuds
        resw <- 1/prod(unlist(resw))
        return(resw)
    }
    diag(w) <- unlist(lapply(leave.names,floc1))
    dimnames(w) <- list(leave.names,1:nleaves)
    res$Amat <- w
    #############################
    # la composante Amat contient la matrice des probabilits
    # pour une feuille d'tre juste au dessus d'une autre
    # dans l'ensemble des permutations compatibles
    #############################
    # double centrage
    w <- bicenter.wt(w)
    # diagonalisation
    eig <- eigen (w, sym = TRUE)
    w0 <- abs(eig$values)/max(abs(eig$values))
    w0 <- which(w0<tol)
    if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
    if (length(w0)==1) w0 <- (1:nleaves)[-w0]
    else if (length(w0)>1) {
        # on ajoute le vecteur driv de 1n 
        w <- cbind(rep(1,nleaves),eig$vectors[,w0])
        # on orthonormalise l'ensemble
        w <- qr.Q(qr(w))
        # on met les valeurs propres  0
        eig$values[w0] <- 0
        # on remplace les vecteurs du noyau par une base orthonorme contenant 
        # en premire position le parasite
        eig$vectors[,w0] <- w[,-ncol(w)]
        # on enlve la position du parasite
        w0 <- (1:nleaves)[-w0[1]]
    }
    rank <- length(w0)
    res$Avalues <- eig$values[w0]*nleaves
    #############################
    # la composante Avalues contient les valeurs propres de QAQ
    #############################
    res$Adim <- sum(res$Avalues>tol)
    #############################
    # la composante Adim contient le nombre de valeurs propres positives
    # associes  la composante positive de la variance
    #############################
    w <- eig$vectors[,w0]*sqrt(nleaves)
    w <- data.frame(w)
    row.names(w) <- leave.names
    names(w) <- paste("A",1:rank,sep="")
    res$Ascores <- w
    #############################
    # la composante Ascores contient une base orthoborme de l'orthogonal de n
    # pour la pondration uniforme. Elle dfinit un phylogramme
    #############################

    # Complment : la valeur des noeuds #    

    floc1 <- function(k) {
        # k est un numro de noeud
        # x est un vecteur comportant un nom de noeud et des noms de descendants 
        # de ce noeud. 
        # A la fin parts wnodes contient le logarithme
        # du nombre de permutations compatibles de chaque sous-arbre
        # et effnodes contient le nombre de descendants de chaque sous-arbre
        y <- res$parts[[k]]
        x <- y[y%in%names(res$nodes)]
        n1 <- names(res$parts)[k]
        if (length(x)<=0) return(NULL)
        effnodes[n1] <<- effnodes[n1] - length(x) + sum(effnodes[x])
        wnodes[n1] <<- wnodes[n1] + sum(wnodes[x])
        return(NULL)
    }
    
    lapply(1:length(res$parts),floc1)
    typolo.value <- 1-exp(wnodes-lgamma(effnodes+1))
    
    res$Aparam <- data.frame(x1=I(dimnodes), x2=I(effnodes), x3=I(wnodes), x4=I(typolo.value))
    #############################
    # la composante Aparam est un data.frame de paramtre sur l'ensemble des noeuds
    # x1 = nombre de descendants directs
    # x2 = nombre de feuilles descendantes 
    # x3 = log du nombre de permutations compatibles avec la phylognie extraite
    # x4 = 1-rapport du nombre de permutations compatibles sur le nombre de permutations totales
    # pour la phylognie extraite dans ce noeud
    # cet indice vaut 0 si le noeud est final et est maximal  la racine
    # attention il ne vaut pas 1 mais 1-epsilon quand il est affich 1
    #############################

    # Complment : la base B #
    w1 <- matrix(0, nleaves, nnodes)
    x1 <- res$Aparam$x2 #le nombre de feuilles descendantes
    # on calcule une matrice auxiliaire pour avoir la liste des feuilles descendantes
    # pour chacun des noeuds
    dimnames(w1) <- list(leave.names, names(x1))
    for (i in leave.names) {
        ancetres <- res$paths[[i]]
        ancetres <- rev(ancetres)[-1]#rev(ancetres[-1])[-1]
        w1[i, ancetres] <- 1
    }
    w1 <- cbind(w1, diag(1, nleaves))
    dimnames(w1)[[2]] <- c(names(x1),leave.names)
    x1 <- c(x1, rep(-1,nleaves))
    names(x1) <-dimnames(w1)[[2]]
    # La matrice w1 contient 1 en i-j si la feuille i descend du noeud j

    ######################################
    # on construit une famille d'indicatrices de classes
    # Une arte de l'arborescence est un lien de descendance
    # Chaque noeud et chaque feuille ( l'expection de la racine) a un seul ascendant
    # Il y a n+f-1 artes. Le noeud j a m(j) descendants
    # Les feuilles n'en n'ont pas. Donc m(1)+m(2)+ ... + m(n) = n+f-1
    # Il y a n+f-1 artes rparties en n blocs.
    # Il y a donc n+f-1-n=f-1 descendants indicateurs DI quand on enlve une arte descendante par noeud
    # Rien n'est conserv pour un noeud avec un seul descendant
    # Pour chaque DI on utilise l'indicatrice de la classe des feuilles descendant de cet noeud
    # la composante Bindica contient f-1 indicatrices de classes de feuilles
    # names (w) contient des noms de descendants
    # nomuni contient les noms de DI pour l'tiquetage final
    ####################################
    funnoe <- function (noeud) {
        # renvoie pour un noeud une liste dont chaque composante est un descendant immdiat du noeud
        # caractris par la liste des feuilles qui en descendent sous forme de matrice 
        # d'indicatrices. Le dernier descendant immdiat du noeud est limin.
        x <- res$parts[[noeud]] # les descendants immdiats
        xval <- x1[x] # le nombre de feuilles descendantes des descendants
        xval <- rev(sort(xval)) # trie
        x <- names(xval) # on rcupre lesquels
        x <- x[-length(x)] # on enlve le dernier
        if (length(x) ==0) return(NULL)
        if (length(x) ==1) xmat <- matrix(w1[,x],ncol=1,dimnames=list(leave.names,noeud))
        else {
           xmat <- w1[,x]
           dimnames(xmat)[[2]] <- rep(noeud, ncol(xmat))
        }
        return (list(xmat, x))
        # les noms des colonnes de xmat repte le nom du noeud
        # dans y on a le nom des descendants retenus
    }

    nomuni <- NULL
    w <- matrix(1,nleaves,1)
    dimnames(w) <- list(leave.names, "un")
    for (i in names(x1)[1:nnodes]) {
        provi <- funnoe(i)
        if (!is.null(provi)) {
            w <-cbind(w, provi[[1]])
            nomuni <- c(nomuni,provi[[2]])
        }
    }
    w <- w[,-1]
    nomrepet <- dimnames(w)[[2]]
    names(nomrepet) <- nomuni
    dimnames(w)[[2]] <- nomuni
    names(nomuni) <- nomuni
    #############################
    # Les indicatrices sont classes par ordre dcroissant
    # de xtQWQx la variance phylogntique formelle de l'indicatrice centre
    # Bindica n'a qu'une valeur pdagogique et ne sert pas explicitement
    # mais la procdure est simple
    # 1) dfinition des indicatrices, il y en a toujours f-1
    # 2) rangement par valeur dcroissante de la forme quadratique
    # Ce rangement est conserv dans res$Bindica
    # les valeurs du critre de rangement dans Bvalues
    # 3) rajout de 1n devant
    # 4) orthonormalisation
    # on obtient toujours une base orthonorme de l'orthogonal de 1n
    #############################
    floc <- function (x) {
        x <- x-mean(x)
        sum(t(res$Wmat*x)*x)
    }
    # chaque indicatrice donne une valeur
    w.val <- unlist(apply(w,2, floc))
    # trie par ordre descendant
    w.val <- rev(sort(w.val))
    # lesquels
    w <- w[,names(w.val)]
    # nomrepet / w sont tris
    nomrepet <- nomrepet[names(w.val)]    
    res$Bindica <- as.data.frame(w)
    w <- cbind(rep(1,nleaves),w)
    w <- qr.Q(qr(w))
    w <- w[, -1] * sqrt(nleaves)
    w <- data.frame(w)
    row.names(w) <- leave.names
    names(w) <- paste("B",1:(nleaves-1),sep="")
    res$Bscores <- w
    res$Bvalues <- w.val
    lw <- lapply(node.names, function (x) which(nomrepet==x))
    names(lw) <- node.names
    fun1 <- function (x) {
        if (length(x)==0) return("x")
        if (length(x)==1) return(as.character(x))
        y <- x[1]
        for(k in 2:length(x)) y <- paste(y,x[k],sep="/")
        return(y)
    }       
    lw <- unlist(lapply(lw, fun1))
    res$Blabels <- lw
    return(res)
}
"niche" <- function (dudiX, Y, scannf = TRUE, nf = 2) {
    if (!inherits(dudiX, "dudi")) 
        stop("Object of class dudi expected")
    lig1 <- nrow(dudiX$tab)
    col1 <- ncol(dudiX$tab)
    if (!is.data.frame(Y)) 
        stop("Y is not a data.frame")
    lig2 <- nrow(Y)
    col2 <- ncol(Y)
    if (lig1 != lig2) 
        stop("Non equal row numbers")
    w1 <- apply(Y, 2, sum)
    if (any(w1 <= 0)) 
        stop(paste("Column sum <=0 in Y"))
    Y <- sweep(Y, 2, w1, "/")
    w1 <- w1/sum(w1)
    tabcoiner <- t(as.matrix(Y)) %*% (as.matrix(dudiX$tab))
    tabcoiner <- data.frame(tabcoiner)
    names(tabcoiner) <- names(dudiX$tab)
    row.names(tabcoiner) <- names(Y)
    if (nf > dudiX$nf) 
        nf <- dudiX$nf
    nic <- as.dudi(tabcoiner, dudiX$cw, w1, scannf = scannf, 
        nf = nf, call = match.call(), type = "niche")
    U <- as.matrix(nic$c1) * unlist(nic$cw)
    U <- data.frame(as.matrix(dudiX$tab) %*% U)
    row.names(U) <- row.names(dudiX$tab)
    names(U) <- names(nic$c1)
    nic$ls <- U
    U <- as.matrix(nic$c1) * unlist(nic$cw)
    U <- data.frame(t(as.matrix(dudiX$c1)) %*% U)
    row.names(U) <- names(dudiX$li)
    names(U) <- names(nic$li)
    nic$as <- U
    return(nic)
}

"plot.niche" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "niche")) 
        stop("Use only with 'niche' objects")
    if (x$nf == 1) {
        warnings("One axis only : not yet implemented")
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    s.corcircle(x$as, xax, yax, sub = "Axis", csub = 2, 
        clab = 1.25)
    s.arrow(x$c1, xax, yax, sub = "Variables", csub = 2, 
        clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
    s.label(x$ls, xax, yax, clab = 0, cpo = 2, sub = "Samples and Species", 
        csub = 2)
    s.label(x$li, xax, yax, clab = 1.5, add.p = TRUE)
    s.label(x$ls, xax, yax, clab = 1.25, sub = "Samples", 
        csub = 2)
    s.distri(x$ls, eval(as.list(x$call)[[3]], sys.frame(0)), 
        cstar = 0, axesell = FALSE, cell = 1, sub = "Niches", csub = 2)
}

"print.niche" <- function (x, ...) {
    if (!inherits(x, "niche")) 
        stop("to be used with 'niche' object")
    cat("Niche analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$rank (rank)     :", x$rank)
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n$RV (RV coeff)   :", x$RV)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(3, 4), list(1:3, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (averaging species/sites)")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "species coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "species normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "variables coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "variables normed scores")
    sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "sites coordinates")
    sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "axis upon niche axis")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
print.orthobasis <- function(x,...) {
    if (!inherits(x,"orthobasis")) stop ("for 'orthobasis' object")
    cat("Orthonormal basis: ")
    n <- nrow(x)
    p <- ncol(x)
    if (n!=(p+1)) stop ("Non convenient dimension: author's error")
    cat("data.frame with",n,"rows and",ncol(x),"columns\n")
    cat("--------------------------------------\n")
    cat("Columns are an orthonormal basis of 1n-orthogonal for\n")
    cat("the inner product defined by the weights attribute\n")
    cat("---------------------------------------\n")
    w <- attributes(x)
    if (!is.null(w$"names")) cat("names =", w$names[1],"...",w$names[p],"\n")
    if (!is.null(w$"row.names")) cat("row.names =", w$row.names[1],"...",w$row.names[n],"\n")
    if (!is.null(w$"weights")) cat("weights =", w$weights[1],"...",w$weights[n],"\n")
    if (!is.null(w$"values")) cat("values =", w$values[1],"...",w$values[p],"\n")
    if (!is.null(w$"class")) cat("class =", w$class,"\n")
    if (!is.null(w$"call")) {
        cat("call =")
        print(w$"call")
    }
  } 


orthobasis.mat <- function(mat, cnw=TRUE) {
    if (!is.matrix(mat)) stop ("matrix expected")
    if (any(mat<0)) stop ("negative value in 'mat'")
    if (nrow(mat)!=ncol(mat)) stop ("squared matrix expected")
    mat <- (mat+t(mat))/2
    nlig <- nrow(mat)
    if (is.null(dimnames(mat))) {
        w <- paste("P",1:nrow(mat),sep="")
        dimnames(mat) <- list(w,w)
    }
    labels <- dimnames(mat)[[1]]
    if (cnw) {
        margi <- apply(mat,1,sum)
        margi <- max(margi)-margi
        mat <- mat+diag(margi)
    }
    mat <- mat/sum(mat)
    wt <- rep ((1/nlig),nlig) 
    # calculs extensibles  une pondration quelconque
    wt <- wt/sum(wt)
    # si mat wt est la pondration marginale associe  mat 
    # tot = sum(mat)
    # mat = mat-matrix(wt,nlig,nlig,byrow=TRUE)*wt*tot
    # encore plus particulier mat = mat-1/nlig/nlig
    # en gnral les prcdents sont des cas particuliers    
    U <- matrix(1,nlig,nlig)
    U  <- diag(1,nlig)-U*wt
    mat <- U%*%mat%*%t(U)
    wt <- sqrt(wt)
    mat <- t(t(mat)/wt)
    mat <- mat/wt
    eig <- eigen(mat,sym=TRUE)
    w0 <- abs(eig$values)/max(abs(eig$values))
    tol <- 1e-07
    w0 <- which(w0<tol)
    if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
    else if (length(w0)==1) w0 <- (1:nlig)[-w0]
    else if (length(w0)>1) {
        # on ajoute le vecteur driv de 1n 
        w <- cbind(wt,eig$vectors[,w0])
        # on orthonormalise l'ensemble
        w <- qr.Q(qr(w))
        # on met les valeurs propres  0
        eig$values[w0] <- 0
        # on remplace les vecteurs du noyau par une base orthonorme contenant 
        # en premire position le parasite
        eig$vectors[,w0] <- w[,-ncol(w)]
        # on enlve la position du parasite
        w0 <- (1:nlig)[-w0[1]]
    }
    mat <- eig$vectors[,w0]/wt
    mat <- data.frame(mat)
    row.names(mat) <- labels
    names(mat) <- paste("S",1:(nlig-1),sep="")
    attr(mat,"values") <- eig$values[w0]
    attr(mat,"weights") <- rep(1/nlig,nlig)
    attr(mat,"call") <- match.call()
    attr(mat,"class") <- c("orthobasis","data.frame")
    return(mat)
}

"orthobasis.haar" <- function(n) {
# on dfinit deux fonctions :
    appel = match.call()
    a <- log(n)/log(2)
    b <- floor(a)
    if ((a-b)^2>1e-10) stop ("Haar is not a power of 2")
# la premire est crite par Daniel et elle donne la dmonstration (par analogie avec la fonction qui construit la base Bscores)
# que la base Bscores est exactement la base de Haar quand on prend une phylognie rgulire rsolue.
"haar.basis.1" <- function (n) {
    pari <- matrix(c(1,n),1)
    "div2" <- function (mat) {
        res <- NULL
        for (k in 1 : nrow(mat)) {
            n1 <- mat[k,1]
            n2 <- mat[k,2]
            diff <- n2-n1
            if (diff <=0) break
            n3 <- floor((n1+n2)/2)
            res <- rbind(res,c(n1,n3),c(n3+1,n2))
        }
        if (!is.null(res)) pari <<- rbind(pari,res)
        return(res)
    }
    mat <- div2(pari)
    while (!is.null(mat)) mat <- div2(mat)
    res <- NULL
    for (k in 1:nrow(pari)) {
        x<-rep(0,n)
        x[(pari[k,1]):(pari[k,2])] <- 1
        res <-c(res,x)
    }
    res = matrix(res,n)
    res <- qr.Q(qr(res))
    res <- res[, -1] * sqrt(n)
    res <- data.frame(res)
    row.names(res) <- paste("u",1:n,sep="")
    names(res) <- paste("B",1:(n-1),sep="")
return(res)
}

# la seconde exploite les potentialits de la librairie waveslim, en remarquant qu'il existe un lien troit entre la dfinition des filtres et la dfinition
# des bases. Cette stratgie permettra  l'avenir de dfinir les bases associes  d'autres famille de fonctions.
"haar.basis.2" <-  function (n) {
    if (!require(waveslim)) stop ("Please install waveslim")
    J <- a    #nombre de niveau
    res <- matrix(0, nrow = n,ncol = n-1)
    filter.seq <- "H" #filtre correspondant au niveau 1
    h <- wavelet.filter(wf.name = "haar", filter.seq = filter.seq)   #paramtre du filtre au niveau 1
    k <- 0
        for(i in 1:J){
        z <- rep(h,2**(J-i))
        x <- 1:n
        y <- rep((n-1-k):(n-2**(J-i)-k),rep(2**i,2**(J-i)))
        for(j in 1:n)   res[x[j],y[j]] <- z[j]
        k <- k+2**(J-i)
        filter.seq <- paste(filter.seq, "L", sep = "")
        h <- wavelet.filter(wf.name = "haar", filter.seq = filter.seq)
        }
        res <- res*sqrt(n)
        res <- data.frame(res)
        row.names(res) <- paste("u", 1:n, sep = "")
        names(res) <- paste("B", 1:(n-1), sep = "")
return(res)
}
    
# suivant que n est grand (n > 257) ou non, on choisit l'une des deux stratgies :
    if (n < 257)
        res <- haar.basis.1(n)
        else
            res <- haar.basis.2(n)
    
    attr(res,"values") <- NULL
    attr(res,"weights") <- rep(1/n,n)
    attr(res,"call") <- appel
    attr(res,"class") <- c("orthobasis","data.frame")
    return(res)
}

"orthobasis.line" <- function (n) {
    appel = match.call()
    # solution de Cornillon p. 12
    res <- NULL
    r2 <- sqrt(2)
    for (k in 1:(n-1)) {
        x <- cos(k*pi*(2*(1:n)-1)/2/n)
        x <- sqrt(n)*x/sqrt(sum(x*x))
        res <-c(res,x)
    }
    res=matrix(res,n)
    res <- data.frame(res)
    row.names(res) <- paste("u",1:n,sep="")
    names(res) <- paste("B",1:(n-1),sep="")
    w <- (1:(n-1))*pi/2/n
    valpro <- 4*(sin(w)^2)/n
    poivoisi <- c(1,rep(2,n-2),1)
    poivoisi <- poivoisi/sum(poivoisi)
    norm <- unlist(apply(res, 2, function(a) sum(a*a*poivoisi)))
    y <- valpro*n*n/2/(n-1)
    val <- norm - y
    attr(res,"values") <- val
    attr(res,"weights") <- rep(1/n,n)
    attr(res,"call") <- appel
    attr(res,"class") <- c("orthobasis","data.frame")
    
    # vrification locale. Ce paragraphe vrifie que les vecteurs et les valeurs
    # propose par Cornillon p. 12 sont bien les vecteurs propres de l'oprateur de voisinage
    # range dans la solution analytique par variance locale croissante
    # l'article de Mot est erron et a donn le graphe circulaire pour le graphe linaire
    # d0=neig2mat(neig(n.lin=n))
    # d0 = d0/n
    # d1=apply(d0,1,sum)
    # d0=diag(d1)-d0
    # fun2 <- function(x) {
    #     z <- sum(t(d0*x)*x)/n
    #     z <- z/sum(x*x)
    #     return(z)
    # }
    # lambda <- unlist(apply(res,2,fun2))
    # print(lambda)
    # print(attr(res,"values"))
    # plot(lambda,attr(res,"values"))
    # abline(lm(attr(res,"values")~lambda))
    # print(coefficients(lm(attr(res,"values")~lambda)))
    
    # vrification que les valeurs drives des valeurs propres sont exactement des indices de Moran
    # d = neig2mat(neig(n.lin=n))
    # d = d/sum(d) # Moran type W
    # moran <- unlist(lapply(res,function(x) sum(t(d*x)*x)))
    # print(moran)
    # plot(moran,attr(res,"values"))
    # abline(lm(attr(res,"values")~moran))
    # print(summary(lm(attr(res,"values")~moran)))
    return(res)
} 
    
"orthobasis.circ" <- function (n) {
    appel = match.call()
    if (n<3) stop ("'n' too small")
    "vecprosin" <- function(k) {
        x <- sin(2*k*pi*(1:n)/n)
        x <- x/sqrt(sum(x*x))
    }
    "vecprocos" <- function(k) {
        x <- cos(2*k*pi*(1:n)/n)
        x <- x/sqrt(sum(x*x))
    }
    "valpro" <- function(k,bis=TRUE) {
        x <- (4/n)*((sin(k*pi/n))^2)
        if (bis) x <- c(x,x)
        return(x)
    }
    
    k <- floor(n/2)
    if (k==n/2) {
        #n est pair
        w1 <- matrix(unlist(lapply(1:k,vecprocos)),n,k)
        w2 <- matrix(unlist(lapply(1:(k-1),vecprosin)),n,k-1)
        res <- cbind(w1,w2)
        res[,seq(1,2*k-1,by=2)]<-w1
        res[,seq(2,2*k-2,by=2)]<-w2
        vp <- unlist(lapply(1:(k-1),valpro))
        vp <- c(vp, valpro(k,FALSE))
    } else {
        # n est impair
        w1 <- matrix(unlist(lapply(1:k,vecprocos)),n,k)
        w2 <- matrix(unlist(lapply(1:k,vecprosin)),n,k)
        res <- cbind(w1,w2)
        res[,seq(1,2*k-1,by=2)]<-w1
        res[,seq(2,2*k,by=2)]<-w2
        vp <- unlist(lapply(1:k,valpro))
    }
    res=sqrt(n)*res
    res <- as.data.frame(res)
    row.names(res) <- paste("u",1:n,sep="")
    names(res) <- paste("B",1:(n-1),sep="")
    attr(res,"values") <- 1 - n*vp/2
    attr(res,"weights") <- rep(1/n,n)
    attr(res,"call") <- appel
    attr(res,"class") <- c("orthobasis","data.frame")        
    # vrification qu'on a exactement des indices de Moran  partie des valeurs propres
    # d = neig2mat(neig(n.cir=n))
    # d = d/sum(d) # Moran type W
    # moran <- unlist(lapply(res,function(x) sum(t(d*x)*x)))
    # print(moran)
    # plot(moran,attr(res,"values"))
    # abline(lm(attr(res,"values")~moran))
    # print(summary(lm(attr(res,"values")~moran)))
    return(res)
}

"orthobasis.listw" <- function( listw) {
    appel = match.call()
    if(!inherits(listw,"listw")) stop ("object of class 'listw' expected") 
    if(listw$style!="W") stop ("object of class 'listw' with style 'W' expected") 
    n = length(listw$weights)
    fun <- function (x) {
        num = listw$neighbours[[x]]
        wei = listw$weights[[x]]
        res = rep(0,n)
        res[num] = wei
        return (res)
    }
    b0 <- matrix(unlist(lapply(1:n,fun)),n,n)
    b0=(t(b0)+b0)/2 
    b0=bicenter.wt(b0)
    a0 <- eigen(b0, sym = TRUE)
    #barplot(a0$values)
    a0 <- a0$vectors
    a0 <- cbind(rep(1,n),a0)
    a0 <- qr.Q(qr(a0))
    a0 <- as.data.frame(a0[,-1])*sqrt(n)
    row.names(a0) <- attr(listw,"region.id")
    names(a0) <- paste("VP", 1:(n-1), sep = "")
    z <- apply(a0,2,function(x) sum((t(b0*x)*x))/n)
    attr(a0,"values") <- z
    attr(a0,"weights") <- rep(1/n,n)
    attr(a0,"call") <- appel
    attr(a0,"class") <- c("orthobasis","data.frame")        
    return(a0)
}


"orthobasis.neig" <- function( neig) {
    appel = match.call()
    if(!inherits(neig,"neig")) stop ("object of class 'neig' expected")
    n <- length(attr(neig,"degree"))
    m <- sum(attr(neig,"degree"))
    poivoisi <- attr(neig,"degree")/m
    if (is.null(names(poivoisi))) names(poivoisi) <- as.character(1:n)
    d0 = neig2mat(neig)
    d0 = diag(poivoisi)-d0/m
    eig <- eigen(d0, sym = TRUE)
    ########
    tol <- 1e-07
    w0 <- abs(eig$values)/max(abs(eig$values))
    w0 <- which(w0<tol)
    if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
    else if (length(w0)==1) w0 <- (1:n)[-w0]
    else if (length(w0)>1) {
        # on ajoute le vecteur driv de 1n 
        wt <- rep(1,n)
        w <- cbind(wt,eig$vectors[,w0])
        # on orthonormalise l'ensemble
        w <- qr.Q(qr(w))
        # on met les valeurs propres  0
        eig$values[w0] <- 0
        # on remplace les vecteurs du noyau par une base orthonorme contenant 
        # en premire position le parasite
        eig$vectors[,w0] <- w[,-ncol(w)]
        # on enlve la position du parasite
        w0 <- (1:n)[-w0[1]]
    }
    w0 <- rev(w0)
    valpro <- eig$values[w0]
    eig <- eig$vectors[,w0]
    eig <- as.data.frame(eig)*sqrt(n)
    z <- apply(eig,2,function(x) sum(x*x*poivoisi))
    z <- z - valpro*n
    w <- rev(order(z))
    z <- z[w]
    eig <- eig[,w]
    row.names(eig) <- names(poivoisi)
    names(eig) <- paste("VP", 1:(n-1), sep = "")
    attr(eig,"values") <- z
    attr(eig,"weights") <- rep(1/n,n)
    attr(eig,"call") <- appel
    attr(eig,"class") <- c("orthobasis","data.frame")        
    return(eig)
}
"orthogram"<- function (x, orthobas = NULL, neig = NULL, phylog = NULL,
    nrepet = 999, posinega = 0, tol = 1e-07,
    na.action = c("fail", "mean"), 
    cdot = 1.5, cfont.main = 1.5, lwd = 2, nclass, high.scores = 0) 
{
    "orthoneig" <- function (obj) {
        tol <- 1e-07
        if (!inherits(obj, "neig")) 
            stop("Object of class 'neig' expected")
        b0 <- neig.util.LtoG(obj)
        deg <- attr(obj, "degrees")
        m <- sum(deg)
        n <- length(deg)
        b0 <- -b0/m + diag(deg)/m
        # b0 est la matrice D-P
        eig <- eigen (b0, sym = TRUE)
        w0 <- abs(eig$values)/max(abs(eig$values))
        w0 <- which(w0<tol)
        if (length(w0)==0) stop ("abnormal output : no null eigenvalue")
        if (length(w0)==1) w0 <- (1:n)[-w0]
        else if (length(w0)>1) {
            # on ajoute le vecteur driv de 1n 
            w <- cbind(rep(1,n),eig$vectors[,w0])
            # on orthonormalise l'ensemble
            w <- qr.Q(qr(w))
            # on met les valeurs propres  0
            eig$values[w0] <- 0
            # on remplace les vecteurs du noyau par une base orthonorme contenant 
            # en premire position le parasite
            eig$vectors[,w0] <- w[,-ncol(w)]
            # on enlve la position du parasite
            w0 <- (1:n)[-w0[1]]
        }
        w0=rev(w0)
        rank <- length(w0)
        values <- n-eig$values[w0]*n
        eig <- eig$vectors[,w0]*sqrt(n)
        eig <- data.frame(eig)
        row.names(eig) <- names(deg)
        names(eig) <- paste("V",1:rank,sep="")
        attr(eig,"values")<-values
        eig
    }

    if (!is.numeric(x)) stop("x is not numeric")
    nobs <- length(x)
    if (!is.null(orthobas)) cas <- "orthobas"
    else if (!is.null(neig)) {
        cas <- "neig"
        orthobas <- orthoneig(neig)
    } else if (!is.null(phylog)) {
         if (!inherits(phylog, "phylog")) stop ("'phylog' expected with class 'phylog'")
         orthobas <- phylog$Bscores
    } else stop ("'orthobas','neig','phylog' all NULL")
    
    if (!inherits(orthobas, "data.frame")) stop ("'orthobas' is not a data.frame")
    if (nrow(orthobas) != nobs) stop ("non convenient dimensions")
    if (ncol(orthobas) != (nobs-1)) stop (paste("'orthobas' has",ncol(orthobas),"columns, expected:",nobs-1))
    vecpro <- as.matrix(orthobas)
    npro <- ncol(vecpro) 
    if (any(is.na(x))) {
        if (na.action == "fail") 
            stop("missing value in 'x'")
        else if (na.action == "mean") 
            x[is.na(x)] <- mean(na.omit(x))
        else stop("unknown method for 'na.action'")
    }
    w <- t(vecpro/nobs)%*%vecpro
    if (any(abs(diag(w)-1)>1e-07)) {
        # print(abs(diag(w)-1))
        stop("'orthobas' is not orthonormal for uniform weighting")
    }
    diag(w) <- 0
    if ( any( abs(as.numeric(w))>1e-07) ) stop("'orthobas' is not orthogonal for uniform weighting")
    if (nrepet < 99) nrepet <- 99
    if (posinega !=0) {
        if (posinega >= nobs-1) stop ("Non convenient value in 'posinega'")
        if (posinega <0) stop ("Non convenient value in 'posinega'")
    }
    
    # prparation d'un graphique  6 fentres
    # 1 pgram
    # 2 pgram cumul
    # 3-6 Tests de randomisation
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    layout (matrix(c(1,1,2,2,1,1,2,2,3,4,5,6),4,3))
    mar.old <- par("mar")
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    par("usr"=c(0,1,-0.05,1))
    # layout.show(6)
    
    z <- x - mean(x)
    et <- sqrt(mean(z * z))
    if ( et <= tol*(max(z)-min(z))) stop ("No variance")
    z <- z/et
    sig50 <- (1:npro)/npro
    w <- .C("VarianceDecompInOrthoBasis",
        param = as.integer(c(nobs,npro,nrepet,posinega)),
        observed = as.double(z),
        vecpro = as.double(vecpro),
        phylogram = double(npro),
        phylo95 = double(npro),
        sig025 = double(npro),
        sig975 = double(npro),
        R2Max = double(nrepet+1),
        SkR2k = double(nrepet+1), 
        Dmax = double(nrepet+1), 
        SCE = double(nrepet+1), 
        ratio = double(nrepet+1),
        PACKAGE="ade4"
    )
   ylim <- max(c(w$phylogram, w$phylo95))
   z0 <- apply(vecpro, 2, function(x) sum(z * x))
   names(w$phylogram) <- as.character(1:npro)
   phylocum <- cumsum(w$phylogram)
   lwd0=2
   fun <- function (y, last=FALSE) {
        delta <- (mp[2]-mp[1])/3
        sel <- 1:(npro - 1)
        segments(mp[sel]-delta,y[sel],mp[sel]+delta, y[sel],lwd=lwd0)
        if(last) segments(mp[npro]-delta,y[npro],mp[npro]+delta, y[npro],lwd=lwd0)
    }
    y0 <- phylocum - sig50
    h.obs <- max(y0)
    x0 <- min(which(y0 == h.obs))
    par(mar = c(3.1, 2.5, 2.1, 2.1))
    mp <- barplot(w$phylogram, col = grey(1 - 0.3 * (sign(z0) > 0)), 
            ylim = c(0, ylim * 1.05))
    scores.order <- (1:length(w$phylogram))[order(w$phylogram, decreasing=TRUE)[1:high.scores]]
    fun(w$phylo95,TRUE)
    abline(h = 1/npro)
    if (posinega!=0) {
        verti = (mp[posinega]+mp[posinega+1])/2
        abline (v=verti, col="red",lwd=1.5)
    }
    title(main = "Variance decomposition",font.main=1, cex.main=cfont.main)
    box()
    obs0 <- rep(0, npro)
    names(obs0) <- as.character(1:npro)
    barplot(obs0, ylim = c(-0.05, 1.05))
    abline(h=0,col="white")
    if (posinega!=0) {
        verti = (mp[posinega]+mp[posinega+1])/2
        abline (v=verti, col="red",lwd=1.5)
    }

    title(main = "Cumulative decomposition",font.main=1, cex.main=cfont.main)
    points(mp, phylocum, pch = 21, cex = cdot, type = "b")
    segments(mp[1], 1/npro, mp[npro], 1, lty = 1)
    fun(w$sig975)
    fun(w$sig025)
    arrows(mp[x0], sig50[x0], mp[x0], phylocum[x0], ang = 15, le = 0.15, 
            lwd = 2)
    box()
    if (missing(nclass)) {
        nclass <- as.integer (nrepet/25)
        nclass <- min(c(nclass,40))
    }
    plot.randtest (as.randtest (w$R2Max[-1],w$R2Max[1],call=match.call()),main = "R2Max",nclass=nclass)
    if (posinega !=0) {
        plot.randtest (as.randtest (w$ratio[-1],w$ratio[1],call=match.call()),main = "Ratio",nclass=nclass)
    } else {
        plot.randtest (as.randtest (w$SkR2k[-1],w$SkR2k[1],call=match.call()),main = "SkR2k",nclass=nclass)
    }
    plot.randtest (as.randtest (w$Dmax[-1],w$Dmax[1],call=match.call()),main = "DMax",nclass=nclass)
    plot.randtest (as.randtest (w$SCE[-1],w$SCE[1],call=match.call()),main = "SCE",nclass=nclass)
    
    w$param <- w$observed <- w$vecpro <- NULL
    w$phylogram <- NULL
    w$phylo95 <- w$sig025 <- w$sig975 <- NULL
    if (posinega==0) w$ratio <- NULL
    attr(w,"call") <- match.call()
    attr(w,"class") <- "krandtest"

    if (high.scores != 0)
        return(w, scores.order)
    
        else
            return(w)
}
"pcaiv" <- function (dudi, df, scannf = TRUE, nf = 2) {
    lm.pcaiv <- function(x, df, weights, use) {
        if (!inherits(df, "data.frame")) 
            stop("data.frame expected")
        reponse.generic <- x
        begin <- "reponse.generic ~ "
        fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
        df <- cbind.data.frame(reponse.generic, df)
        lm0 <- lm(fmla, data = df, weights = weights)
        if (use == 0) 
            return(predict(lm0))
        else if (use == 1) 
            return(residuals(lm0))
        else if (use == -1) 
            return(lm0)
        else stop("Non convenient use")
    }
    if (!inherits(dudi, "dudi")) 
        stop("dudi is not a 'dudi' object")
    df <- data.frame(df)
    if (!inherits(df, "data.frame")) 
        stop("df is not a 'data.frame'")
    if (nrow(df) != length(dudi$lw)) 
        stop("Non convenient dimensions")
    weights <- dudi$lw
    isfactor <- unlist(lapply(as.list(df), is.factor))
    for (i in 1:ncol(df)) {
        if (!isfactor[i]) 
            df[, i] <- scalewt(df[, i], weights)
    }
    tab <- data.frame(apply(dudi$tab, 2, lm.pcaiv, df = df, use = 0, 
        weights = dudi$lw))
    X <- as.dudi(tab, dudi$cw, dudi$lw, scannf = scannf, nf = nf, 
        call = match.call(), type = "pcaiv")
    X$X <- df
    X$Y <- dudi$tab
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- as.matrix(dudi$tab) %*% U
    U <- data.frame(U)
    row.names(U) <- row.names(dudi$tab)
    names(U) <- names(X$li)
    X$ls <- U
    sumry <- array("", c(X$nf, 7), list(rep("", X$nf), c("iner", 
        "inercum", "inerC", "inercumC", "ratio", "R2", "lambda")))
    sumry[, 1] <- signif(dudi$eig[1:X$nf], dig = 3)
    sumry[, 2] <- signif(cumsum(dudi$eig[1:X$nf]), dig = 3)
    varpro <- apply(U, 2, function(x) sum(x * x * dudi$lw))
    sumry[, 3] <- signif(varpro, dig = 3)
    sumry[, 4] <- signif(cumsum(varpro), dig = 3)
    sumry[, 5] <- signif(cumsum(varpro)/cumsum(dudi$eig[1:X$nf]), 
        dig = 3)
    sumry[, 6] <- signif(X$eig[1:X$nf]/varpro, dig = 3)
    sumry[, 7] <- signif(X$eig[1:X$nf], dig = 3)
    class(sumry) <- "table"
    X$param <- sumry
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
    row.names(U) <- names(dudi$li)
    names(U) <- names(X$li)
    X$as <- U
    w <- apply(X$ls, 2, function(x) coefficients(lm.pcaiv(x, 
        df, weights, -1)))
    w <- data.frame(w)
    names(w) <- names(X$l1)
    X$fa <- w
    fmla <- as.formula(paste("~ ", paste(names(df), collapse = "+")))
    w <- scalewt(model.matrix(fmla, data = df), weights) * weights
    w <- t(w) %*% as.matrix(X$l1)
    w <- data.frame(w)
    X$cor <- w
    return(X)
}

"plot.pcaiv" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "pcaiv")) 
        stop("Use only with 'pcaiv' objects")
    if (x$nf == 1) {
        warnings("One axis only : not yet implemented")
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    s.arrow(x$fa, xax, yax, sub = "Loadings", csub = 2, 
        clab = 1.25)
    s.arrow(na.omit(x$cor), xax = xax, yax = yax, sub = "Correlation", 
        csub = 2, clab = 1.25)
    s.corcircle(x$as, xax, yax, sub = "Inertia axes", csub = 2)
    s.match(x$li, x$ls, xax, yax, clab = 1.5, sub = "Scores and predictions", 
        csub = 2)
    if (inherits(x, "cca")) 
        s.label(x$co, xax, yax, clab = 0, cpoi = 3, add.p = TRUE)
    if (inherits(x, "cca")) 
        s.label(x$co, xax, yax, clab = 1.25, sub = "Species", 
            csub = 2)
    else s.arrow(x$c1, xax = xax, yax = yax, sub = "Variables", 
        csub = 2, clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
}

"print.pcaiv" <- function (x, ...) {
    if (!inherits(x, "pcaiv")) 
        stop("to be used with 'pcaiv' object")
    cat("Principal Component Analysis with Instrumental Variables\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$rank (rank)     :", x$rank)
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(3, 4), list(rep("", 3), c("vector", 
        "length", "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (from dudi)")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (from dudi)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(3, 4), list(rep("", 3), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$Y", nrow(x$Y), ncol(x$Y), "Dependant variables")
    sumry[2, ] <- c("$X", nrow(x$X), ncol(x$X), "Explanatory variables")
    sumry[3, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array (projected variables)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "PPA Pseudo Principal Axes")
    sumry[2, ] <- c("$as", nrow(x$as), ncol(x$as), "Principal axis of dudi$tab on PAP")
    sumry[3, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "projection of lines of dudi$tab on PPA")
    sumry[4, ] <- c("$li", nrow(x$li), ncol(x$li), "$ls predicted by X")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(4, 4), list(rep("", 4), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$fa", nrow(x$fa), ncol(x$fa), "Loadings (CPC as linear combinations of X")
    sumry[2, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "CPC Constraint Principal Components")
    sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "inner product CPC - Y")
    sumry[4, ] <- c("$cor", nrow(x$cor), ncol(x$cor), "correlation CPC - X")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    print(x$param)
    cat("\n")
}
"pcaivortho" <- function (dudi, df, scannf = TRUE, nf = 2) {
    lm.pcaiv <- function(x, df, weights, use) {
        if (!inherits(df, "data.frame")) 
            stop("data.frame expected")
        reponse.generic <- x
        begin <- "reponse.generic ~ "
        fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
        df <- cbind.data.frame(reponse.generic, df)
        lm0 <- lm(fmla, data = df, weights = weights)
        if (use == 0) 
            return(predict(lm0))
        else if (use == 1) 
            return(residuals(lm0))
        else if (use == -1) 
            return(lm0)
        else stop("Non convenient use")
    }
    if (!inherits(dudi, "dudi")) 
        stop("dudi is not a 'dudi' object")
    df <- data.frame(df)
    if (!inherits(df, "data.frame")) 
        stop("df is not a 'data.frame'")
    if (nrow(df) != length(dudi$lw)) 
        stop("Non convenient dimensions")
    weights <- dudi$lw
    isfactor <- unlist(lapply(as.list(df), is.factor))
    for (i in 1:ncol(df)) {
        if (!isfactor[i]) 
            df[, i] <- scalewt(df[, i], weights)
    }
    tab <- data.frame(apply(dudi$tab, 2, lm.pcaiv, df = df, use = 1, 
        weights = dudi$lw))
    X <- as.dudi(tab, dudi$cw, dudi$lw, scannf = scannf, nf = nf, 
        call = match.call(), type = "pcaivortho")
    X$X <- df
    X$Y <- dudi$tab
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- as.matrix(dudi$tab) %*% U
    U <- data.frame(U)
    row.names(U) <- row.names(dudi$tab)
    names(U) <- names(X$li)
    X$ls <- U
    sumry <- array("", c(X$nf, 7), list(rep("", X$nf), c("iner", 
        "inercum", "inerC", "inercumC", "ratio", "R2", "lambda")))
    sumry[, 1] <- signif(dudi$eig[1:X$nf], dig = 3)
    sumry[, 2] <- signif(cumsum(dudi$eig[1:X$nf]), dig = 3)
    varpro <- apply(U, 2, function(x) sum(x * x * dudi$lw))
    sumry[, 3] <- signif(varpro, dig = 3)
    sumry[, 4] <- signif(cumsum(varpro), dig = 3)
    sumry[, 5] <- signif(cumsum(varpro)/cumsum(dudi$eig[1:X$nf]), 
        dig = 3)
    sumry[, 6] <- signif(X$eig[1:X$nf]/varpro, dig = 3)
    sumry[, 7] <- signif(X$eig[1:X$nf], dig = 3)
    class(sumry) <- "table"
    X$param <- sumry
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
    row.names(U) <- names(dudi$li)
    names(U) <- names(X$li)
    X$as <- U
    return(X)
}
"pcoscaled" <- function (distmat, tol = 1e-07) {
    if (!inherits(distmat, "dist")) 
        stop("Object of class 'dist' expected")
    if (!is.euclid(distmat)) 
        stop("Euclidean distance expected")
    lab <- attr(distmat, "Labels")
    distmat <- dist2mat(distmat)
    n <- ncol(distmat)
    if (is.null(lab)) 
        lab <- as.character(1:n)
    delta <- -0.5 * bicenter.wt(distmat * distmat)
    eig <- eigen(delta, symmetric = TRUE)
    w0 <- eig$values[n]/eig$values[1]
    if ((w0 < -tol)) 
        stop("Euclidean distance matrix expected")
    ncomp <- sum(eig$values > (eig$values[1] * tol))
    x <- eig$vectors[, 1:ncomp]
    variances <- eig$values[1:ncomp]
    x <- t(apply(x, 1, "*", sqrt(variances)))
    inertot <- sum(variances)
    x <- x/sqrt(inertot)
    x <- x*sqrt(n)
    x <- data.frame(x)
    names(x) <- paste("C", 1:ncomp, sep = "")
    row.names(x) <- lab
    return(x)
}
"print.phylog" <- function (x, ...) {
    phylog <- x
    if (!inherits(phylog, "phylog")) 
        stop("for 'phylog' object")
   leaves.n <- length(phylog$leaves)
    nodes.n <- length(phylog$nodes)
     cat("Phylogenetic tree with",leaves.n,"leaves and",nodes.n,"nodes\n")
    cat("$class: ")
    cat(class(phylog))
    cat("\n$call: ")
    print(phylog$call)
    cat("$tre: ")
    l0 <- nchar(phylog$tre)
    if (l0 < 50) 
        cat(phylog$tre, "\n")
    else {
        cat(substring(phylog$tre, 1, 25))
        cat("...")
        cat(substring(phylog$tre, l0 - 26, l0), "\n")
    }
    cat("\n")
    n1 <-paste("$",names(phylog)[2:6],sep="")
    sumry <- array(" ", c(length(n1), 3), list(n1, c("class", "length", "content")))
    # leaves
    k <- 1; sumry[k,1] <- "numeric" ; sumry[k,2] <- as.character(length(phylog$leaves))
    sumry[k,3] <- "length of the first preceeding adjacent edge"
    #nodes
    k <- 2 ; sumry[k,1] <- "numeric" ; sumry[k,2] <- as.character(length(phylog$nodes))
    sumry[k,3]  <- "length of the first preceeding adjacent edge"
    #parts
    k <-3; sumry[k,1] <- "list";sumry[k,2] <- as.character(length(phylog$parts))
    sumry[k,3]  <- "subsets of descendant nodes"
    #paths
    k = 4; sumry[k,1] <- "list";sumry[k,2] <- as.character(length(phylog$paths))
    sumry[k,3]  <- "path from root to node or leave"
    #droot
    k = 5; sumry[k,1] <- "numeric";sumry[k,2] <- as.character(length(phylog$droot))
    sumry[k,3]  <- "distance to root"
    print.noquote(sumry)
    cat("\n")
    if (is.null(phylog$Wmat)) return(invisible())

    n1 <- names(phylog)[-(1:7)]
    n1 <- n1 <-paste("$",n1,sep="")
    sumry <- array(" ", c(length(n1), 3), list(n1, c("class", "dim", "content")))
    # 8 Wmat
    k = 1
    sumry[k,1] <- "matrix"
    sumry[k,2] <- paste(nrow(phylog$Wmat),ncol(phylog$Wmat),sep="-")
    sumry[k,3] <- "W matrix : root to the closest ancestor"
    #9 Wdist
    k = 2
    sumry[k,1] <- "dist" ; 
    sumry[k,2] <- as.character(length(phylog$Wdist))
    sumry[k,3] <- "Nodal distances"
    # 10 Wvalues
    k = 3
    sumry[k,1] <- "numeric"
    sumry[k,2] <- length(phylog$Avalues)
    sumry[k,3] <- "Eigen values of QWQ/sum(Q)"
    #11 "Wscores"
    k = 4
    sumry[k,1] <- "data.frame"
    sumry[k,2] <- paste(nrow(phylog$Wscores),ncol(phylog$Wscores),sep="-")
    sumry[k,3] <- "Eigen vectors of QWQ '1/n' normed"
    #12 "Amat" 
    k = 5
    sumry[k,1] <- "matrix"
    sumry[k,2] <- paste(nrow(phylog$Amat),ncol(phylog$Amat),sep="-")
    sumry[k,3] <- "Topological proximity matrix A"
    #13 Avalues
    k = 6
    sumry[k,1] <- "numeric"
    sumry[k,2] <- length(phylog$Avalues)
    sumry[k,3] <- "Eigen values of QAQ matrix"
    #14 Adim
    k = 7
    sumry[k,1] <- "integer"
    sumry[k,2] <- "1"
    sumry[k,3] <- "number of positive eigen values of QAQ"  
    #15 Ascores
    k = 8
    sumry[k,1] <- "data.frame"
    sumry[k,2] <- paste(nrow(phylog$Ascores),ncol(phylog$Ascores),sep="-")
    sumry[k,3] <- "Eigen vectors of QAQ '1/n' normed"
    #16 Aparam
    k = 9
    sumry[k,1] <- "data.frame"
    sumry[k,2] <- paste(nrow(phylog$Aparam),ncol(phylog$Aparam),sep="-")
    sumry[k,3] <- "Topological indices for nodes"   
    # 17 Bindica
    k = 10 
    sumry[k,1] <- "data.frame"
    sumry[k,2] <- paste(nrow(phylog$Bindica),ncol(phylog$Bindica),sep="-")
    sumry[k,3] <- "class indicator from nodes"   
    # 18 Bscores
    k = 11 
    sumry[k,1] <- "data.frame"
    sumry[k,2] <- paste(nrow(phylog$Bscores),ncol(phylog$Bscores),sep="-")
    sumry[k,3] <- "Topological orthonormal basis '1/n' normed"   
    # 19 Bvalues
    k=12
    sumry[k,1] <- "numeric"
    sumry[k,2] <- length(phylog$Bvalues)
    sumry[k,3] <- "xtWx values for orthonormal basis"
    # 20 Blabels
    k=13
    sumry[k,1] <- "character"
    sumry[k,2] <- length(phylog$Blabels)
    sumry[k,3] <- "Nodes labelling from orthonormal basis"
    print.noquote(sumry)
    return(invisible())
}

#######################################################################################
phylog.extract<-function(phylog,node,distance=TRUE){
    #extrait d'une phylognie phylog le sous-arbre enracin au noeud node
    #il serait intressant de traduire cett fonction en C
    #en ne travaillant que sur les chaines de caractres newick
    tre2tre<-function(res){
        # cette fonction assure la conversion de l'objet res
        # en son quivalent munie des distances
        # on affecte les distances au noeud le plus proche pour chaque feuilles et noeuds
        for(i in 1:length(leaves.names)) {
            res<- sub(paste(leaves.names[i],",",sep=""),paste(leaves.names[i],":",phylog$leaves[i],",",sep=""),res)
        }
        for(i in 1:length(leaves.names)) {
            res<- sub(paste(leaves.names[i],")",sep=""),paste(leaves.names[i],":",phylog$leaves[i],")",sep=""),res)
        }
        for(i in 1:length(nodes.names)) {
            res<- sub(paste(nodes.names[i],",",sep=""),paste(nodes.names[i],":",phylog$nodes[i],",",sep=""),res)
        }
        for(i in 1:length(nodes.names)) {
            res<- sub(paste(nodes.names[i],")",sep=""),paste(nodes.names[i],":",phylog$nodes[i],")",sep=""),res)
        }
        res
    }

    #variables locales
    add.t <- !is.null(phylog$Wmat)
    tre<-phylog$tre
    nodes.names<- names(phylog$nodes)
    leaves.names<- names(phylog$leaves)
    node.number<- grep(node, nodes.names)

    #on dtermine la feuilles la plus  gauche associe au noeud
    leave<-node
    k<-0
    while(length(grep(leave,leaves.names))==0) {
        k<-k+1
        leave.number<-grep(leave, nodes.names)[1]
        leave<-phylog$parts[[leave.number]][1]
    }

    #on construit la chaine de caractre associe  l'arbre enracin au noeud
    leave.pos<-regexpr(leave,tre)
    node.pos<-regexpr(node,tre)
    res<-substr(tre,leave.pos,node.pos-1) 
    res<-paste(res,node,sep="")
    if (k==0) parentheses<-"" else parentheses<-"("
    if (k > 1) {
        for(i in 2:k){
            parentheses<-paste(parentheses,"(", sep="")
        }
    }
    res<-(paste(parentheses, res, sep=""))
    res <- paste(res,";",sep="")
    if (distance) res<-tre2tre(res)
return(res)
   res <- newick2phylog(res, add.tools= add.t,call=match.call())
   res
}

#######################################################################################
phylog.permut <- function(phylog,list.nodes = NULL, distance = TRUE){
    if (is.null(list.nodes)) list.nodes <- lapply(phylog$parts,function(a) if (length(a)==1) a else sample(a))
    #############################
    adddistances<-function(){
        # cette fonction assure la conversion de tre
        # en son quivalent muni des distances
        for(i in 1:length(leaves.names)) {
             tre<<- sub(paste(leaves.names[i],",",sep=""),paste(leaves.names[i],":",phylog$leaves[i],",",sep=""),tre,extended=FALSE)
        }
        for(i in 1:length(leaves.names)) {
            tre<<- sub(paste(leaves.names[i],")",sep=""),paste(leaves.names[i],":",phylog$leaves[i],")",sep=""),tre,extended=FALSE)
        }
      for(i in 1:length(nodes.names)) {
            tre<<- sub(paste(nodes.names[i],",",sep=""),paste(nodes.names[i],":",phylog$nodes[i],",",sep=""),tre,extended=FALSE)
        }
        for(i in 1:length(nodes.names)) {
            tre<<- sub(paste(nodes.names[i],")",sep=""),paste(nodes.names[i],":",phylog$nodes[i],")",sep=""),tre,extended=FALSE)
        }
    }
    #############################
    extract<-function(node) {
        # extrait de tre le sous-arbre enracin au noeud node
        # il serait intressant de traduire cett fonction en C,
        # en ne travaillant que sur les chaines de caractres newick
        # node.number<- grep(node, nodes.names)
        # on dtermine la feuilles la plus  gauche associe au noeud
        # utilise la liste phylogparts contenant les descendants
        leave <- node
        k <- 0
        while(length(grep(leave,leaves.names))==0) {
            k <- k+1
            leave <- phylogparts[[leave]][1]
        }
        #on construit la chaine de caractre associe  l'arbre enracin au noeud
        if (regexpr(paste(leave,")",sep=""),tre) == -1) {
            leave.pos <- regexpr(paste(leave,",",sep=""),tre)
        } else { 
            leave.pos <- regexpr(paste(leave,")",sep=""),tre)            
        }
        if (regexpr(paste(node,")",sep=""),tre) == -1) {
            node.pos <- regexpr(paste(node,",",sep=""),tre)
        } else { 
            node.pos <- regexpr(paste(node,")",sep=""),tre)            
        }
        res<-substr(tre,leave.pos,node.pos-1) 
        res<-paste(res,node,sep="")
        if (k==0) parentheses<-"" else parentheses<-"("
        if(k > 1) {
            for(i in 2:k){
                parentheses<-paste(parentheses,"(", sep="")
            }
        }
        res<-(paste(parentheses, res, sep=""))
        return(res)
    }
    #############################
    permute <- function (node) {
        # cette fonction assure la permutation dans tre des branches descendantes du noeud node
        # on remplace l'ordre initial conserv dans phylogparts[[node]]
        # par l'ordre final conserv dans list.nodes[[node]]
        # phylogparts[[node]] est mis  jour  la sortie
        new.part <- list.nodes[[node]]
        if (length(new.part)==1) return(invisible())
        old.part <- phylogparts[[node]]
        if (all (old.part==new.part)) return(invisible())
        for (k in 1:(length(new.part)-1)) {
            if (old.part[k]!=new.part[k]) {
                n1 <- old.part[k]
                n2 <- new.part[k]
                u1 <- extract(n1)
                u1.pos <- regexpr(paste(u1,"[,);]",sep=""),tre,ext=FALSE)
                u1.fin <- u1.pos+attr(u1.pos,"match.length")-1
                lastcar1 <- substring(tre, u1.fin, u1.fin)
                u2 <- extract(n2)
                u2.pos<-regexpr(paste(u2,"[,);]",sep=""),tre,ext=FALSE)
                u2.fin <- u2.pos+attr(u2.pos,"match.length")-1
                lastcar2 <- substring(tre, u2.fin, u2.fin)
                tre <<- sub(paste(u1,lastcar1,sep=""),"Restunlogicielformidable",tre,extended=FALSE)
                tre <<- sub(paste(u2,lastcar2,sep=""), paste(u1,lastcar2,sep=""),tre,extended=FALSE)
                tre <<- sub("Restunlogicielformidable",paste(u2,lastcar1,sep=""), tre,extended=FALSE)
                old.part[old.part==n1] <- "1234564789"
                old.part[old.part==n2] <- n1
                old.part[old.part=="1234564789"] <- n2
             }
        }
        phylogparts[[node]] <<- new.part
    }    
    #############################
    verif <- function(node) {
        new.part <- sort(list.nodes[[node]])
        old.part <- sort(phylogparts[[node]])
        if (!(all(new.part==old.part))) return (FALSE)
        return (TRUE)
    }
    if(!inherits(phylog,"phylog")) stop ("Object with class 'phylog' expected")
    nodes.names<- names(phylog$nodes)
    nodes.number<- length(nodes.names)
    leaves.names<- names(phylog$leaves)
    droot <- phylog$droot
    new.names <- names(list.nodes)
    phylogparts <- phylog$parts
    phylogleaves <- phylog$leaves
    if (any(!new.names%in%nodes.names)) stop ("Non convient name in 'list.nodes'")
    wverif <- unlist(lapply(new.names,verif))
    if (any(!wverif)) stop ("Non convient content in 'list.nodes'")
    tre <- phylog$tre
    add.t <- !is.null(phylog$Wmat)
    for (node in new.names) permute(node)
    if (distance) adddistances ()
    res <- newick2phylog(tre, add.tools= add.t, call = match.call())
    return(res)
}
"plot.phylog" <- function (x, y = NULL,
    f.phylog = 0.5, cleaves = 1, cnodes = 0,
    labels.leaves = names(x$leaves), clabel.leaves = 1,
    labels.nodes = names(x$nodes), clabel.nodes = 0,
    sub = "", csub = 1.25, possub = "bottomleft", draw.box = FALSE, ...)
 {
    if (!inherits(x, "phylog")) 
        stop("Non convenient data")
    leaves.number <- length(x$leaves)
    leaves.names <- names(x$leaves)
    nodes.number <- length(x$nodes)
    nodes.names <- names(x$nodes)
    if (length(labels.leaves) != leaves.number) labels.leaves <- names(x$leaves)
    if (length(labels.nodes) != nodes.number) labels.nodes <- names(x$nodes)
    leaves.car <- gsub("[_]"," ",labels.leaves, ext = FALSE)
    nodes.car <- gsub("[_]"," ",labels.nodes, ext = FALSE)
    mar.old <- par("mar")
    on.exit(par(mar=mar.old))

    par(mar = c(0.1, 0.1, 0.1, 0.1))

    if (f.phylog < 0.05) f.phylog <- 0.05 
    if (f.phylog > 0.95) f.phylog <- 0.95 

    maxx <- max(x$droot)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", 
        yaxt = "n", xlim = c(-maxx*0.15, maxx/f.phylog), ylim = c(-0.05, 1), xaxs = "i", 
        yaxs = "i", frame.plot = FALSE)

    x.leaves <- x$droot[leaves.names]
    x.nodes <- x$droot[nodes.names]
    if (is.null(y)) y <- (leaves.number:1)/(leaves.number + 1)
    else y <- (leaves.number+1-y)/(leaves.number+1)
    names(y) <- leaves.names
    xcar <- maxx*1.05
    xx <- c(x.leaves, x.nodes)
     
    if (clabel.leaves > 0) {
        for (i in 1:leaves.number) {
            text(xcar, y[i], leaves.car[i], adj = 0, cex = par("cex") * 
                clabel.leaves)
            segments(xcar, y[i], xx[i], y[i], col = grey(0.7))
        }
    }
    yleaves <- y[1:leaves.number]
    xleaves <- xx[1:leaves.number]
    if (cleaves > 0) {
        for (i in 1:leaves.number) {
            points(xx[i], y[i], pch = 21, bg=1, cex = par("cex") * cleaves)
        }
    }
    yn <- rep(0, nodes.number)
    names(yn) <- nodes.names
    y <- c(y, yn)
    for (i in 1:length(x$parts)) {
        w <- x$parts[[i]]
        but <- names(x$parts)[i]
        y[but] <- mean(y[w])
        b <- range(y[w])
        segments(xx[but], b[1], xx[but], b[2])
        x1 <- xx[w]
        y1 <- y[w]
        x2 <- rep(xx[but], length(w))
        segments(x1, y1, x2, y1)
    }
    if (cnodes > 0) {
        for (i in nodes.names) {
            points(xx[i], y[i], pch = 21, bg="white", cex = cnodes)
        }
    }
    if (clabel.nodes > 0) {
        scatterutil.eti(xx[names(x.nodes)], y[names(x.nodes)], labels.nodes, 
            clabel.nodes)
    }
    x <- (x.leaves - par("usr")[1])/(par("usr")[2]-par("usr")[1])
    y <- y[leaves.names]
    xbase <- (xcar - par("usr")[1])/(par("usr")[2]-par("usr")[1])
    if (csub>0) scatterutil.sub(sub, csub=csub, possub=possub)
    if (draw.box) box()
    if (cleaves > 0) points(xleaves, yleaves, pch = 21, bg=1, cex = par("cex") * cleaves)
    
    return(invisible(list(xy=data.frame(x=x, y=y), xbase= xbase, cleaves=cleaves)))
}



"radial.phylog" <- function (phylog, circle = 1,
    cleaves = 1, cnodes = 0,
    labels.leaves = names(phylog$leaves), clabel.leaves = 1,
    labels.nodes = names(phylog$nodes), clabel.nodes = 0,
    draw.box = FALSE) 
{
    if (!inherits(phylog, "phylog")) 
        stop("Non convenient data")
    leaves.number <- length(phylog$leaves)
    leaves.names <- names(phylog$leaves)
    nodes.number <- length(phylog$nodes)
    nodes.names <- names(phylog$nodes)
    if (length(labels.leaves) != leaves.number) labels.leaves <- names(phylog$leaves)
    if (length(labels.nodes) != nodes.number) labels.nodes <- names(phylog$nodes)
    if (circle<0) stop("'circle': non convenient value")
    leaves.car <- gsub("[_]"," ",labels.leaves, ext = FALSE)
    nodes.car <- gsub("[_]"," ",labels.nodes, ext = FALSE)
    
    opar <- par(mar = par("mar"), srt = par("srt"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))

    dis <- phylog$droot
    dis <- dis/max(dis)
    rayon <- circle
    dis <- dis * rayon
    dist.leaves <- dis[leaves.names]
    dist.nodes <- dis[nodes.names]
    plot.default(0, 0, type = "n", asp = 1, xlab = "", ylab = "", 
        xaxt = "n", yaxt = "n", xlim = c(-2, 2), ylim = c(-2, 
            2), xaxs = "i", yaxs = "i", frame.plot = FALSE)
    d.rayon <- rayon/(nodes.number - 1)
    alpha <- 2 * pi * (1:leaves.number)/leaves.number
    names(alpha) <- leaves.names
    x <- dist.leaves * cos(alpha)
    y <- dist.leaves * sin(alpha)
    xcar <- (rayon + d.rayon) * cos(alpha)
    ycar <- (rayon + d.rayon) * sin(alpha)
    if (clabel.leaves>0) {
        for (i in 1:leaves.number) {
            segments(xcar[i], ycar[i], x[i], y[i], col = grey(0.7))
        }
        for (i in 1:leaves.number) {
            par(srt = alpha[i] * 360/2/pi)
            text(xcar[i], ycar[i], leaves.car[i], adj = 0, cex = par("cex") * 
                clabel.leaves)
            segments(xcar[i], ycar[i], x[i], y[i], col = grey(0.7))
        }
    }
    if (cleaves > 0) {
        for (i in 1:leaves.number) points(x[i], y[i], pch = 21, bg="black", cex = par("cex") * 
            cleaves)
    }
    ang <- rep(0, length(dist.nodes))
    names(ang) <- names(dist.nodes)
    ang <- c(alpha, ang)
    for (i in 1:length(phylog$parts)) {
        w <- phylog$parts[[i]]
        but <- names(phylog$parts)[i]
        ang[but] <- mean(ang[w])
        b <- range(ang[w])
        a.seq <- c(seq(b[1], b[2], by = pi/180), b[2])
        lines(dis[but] * cos(a.seq), dis[but] * sin(a.seq))
        x1 <- dis[w] * cos(ang[w])
        y1 <- dis[w] * sin(ang[w])
        x2 <- dis[but] * cos(ang[w])
        y2 <- dis[but] * sin(ang[w])
        segments(x1, y1, x2, y2)
    }
    if (cnodes > 0) {
        for (i in 1:length(phylog$parts)) {
            w <- phylog$parts[[i]]
            but <- names(phylog$parts)[i]
            ang[but] <- mean(ang[w])
             points(dis[but] * cos(ang[but]), dis[but] * sin(ang[but]), 
                pch = 21, bg="white", cex = par("cex") * cnodes)
        }
    }
    points(0, 0, pch = 21, cex = par("cex") * 2, bg = "red")
    if (clabel.nodes > 0) {
        delta <- strwidth(as.character(length(dist.nodes)), cex = par("cex") * 
            clabel.nodes)
        for (j in 1:length(dist.nodes)) {
            i <- names(dist.nodes)[j]
            par(srt = (ang[i] * 360/2/pi + 90))
            x1 <- dis[i] * cos(ang[i])
            y1 <- dis[i] * sin(ang[i])
            symbols(x1, y1, delta, bg = "white", add = TRUE, inch = FALSE)
            text(x1, y1, nodes.car[j], adj = 0.5, cex = par("cex") * 
                clabel.nodes)
        }
    }
    if (draw.box) box()
    return(invisible())
}

#######################################################################################
enum.phylog<-function (phylog, no.over=1000) {

    # Pour chaque phylognie phylog, il existe un grand nombre de reprsentations
    # toutes quivalentes ssocies  la mme topologie
    # Il y en a exactement 2^k pour une phylognie rsolue 
    # (que des dichotomies), ou k reprsente le nombre de noeuds
    # Cette fonction numre tous les possibles
    if (!inherits(phylog, "phylog")) stop("Object 'phylog' expected")
    leaves.number<- length(phylog$leaves)
    leaves.names<- names(phylog$leaves)
    # les descendants sont pris par la racine
    parts <- rev(phylog$parts)
    nodes.number<- length(parts)
    nodes.names<- (names(parts))
    nodes.dim <- unlist(lapply(parts,length))
    perms.number <- prod(gamma(nodes.dim+1))
    if (perms.number>no.over) {
        cat("Permutation number =",perms.number,"( no.over =", no.over,")\n")
        return(invisible())
    }
    
    "perm" <- function(cha=as.character(1:n),a=matrix(1,1,1)) {
        n0 = ncol(a)
        n = length(cha)
        if (n0 == n) {
            a <- apply(a,c(1,2),function(x) cha[x])
            return(a)
        }
        fun1 <- function(x) {
                xplus = length(x)+1
                fun2 <- function (j) {
                        if (j==1) w= c(xplus,x)
                        else if (j==xplus) w = c(x,xplus)
                        else w = c(x[1:j-1],xplus,x[j:length(x)])
                        return(w)
                }
                w = sapply(1:(length(x)+1) , fun2)
        }
        a = matrix(unlist(apply(a,1,fun1)),ncol=n0+1,byr=TRUE)
        Recall(cha,a)
    }
    
    res <- matrix (1,1,1)
    
    lw <- lapply(parts,perm)
    names(lw) <- nodes.names
    res <- lw[[1]]

    lw[[1]]<- NULL
    
    "permtot" <- function (matcar) {
        n1 <- nrow(res) ; n2 <- nrow(matcar)
        p1 <- ncol(res) ; p2 <- ncol(matcar)
        f1 <- function(x) unlist(apply(res,1,function(y) c(y,x)))
        res <<- matrix(unlist(apply(matcar,1,f1)),n1*n2, p1+p2,byr=TRUE)
    }
    
    lapply(lw, permtot)
    
     ##############################################
    permut<-function(init, node){
        # init est un vecteur des noms des feuilles compatibles avec la phylognie
        # on opre une permutation circulaire des blocs de feuilles associs
        # aux descendants immdiats du noeud node
        
        num<- grep(node, nodes.names)[1]
        w0 <- enfants(node,res)
        if (min(w0)>1) a <- 1:(min(w0)-1) else a <- NULL
        if (max(w0)<leaves.number) b <- (max(w0)+1):leaves.number else b <- NULL
        agauche<-which(unlist(phylog$parts[node])%in%unlist(phylog$paths[init[w0[1]]]))
        w1 <- unlist(lapply(phylog$parts[[num]][agauche],enfants, init=res))
        w2 <- unlist(lapply(phylog$parts[[num]][-agauche],enfants, init=res))
        return(init[c(a,w2,w1,b)])
    }
    ##############################################
    fac <- factor(rep(1:nodes.number,nodes.dim))
    renum <- function (cha) {
        cha <- split(cha, fac)
        names(cha) <- nodes.names
        w <- cha[[1]]
        for (j in nodes.names[-1]) {
              k <- which(w==j)
              wcha <- cha[[j]]
              if (k==1) w <- c(wcha,w[-k])
              else if (k == length(w)) w <- c(w[-k],wcha)
              else w <- c(w[1:(k-1)],wcha,w[(k+1):length(w)])
        }
        res <- 1:leaves.number
        names(res)=w
        return(res[leaves.names])
    }
    return(t(apply(res,1,renum)))  
    
    
}
"procuste" <- function (df1, df2, scale = TRUE, nf = 4, tol = 1e-07) {
    df1 <- data.frame(df1)
    df2 <- data.frame(df2)
    if (!is.data.frame(df1)) 
        stop("data.frame expected")
    if (!is.data.frame(df2)) 
        stop("data.frame expected")
    l1 <- nrow(df1)
    if (nrow(df2) != l1) 
        stop("Row numbers are different")
    if (any(row.names(df2) != row.names(df1))) 
        stop("row names are different")
    c1 <- ncol(df1)
    c2 <- ncol(df2)
    X <- scale(df1, scale = FALSE)
    Y <- scale(df2, scale = FALSE)
    var1 <- apply(X, 2, function(x) sum(x^2))
    var2 <- apply(Y, 2, function(x) sum(x^2))
    tra1 <- sum(var1)
    tra2 <- sum(var2)
    if (scale) {
        X <- X/sqrt(tra1)
        Y <- Y/sqrt(tra2)
    }
    X <-as.matrix(X)
    Y <- as.matrix(Y)
    PS <- t(X) %*% Y
    svd1 <- svd(PS)
    rank <- sum((svd1$d/svd1$d[1]) > tol)
    if (nf > rank) 
        nf <- rank
    u <- svd1$u[, 1:nf]
    v <- svd1$v[, 1:nf]
    scor1 <- X %*% u
    scor2 <- Y %*% v
    rot1 <- X %*% u %*% t(v)
    rot2 <- Y %*% v %*% t(u)
    res <- list()
    X <- data.frame(X)
    row.names(X) <- row.names(df1)
    names(X) <- names(df1)
    Y <- data.frame(Y)
    row.names(Y) <- row.names(df2)
    names(Y) <- names(df2)
    res$d <- svd1$d
    res$rank <- rank
    res$nfact <- nf
    u <- data.frame(u)
    row.names(u) <- names(df1)
    names(u) <- paste("ax", 1:nf, sep = "")
    v <- data.frame(v)
    row.names(v) <- names(df2)
    names(v) <- paste("ax", 1:nf, sep = "")
    scor1 <- data.frame(scor1)
    row.names(scor1) <- row.names(df1)
    names(scor1) <- paste("ax", 1:nf, sep = "")
    scor2 <- data.frame(scor2)
    row.names(scor2) <- row.names(df1)
    names(scor2) <- paste("ax", 1:nf, sep = "")
    if ((nf == c1) & (nf == c2)) {
        rot1 <- data.frame(rot1)
        row.names(rot1) <- row.names(df1)
        names(rot1) <- names(df2)
        rot2 <- data.frame(rot2)
        row.names(rot2) <- row.names(df1)
        names(rot2) <- names(df1)
        res$rot1 <- rot1
        res$rot2 <- rot2
    }
    res$tab1 <- X
    res$tab2 <- Y
    res$load1 <- u
    res$load2 <- v
    res$scor1 <- scor1
    res$scor2 <- scor2
    res$call <- match.call()
    class(res) <- "procuste"
    return(res)
}

"plot.procuste" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "procuste")) 
        stop("Use only with 'procuste' objects")
    if (x$nf == 1) {
        warnings("One axis only : not yet implemented")
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    s.arrow(x$load1, xax, yax, sub = "Loadings 1", csub = 2, 
        clab = 1.25)
    s.arrow(x$load2, xax, yax, sub = "Loadings 2", csub = 2, 
        clab = 1.25)
    scatterutil.eigen(x$d^2, wsel = c(xax, yax))
    s.match(x$scor1, x$scor2, xax, yax, clab = 1.5, sub = "Common projection", 
        csub = 2)
    s.label(x$scor1, xax = xax, yax = yax, sub = "Array 1", 
        csub = 2, clab = 1.25)
    s.label(x$scor2, xax = xax, yax = yax, sub = "Array 2", 
        csub = 2, clab = 1.25)
}

"print.procuste" <- function (x, ...) {
    cat("Procustes rotation\n")
    cat("call: ")
    print(x$call)
    cat(paste("class:", class(x)))
    cat(paste("\nrank:", x$rank))
    cat(paste("\naxis number:", x$nfact))
    cat("\nSingular value decomposition: ")
    l0 <- length(x$d)
    cat(signif(x$d, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("tab1   data.frame  ", nrow(x$tab1), "  ", ncol(x$tab1), 
        "   scaled array 1\n")
    cat("tab2   data.frame  ", nrow(x$tab2), "  ", ncol(x$tab2), 
        "   scaled array 2\n")
    cat("scor1  data.frame  ", nrow(x$scor1), " ", ncol(x$scor1), 
        "   row coordinates 1\n")
    cat("scor2  data.frame  ", nrow(x$scor2), " ", ncol(x$scor2), 
        "   row coordinates 2\n")
    cat("load1  data.frame  ", nrow(x$load1), " ", ncol(x$load1), 
        "   loadings 1\n")
    cat("load2  data.frame  ", nrow(x$load2), " ", ncol(x$load2), 
        "   loadings 2\n")
    if (length(names(x)) > 12) {
        cat("other elements: ")
        cat(names(x)[11:(length(x))], "\n")
    }
}
"procuste.randtest" <- function(df1, df2, nrepet=999) {
    nrepet <- nrepet +1
    if (!is.data.frame(df1)) 
        stop("data.frame expected")
    if (!is.data.frame(df2)) 
        stop("data.frame expected")
    l1 <- nrow(df1)
    if (nrow(df2) != l1) 
        stop("Row numbers are different")
    if (any(row.names(df2) != row.names(df1))) 
        stop("row names are different")
    X <- scale(df1, scale = FALSE)
    Y <- scale(df2, scale = FALSE)
    var1 <- apply(X, 2, function(x) sum(x^2))
    var2 <- apply(Y, 2, function(x) sum(x^2))
    tra1 <- sum(var1)
    tra2 <- sum(var2)
    X <- X/sqrt(tra1)
    Y <- Y/sqrt(tra2)
    lig<-nrow(X)
    c1<-ncol(X)
    c2<-ncol(Y)
    isim<-testprocuste(nrepet, lig, c1, c2, as.matrix(X), as.matrix(Y))
    obs<-isim[1]
    return(as.randtest(isim[-1],obs,call=match.call()))
}
"procuste.rtest" <- function (df1, df2, nrepet = 99) {
    if (!is.data.frame(df1)) 
        stop("data.frame expected")
    if (!is.data.frame(df2)) 
        stop("data.frame expected")
    l1 <- nrow(df1)
    if (nrow(df2) != l1) 
        stop("Row numbers are different")
    if (any(row.names(df2) != row.names(df1))) 
        stop("row names are different")
    X <- scale(df1, scale = FALSE)
    Y <- scale(df2, scale = FALSE)
    var1 <- apply(X, 2, function(x) sum(x^2))
    var2 <- apply(Y, 2, function(x) sum(x^2))
    tra1 <- sum(var1)
    tra2 <- sum(var2)
    X <- X/sqrt(tra1)
    Y <- Y/sqrt(tra2)
    X <- as.matrix(X)
    Y <- as.matrix(Y)
    obs <- sum(svd(t(X) %*% Y)$d)
    if (nrepet == 0) 
        return(obs)
    perm <- matrix(0, nrow = nrepet, ncol = 1)
    perm <- apply(perm, 1, function(x) sum(svd(t(X) %*% Y[sample(l1), 
        ])$d))
    w <- as.rtest(obs = obs, sim = perm, call = match.call())
    return(w)
}
"pta" <- function (X, scannf = TRUE, nf = 2) {
    # 21/08/02 Correction d'un bug suite  message de G. BALENT balent@toulouse.inra.fr
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    auxinames <- ktab.util.names(X)
    sepa <- sepan(X, nf = 4)
    blocks <- X$blo
    nblo <- length(blocks)
    tnames <- tab.names(X)
    lw <- X$lw
    lwsqrt <- sqrt(X$lw)
    nl <- length(lw)
    r.n <- row.names(X[[1]])
    for (i in 1:nblo) {
        r.new <- row.names(X[[i]])
        if (any(r.new != r.n)) 
            stop("non equal row.names among array")
    }
    if (length(unique(blocks)) != 1) 
        stop("non equal col numbers among array")
    unique.col.names <- names(X[[1]])
    for (i in 1:nblo) {
        c.new <- names(X[[i]])
        if (any(c.new != unique.col.names)) 
            stop("non equal col.names among array")
    }
    indica <- as.factor(rep(1:nblo, blocks))
    w <- split(X$cw, indica)
    cw <- w[[1]]
    for (i in 1:nblo) {
        col.w.new <- w[[i]]
        if (any(cw != col.w.new)) 
            stop("non equal column weights among array")
    }
    cwsqrt <- sqrt(cw)
    nc <- length(cw)
    atp <- list()
    for (i in 1:nblo) {
        w <- as.matrix(X[[i]]) * lwsqrt
        w <- t(t(w) * cwsqrt)
        atp[[i]] <- w
    }
    atp <- matrix(unlist(atp), nl * nc, nblo)
    RV <- t(atp) %*% atp
    ak <- sqrt(diag(RV))
    RV <- sweep(RV, 1, ak, "/")
    RV <- sweep(RV, 2, ak, "/")
    dimnames(RV) <- list(tnames, tnames)
    atp <- list()
    inter <- eigen(as.matrix(RV))
    if (any(inter$vectors[, 1] < 0)) 
        inter$vectors[, 1] <- -inter$vectors[, 1]
    is <- inter$vectors[, (1:min(c(nblo, 4)))]
    tabw <- as.vector(is[, 1])
    is <- t(t(is) * sqrt(inter$values[1:ncol(is)]))
    is <- as.data.frame(is)
    row.names(is) <- tnames
    names(is) <- paste("IS", 1:ncol(is), sep = "")
    atp$RV <- RV
    atp$RV.eig <- inter$values
    atp$RV.coo <- is
    atp$tabw <- tabw
    tab <- X[[1]] * tabw[1]
    for (i in 2:nblo) {
        tab <- tab + X[[i]] * tabw[i]
    }
    tab <- as.data.frame(tab, row.names = row.names(X))
    names(tab) <- unique.col.names
    comp <- as.dudi(tab, col.w = cw, row.w = lw, nf = nf, scannf = scannf, 
        call = match.call(), type = "pta")
    atp$rank <- comp$rank
    nf <- atp$nf <- comp$nf
    atp$tab <- comp$tab
    atp$lw <- comp$lw
    atp$cw <- comp$cw
    atp$eig <- comp$eig
    atp$li <- comp$li
    atp$co <- comp$co
    atp$l1 <- comp$li
    atp$c1 <- comp$co
    w1 <- matrix(0, nblo * 4, nf)
    w2 <- matrix(0, nblo * 4, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:nblo) {
        i1 <- i2 + 1
        i2 <- i2 + 4
        tab1 <- as.matrix(sepa$L1[X$TL[, 1] == k, ])
        tab1 <- t(tab1 * lw) %*% as.matrix(comp$l1)
        tab2 <- as.matrix(sepa$C1[X$TC[, 1] == k, ])
        tab2 <- (t(tab2) * cw) %*% as.matrix(comp$c1)
        for (i in 1:min(nf, 4)) {
            if (tab2[i, i] < 0) {
                for (j in 1:nf) tab2[i, j] <- -tab2[i, j]
            }
            if (tab1[i, i] < 0) {
                for (j in 1:nf) tab1[i, j] <- -tab1[i, j]
            }
        }
        w1[i1:i2, ] <- tab1
        w2[i1:i2, ] <- tab2
    }
    w1 <- data.frame(w1, row.names = auxinames$tab)
    w2 <- data.frame(w2, row.names = auxinames$tab)
    names(w2) <- names(w1) <- paste("C", 1:nf, sep = "")
    atp$Tcomp <- w1
    atp$Tax <- w2
    tab <- as.matrix(X[[1]])
    w <- as.matrix(comp$c1)
    cooli <- t(t(tab) * cw) %*% w
    for (k in 2:nblo) {
        tab <- as.matrix(X[[k]])
        cooliauxi <- t(t(tab) * cw) %*% w
        cooli <- rbind(cooli, cooliauxi)
    }
    cooli <- data.frame(cooli, row.names = auxinames$row)
    atp$Tli <- cooli
    tab <- as.matrix(X[[1]])
    w <- as.matrix(comp$l1) * lw
    cooco <- t(tab) %*% w
    for (k in 2:nblo) {
        tab <- as.matrix(X[[k]])
        coocoauxi <- t(tab) %*% w
        cooco <- rbind(cooco, coocoauxi)
    }
    cooco <- data.frame(cooco, row.names = auxinames$col)
    atp$Tco <- cooco
    normcompro <- sum(atp$eig)
    indica <- as.factor(rep(1:nblo, sepa$rank))
    w <- split(sepa$Eig, indica)
    normtab <- unlist(lapply(w, sum))
    covv <- rep(0, nblo)
    w1 <- atp$tab * lwsqrt
    w1 <- t(t(w1) * cwsqrt)
    for (k in 1:nblo) {
        wk <- X[[k]] * lwsqrt
        wk <- t(t(wk) * cwsqrt)
        covv[k] <- sum(w1 * wk)
    }
    atp$cos2 <- covv/sqrt(normcompro)/sqrt(normtab)
    atp$TL <- X$TL
    atp$TC <- X$TC
    atp$T4 <- X$T4
    atp$blo <- X$blo
    atp$tab.names <- tnames
    atp$call <- match.call()
    class(atp) <- c("pta", "dudi")
    return(atp)
}

"plot.pta" <- function (x, xax = 1, yax = 2, option = 1:4, ...) {
    if (!inherits(x, "pta")) 
        stop("Object of type 'pta' expected")
    nf <- x$nf
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    mfrow <- n2mfrow(length(option))
    par(mfrow = mfrow)
    for (j in option) {
        if (j == 1) {
            coolig <- x$RV.coo[, c(1, 2)]
            s.corcircle(coolig, label = x$tab.names, 
                cgrid = 0, sub = "Interstructure", csub = 1.5, 
                possub = "topleft", full = TRUE)
            l0 <- length(x$RV.eig)
            add.scatter.eig(x$RV.eig, l0, 1, 2, posi = "bottom", 
                ratio = 1/4)
        }
        if (j == 2) {
            coolig <- x$li[, c(xax, yax)]
            s.label(coolig, sub = "Compromise", csub = 1.5, 
                possub = "topleft", )
            add.scatter.eig(x$eig, x$nf, xax, yax, posi = "bottom", 
                ratio = 1/4)
        }
        if (j == 3) {
            cooco <- x$co[, c(xax, yax)]
            s.arrow(cooco, sub = "Compromise", csub = 1.5, 
                possub = "topleft")
        }
        if (j == 4) {
            plot(x$tabw, x$cos2, xlab = "Tables weights", 
                ylab = "Cos 2")
            scatterutil.grid(0)
            title(main = "Typological value")
            par(xpd = TRUE)
            scatterutil.eti(x$tabw, x$cos2, label = x$tab.names, 
                clabel = 1)
        }
    }
}


"print.pta" <- function (x, ...) {
    cat("Partial Triadic Analysis\n")
    cat("class:")
    cat(class(x), "\n")
    cat("table number:", length(x$blo), "\n")
    cat("row number:", length(x$lw), "  column number:", length(x$cw), 
        "\n")
    cat("\n     **** Interstructure ****\n")
    cat("\neigen values: ")
    l0 <- length(x$RV.eig)
    cat(signif(x$RV.eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat(" $RV       matrix      ", nrow(x$RV), "    ", ncol(x$RV), "    RV coefficients\n")
    cat(" $RV.eig   vector      ", length(x$RV.eig), "      eigenvalues\n")
    cat(" $RV.coo   data.frame  ", nrow(x$RV.coo), "    ", ncol(x$RV.coo), 
        "   array scores\n")
    cat(" $tab.names    vector      ", length(x$tab.names), "       array names\n")
    cat("\n      **** Compromise ****\n")
    cat("\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("\n $nf:", x$nf, "axis-components saved")
    cat("\n $rank: ")
    cat(x$rank, "\n\n")
    sumry <- array("", c(5, 4), list(rep("", 5), c("vector", 
        "length", "mode", "content")))
    sumry[1, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "array weights")
    sumry[2, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights")
    sumry[3, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights")
    sumry[4, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[5, ] <- c("$cos2", length(x$cos2), mode(x$cos2), "cosine^2 between compromise and arrays")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(5, 4), list(rep("", 5), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    class(sumry) <- "table"
    print(sumry)
    cat("\n     **** Intrastructure ****\n\n")
    sumry <- array("", c(7, 4), list(rep("", 7), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$Tli", nrow(x$Tli), ncol(x$Tli), "row coordinates (each table)")
    sumry[2, ] <- c("$Tco", nrow(x$Tco), ncol(x$Tco), "col coordinates (each table)")
    sumry[3, ] <- c("$Tcomp", nrow(x$Tcomp), ncol(x$Tcomp), "principal components (each table)")
    sumry[4, ] <- c("$Tax", nrow(x$Tax), ncol(x$Tax), "principal axis (each table)")
    sumry[5, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Tli")
    sumry[6, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Tco")
    sumry[7, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for Tax Tcomp")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"quasieuclid" <- function (distmat) {
    if (is.euclid(distmat)) {
        warning("Euclidean distance found : no correction need")
        return(distmat)
    }
    distmat <- dist2mat(distmat)
    n <- ncol(distmat)
    delta <- -0.5 * bicenter.wt(distmat * distmat)
    eig <- eigen(delta, sym = TRUE)
    ncompo <- sum(eig$value > 0)
    tabnew <- eig$vectors[, 1:ncompo] * rep(sqrt(eig$values[1:ncompo]), 
        rep(n, ncompo))
    distmat <- dist.quant(tabnew, 1)
    attr(distmat, "call") <- match.call()
    return(distmat)
}
testdiscrimin <- function(npermut, rank, pl, moda, indica, tab, l1, c1)
    .C("testdiscrimin",
        as.integer(npermut),
        as.double(rank),
        as.double(pl),
        as.integer(length(pl)),
        as.integer(moda),
        as.double(indica),
        as.integer(length(indica)),
        as.double(t(tab)),
        as.integer(l1),
        as.integer(c1),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testertrace <- function(npermut, pc1, pc2, tab1, tab2, l1, c1, c2)
    .C("testertrace",
        as.integer(npermut),
        as.double(pc1),
        as.integer(length(pc1)),
        as.double(pc2),
        as.integer(length(pc2)),
        as.double(t(tab1)),
        as.integer(l1),
        as.integer(c1),
        as.double(t(tab2)),
        as.integer(l1),
        as.integer(c2),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testertracenu <- function(npermut, pc1, pc2, pl, tab1, tab2, l1, c1, c2, Xinit, Yinit, typX, typY)
    .C("testertracenu",
        as.integer(npermut),
        as.double(pc1),
        as.integer(length(pc1)),
        as.double(pc2),
        as.integer(length(pc2)),
        as.double(pl),
        as.integer(length(pl)),
        as.double(t(tab1)),
        as.integer(l1),
        as.integer(c1),
        as.double(t(tab2)),
        as.integer(l1),
        as.integer(c2),
        as.double(t(Xinit)),
        as.double(t(Yinit)),
        as.character(typX),
        as.character(typY),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testertracenubis <- function(npermut, pc1, pc2, pl, tab1, tab2, l1, c1, c2, Xinit, Yinit, typX, typY, fixed)
    .C("testertracenubis",
        as.integer(npermut),
        as.double(pc1),
        as.integer(length(pc1)),
        as.double(pc2),
        as.integer(length(pc2)),
        as.double(pl),
        as.integer(length(pl)),
        as.double(t(tab1)),
        as.integer(l1),
        as.integer(c1),
        as.double(t(tab2)),
        as.integer(l1),
        as.integer(c2),
        as.double(t(Xinit)),
        as.double(t(Yinit)),
        as.character(typX),
        as.character(typY),
        as.integer(fixed),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testinter <- function(npermut, pl, pc, moda, indica, tab, l1, c1)
    .C("testinter",
        as.integer(npermut),
        as.double(pl),
        as.integer(length(pl)),
        as.double(pc),
        as.integer(length(pc)),
        as.integer(moda),
        as.double(indica),
        as.integer(length(indica)),
        as.double(t(tab)),
        as.integer(l1),
        as.integer(c1),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testprocuste <- function(npermut, lig, c1, c2, tab1, tab2)
    .C("testprocuste",
        as.integer(npermut),
        as.integer(lig),
        as.integer(c1),
        as.integer(c2),
        as.double(t(tab1)),
        as.double(t(tab2)),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testmantel <- function(npermut, col, tab1, tab2)
    .C("testmantel",
        as.integer(npermut),
        as.integer(col),
        as.double(t(tab1)),
        as.double(t(tab2)),
        inersim = double(npermut),
        PACKAGE="ade4")$inersim

testamova <- function(distab, l1, c1, samtab, l2, c2, strtab, l3, c3, indic, nbhapl, npermut, divtotal, df, r2)
    .C("testamova",
        as.double(t(distab)),
        as.integer(l1),
        as.integer(c1),
        as.integer(t(samtab)),
        as.integer(l2),
        as.integer(c2),
        as.integer(t(strtab)),
        as.integer(l3),
        as.integer(c3),
        as.integer(indic),
        as.integer(nbhapl),
        as.integer(npermut),
        as.double(divtotal),
        as.double(df),
        result = double(r2),
        PACKAGE="ade4")$result
"randtest" <- function (xtest, ...) {
    UseMethod("randtest")
}

"as.randtest" <- function (sim, obs, call = match.call()) {
    res <- list(sim = sim, obs = obs)
    res$rep <- length(sim)
    res$pvalue <- (sum(sim >= obs) + 1)/(length(sim) + 1)
    res$call <- call
    class(res) <- "randtest"
    return(res)
}

"print.randtest" <- function (x, ...) {
    if (!inherits(x, "randtest")) 
        stop("Non convenient data")
    cat("Monte-Carlo test\n")
    cat("Observation:", x$obs, "\n")
    cat("Call: ")
    print(x$call)
    cat("Based on", x$rep, "replicates\n")
    cat("Simulated p-value:", x$pvalue, "\n")
}

"plot.randtest" <- function (x, nclass = 10, coeff = 1, ...) {
    if (!inherits(x, "randtest")) 
        stop("Non convenient data")
    obs <- x$obs
    sim <- x$sim
    r0 <- c(sim, obs)
    h0 <- hist(sim, plot = FALSE, nclass = nclass, xlim = xlim0)
    y0 <- max(h0$counts)
    l0 <- max(sim) - min(sim)
    w0 <- l0/(log(length(sim), base = 2) + 1)
    w0 <- w0 * coeff
    xlim0 <- range(r0) + c(-w0, w0)
    hist(sim, plot = TRUE, nclass = nclass, xlim = xlim0, col = grey(0.8), 
        ...)
    lines(c(obs, obs), c(y0/2, 0))
    points(obs, y0/2, pch = 18, cex = 2)
    invisible()
}
randtest.amova <- function(xtest, nrepet = 99, ...) {
    if (!inherits(xtest, "amova")) stop("Object of class 'amova' expected for xtest")
    if (nrepet <= 1) stop("Non convenient nrepet")
    distances <- as.matrix(xtest$distances) / 2
    samples <- as.matrix(xtest$samples)
    structures <- xtest$structures
    ddl <- xtest$results$Df
    ddl[1:(length(ddl) - 1)] <- ddl[(length(ddl) - 1):1]
    sigma <- xtest$componentsofcovariance$Sigma
    lesss <- xtest$results$"Sum Sq"
    if (is.null(structures)) {
        structures <- cbind.data.frame(rep(1, nrow(samples)))
        indic <- 0
    }
    else {
        for (i in 1:ncol(structures)) {
            structures[, i] <- factor(as.numeric(structures[, i]))
        }
        indic <- 1
    }
    Restests2 <- function(restests, sigma) {
        tests <- as.list(as.data.frame(t(cbind.data.frame(sigma[(length(sigma) - 1):1], t(restests)))))
        class(tests) <- "krandtest"
        return(tests)
    }    
    if (indic != 0) {
        longueurresult <- nrepet * (length(sigma) - 1)
        res <- testamova(distances, nrow(distances), nrow(distances), samples, nrow(samples), ncol(samples), structures, nrow(structures), ncol(structures), indic, sum(samples), nrepet, lesss[length(lesss)] / sum(samples), ddl, longueurresult)
        restests <- matrix(res, nrepet, length(sigma) - 1, byrow = TRUE)
        permutationtests <- Restests2(restests, sigma)
        names(permutationtests) <- paste("Variations", c("within samples", "between samples", paste("between", names(structures))))
    }
    else {
        longueurresult <- nrepet * (length(sigma) - 2)
        res <- testamova(distances, nrow(distances), nrow(distances), samples, nrow(samples), ncol(samples), structures, nrow(structures), ncol(structures), indic, sum(samples), nrepet, lesss[length(lesss)] / sum(samples), ddl, longueurresult)
        permutationtests <- as.randtest(res, sigma[1])
    }
    return(permutationtests)
}
"randtest.between" <- function(xtest, nrepet=999, ...) {
    nrepet<-nrepet+1
    if (!inherits(xtest,"dudi"))
        stop("Object of class dudi expected")
    if (!inherits(xtest,"between"))
        stop ("Type 'between' expected")
    appel<-as.list(xtest$call)
    dudi1<-eval(appel$dudi,sys.frame(0))
    fac<-eval(appel$fac,sys.frame(0))
    X<-dudi1$tab
    X.lw<-dudi1$lw
    X.lw<-X.lw/sum(X.lw)
    X.cw<-sqrt(dudi1$cw)
    X<-t(t(X)*X.cw)
    inertot<-sum(dudi1$eig)
#   isim<-testinter(nrepet, X.lw, X.cw, length(unique(fac)), fac, X, nrow(X), ncol(X))/inertot
    isim<-testinter(nrepet, dudi1$lw, dudi1$cw, length(unique(fac)), fac, dudi1$tab, nrow(X), ncol(X))/inertot
    obs<-isim[1]
    return(as.randtest(isim[-1],obs,call=match.call()))
}
"randtest.coinertia" <- function(xtest, nrepet=999, fixed=0, ...) {
    nrepet<-nrepet+1
    if (!inherits(xtest,"dudi"))
        stop("Object of class dudi expected")
    if (!inherits(xtest,"coinertia"))
        stop("Object of class 'coinertia' expected")
    appel<-as.list(xtest$call)
    dudiX<-eval(appel$dudiX,sys.frame(0))
    dudiY<-eval(appel$dudiY,sys.frame(0))
    X<-dudiX$tab
    X.cw<-dudiX$cw
    X.lw<-dudiX$lw
    appelX<-as.list(dudiX$call)
    apx<-appelX$df
    Xinit<-eval(appelX$df,sys.frame(0))
    if (appelX[[1]] == "dudi.pca") {        
        if (is.null(appelX$scale)) appelX$scale<-TRUE
        if (appelX$scale=="TRUE") appelX$scale<-TRUE
        if (appelX$scale=="FALSE") appelX$scale<-FALSE
        if (is.null(appelX$center)) appelX$center<-TRUE
        if (appelX$center=="TRUE") appelX$center<-TRUE
        if (appelX$center=="FALSE") appelX$center<-FALSE
        if (appelX$center == FALSE && appelX$scale == FALSE) typX<-"nc"
        if (appelX$center == FALSE && appelX$scale == TRUE) typX<-"cs"
        if (appelX$center == TRUE  && appelX$scale == FALSE) typX<-"cp"
        if (appelX$center == TRUE  && appelX$scale == TRUE) typX<-"cn"
    } else if (appelX[[1]] == "dudi.coa") {
        typX<-"fc"
    } else if (appelX[[1]] == "dudi.fca") {
        typX<-"fc"
    } else if (appelX[[1]] == "dudi.acm") {
        typX<-"cm"
        Xinit <- acm.disjonctif(Xinit)
    }
    Y<-dudiY$tab
    Y.cw<-dudiY$cw
    Y.lw<-dudiY$lw
    appelY<-as.list(dudiY$call)
    apy<-appelY$df
    Yinit<-eval(appelY$df,sys.frame(0))
    if (appelY[[1]] == "dudi.pca") {        
        if (is.null(appelY$scale)) appelY$scale<-TRUE
        if (appelY$scale=="TRUE") appelY$scale<-TRUE
        if (appelY$scale=="FALSE") appelY$scale<-FALSE
        if (is.null(appelY$center)) appelY$center<-TRUE
        if (appelY$center=="TRUE") appelY$center<-TRUE
        if (appelY$center=="FALSE") appelY$center<-FALSE
        if (appelY$center == FALSE && appelY$scale == FALSE) typY<-"nc"
        if (appelY$center == FALSE && appelY$scale == TRUE) typY<-"cs"
        if (appelY$center == TRUE  && appelY$scale == FALSE) typY<-"cp"
        if (appelY$center == TRUE  && appelY$scale == TRUE) typY<-"cn"
    } else if (appelY[[1]] == "dudi.coa") {
        typY<-"fc"
    } else if (appelY[[1]] == "dudi.fca") {
        typY<-"fc"
    } else if (appelY[[1]] == "dudi.acm") {
        typY<-"cm"
        Yinit <- acm.disjonctif(Yinit)
   }
    if (all(X.lw==Y.lw)) {
        if ( all(X.lw==rep(1/nrow(X), nrow(X))) ) {
            isim<-testertrace(nrepet, X.cw, Y.cw, X, Y, nrow(X), ncol(X), ncol(Y))
        } else {
            if (fixed==0) {
                cat("Warning: non uniform weight. The results from simulations\n")
                cat("are not valid if weights are computed from analysed data.\n")
                isim<-testertracenu(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY)
            } else if (fixed==1) {
                cat("Warning: non uniform weight. The results from permutations\n")
                cat("are valid only if the row weights come from the fixed table.\n")
                cat("The fixed table is table X : ")
                print(apx)
                isim<-testertracenubis(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY, fixed)
            } else if (fixed==2) {
                cat("Warning: non uniform weight. The results from permutations\n")
                cat("are valid only if the row weights come from the fixed table.\n")
                cat("The fixed table is table Y : ")
                print(apy)
                isim<-testertracenubis(nrepet, X.cw, Y.cw, X.lw, X, Y, nrow(X), ncol(X), ncol(Y), Xinit, Yinit, typX, typY, fixed)
            } else if (fixed==3) stop ("Error : fixed must be =< 2")
        }
        # On calcule le RV a partir de la coinertie
        isim<-isim/sqrt(sum(dudiX$eig^2))/sqrt(sum(dudiY$eig^2))
        obs<-isim[1]
        return(as.randtest(isim[-1],obs,call=match.call()))
    } else {
        stop ("Equal row weights expected")
    }
}
"randtest.discrimin" <- function(xtest, nrepet=999, ...) {
    nrepet <- nrepet +1
    if (!inherits(xtest, "discrimin"))
        stop("'discrimin' object expected")
    appel<-as.list(xtest$call)
    dudi<-eval(appel$dudi,sys.frame(0))
    fac<-eval(appel$fac,sys.frame(0))
    lig<-nrow(dudi$tab)
    if (length(fac)!=lig) stop ("Non convenient dimension")
    rank<-dudi$rank
    dudi<-redo.dudi(dudi,rank)
    # dudi.lw<-dudi$lw
    # dudi<-dudi$l1
    X<-dudi$l1
    X.lw<-dudi$lw
    # dudi et dudi.lw sont soumis a la permutation
    # fac reste fixe

    isim<-testdiscrimin(nrepet, rank, X.lw, length(unique(fac)), fac, X, nrow(X), ncol(X))
    obs<-isim[1]
    return(as.randtest(isim[-1],obs,call=match.call()))
}
"reconst" <- function (dudi, ...) {
    UseMethod("reconst")
}

 "reconst.pca" <- function (dudi, nf = 1, ...) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (nf > dudi$nf) 
        stop(paste(nf, "factors need >", dudi$nf, "factors available\n"))
    if (!inherits(dudi, "pca")) 
        stop("Object of class 'dudi' expected")
    cent <- dudi$cent
    norm <- dudi$norm
    n <- nrow(dudi$tab)
    p <- ncol(dudi$tab)
    res <- matrix(0, n, p)
    for (i in 1:nf) {
        xli <- dudi$li[, i]
        yc1 <- dudi$c1[, i]
        res <- res + matrix(xli, n, 1) %*% matrix(yc1, 1, p)
    }
    res <- t(apply(res, 1, function(x) x * norm))
    res <- t(apply(res, 1, function(x) x + cent))
    res <- data.frame(res)
    names(res) <- names(dudi$tab)
    row.names(res) <- row.names(dudi$tab)
    return(res)
}
"as.coinertia" <-
function (dudiRLQ, fixed="R") 
{
    if (!inherits(dudiRLQ, "rlq")) 
        stop("to be used with 'rlq' object")
    appel <- as.list(dudiRLQ$call)
    dudiL <- eval(appel$dudiL, sys.frame(0))
    dudiR <- eval(appel$dudiR, sys.frame(0))
    dudiQ <- eval(appel$dudiQ, sys.frame(0))
    if(fixed!="R" && fixed!="Q") {
        stop("fixed must be R or Q")
    }
    if(fixed=="R") {
        dudiX <- dudiR
        tabY <- (as.matrix(dudiL$tab)) %*% diag(dudiL$cw) %*% (as.matrix(dudiQ$tab))
        tabY <- as.data.frame(tabY)
        names(tabY) <- names(dudiQ$tab)
        row.names(tabY) <- row.names(dudiL$tab)
        dudiY <- as.dudi(tabY,dudiQ$cw,dudiL$lw,scannf=F,nf=2,call=match.call(),type="pca")
    }
    if(fixed=="Q") {
        dudiX <- dudiQ
        tabY <- t(as.matrix(dudiL$tab)) %*% diag(dudiL$lw) %*% (as.matrix(dudiR$tab))
        tabY <- as.data.frame(tabY)
        names(tabY) <- names(dudiR$tab)
        row.names(tabY) <- names(dudiL$tab)
        dudiY <- as.dudi(tabY,dudiR$cw,dudiL$cw,scannf=F,nf=2,call=match.call(),type="pca")

    }
    return(coinertia(dudiX,dudiY,scannf=F,nf=dudiRLQ$nf))
    

}
"dudi.hillsmith" <-
function (df, row.w=rep(1, nrow(df))/nrow(df), scannf = TRUE, nf = 2) 
{
    if (!is.data.frame(df)) 
        stop("data.frame expected")

    acm.util <- function(cl) {
        n <- length(cl)
        cl <- as.factor(cl)
        x <- matrix(0, n, length(levels(cl)))
        x[(1:n) + n * (unclass(cl) - 1)] <- 1
        dimnames(x) <- list(names(cl), as.character(levels(cl)))
        data.frame(x)
    }
    df <- data.frame(df)
    nc <- ncol(df)
    nl <- nrow(df)
    row.w <- row.w/sum(row.w)
    if (any(is.na(df))) 
        stop("na entries in table")
    index <- rep("", nc)
    for (j in 1:nc) {
        w1 <- "q"
        if (is.factor(df[, j])) 
            w1 <- "f"
        if (is.ordered(df[, j])) 
            stop("use dudi.mix for ordered data")
        index[j] <- w1
    }
    res <- matrix(0, nl, 1)
    provinames <- "0"
    col.w <- NULL
    col.assign <- NULL
    k <- 0
    for (j in 1:nc) {
        if (index[j] == "q") {
            
                res <- cbind(res, scalewt(df[, j],w=row.w))
                provinames <- c(provinames, names(df)[j])
                col.w <- c(col.w, 1)
                k <- k + 1
                col.assign <- c(col.assign, k)
            
        }
        else if (index[j] == "f") {
            w <- acm.util(factor(df[, j]))
            cha <- paste(substr(names(df)[j], 1, 5), ".", names(w), 
                sep = "")
            col.w.provi <- drop(row.w %*% as.matrix(w))
            w <- t(t(w)/col.w.provi) - 1
            col.w <- c(col.w, col.w.provi)
            res <- cbind(res, w)
            provinames <- c(provinames, cha)
            k <- k + 1
            col.assign <- c(col.assign, rep(k, length(cha)))
        }
    }
    res <- data.frame(res)
    names(res) <- make.names(provinames, unique = TRUE)
    row.names(res)<-row.names(df)
    res <- res[, -1]
    names(col.w) <- provinames[-1]
    X <- as.dudi(res, col.w, row.w, scannf = scannf, nf = nf, 
        call = match.call(), type = "mix")
    X$assign <- factor(col.assign)
    X$index <- factor(index)
    rcor <- matrix(0, nc, X$nf)
    rcor <- row(rcor) + 0 + (0 + (0+1i)) * col(rcor)
    floc <- function(x) {
        i <- Re(x)
        j <- Im(x)
        if (index[i] == "q") {
            if (sum(col.assign == i)) {
                w <- X$l1[, j] * X$lw * X$tab[, col.assign == 
                  i]
                return(sum(w)^2)
            }
            else {
                w <- X$lw * X$l1[, j]
                w <- X$tab[, col.assign == i] * w
                w <- apply(w, 2, sum)
                return(sum(w^2))
            }
        }
        else if (index[i] == "f") {
            x <- X$l1[, j] * X$lw
            qual <- df[, i]
            poicla <- unlist(tapply(X$lw, qual, sum))
            z <- unlist(tapply(x, qual, sum))/poicla
            return(sum(poicla * z * z))
        }
        else return(NA)
    }
    rcor <- apply(rcor, c(1, 2), floc)
    rcor <- data.frame(rcor)
    row.names(rcor) <- names(df)
    names(rcor) <- names(X$l1)
    X$cr <- rcor
    X
}

"plot.rlq" <-
function (x, xax = 1, yax = 2, ...) 
{
    if (!inherits(x, "rlq")) 
        stop("Use only with 'rlq' objects")
    if (x$nf == 1) {
        warnings("One axis only : not yet implemented")
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 1, 3, 1, 1, 4, 2, 2,5,2,2,6,8,8,7), 3, 5), 
        respect = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    s.label(x$lR[, c(xax, yax)], sub = "R row scores",csub = 2,clab=1.25)
    s.label(x$lQ[, c(xax, yax)], sub = "Q row scores",csub = 2,clab=1.25)
    s.corcircle(x$aR, xax, yax, sub = "R axes", csub = 2, clab = 1.25)
    s.arrow(x$l1, xax = xax, yax = yax, sub = "R Canonical weights", csub = 2, clab = 1.25)
    s.corcircle(x$aQ, xax, yax, sub = "Q axes", csub = 2, clab = 1.25)
    s.arrow(x$c1, xax = xax, yax = yax, sub = "Q Canonical weights", csub = 2, clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
    
    
}
"print.rlq" <-
function (x, ...) 
{
    if (!inherits(x, "rlq")) 
        stop("to be used with 'rlq' object")
    cat("RLQ analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$rank (rank)     :", x$rank)
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n$RV (RV coeff)   :", x$RV)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(3, 4), list(1:3, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths (crossed array)")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths (crossed array)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(11, 4), list(1:11, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "crossed array (CA)")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "R col = CA row: coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "R col = CA row: normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "Q col = CA column: coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "Q col = CA column: normed scores")
    sumry[6, ] <- c("$lR", nrow(x$lR), ncol(x$lR), "row coordinates (R)")
    sumry[7, ] <- c("$mR", nrow(x$mR), ncol(x$mR), "normed row scores (R)")
    sumry[8, ] <- c("$lQ", nrow(x$lQ), ncol(x$lQ), "row coordinates (Q)")
    sumry[9, ] <- c("$mQ", nrow(x$mQ), ncol(x$mQ), "normed row scores (Q)")
    sumry[10, ] <- c("$aR", nrow(x$aR), ncol(x$aR), "axis onto rlq axis (R)")
    sumry[11, ] <- c("$aQ", nrow(x$aQ), ncol(x$aQ), "axis onto rlq (Q)")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"rlq" <-
function( dudiR, dudiL, dudiQ , scannf = TRUE, nf = 2) {

    normalise.w <- function(X, w) {
    f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
    norm <- apply(X, 2, f2)
    X <- sweep(X, 2, norm, "/")
    return(X)
    }
    

    if (!inherits(dudiR, "dudi")) 
        stop("Object of class dudi expected")
    lig1 <- nrow(dudiR$tab)
    col1 <- ncol(dudiR$tab)
    
    if (!inherits(dudiL, "dudi")) 
        stop("Object of class dudi expected")
    if (!inherits(dudiL, "coa")) 
        stop("dudi.coa expected for table L")
    lig2 <- nrow(dudiL$tab)
    col2 <- ncol(dudiL$tab)
    if (!inherits(dudiQ, "dudi")) 
        stop("Object of class dudi expected")
    lig3 <- nrow(dudiQ$tab)
    col3 <- ncol(dudiQ$tab)
    if (lig1 != lig2) 
        stop("Non equal row numbers")
    if (any((dudiR$lw - dudiL$lw)^2 > 1e-07)) 
        stop("Non equal row weights")
    if (col2 != lig3) 
        stop("Non equal row numbers")
    if (any((dudiL$cw - dudiQ$lw)^2 > 1e-07)) 
        stop("Non equal row weights")
    tabcoiner <- t(as.matrix(dudiR$tab)) %*% diag(dudiL$lw) %*% (as.matrix(dudiL$tab)) %*% diag(dudiL$cw) %*% (as.matrix(dudiQ$tab))
    tabcoiner <- data.frame(tabcoiner)
    names(tabcoiner) <- names(dudiQ$tab)
    row.names(tabcoiner) <- names(dudiR$tab)
    if (nf > dudiR$nf) 
        nf <- dudiR$nf
    if (nf > dudiQ$nf) 
        nf <- dudiQ$nf
    coi <- as.dudi(tabcoiner, dudiQ$cw, dudiR$cw, scannf = scannf, nf = nf, call = match.call(), type = "rlq")
    U <- as.matrix(coi$c1) * unlist(coi$cw)
    U <- data.frame(as.matrix(dudiQ$tab) %*% U)
    row.names(U) <- row.names(dudiQ$tab)
    names(U) <- paste("AxcQ", (1:coi$nf), sep = "")
    coi$lQ <- U
    U <- normalise.w(U, dudiQ$lw)
    row.names(U) <- row.names(dudiQ$tab)
    names(U) <- paste("NorS", (1:coi$nf), sep = "")
    coi$mQ <- U
    U <- as.matrix(coi$l1) * unlist(coi$lw)
    U <- data.frame(as.matrix(dudiR$tab) %*% U)
    row.names(U) <- row.names(dudiR$tab)
    names(U) <- paste("AxcR", (1:coi$nf), sep = "")
    coi$lR <- U
    U <- normalise.w(U, dudiR$lw)
    row.names(U) <- row.names(dudiR$tab)
    names(U) <- paste("NorS", (1:coi$nf), sep = "")
    coi$mR <- U
    U <- as.matrix(coi$c1) * unlist(coi$cw)
    U <- data.frame(t(as.matrix(dudiQ$c1)) %*% U)
    row.names(U) <- paste("Ax", (1:dudiQ$nf), sep = "")
    names(U) <- paste("AxcQ", (1:coi$nf), sep = "")
    coi$aQ <- U
    U <- as.matrix(coi$l1) * unlist(coi$lw)
    U <- data.frame(t(as.matrix(dudiR$c1)) %*% U)
    row.names(U) <- paste("Ax", (1:dudiR$nf), sep = "")
    names(U) <- paste("AxcR", (1:coi$nf), sep = "")
    coi$aR <- U
    RV <- sum(coi$eig)/sqrt(sum(dudiQ$eig^2))/sqrt(sum(dudiR$eig^2))
    coi$RV <- RV
    return(coi)
    
}

"summary.rlq" <-
function (object, ...) 
{
    if (!inherits(object, "rlq")) 
        stop("to be used with 'rlq' object")
    appel <- as.list(object$call)
    dudiL <- eval(appel$dudiL, sys.frame(0))
    dudiR <- eval(appel$dudiR, sys.frame(0))
    dudiQ <- eval(appel$dudiQ, sys.frame(0))
    norm.w <- function(X, w) {
        f2 <- function(v) sqrt(sum(v * v * w)/sum(w))
        norm <- apply(X, 2, f2)
        return(norm)
    }
    util <- function(n) {
        x <- "1"
        for (i in 2:n) x[i] <- paste(x[i - 1], i, sep = "")
        return(x)
    }
    eig <- object$eig[1:object$nf]
    covar <- sqrt(eig)
    sdR <- norm.w(object$lR, dudiR$lw)
    sdQ <- norm.w(object$lQ, dudiQ$lw)
    corr <- covar/sdR/sdQ
    U <- cbind.data.frame(eig, covar, sdR, sdQ, corr)
    row.names(U) <- as.character(1:object$nf)
    cat("\nEigenvalues decomposition:\n")
    print(U)
    cat("\nInertia & coinertia R:\n")
    inertia <- cumsum(sdR^2)
    max <- cumsum(dudiR$eig[1:object$nf])
    ratio <- inertia/max
    U <- cbind.data.frame(inertia, max, ratio)
    row.names(U) <- util(object$nf)
    print(U)
    cat("\nInertia & coinertia Q:\n")
    inertia <- cumsum(sdQ^2)
    max <- cumsum(dudiQ$eig[1:object$nf])
    ratio <- inertia/max
    U <- cbind.data.frame(inertia, max, ratio)
    row.names(U) <- util(object$nf)
    print(U)
    cat("\nCorrelation L:\n")

    max <- sqrt(dudiL$eig[1:object$nf])
    ratio <- corr/max
    U <- cbind.data.frame(corr, max, ratio)
    row.names(U) <- 1:object$nf
    print(U)
    RV <- sum(object$eig)/sqrt(sum(dudiR$eig^2))/sqrt(sum(dudiQ$eig^2))
    cat("\nRV:\n", RV, "\n")

}

randtest.rlq<-function(xtest, nrepet=999,RV=TRUE,...)
{
    nrepet<-nrepet+1
    if (!inherits(xtest,"dudi"))
        stop("Object of class dudi expected")
    if (!inherits(xtest,"rlq"))
        stop("Object of class 'rlq' expected")
    appel<-as.list(xtest$call)
    dudiR<-eval(appel$dudiR,sys.frame(0))
    dudiQ<-eval(appel$dudiQ,sys.frame(0))
    dudiL<-eval(appel$dudiL,sys.frame(0))
    acm.util <- function(cl) {
        n <- length(cl)
        cl <- as.factor(cl)
        x <- matrix(0, n, length(levels(cl)))
        x[(1:n) + n * (unclass(cl) - 1)] <- 1
        dimnames(x) <- list(names(cl), as.character(levels(cl)))
        data.frame(x)
    }

    R.cw<-dudiR$cw
    R.lw<-dudiR$lw
    appelR<-as.list(dudiR$call)
    Rinit<-eval(appelR$df,sys.frame(0))
    if (appelR[[1]] == "dudi.pca") {        
        if (is.null(appelR$scale)) appelR$scale<-TRUE
        if (appelR$scale=="TRUE") appelR$scale<-TRUE
        if (appelR$scale=="FALSE") appelR$scale<-FALSE
        if (is.null(appelR$center)) appelR$center<-TRUE
        if (appelR$center=="TRUE") appelR$center<-TRUE
        if (appelR$center=="FALSE") appelR$center<-FALSE
        if (appelR$center == FALSE && appelR$scale == FALSE) typR<-"nc"
        if (appelR$center == FALSE && appelR$scale == TRUE) typR<-"cs"
        if (appelR$center == TRUE  && appelR$scale == FALSE) typR<-"cp"
        if (appelR$center == TRUE  && appelR$scale == TRUE) typR<-"cn"
        indexR<-rep("q",ncol(Rinit))
        assignR<-1:ncol(Rinit)
    } else if (appelR[[1]] == "dudi.coa") {
        typR<-"fc"
        indexR<-rep("q",ncol(Rinit))
        assignR<-1:ncol(Rinit)
    } else if (appelR[[1]] == "dudi.fca") {
        typR<-"fc"
        indexR<-rep("q",ncol(Rinit))
        assignR<-1:ncol(Rinit)
    } else if (appelR[[1]] == "dudi.acm") {
        typR<-"cm"
        indexR<-rep("f",ncol(Rinit))
        assignR<- rep(1:ncol(Rinit),apply(Rinit,2,function(x) length(levels(as.factor(x)))))
        Rinit <- acm.disjonctif(Rinit)
    } else if (appelR[[1]] == "dudi.hillsmith") {
        indexR<-dudiR$index
        assignR<-dudiR$assign
        if (all(indexR=="f")){
            typR<-"cm"
            Rinit <- acm.disjonctif(Rinit)
        }
        else if (all(indexR=="q")){
            typR<-"cn"
        }
        
        else{
            typR<-"hi"
            res <- matrix(0, nrow(Rinit), 1)

            for (j in 1:(ncol(Rinit))) {
                if (indexR[j] == "q") {
                    res <- cbind(res, Rinit[, j])
                }
                else if (indexR[j] == "f") {
                    w <- acm.util(factor(Rinit[, j]))
                    res <- cbind(res, w)
                }
            }
            Rinit<-res[,-1]
        }
    }


    
    Q<-dudiQ$tab
    Q.cw<-dudiQ$cw
    Q.lw<-dudiQ$lw
    appelQ<-as.list(dudiQ$call)
    Qinit<-eval(appelQ$df,sys.frame(0))
    
    if (appelQ[[1]] == "dudi.pca") {        
        if (is.null(appelQ$scale)) appelQ$scale<-TRUE
        if (appelQ$scale=="TRUE") appelQ$scale<-TRUE
        if (appelQ$scale=="FALSE") appelQ$scale<-FALSE
        if (is.null(appelQ$center)) appelQ$center<-TRUE
        if (appelQ$center=="TRUE") appelQ$center<-TRUE
        if (appelQ$center=="FALSE") appelQ$center<-FALSE
        if (appelQ$center == FALSE && appelQ$scale == FALSE) typQ<-"nc"
        if (appelQ$center == FALSE && appelQ$scale == TRUE) typQ<-"cs"
        if (appelQ$center == TRUE  && appelQ$scale == FALSE) typQ<-"cp"
        if (appelQ$center == TRUE  && appelQ$scale == TRUE) typQ<-"cn"
        indexQ<-rep("q",ncol(Qinit))
        assignQ<-1:ncol(Qinit)
    } else if (appelQ[[1]] == "dudi.coa") {
        typQ<-"fc"
        indexQ<-rep("q",ncol(Qinit))
        assignQ<-1:ncol(Qinit)
    } else if (appelQ[[1]] == "dudi.fca") {
        typQ<-"fc"
        indexQ<-rep("q",ncol(Qinit))
        assignQ<-1:ncol(Qinit)
    } else if (appelQ[[1]] == "dudi.acm") {
        typQ<-"cm"
        indexQ<-rep("f",ncol(Qinit))
        assignQ<- rep(1:ncol(Qinit),apply(Qinit,2,function(x) length(levels(as.factor(x)))))
        Qinit <- acm.disjonctif(Qinit)
        
    } else if (appelQ[[1]] == "dudi.hillsmith") {
        indexQ<-dudiQ$index
        assignQ<-dudiQ$assign
        if (all(indexQ=="f")){
            typQ<-"cm"
            Qinit <- acm.disjonctif(Qinit)
        }
        else if (all(indexQ=="q")){
            typQ<-"cn"
        }
        
        else{
            typQ<-"hi"
            res <- matrix(0, nrow(Qinit), 1)
            for (j in 1:(ncol(Qinit))) {
                if (indexQ[j] == "q") {
                    res <- cbind(res, Qinit[, j])
                }
                else if (indexQ[j] == "f") {
                    w <- acm.util(factor(Qinit[, j]))
                    res <- cbind(res, w)
                }
            }
            Qinit<-res[,-1]
        }
    }   

    L<-dudiL$tab
    L.cw<-dudiL$cw
    L.lw<-dudiL$lw
    isim<-testertracerlq(nrepet, R.cw, Q.cw, L.lw, L.cw, Rinit,Qinit,L, typQ,typR,ifelse(indexR=='f',1,2),assignR,ifelse(indexQ=='f',1,2),assignQ)
    # On calcule le RV a partir de la coinertie
    if (RV) {isim<-isim/sqrt(sum(dudiR$eig^2))/sqrt(sum(dudiQ$eig^2))}
    obs<-isim[1]
    return(as.randtest(isim[-1],obs,call=match.call()))
}

testertracerlq<-function (npermut, pcR, pcQ, plL, pcL,tabR, tabQ, tabL,typQ, typR,indexR,assignR,indexQ,assignQ){ 
.C("testertracerlq", as.integer(npermut), as.double(pcR), as.integer(length(pcR)), 
    as.double(pcQ), as.integer(length(pcQ)), as.double(plL), as.integer(length(plL)),
    as.double(pcL), as.integer(length(pcL)), 
    as.double(t(tabR)), as.double(t(tabQ)),as.double(t(tabL)),
    as.integer(assignR),as.integer(assignQ),
    as.integer(indexR),as.integer (length(indexR)),as.integer(indexQ), as.integer (length(indexQ)),
    as.character(typQ), typR=as.character(typR), inersim = double(npermut), PACKAGE = "ade4")$inersim
}

"as.rtest" <- function (sim, obs, call = match.call()) {
    res <- list(sim = sim, obs = obs)
    res$rep <- length(sim)
    res$pvalue <- (sum(sim >= obs) + 1)/(length(sim) + 1)
    res$call <- call
    class(res) <- "rtest"
    return(res)
} 

"plot.rtest" <- function (x, nclass = 10, coeff = 1, ...) {
    if (!inherits(x, "rtest")) 
        stop("Non convenient data")
    obs <- x$obs
    sim <- x$sim
    r0 <- c(sim, obs)
    h0 <- hist(sim, plot = FALSE, nclass = nclass, xlim = xlim0)
    y0 <- max(h0$counts)
    l0 <- max(sim) - min(sim)
    w0 <- l0/(log(length(sim), base = 2) + 1)
    w0 <- w0 * coeff
    xlim0 <- range(r0) + c(-w0, w0)
    hist(sim, plot = TRUE, nclass = nclass, xlim = xlim0, col = grey(0.8), 
        ...)
    lines(c(obs, obs), c(y0/2, 0))
    points(obs, y0/2, pch = 18, cex = 2)
    invisible()
} 

"print.rtest" <- function (x, ...) {
    if (!inherits(x, "rtest")) 
        stop("Non convenient data")
    cat("Monte-Carlo test\n")
    cat("Observation:", x$obs, "\n")
    cat("Call: ")
    print(x$call)
    cat("Based on", x$rep, "replicates\n")
    cat("Simulated p-value:", x$pvalue, "\n")
} 

"rtest" <- function (xtest, ...) {
    UseMethod("rtest")
}
"rtest.between" <- function (xtest, nrepet = 99, ...) {
    if (!inherits(xtest, "dudi")) 
        stop("Object of class dudi expected")
    if (!inherits(xtest, "between")) 
        stop("Type 'between' expected")
    appel <- as.list(xtest$call)
    dudi1 <- eval(appel$dudi, sys.frame(0))
    fac <- eval(appel$fac, sys.frame(0))
    X <- dudi1$tab
    X.lw <- dudi1$lw
    X.lw <- X.lw/sum(X.lw)
    X.cw <- sqrt(dudi1$cw)
    X <- t(t(X) * X.cw)
    inertot <- sum(dudi1$eig)
    inerinter <- function(perm = TRUE) {
        if (perm) 
            sel <- sample(nrow(X))
        else sel <- 1:nrow(X)
        Y <- X[sel, ]
        Y.lw <- X.lw[sel]
        cla.w <- tapply(Y.lw, fac, sum)
        Y1 <- Y * Y.lw
        Y <- apply(Y * Y.lw, 2, function(x) tapply(x, fac, sum)/cla.w)
        inerb <- sum(apply(Y, 2, function(x) sum(x * x * cla.w)))
        return(inerb/inertot)
    }
    obs <- inerinter(FALSE)
    sim <- unlist(lapply(1:nrepet, inerinter))
    return(as.rtest(sim, obs))
}
 "rtest.discrimin" <- function (xtest, nrepet = 99, ...) {
    if (!inherits(xtest, "discrimin")) 
        stop("'discrimin' object expected")
    appel <- as.list(xtest$call)
    dudi <- eval(appel$dudi, sys.frame(0))
    fac <- eval(appel$fac, sys.frame(0))
    lig <- nrow(dudi$tab)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    rank <- dudi$rank
    dudi <- redo.dudi(dudi, rank)
    dudi.lw <- dudi$lw
    dudi <- dudi$l1
    between.var <- function(x, w, group, group.w) {
        z <- x * w
        z <- tapply(z, group, sum)/group.w
        return(sum(z * z * group.w))
    }
    inertia.ratio <- function(perm = TRUE) {
        if (perm) {
            sigma <- sample(lig)
            Y <- dudi[sigma, ]
            Y.w <- dudi.lw[sigma]
        }
        else {
            Y <- dudi
            Y.w <- dudi.lw
        }
        cla.w <- tapply(Y.w, fac, sum)
        ww <- apply(Y, 2, between.var, w = Y.w, group = fac, 
            group.w = cla.w)
        return(sum(ww)/rank)
    }
    obs <- inertia.ratio(perm = FALSE)
    sim <- unlist(lapply(1:nrepet, inertia.ratio))
    return(as.rtest(sim, obs))
}
"s.arrow" <- function (dfxy, xax = 1, yax = 2, label = row.names(dfxy), clabel = 1,
    pch = 20, cpoint = 0, edge = TRUE, origin = c(0, 0), xlim = NULL, 
    ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1, sub = "", 
    csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL, 
    area = NULL, add.plot = FALSE) 
{
    arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1, 
        edge) {
        d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
        if (d0 < 1e-07) 
            return(invisible())
        segments(x0, y0, x1, y1, lty = lty)
        h <- strheight("A", cex = par("cex"))
        if (d0 > 2 * h) {
            x0 <- x1 - h * (x1 - x0)/d0
            y0 <- y1 - h * (y1 - y0)/d0
            if (edge) 
                arrows(x0, y0, x1, y1, ang = ang, len = len, 
                  lty = 1)
        }
    }
    dfxy <- data.frame(dfxy)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = TRUE, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (grid & !add.plot) 
        scatterutil.grid(cgrid)
    if (addaxes & !add.plot) 
        abline(h = 0, v = 0, lty = 1)
    if (cpoint > 0) 
        points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
    for (i in 1:(length(coo$x))) arrow1(origin[1], origin[2], 
        coo$x[i], coo$y[i], edge = edge)
    if (clabel > 0) 
        scatterutil.eti.circ(coo$x, coo$y, label, clabel, origin)
    if (csub > 0) 
        scatterutil.sub(sub, csub, possub)
    box()
}
"s.chull" <- function (dfxy, fac, xax = 1, yax = 2, optchull = c(0.25, 0.5,
    0.75, 1), label = levels(fac), clabel = 1, cpoint = 0, col = rep(1, length(levels(fac))),
    xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, origin = c(0, 0), 
    include.origin = TRUE, sub = "", csub = 1, possub = "bottomleft", 
    cgrid = 1, pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE) 
{
    dfxy <- data.frame(dfxy)
    opar <- par(mar = par("mar"))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    on.exit(par(opar))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    scatterutil.chull(coo$x, coo$y, fac, optchull = optchull, col=col)
    if (cpoint > 0) 
    	for (i in 1:nlevels(fac)) {
	        points(coo$x[fac == levels(fac)[i]], coo$y[fac == levels(fac)[i]], pch = 20, cex = par("cex") * cpoint, col=col[i])
	    }
    if (clabel > 0) {
        coox <- tapply(coo$x, fac, mean)
        cooy <- tapply(coo$y, fac, mean)
        scatterutil.eti(coox, cooy, label, clabel, coul = col)
    }
    box()
}
"s.class" <- function (dfxy, fac, wt = rep(1, length(fac)), xax = 1, yax = 2, 
    cstar = 1, cellipse = 1.5, axesell = TRUE, label = levels(fac), 
    clabel = 1, cpoint = 1, pch = 20, col = rep(1, length(levels(fac))), xlim = NULL, ylim = NULL, 
    grid = TRUE, addaxes = TRUE, origin = c(0, 0), include.origin = TRUE, 
    sub = "", csub = 1, possub = "bottomleft", cgrid = 1, pixmap = NULL, 
    contour = NULL, area = NULL, add.plot = FALSE) 
{
    f1 <- function(cl) {
        n <- length(cl)
        cl <- as.factor(cl)
        x <- matrix(0, n, length(levels(cl)))
        x[(1:n) + n * (unclass(cl) - 1)] <- 1
        dimnames(x) <- list(names(cl), levels(cl))
        data.frame(x)
    }
    opar <- par(mar = par("mar"))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    on.exit(par(opar))
    dfxy <- data.frame(dfxy)
    if (!is.data.frame(dfxy)) 
        stop("Non convenient selection for dfxy")
    if (any(is.na(dfxy))) 
        stop("NA non implemented")
    if (!is.factor(fac)) 
        stop("factor expected for fac")
    dfdistri <- f1(fac) * wt
    coul=col
    w1 <- unlist(lapply(dfdistri, sum))
    dfdistri <- t(t(dfdistri)/w1)
    coox <- as.matrix(t(dfdistri)) %*% dfxy[, xax]
    cooy <- as.matrix(t(dfdistri)) %*% dfxy[, yax]
    if (nrow(dfxy) != nrow(dfdistri)) 
        stop(paste("Non equal row numbers", nrow(dfxy), nrow(dfdistri)))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (cpoint > 0)
    	for (i in 1:ncol(dfdistri)) {
			points(coo$x[dfdistri[,i] > 0], coo$y[dfdistri[,i] > 0], pch = pch, cex = par("cex") * cpoint, col=coul[i])
		}
    if (cstar > 0) 
        for (i in 1:ncol(dfdistri)) {
            scatterutil.star(coo$x, coo$y, dfdistri[, i], cstar = cstar, coul[i])
        }
    if (cellipse > 0) 
        for (i in 1:ncol(dfdistri)) {
            scatterutil.ellipse(coo$x, coo$y, dfdistri[, i], 
                cellipse = cellipse, axesell = axesell, coul[i])
        }
    if (clabel > 0) 
        scatterutil.eti(coox, cooy, label, clabel, coul = col)
    box()
}
"s.corcircle" <- function (dfxy, xax = 1, yax = 2, label = row.names(df), clabel = 1,
    grid = TRUE, sub = "", csub = 1, possub = "bottomleft", cgrid = 0, 
    fullcircle = TRUE, box = FALSE, add.plot = FALSE) 
{
    arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1, 
        edge) {
        d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
        if (d0 < 1e-07) 
            return(invisible())
        segments(x0, y0, x1, y1, lty = lty)
        h <- strheight("A", cex = par("cex"))
        if (d0 > 2 * h) {
            x0 <- x1 - h * (x1 - x0)/d0
            y0 <- y1 - h * (y1 - y0)/d0
            if (edge) 
                arrows(x0, y0, x1, y1, ang = ang, len = len, 
                  lty = 1)
        }
    }
    scatterutil.circ <- function(cgrid, h) {
        cc <- seq(from = -1, to = 1, by = h)
        col <- "lightgray"
        lty <- 1
        for (i in 1:(length(cc))) {
            x <- cc[i]
            a1 <- sqrt(1 - x * x)
            a2 <- (-a1)
            segments(x, a1, x, a2, col = col)
            segments(a1, x, a2, x, col = col)
        }
        symbols(0, 0, circles = 1, inches = FALSE, add = TRUE)
        segments(-1, 0, 1, 0)
        segments(0, -1, 0, 1)
        if (cgrid <= 0) 
            return(invisible())
        cha <- paste("d = ", h, sep = "")
        cex0 <- par("cex") * cgrid
        xh <- strwidth(cha, cex = cex0)
        yh <- strheight(cha, cex = cex0) + strheight(" ", cex = cex0)/2
        x0 <- strwidth(" ", cex = cex0)
        y0 <- strheight(" ", cex = cex0)/2
        x1 <- par("usr")[2]
        y1 <- par("usr")[4]
        rect(x1 - x0, y1 - y0, x1 - xh - x0, y1 - yh - y0, col = "white", 
            border = 0)
        text(x1 - xh/2 - x0/2, y1 - yh/2 - y0/2, cha, cex = cex0)
    }
    origin <-c(0,0)
    df <- data.frame(dfxy)
    if (!is.data.frame(df)) 
        stop("Non convenient selection for df")
    if ((xax < 1) || (xax > ncol(df))) 
        stop("Non convenient selection for xax")
    if ((yax < 1) || (yax > ncol(df))) 
        stop("Non convenient selection for yax")
    if (!is.null(label)) 
        showpoint <- FALSE
    x <- df[, xax]
    y <- df[, yax]
    if (add.plot) {
        for (i in 1:length(x)) arrow1(0, 0, x[i], y[i], len = 0.1, 
            ang = 15, edge = TRUE)
        if (clabel > 0) 
            scatterutil.eti.circ(x, y, label, clabel)
        return(invisible())
    }
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    x1 <- x
    y1 <- y
    x1 <- c(x1, -0.01, +0.01)
    y1 <- c(y1, -0.01, +0.01)
    if (fullcircle) {
        x1 <- c(x1, -1, 1)
        y1 <- c(y1, -1, 1)
    }
    x1 <- c(x1 - diff(range(x1)/20), x1 + diff(range(x1))/20)
    y1 <- c(y1 - diff(range(y1)/20), y1 + diff(range(y1))/20)
    plot(x1, y1, type = "n", ylab = "", asp = 1, xaxt = "n", 
        yaxt = "n", frame.plot = FALSE)
    if (grid) 
        scatterutil.circ(cgrid = cgrid, h = 0.2)
    for (i in 1:length(x)) arrow1(0, 0, x[i], y[i], len = 0.1, 
        ang = 15, edge = TRUE)
    if (clabel > 0) 
        scatterutil.eti.circ(x, y, label, clabel,origin)
    if (csub > 0) 
        scatterutil.sub(sub, csub, possub)
    if (box) 
        box()
}
"s.distri" <- function (dfxy, dfdistri, xax = 1, yax = 2, cstar = 1, cellipse = 1.5,
    axesell = TRUE, label = names(dfdistri), clabel = 0, cpoint = 1, 
    pch = 20, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, 
    origin = c(0, 0), include.origin = TRUE, sub = "", csub = 1, 
    possub = "bottomleft", cgrid = 1, pixmap = NULL, contour = NULL, 
    area = NULL, add.plot = FALSE) 
{
    opar <- par(mar = par("mar"))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    on.exit(par(opar))
    dfxy <- data.frame(dfxy)
    dfdistri <- data.frame(dfdistri)
    if (!is.data.frame(dfxy)) 
        stop("Non convenient selection for dfxy")
    if (!is.data.frame(dfdistri)) 
        stop("Non convenient selection for dfdistri")
    if (any(dfdistri < 0)) 
        stop("Non convenient selection for dfdistri")
    if (nrow(dfxy) != nrow(dfdistri)) 
        stop("Non equal row numbers")
    if (any(is.na(dfxy))) 
        stop("NA non implemented")
    w1 <- unlist(lapply(dfdistri, sum))
    label <- label
    dfdistri <- t(t(dfdistri)/w1)
    coox <- as.matrix(t(dfdistri)) %*% as.matrix(dfxy[, xax])
    cooy <- as.matrix(t(dfdistri)) %*% as.matrix(dfxy[, yax])
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (cpoint > 0) 
        points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
    if (cstar > 0) 
        for (i in 1:ncol(dfdistri)) {
            scatterutil.star(coo$x, coo$y, dfdistri[, i], cstar = cstar)
        }
    if (cellipse > 0) 
        for (i in 1:ncol(dfdistri)) {
            scatterutil.ellipse(coo$x, coo$y, dfdistri[, i], 
                cellipse = cellipse, axesell = axesell)
        }
    if (clabel > 0) 
        scatterutil.eti(unlist(coox), unlist(cooy), label, clabel)
    box()
}
"s.hist" <- function(dfxy, xax = 1, yax = 2, cgrid=1, cbreaks=2, adjust=1,...) {
    def.par <- par(no.readonly = TRUE)# save default, for resetting...
    nf <- layout(matrix(c(2,4,1,3),2,2,byrow=TRUE), c(3,1), c(1,3), TRUE)
    ## pour avoir des quadrillages compatibles
    if (cbreaks>=1) cbreaks <- floor(cbreaks)
    else if (cbreaks<0.1) cbreaks <- 2
    else cbreaks <-  1/floor(1/cbreaks)
    layout.show(nf)
    ## trac du nuage 
    s.label(dfxy,xax,yax,cgrid=cgrid,...)
    par(mar=c(0.1,0.1,0.1,0.1))
    ## quadrillage du plan
    col <- "lightgray"
    lty <- 1
    xmin <- par("xaxp")[1]
    xmax <- par("xaxp")[2]
    xampli <- par("xaxp")[3]
     ax <- (xmax-xmin)/xampli/cbreaks

    ymin <- par("yaxp")[1]
    ymax <- par("yaxp")[2]
    yampli <- par("yaxp")[3]
    ay <- (ymax-ymin)/yampli/cbreaks
    a <- min(ax, ay)
    while ((xmin-a)>par("usr")[1]) xmin<-xmin-a
    while ((xmax+a)<par("usr")[2]) xmax<-xmax+a
    while ((ymin-a)>par("usr")[3]) ymin<-ymin-a
    while ((ymax+a)<par("usr")[4]) ymax<-ymax+a
    v0 <- seq(xmin, xmax, by = a)
    h0 <- seq(ymin, ymax, by = a)
    if (par("usr")[1] < xmin) v0 <- c(par("usr")[1],v0)
    if (par("usr")[2] > xmax) v0 <- c(v0,par("usr")[2])
    if (par("usr")[3] < ymin) h0 <- c(par("usr")[3],h0)
    if (par("usr")[4] > ymax) h0 <- c(h0,par("usr")[4])
    abline(v = v0[v0!=0], col = col, lty = lty)
    abline(h = h0[h0!=0], col = col, lty = lty)
    if (cgrid > 0) {
        a1 = round(a,dig=3)
        cha <- paste(" d = ", a1, " ", sep = "")
        cex0 <- par("cex") * cgrid
        xh <- strwidth(cha, cex = cex0)
        yh <- strheight(cha, cex = cex0) * 5/3
        x1 <- par("usr")[2]
        y1 <- par("usr")[4]
        rect(x1 - xh, y1 - yh, x1 + xh, y1 + yh, col = "white", border = 0)
        text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
    }
    para<-par("usr")
    abline(h = 0, v = 0, lty = 1)
    box()

    ## calcul des histogrammes 
    nlig <- nrow(dfxy)
    w <- dfxy[,xax]
    xhist <- hist(w, breaks=v0,plot=FALSE)
    xdens <- density(w,adjust=adjust)
    xdensx <- xdens[[1]]
    xdensy <- xdens[[2]]*nlig*a
    w <- dfxy[,yax]
    yhist <- hist(w, breaks=h0,plot=FALSE)
    ydens <- density(w,adjust=adjust)
    ydensx <- ydens[[2]]*nlig*a
    ydensy <- ydens[[1]]
    top <- max(c(xhist$counts, yhist$counts))
    leg <- pretty(0:top)
    leg <- leg[-c(1,length(leg))]
    ## l'histogramme des x
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE)
    par(usr=c(para[1:2],c(0,top)))
    abline(h=leg,lty=2)
    rect(xhist$mids-a/2,rep(0,length(xhist$mids)),xhist$mids+a/2,xhist$counts,col=grey(0.8))
    lines(xdensx,xdensy)
    ## l'histogramme des y
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE)
    par(usr=c(c(0,top),para[3:4]))
    abline(v=leg,lty=2)
    rect(rep(0,length(yhist$mids)),yhist$mids-a/2,yhist$counts,yhist$mids+a/2,col=grey(0.8))
    lines(ydensx,ydensy)
    ## la lgende dans le petit carr
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = FALSE)
    par(usr=c(c(0,top),c(0,top)))
    print(leg)
    symbols(rep(0,length(leg)),rep(0,length(leg)),circ=leg,lty=2,inch=FALSE, add=TRUE)
    scatterutil.eti (sqrt(0.5)*leg, sqrt(0.5)*leg, as.character(leg), clabel=1)
    ## restauration des paramtres
    par(def.par)#- reset to default
}


s.image <- function(dfxy, z, xax=1, yax=2, span=0.5,
    xlim = NULL, ylim = NULL,
    kgrid=2, scale=TRUE, 
    grid = FALSE, addaxes = FALSE, cgrid = 0, include.origin = FALSE, 
    origin = c(0, 0), sub = "", csub = 1, possub = "topleft", 
    neig = NULL, cneig = 1, image.plot=TRUE, contour.plot=TRUE,
    pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE) 
{
    dfxy <- data.frame(dfxy)
    if (scale) z <- scalewt(z)
    if (length(z) != nrow(dfxy)) 
        stop(paste("Non equal row numbers", nrow(dfxy), length(z)))
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    xy <- dfxy[,c(xax,yax)]
    names(xy) <- c("x","y")
    coo <- scatterutil.base(dfxy = xy, xax = xax, yax = yax, 
            xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
            cgrid = cgrid, include.origin = include.origin, origin = origin, 
            sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
            contour = contour, area = area, add.plot = add.plot)
    if (!require(splancs)) stop ("splancs required for inout")
    if (!require(modreg)) stop ("modreg required for loess")
    w = cbind.data.frame(xy,z)
    ngrid <- floor(kgrid*sqrt(nrow(w)))
    if (ngrid<5) ngrid<-5
    lo=loess(z~x+y,data=w,span=span)
    xg = seq(from=par("usr")[1],to=par("usr")[2],le=ngrid)
    yg = seq(from=par("usr")[3],to=par("usr")[4],le=ngrid)
    gr=expand.grid(xg, yg)
    names(gr)=names(xy)
    mod = predict(lo,newdata=gr)
    if (is.null(area)) {
        polyin = w[chull(xy),]
        grin = inpip(gr,polyin)
        mod[-grin] = NA
    } else {
        grin=rep(0,nrow(gr))
        larea <- split(area[,2:3],area[,1])
        lapply(larea,function(x) grin<<- grin+inout(gr,x))
          mod[!grin] = NA
    }
    mod = matrix(mod,ngrid,ngrid)
    if (image.plot) image(xg,yg,mod,add=TRUE, col=gray((32:0)/32))
    if (contour.plot) contour(xg,yg,mod,add=TRUE,labcex=1,lwd=2,nlevels=5,levels=pretty(z,7)[-c(1,7)],col="red")  
}

"s.label" <- function (dfxy, xax = 1, yax = 2, label = row.names(dfxy), clabel = 1,
    pch = 20, cpoint = if (clabel == 0) 1 else 0, neig = NULL, 
    cneig = 2, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, 
    cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "", 
    csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL, 
    area = NULL, add.plot = FALSE) 
{
    dfxy <- data.frame(dfxy)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (!is.null(neig)) {
        if (is.null(class(neig))) 
            neig <- NULL
        if (class(neig) != "neig") 
            neig <- NULL
        deg <- attr(neig, "degrees")
        if ((length(deg)) != (length(coo$x))) 
            neig <- NULL
    }
    if (!is.null(neig)) {
        fun <- function(x, coo) {
            segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]], 
                lwd = par("lwd") * cneig)
        }
        apply(unclass(neig), 1, fun, coo = coo)
    }
    if (clabel > 0) 
        scatterutil.eti(coo$x, coo$y, label, clabel)
    if (cpoint > 0) 
        points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
    box()
}
"s.match" <- function (df1xy, df2xy, xax = 1, yax = 2, pch = 20, cpoint = 1,
    label = row.names(df1xy), clabel = 1, edge = TRUE, xlim = NULL, 
    ylim = NULL, grid = TRUE, addaxes = TRUE, cgrid = 1, include.origin = TRUE, 
    origin = c(0, 0), sub = "", csub = 1.25, possub = "bottomleft", 
    pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE) 
{
    arrow1 <- function(x0, y0, x1, y1, len = 0.1, ang = 15, lty = 1, 
        edge) {
        d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
        if (d0 < 1e-07) 
            return(invisible())
        segments(x0, y0, x1, y1, lty = lty)
        h <- strheight("A", cex = par("cex"))
        if (d0 > 2 * h) {
            x0 <- x1 - h * (x1 - x0)/d0
            y0 <- y1 - h * (y1 - y0)/d0
            if (edge) 
                arrows(x0, y0, x1, y1, ang = ang, len = len, 
                  lty = 1)
        }
    }
    df1xy <- data.frame(df1xy)
    df2xy <- data.frame(df2xy)
    if (!is.data.frame(df1xy)) 
        stop("Non convenient selection for df1xy")
    if (!is.data.frame(df2xy)) 
        stop("Non convenient selection for df2xy")
    if (any(is.na(df1xy))) 
        stop("NA non implemented")
    if (any(is.na(df2xy))) 
        stop("NA non implemented")
    n <- nrow(df1xy)
    if (n != nrow(df2xy)) 
        stop("Non equal row numbers")
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = rbind.data.frame(df1xy, df2xy), 
        xax = xax, yax = yax, xlim = xlim, ylim = ylim, grid = grid, 
        addaxes = addaxes, cgrid = cgrid, include.origin = include.origin, 
        origin = origin, sub = sub, csub = csub, possub = possub, 
        pixmap = pixmap, contour = contour, area = area, add.plot = add.plot)
    for (i in 1:n) {
        arrow1(coo$x[i], coo$y[i], coo$x[i + n], coo$y[i + n], 
            lty = 1, edge = edge)
    }
    if (cpoint > 0) 
        points(coo$x[1:n], coo$y[1:n], pch = pch, cex = par("cex") * 
            cpoint)
    if (clabel > 0) {
        a <- (coo$x[1:n] + coo$x[(n + 1):(2 * n)])/2
        b <- (coo$y[1:n] + coo$y[(n + 1):(2 * n)])/2
        scatterutil.eti(a, b, label, clabel)
    }
    box()
}
"s.traject" <- function (dfxy, fac = factor(rep(1, nrow(dfxy))), ord = (1:length(fac)),
    xax = 1, yax = 2, label = levels(fac), clabel = 1, cpoint = 1, 
    pch = 20, xlim = NULL, ylim = NULL, grid = TRUE, addaxes = TRUE, 
    edge = TRUE, origin = c(0, 0), include.origin = TRUE, sub = "", 
    csub = 1, possub = "bottomleft", cgrid = 1, pixmap = NULL, 
    contour = NULL, area = NULL, add.plot = FALSE) 
{
    opar <- par(mar = par("mar"))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    on.exit(par(opar))
    dfxy <- data.frame(dfxy)
    if (!is.data.frame(dfxy)) 
        stop("Non convenient selection for dfxy")
    if (any(is.na(dfxy))) 
        stop("NA non implemented")
    if (!is.factor(fac)) 
        stop("factor expected for fac")
    if (length(fac) != nrow(dfxy)) 
        stop("Non convenient length (fac)")
    if (length(ord) != nrow(dfxy)) 
        stop("Non convenient length (ord)")
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    arrow1 <- function(x0, y0, x1, y1, len = 0.15, ang = 15, 
        lty = 1, edge) {
        d0 <- sqrt((x0 - x1)^2 + (y0 - y1)^2)
        if (d0 < 1e-07) 
            return(invisible())
        segments(x0, y0, x1, y1, lty = lty)
        h <- strheight("A", cex = par("cex"))
        x0 <- x1 - h * (x1 - x0)/d0
        y0 <- y1 - h * (y1 - y0)/d0
        if (edge) 
            arrows(x0, y0, x1, y1, ang = 15, len = 0.1, lty = 1)
    }
    trajec <- function(X, cpoint, clabel, label) {
        if (nrow(X) == 1) 
            return(as.numeric(X[1, ]))
        x <- X$x
        y <- X$y
        ord <- order(X$ord)
        fac <- as.numeric(X$fac)
        dmax <- 0
        xmax <- 0
        ymax <- 0
        for (i in 1:(length(x) - 1)) {
            x0 <- x[ord[i]]
            y0 <- y[ord[i]]
            x1 <- x[ord[i + 1]]
            y1 <- y[ord[i + 1]]
            arrow1(x0, y0, x1, y1, lty = fac, edge = edge)
            if (cpoint > 0) 
                points(x0, y0, pch = 14 + fac, cex = par("cex") * 
                  cpoint)
            d0 <- sqrt((origin[1] - (x0 + x1)/2)^2 + (origin[2] - 
                (y0 + y1)/2)^2)
            if (d0 > dmax) {
                xmax <- (x0 + x1)/2
                ymax <- (y0 + y1)/2
                dmax <- d0
            }
        }
        if (cpoint > 0) 
            points(x[ord[length(x)]], y[ord[length(x)]], pch = 14 + 
                fac, cex = par("cex") * cpoint)
        return(c(xmax, ymax))
    }
    provi <- cbind.data.frame(x = coo$x, y = coo$y, fac = fac, 
        ord = ord)
    provi <- split(provi, fac)
    w <- lapply(provi, trajec, cpoint = cpoint, clabel = clabel, 
        label = label)
    w <- t(data.frame(w))
    if (clabel > 0) 
        scatterutil.eti(w[, 1], w[, 2], label, clabel)
    box()
}
"s.value" <- function (dfxy, z, xax = 1, yax = 2, method = c("squaresize",
    "greylevel"), zmax=NULL, csize = 1, cpoint = 0, pch = 20, 
    clegend = 0.75, neig = NULL, cneig = 1, xlim = NULL, ylim = NULL, 
    grid = TRUE, addaxes = TRUE, cgrid = 0.75, include.origin = TRUE, 
    origin = c(0, 0), sub = "", csub = 1, possub = "topleft", 
    pixmap = NULL, contour = NULL, area = NULL, add.plot = FALSE) 
{
    # modif samedi, novembre 29, 2003 at 08:43 le coefficient de taille
    # est rapport aux bornes utilisateurs pour reproduire les mmes
    # valeurs sur plusieurs fentres
    dfxy <- data.frame(dfxy)
    if (length(z) != nrow(dfxy)) 
        stop(paste("Non equal row numbers", nrow(dfxy), length(z)))
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (!is.null(neig)) {
        if (is.null(class(neig))) 
            neig <- NULL
        if (class(neig) != "neig") 
            neig <- NULL
        deg <- attr(neig, "degrees")
        if ((length(deg)) != (length(coo$x))) 
            neig <- NULL
    }
    if (!is.null(neig)) {
        fun <- function(x, coo) {
            segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]], 
                lwd = par("lwd") * cneig)
        }
        apply(unclass(neig), 1, fun, coo = coo)
    }
    
    method <- method [1]
    if (method == "greylevel") {
        br0 <- pretty(z, 6)
        nborn <- length(br0)
        coeff <- diff(par("usr")[1:2])/15
        numclass <- cut.default(z, br0, include = TRUE, lab = FALSE)
        valgris <- seq(1, 0, le = (nborn - 1))
        h <- csize * coeff
        for (i in 1:(nrow(dfxy))) {
            symbols(coo$x[i], coo$y[i], squares = h, bg = gray(valgris[numclass[i]]), 
                add = TRUE, inch = FALSE)
        }
        scatterutil.legend.square.grey(br0, valgris, h/2, clegend)
        if (cpoint > 0) 
            points(coo$x, coo$y, pch = pch, cex = par("cex") * 
                cpoint)
    }
    else if (method == "squaresize") {
        coeff <- diff(par("usr")[1:2])/15
        sq <- sqrt(abs(z))
        if (is.null(zmax)) zmax <- max(abs(z))
        w1 <- sqrt(zmax)
        sq <- csize * coeff * sq/w1
        for (i in 1:(nrow(dfxy))) {
            if (sign(z[i]) >= 0) {
                symbols(coo$x[i], coo$y[i], squares = sq[i],
                    bg = "black", fg = "white", add = TRUE, inch = FALSE)
            }
            else {
                symbols(coo$x[i], coo$y[i], squares = sq[i], 
                  bg = "white", fg = "black", add = TRUE, inch = FALSE)
            }
        }
        br0 <- pretty(z, 4)
        l0 <- length(br0)
        br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
        sq0 <- sqrt(abs(br0))
        sq0 <- csize * coeff * sq0/w1
        sig0 <- sign(br0)
        if (clegend > 0) 
            scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
        if (cpoint > 0) 
            points(coo$x, coo$y, pch = pch, cex = par("cex") * 
                cpoint)
    }
    else if (method == "circlesize") {
        print("not yet implemented")
    }
    box()
}
"scalewt" <- function (X, wt = rep(1, nrow(X)), center = TRUE, scale = TRUE) {
    X <- as.matrix(X)
    n <- nrow(X)
    if (length(wt) != n) 
        stop("length of wt must equal the number of rows in x")
    if (any(wt < 0) || (s <- sum(wt)) == 0) 
        stop("weights must be non-negative and not all zero")
    wt <- wt/s
    center <- if (center) 
        apply(wt * X, 2, sum)
    else 0
    X <- sweep(X, 2, center)
    norm <- apply(X * X * wt, 2, sum)
    norm[norm <= 1e-07 * max(norm)] <- 1
    if (scale) 
        X <- sweep(X, 2, sqrt(norm), "/")
    return(X)
}
############ scatter #################
"scatter" <- function (x, ...) UseMethod("scatter")


############ scatterutil.base #################
"scatterutil.base" <- function (dfxy, xax, yax, xlim, ylim, grid, addaxes, cgrid, include.origin,
    origin, sub, csub, possub, pixmap, contour, area, add.plot) 
{
    df <- data.frame(dfxy)
    if (!is.data.frame(df)) 
        stop("Non convenient selection for df")
    if ((xax < 1) || (xax > ncol(df))) 
        stop("Non convenient selection for xax")
    if ((yax < 1) || (yax > ncol(df))) 
        stop("Non convenient selection for yax")
    x <- df[, xax]
    y <- df[, yax]
    if (is.null(xlim)) {
        x1 <- x
        if (include.origin) 
            x1 <- c(x1, origin[1])
        x1 <- c(x1 - diff(range(x1)/10), x1 + diff(range(x1))/10)
        xlim <- range(x1)
    }
    if (is.null(ylim)) {
        y1 <- y
        if (include.origin) 
            y1 <- c(y1, origin[2])
        y1 <- c(y1 - diff(range(y1)/10), y1 + diff(range(y1))/10)
        ylim <- range(y1)
    }
    if (!is.null(pixmap)) {
        if (is.null(class(pixmap))) 
            pixmap <- NULL
        if (is.na(charmatch("pixmap", class(pixmap)))) 
            pixmap <- NULL
    }
    if (!is.null(pixmap)) {
        dimobj <- attr(pixmap, "dim")
    }
    if (!is.null(contour)) {
        if (!is.data.frame(contour)) 
            contour <- NULL
        if (ncol(contour) != 4) 
            contour <- NULL
    }
    if (!is.null(area)) {
        if (!is.data.frame(area)) 
            area <- NULL
        if (!is.factor(area[, 1])) 
            area <- NULL
        if (ncol(area) < 3) 
            area <- NULL
    }
    if ( !add.plot) 
        plot.default(0, 0, type = "n", asp = 1, xlab = "", ylab = "", 
        xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", 
        yaxs = "i", frame.plot = FALSE)

    if (!is.null(pixmap)) {
        plot(pixmap, add = TRUE)
    }

    if (!is.null(contour)) {
        apply(contour, 1, function(x) segments(x[1], x[2], x[3], 
            x[4], lwd = 1))
    }
    if (grid & !add.plot) 
        scatterutil.grid(cgrid)
    if (addaxes & !add.plot) 
        abline(h = 0, v = 0, lty = 1)
    if (!is.null(area)) {
        nlev <- nlevels(area[, 1])
        x1 <- area[, 2]
        x2 <- area[, 3]
        for (i in 1:nlev) {
            lev <- levels(area[, 1])[i]
            a1 <- x1[area[, 1] == lev]
            a2 <- x2[area[, 1] == lev]
            polygon(a1, a2)
        }
    }
    if (csub > 0) 
        scatterutil.sub(sub, csub, possub)
    return(list(x = x, y = y))
}

############ add.scatter.eig #################
"add.scatter.eig" <- function (w, nf, xax, yax, posi = c("bottom", "top", "none"),
    ratio = 1/4) 
{
    posi <- posi[1]
    if (posi == "none") 
        return(invisible())
    born <- par("usr")
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    neig <- min(length(w), 15)
    w <- w[1:neig]
    col <- rep(grey(1), length(w))
    col[1:nf] <- grey(0.8)
    col[c(xax, yax)] <- grey(0)
    x <- seq(born[1], born[1] + (born[2] - born[1]) * ratio, 
        le = neig + 1)
    w <- w/max(w)
    w <- w * (born[4] - born[3]) * ratio
    if (posi == "bottom") 
        m3 <- born[3]
    else m3 <- born[4] - w[1]
    w <- m3 + w
    rect(x[1], m3, x[neig + 1], w[1], col = grey(1))
    for (i in 1:neig) {
        rect(x[i], m3, x[i + 1], w[i], col = col[i])
    }
}

############ scatterutil.chull #################
"scatterutil.chull" <- function (x, y, fac, optchull = c(0.25, 0.5, 0.75, 1), col=rep(1,length(levels(fac)))) {
    if (!is.factor(fac)) 
        return(invisible())
    if (length(x) != length(fac)) 
        return(invisible())
    if (length(y) != length(fac)) 
        return(invisible())
    for (i in 1:nlevels(fac)) {
        x1 <- x[fac == levels(fac)[i]]
        y1 <- y[fac == levels(fac)[i]]
        long <- length(x1)
        longinit <- long
        cref <- 1
        repeat {
            if (long < 3) 
                break
            if (cref == 0) 
                break
            num <- chull(x1, y1)
            x2 <- x1[num]
            y2 <- y1[num]
            taux <- long/longinit
            if ((taux <= cref) & (cref == 1)) {
                cref <- 0.75
                if (any(optchull == 1)) 
                  polygon(x2, y2, lty = 1, border=col[i])
            }
            if ((taux <= cref) & (cref == 0.75)) {
                if (any(optchull == 0.75)) 
                  polygon(x2, y2, lty = 5, border=col[i])
                cref <- 0.5
            }
            if ((taux <= cref) & (cref == 0.5)) {
                if (any(optchull == 0.5)) 
                  polygon(x2, y2, lty = 3, border=col[i])
                cref <- 0.25
            }
            if ((taux <= cref) & (cref == 0.25)) {
                if (any(optchull == 0.25)) 
                  polygon(x2, y2, lty = 2, border=col[i])
                cref <- 0
            }
            x1 <- x1[-num]
            y1 <- y1[-num]
            long <- length(x1)
        }
    }
}

############ scatterutil.eigen #################
"scatterutil.eigen" <- function (w, xmax = length(w), ymin=0, ymax = max(w), wsel = 1, sub = "Eigenvalues",
    csub = 2, possub = "topright") 
{
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.8, 2.8, 0.8, 0.8))
    if (length(w) < xmax) 
        w <- c(w, rep(0, xmax - length(w)))
    col.w <- rep(grey(0.8), length(w))
    col.w[wsel] <- grey(0)
    barplot(w, col = col.w, ylim = c(ymin, ymax))
    scatterutil.sub(cha = sub, csub = csub, possub = possub)
}

############ scatterutil.ellipse #################
"scatterutil.ellipse" <- function (x, y, z, cellipse, axesell, coul = rep(1,length(x))) 
{
    if (any(is.na(z))) 
        return(invisible())
    if (sum(z * z) == 0) 
        return(invisible())
    util.ellipse <- function(mx, my, vx, cxy, vy, coeff) {
        lig <- 100
        epsi <- 1e-10
        x <- 0
        y <- 0
        if (vx < 0) 
            vx <- 0
        if (vy < 0) 
            vy <- 0
        if (vx == 0 && vy == 0) 
            return(NULL)
        delta <- (vx - vy) * (vx - vy) + 4 * cxy * cxy
        delta <- sqrt(delta)
        l1 <- (vx + vy + delta)/2
        l2 <- vx + vy - l1
        if (l1 < 0) 
            l1 <- 0
        if (l2 < 0) 
            l2 <- 0
        l1 <- sqrt(l1)
        l2 <- sqrt(l2)
        test <- 0
        if (vx == 0) {
            a0 <- 0
            b0 <- 1
            test <- 1
        }
        if ((vy == 0) && (test == 0)) {
            a0 <- 1
            b0 <- 0
            test <- 1
        }
        if (((abs(cxy)) < epsi) && (test == 0)) {
            a0 <- 1
            b0 <- 0
            test <- 1
        }
        if (test == 0) {
            a0 <- 1
            b0 <- (l1 * l1 - vx)/cxy
            norm <- sqrt(a0 * a0 + b0 * b0)
            a0 <- a0/norm
            b0 <- b0/norm
        }
        a1 <- 2 * pi/lig
        c11 <- coeff * a0 * l1
        c12 <- (-coeff) * b0 * l2
        c21 <- coeff * b0 * l1
        c22 <- coeff * a0 * l2
        angle <- 0
        for (i in 1:lig) {
            cosinus <- cos(angle)
            sinus <- sin(angle)
            x[i] <- mx + c11 * cosinus + c12 * sinus
            y[i] <- my + c21 * cosinus + c22 * sinus
            angle <- angle + a1
        }
        return(list(x = x, y = y, seg1 = c(mx + c11, my + c21, 
            mx - c11, my - c21), seg2 = c(mx + c12, my + c22, 
            mx - c12, my - c22)))
    }
    z <- z/sum(z)
    m1 <- sum(x * z)
    m2 <- sum(y * z)
    v1 <- sum((x - m1) * (x - m1) * z)
    v2 <- sum((y - m2) * (y - m2) * z)
    cxy <- sum((x - m1) * (y - m2) * z)
    ell <- util.ellipse(m1, m2, v1, cxy, v2, cellipse)
    if (is.null(ell)) 
        return(invisible())
    polygon(ell$x, ell$y, border=coul)
    if (axesell) 
        segments(ell$seg1[1], ell$seg1[2], ell$seg1[3], ell$seg1[4], 
            lty = 2, col=coul)
    if (axesell) 
        segments(ell$seg2[1], ell$seg2[2], ell$seg2[3], ell$seg2[4], 
            lty = 2, col=coul)
}

############ scatterutil.eti.circ #################
"scatterutil.eti.circ" <- function (x, y, label, clabel, origin=c(0,0), boxes=TRUE) {
    if (is.null(label)) 
        return(invisible())
    # message de JT warning pour R 1.7 modif samedi, mars 29, 2003 at 14:31
    if (any(is.na(label)))
        return(invisible())
    if (any(label == ""))
        return(invisible())
    # modif mercredi, juillet 2, 2003 at 17:26
    # pour les cas o le centre n'est pas l'origine
    xref <- x - origin[1]
    yref <- y - origin[2]
    for (i in 1:(length(x))) {
        cha <- as.character(label[i])
        cha <- paste(" ", cha, " ", sep = "")
        cex0 <- par("cex") * clabel
        
        if (boxes) {
            xh <- strwidth(cha, cex = cex0)
            yh <- strheight(cha, cex = cex0) * 5/6
            if ((xref[i] > yref[i]) & (xref[i] > -yref[i])) {
                x1 <- x[i] + xh/2
                y1 <- y[i]
            }
            else if ((xref[i] > yref[i]) & (xref[i] <= (-yref[i]))) {
                x1 <- x[i]
                y1 <- y[i] - yh
            }
            else if ((xref[i] <= yref[i]) & (xref[i] <= (-yref[i]))) {
                x1 <- x[i] - xh/2
                y1 <- y[i]
            }
            else if ((xref[i] <= yref[i]) & (xref[i] > (-yref[i]))) {
                x1 <- x[i]
                y1 <- y[i] + yh
            }
            rect(x1 - xh/2, y1 - yh, x1 + xh/2, y1 + yh, col = "white", 
                border = 1)
        }
        text(x1, y1, cha, cex = cex0)
    }
}

############ scatterutil.eti #################
"scatterutil.eti" <- function (x, y, label, clabel, boxes=TRUE, coul = rep(1,length(x))) 
{
    if (length(label) == 0) 
        return(invisible())
    if (is.null(label)) 
        return(invisible())
    if (any(label == "")) 
        return(invisible())
    for (i in 1:(length(x))) {
        cha <- as.character(label[i])
        cha <- paste(" ", cha, " ", sep = "")
        cex0 <- par("cex") * clabel
        x1 <- x[i]
        y1 <- y[i]
        if (boxes) {
        	xh <- strwidth(cha, cex = cex0)
        	yh <- strheight(cha, cex = cex0) * 5/3
            rect(x1 - xh/2, y1 - yh/2, x1 + xh/2, y1 + yh/2, col= "white", border = coul[i])
        }
        text(x1, y1, cha, cex = cex0, col=coul[i])
    }
}


############ scatterutil.grid #################
"scatterutil.grid" <- function (cgrid) {
    col <- "lightgray"
    lty <- 1
    xaxp <- par("xaxp")
    ax <- (xaxp[2] - xaxp[1])/xaxp[3]
    yaxp <- par("yaxp")
    ay <- (yaxp[2] - yaxp[1])/yaxp[3]
    a <- min(ax, ay)
    v0 <- seq(xaxp[1], xaxp[2], by = a)
    h0 <- seq(yaxp[1], yaxp[2], by = a)
    abline(v = v0, col = col, lty = lty)
    abline(h = h0, col = col, lty = lty)
    if (cgrid <= 0) 
        return(invisible())
    cha <- paste(" d = ", a, " ", sep = "")
    cex0 <- par("cex") * cgrid
    xh <- strwidth(cha, cex = cex0)
    yh <- strheight(cha, cex = cex0) * 5/3
    x1 <- par("usr")[2]
    y1 <- par("usr")[4]
    rect(x1 - xh, y1 - yh, x1 + xh, y1 + yh, col = "white", border = 0)
    text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
}

############ scatterutil.legend.bw.square #################
"scatterutil.legend.bw.square" <- function (br0, sq0, sig0, clegend) {
    br0 <- round(br0, dig = 6)
    cha <- as.character(br0[1])
    for (i in (2:(length(br0)))) cha <- paste(cha, br0[i], sep = " ")
    cex0 <- par("cex") * clegend
    yh <- max(c(strheight(cha, cex = cex0), sq0))
    h <- strheight(cha, cex = cex0)
    y0 <- par("usr")[3] + yh/2 + h/2
    ltot <- strwidth(cha, cex = cex0) + sum(sq0) + h
    rect(par("usr")[1] + h/4, y0 - yh/2 - h/4, par("usr")[1] + 
        ltot + h/4, y0 + yh/2 + h/4, col = "white")
    x0 <- par("usr")[1] + h/2
    for (i in (1:(length(sq0)))) {
        cha <- br0[i]
        cha <- paste(" ", cha, sep = "")
        xh <- strwidth(cha, cex = cex0)
        text(x0 + xh/2, y0, cha, cex = cex0)
        z0 <- sq0[i]
        x0 <- x0 + xh + z0/2
        if (sig0[i] >= 0) 
            symbols(x0, y0, squares = z0, bg = "black", fg = "white", 
                add = TRUE, inch = FALSE)
        else symbols(x0, y0, squares = z0, bg = "white", fg = "black", 
            add = TRUE, inch = FALSE)
        x0 <- x0 + z0/2
    }
    invisible()
}

############ scatterutil.legend.square.grey #################
"scatterutil.legend.square.grey" <- function (br0, valgris, h, clegend) {
    if (clegend <= 0) 
        return(invisible())
    br0 <- round(br0, dig = 6)
    nborn <- length(br0)
    cex0 <- par("cex") * clegend
    x0 <- par("usr")[1] + h
    x1 <- x0
    for (i in (2:(nborn))) {
        x1 <- x1 + h
        cha <- br0[i]
        cha <- paste(cha, "]", sep = "")
        xh <- strwidth(cha, cex = cex0)
        if (i == (nborn)) 
            break
        x1 <- x1 + xh + h
    }
    yh <- max(strheight(paste(br0), cex = cex0), h)
    y0 <- par("usr")[3] + yh/2 + h/2
    rect(par("usr")[1] + h/4, y0 - yh/2 - h/4, x1 - h/4, y0 + 
        yh/2 + h/4, col = "white")
    x0 <- par("usr")[1] + h
    for (i in (2:(nborn))) {
        symbols(x0, y0, squares = h, bg = gray(valgris[i - 1]), 
            add = TRUE, inch = FALSE)
        x0 <- x0 + h
        cha <- br0[i]
        if (cha < 1e-05) 
            cha <- round(cha, dig = 3)
        cha <- paste(cha, "]", sep = "")
        xh <- strwidth(cha, cex = cex0)
        if (i == (nborn)) 
            break
        text(x0 + xh/2, y0, cha, cex = cex0)
        x0 <- x0 + xh + h
    }
    invisible()
}

############ scatterutil.legendgris #################
"scatterutil.legendgris" <- function (w, nclasslegend, clegend) {
    l0 <- as.integer(nclasslegend)
    if (l0 == 0) 
        return(invisible())
    if (l0 == 1) 
        l0 <- 2
    if (l0 > 10) 
        l0 <- 10
    h0 <- 1/(l0 + 1)
    mid0 <- seq(h0/2, 1 - h0/2, le = l0 + 1)
    qq <- quantile(w, seq(0, 1, le = l0 + 1))
    w0 <- as.numeric(cut(w, br = qq, inc = TRUE))
    w0 <- seq(0, 1, le = l0)[w0]
    opar <- par(new = par("new"), mar = par("mar"), usr = par("usr"))
    on.exit(par(opar))
    par(new = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    plot(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", 
        yaxt = "n", xlim = c(0, 2), ylim = c(0, 1.5))
    rect(rep(0, l0), seq(h0/2, by = h0, le = l0), rep(h0, l0), 
        seq(3 * h0/2, by = h0, le = l0), col = gray(seq(1, 0, 
            le = l0)))
    text(rep(h0, 9), mid0, as.character(signif(qq, dig = 2)), 
        pos = 4, cex = par("cex") * clegend)
    box(col = "white")
}

############ scatterutil.scaling #################
"scatterutil.scaling" <- function (refold, refnew, xyold) {
    refold <- as.matrix(data.frame(refold))
    refnew <- as.matrix(data.frame(refnew))
    meanold <- apply(refold, 2, mean)
    meannew <- apply(refnew, 2, mean)
    refold0 <- sweep(refold, 2, meanold)
    refnew0 <- sweep(refnew, 2, meannew)
    sold <- sqrt(sum(refold0^2))
    snew <- sqrt(sum(refnew0^2))
    xyold <- sweep(xyold, 2, meanold)
    xyold <- t(t(xyold)/sold)
    xynew <- t(t(xyold) * snew)
    xynew <- sweep(xynew, 2, meannew, "+")
    xynew <- data.frame(xynew)
    names(xynew) <- names(xyold)
    row.names(xynew) <- row.names(xyold)
    return(xynew)
}
############ scatterutil.star #################
"scatterutil.star" <- function (x, y, z, cstar, coul = rep(1,length(x))) 
{
    z <- z/sum(z)
    x1 <- sum(x * z)
    y1 <- sum(y * z)
    for (i in which(z > 0)) {
        hx <- cstar * (x[i] - x1)
        hy <- cstar * (y[i] - y1)
        segments(x1, y1, x1 + hx, y1 + hy, col=coul)
    }
}


############ scatterutil.sub #################
"scatterutil.sub" <- function (cha, csub, possub = "bottomleft") {
    cha <- as.character(cha)
    if (length(cha) == 0) 
        return(invisible())
    if (is.null(cha)) 
        return(invisible())
    if (is.na(cha)) 
        return(invisible())
    if (any(cha == ""))
        return(invisible())
    if (csub == 0) 
        return(invisible())
    cex0 <- par("cex") * csub
    cha <- paste(" ", cha, " ", sep = "")
    xh <- strwidth(cha, cex = cex0)
    yh <- strheight(cha, cex = cex0) * 5/3
    if (possub == "bottomleft") {
        x1 <- par("usr")[1]
        y1 <- par("usr")[3]
        rect(x1, y1, x1 + xh, y1 + yh, col = "white", border = 0)
        text(x1 + xh/2, y1 + yh/2, cha, cex = cex0)
    }
    else if (possub == "topleft") {
        x1 <- par("usr")[1]
        y1 <- par("usr")[4]
        rect(x1, y1, x1 + xh, y1 - yh, col = "white", border = 0)
        text(x1 + xh/2, y1 - yh/2, cha, cex = cex0)
    }
    else if (possub == "bottomright") {
        x1 <- par("usr")[2]
        y1 <- par("usr")[3]
        rect(x1, y1, x1 - xh, y1 + yh, col = "white", border = 0)
        text(x1 - xh/2, y1 + yh/2, cha, cex = cex0)
    }
    else if (possub == "topright") {
        x1 <- par("usr")[2]
        y1 <- par("usr")[4]
        rect(x1, y1, x1 - xh, y1 - yh, col = "white", border = 0)
        text(x1 - xh/2, y1 - yh/2, cha, cex = cex0)
    }
}

"scatter.acm" <- function (x, xax = 1, yax = 2, csub = 2, possub = "topleft", ...) {
    if (!inherits(x, "acm")) 
        stop("For 'acm' object")
    if (x$nf == 1) {
        score.(x, 1)
        return(invisible())
    }
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    nvar <- ncol(oritab)
    par(mfrow = n2mfrow(nvar))
    # modif lundi, dcembre 16, 2002 at 16:48 
    # suite  message d'Alain Guerreau  
    for (i in 1:(nvar)) s.class(x$li, oritab[, i], xax=xax, yax=yax, clab = 1.5, 
        sub = names(oritab)[i], csub = csub, possub = possub, 
        cgrid = 0, csta = 0)
}

"scatter.coa" <- function (x, xax = 1, yax = 2, method = 1:3, clab.row = 0.75,
    clab.col = 1.25, posieig = "top", sub = NULL, csub = 2, ...) 
{
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(x, "coa")) 
        stop("Object of class 'coa' expected")
    nf <- x$nf
    if ((xax > nf) || (xax < 1) || (yax > nf) || (yax < 1) || 
        (xax == yax)) 
        stop("Non convenient selection")
    method <- method[1]
    if (method == 1) {
        coolig <- x$li[, c(xax, yax)]
        coocol <- x$co[, c(xax, yax)]
        names(coocol) <- names(coolig)
        s.label(rbind.data.frame(coolig, coocol), clab = 0, 
            cpoi = 0, sub = sub, csub = csub)
        # samedi, mars 29, 2003 at 15:35 correction SD pour ZAN
        s.label(coolig, clab = clab.row, add.p = TRUE)
        s.label(coocol, clab = clab.col, add.p = TRUE)
    }
    else if (method == 2) {
        coocol <- x$c1[, c(xax, yax)]
        coolig <- x$li[, c(xax, yax)]
        s.label(coocol, clab = clab.col, sub = sub, csub = csub)
        s.label(coolig, clab = clab.row, add.plot = TRUE)
    }
    else if (method == 3) {
        coolig <- x$l1[, c(xax, yax)]
        coocol <- x$co[, c(xax, yax)]
        s.label(coolig, clab = clab.col, sub = sub, csub = csub)
        s.label(coocol, clab = clab.row, add.plot = TRUE)
    }
    else stop("Unknown method")
    add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
}

"scatter.dudi" <- function (x, xax = 1, yax = 2, clab.row = .75, clab.col = 1,
    permute = FALSE, posieig = "top", sub = NULL, ...) 
{
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    coolig <- x$li[, c(xax, yax)]
    coocol <- x$c1[, c(xax, yax)]
    if (permute) {
        coolig <- x$co[, c(xax, yax)]
        coocol <- x$l1[, c(xax, yax)]
    }
    s.label(coolig, clab = clab.row)
    born <- par("usr")
    k1 <- min(coocol[, 1])/born[1]
    k2 <- max(coocol[, 1])/born[2]
    k3 <- min(coocol[, 2])/born[3]
    k4 <- max(coocol[, 2])/born[4]
    k <- c(k1, k2, k3, k4)
    coocol <- 0.9 * coocol/max(k)
    s.arrow(coocol, clab = clab.col, add.p = TRUE, sub = sub, 
        possub = "bottomright")
    add.scatter.eig(x$eig, x$nf, xax, yax, posi = posieig, ratio = 1/4)
}
"scatter.fca" <- function (x, xax = 1, yax = 2, clab.moda = 1, labels = names(x$tab),
    sub = NULL, csub = 2, ...) 
{
    opar <- par(mfrow = par("mfrow"))
    on.exit(par(opar))
    if ((xax == yax) || (x$nf == 1)) 
        stop("Unidimensional plot (xax=yax) not yet implemented")
    par(mfrow = n2mfrow(length(x$blo)))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    indica <- factor(rep(names(x$blo), x$blo))
    for (j in levels(indica)) 
        s.distri(x$l1, oritab[, which(indica == j)], 
        clab = clab.moda, sub = as.character(j), cell = 0, 
        csta = 0.5, csub = csub, label = labels[which(indica == j)])
}
"sco.boxplot" <- function (score, df, labels = names(df), clabel = 1, xlim = NULL,
    grid = TRUE, cgrid = 0.75, include.origin = TRUE, origin = 0, sub = NULL, 
    csub = 1) 
{
    if (!is.vector(score)) 
        stop("vector expected for score")
    if (!is.numeric(score)) 
        stop("numeric expected for score")
    if (!is.data.frame(df)) 
        stop("data.frame expected for df")
    if (!all(unlist(lapply(df, is.factor)))) 
        stop("All variables must be factors")
    n <- length(score)
    if ((nrow(df) != n)) 
        stop("Non convenient match")
    n <- length(score)
    nvar <- ncol(df)
    nlev <- unlist(lapply(df, nlevels))
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    ymin <- scoreutil.base(y = score, xlim = xlim, grid = grid, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub)
    n1 <- sum(nlev)
    ymax <- par("usr")[4]
    ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) * 
        1.4
    yunit <- (ymax - ymin - nvar * ylabel)/n1
    y1 <- ymin + ylabel
    xmin <- par("usr")[1]
    xmax <- par("usr")[2]
    xaxp <- par("xaxp")
    nline <- xaxp[3] + 1
    v0 <- seq(xaxp[1], xaxp[2], le = nline)
    for (i in 1:nvar) {
        y2 <- y1 + nlev[i] * yunit
        rect(xmin, y1, xmax, y2)
        if (clabel > 0) {
            text((xmin + xmax)/2, y1 - ylabel/2, labels[i], cex = par("cex") * 
                clabel)
        }
        param <- tapply(score, df[, i], function(x) quantile(x, 
            seq(0, 1, by = 0.25)))
        moy <- tapply(score, df[, i], mean)
        nbox <- length(param)
        namebox <- names(param)
        pp <- ppoints(n = (nbox + 2), a = 1)
        pp <- pp[2:(nbox + 1)]
        ypp <- y1 + (y2 - y1) * pp
        hbar <- (y2 - y1)/nbox/4
        if (grid) {
            segments(v0, rep(y1, nline), v0, rep(y2, nline), 
                col = gray(0.5), lty = 1)
        }
        for (j in 1:nbox) {
            stat <- unlist(param[j])
            amin <- stat[1]
            aq1 <- stat[2]
            amed <- stat[3]
            aq2 <- stat[4]
            amax <- stat[5]
            rect(aq1, ypp[j] - hbar, aq2, ypp[j] + hbar, col = "white")
            segments(amed, ypp[j] - hbar, amed, ypp[j] + hbar, 
                lwd = 2)
            segments(amin, ypp[j], aq1, ypp[j])
            segments(amax, ypp[j], aq2, ypp[j])
            segments(amin, ypp[j] - hbar, amin, ypp[j] + hbar)
            segments(amax, ypp[j] - hbar, amax, ypp[j] + hbar)
            points(moy[j], ypp[j], pch = 20)
            if (clabel > 0) {
                text(amax, ypp[j], namebox[j], pos = 4, cex = par("cex") * 
                  clabel * 0.8, offset = 0.2)
            }
        }
        y1 <- y2 + ylabel
    }
    invisible()
}
"sco.distri" <- function (score, df, y.rank = TRUE, csize = 1, labels = names(df),
    clabel = 1, xlim = NULL, grid = TRUE, cgrid = 0.75, include.origin = TRUE, 
    origin = 0, sub = NULL, csub = 1) 
{
    if (!is.vector(score)) 
        stop("vector expected for score")
    if (!is.numeric(score)) 
        stop("numeric expected for score")
    if (!is.data.frame(df)) 
        stop("data.frame expected for df")
    if (any(df < 0)) 
        stop("data >=0 expected in df")
    n <- length(score)
    if ((nrow(df) != n)) 
        stop("Non convenient match")
    n <- length(score)
    nvar <- ncol(df)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    ymin <- scoreutil.base(y = score, xlim = xlim, grid = grid, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub)
    ymax <- par("usr")[4]
    ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) * 
        1.4
    xmin <- par("usr")[1]
    xmax <- par("usr")[2]
    xaxp <- par("xaxp")
    nline <- xaxp[3] + 1
    v0 <- seq(xaxp[1], xaxp[2], le = nline)
    if (grid) {
        segments(v0, rep(ymin, nline), v0, rep(ymax, nline), 
            col = gray(0.5), lty = 1)
    }
    rect(xmin, ymin, xmax, ymax)
    sum.col <- apply(df, 2, sum)
    df <- df[, sum.col > 0]
    labels <- labels[sum.col > 0]
    nvar <- ncol(df)
    sum.col <- apply(df, 2, sum)
    df <- sweep(df, 2, sum.col, "/")
    y.distri <- (nvar:1)
    if (y.rank) {
        y.distri <- drop(score %*% as.matrix(df))
        y.distri <- rank(y.distri)
    }
    ylabel <- strheight("A", cex = par("cex") * max(1, clabel)) * 
        1.4
    y.distri <- (y.distri - min(y.distri))/(max(y.distri) - min(y.distri))
    y.distri <- ymin + ylabel + (ymax - ymin - 2 * ylabel) * 
        y.distri
    for (i in 1:nvar) {
        w <- df[, i]
        y0 <- y.distri[i]
        x.moy <- sum(w * score)
        x.et <- sqrt(sum(w * (score - x.moy)^2))
        x1 <- x.moy - x.et * csize
        x2 <- x.moy + x.et * csize
        etiagauche <- TRUE
        if ((x1 - xmin) < (xmax - x2)) 
            etiagauche <- FALSE
        segments(x1, y0, x2, y0)
        if (clabel > 0) {
            cha <- labels[i]
            cex0 <- par("cex") * clabel
            xh <- strwidth(cha, cex = cex0)
            xh <- xh + strwidth("x", cex = cex0)
            yh <- strheight(cha, cex = cex0) * 5/6
            if (etiagauche) 
                x0 <- x1 - xh/2
            else x0 <- x2 + xh/2
            text(x0, y0, cha, cex = cex0)
        }
        points(x.moy, y0, pch = 20, cex = par("cex") * 2)
    }
    invisible()
}
"sco.quant" <- function (score, df, fac = NULL, clabel = 1, abline = FALSE,
    sub = names(df), csub = 2, possub = "topleft") 
{
    if (!is.vector(score)) 
        stop("vector expected for score")
    if (!is.numeric(score)) 
        stop("numeric expected for score")
    if (!is.data.frame(df)) 
        stop("data.frame expected for df")
    if (nrow(df) != length(score)) 
        stop("Not convenient dimensions")
    if (!is.null(fac)) {
        fac <- factor(fac)
        if (length(fac) != length(score)) 
            stop("Not convenient dimensions")
    }
    opar <- par(mar = par("mar"), mfrow = par("mfrow"))
    on.exit(par(opar))
    par(mar = c(2.6, 2.6, 1.1, 1.1))
    nfig <- ncol(df)
    par(mfrow = n2mfrow(nfig))
    for (i in 1:nfig) {
        plot(score, df[, i], type = "n")
        if (!is.null(fac)) {
            s.class(cbind.data.frame(score, df[, i]), fac, 
                axesell = FALSE, add.plot = TRUE, clab = clabel)
        }
        else points(score, df[, i])
        if (abline) {
            abline(lm(df[, i] ~ score))
        }
        scatterutil.sub(sub[i], csub, possub)
    }
}
"score" <- function (x, ...) UseMethod("score")

"scoreutil.base" <- function (y, xlim, grid, cgrid, include.origin, origin, sub,
    csub) 
{
    if (is.null(xlim)) {
        x1 <- y
        if (include.origin) 
            x1 <- c(x1, origin)
        x1 <- c(x1 - diff(range(x1)/10), x1 + diff(range(x1))/10)
        xlim <- range(x1)
    }
    ylim <- c(0, 1)
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", 
        yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i", 
        frame.plot = FALSE)
    href <- max(3, 2 * cgrid, 2 * csub)
    href <- strheight("A", cex = par("cex") * href)
    if (grid) {
        xaxp <- par("xaxp")
        nline <- xaxp[3] + 1
        v0 <- seq(xaxp[1], xaxp[2], le = nline)
        segments(v0, rep(par("usr")[3], nline), v0, rep(par("usr")[3] + 
            href, nline), col = gray(0.5), lty = 1)
        segments(0, par("usr")[3], 0, par("usr")[3] + href, col = 1, 
            lwd = 3)
        if (cgrid > 0) {
            a <- (xaxp[2] - xaxp[1])/xaxp[3]
            cha <- paste("d = ", a, sep = "")
            cex0 <- par("cex") * cgrid
            xh <- strwidth(cha, cex = cex0)
            yh <- strheight(cha, cex = cex0) + strheight(" ", 
                cex = cex0)/2
            x0 <- strwidth("  ", cex = cex0)
            y0 <- strheight(" ", cex = cex0)/2
            x1 <- par("usr")[1]
            y1 <- par("usr")[3]
            rect(x1 + x0, y1 + y0, x1 + xh + x0, y1 + yh + y0, 
                col = "white", border = 0)
            text(x1 + xh/2 + x0/2, y1 + yh/2 + y0/2, cha, cex = cex0)
        }
    }
    y1 <- rep(par("usr")[3] + href/2, length(y))
    y2 <- rep(par("usr")[3] + href, length(y))
    segments(y, y1, y, y2)
    if (csub > 0) {
        cha <- as.character(sub)
        if (all(c(length(cha) > 0, !is.null(cha), !is.na(cha), 
            cha != ""))) {
            cex0 <- par("cex") * csub
            xh <- strwidth(cha, cex = cex0)
            yh <- strheight(cha, cex = cex0)
            x0 <- strwidth(" ", cex = cex0)
            y0 <- strheight(" ", cex = cex0)
            x1 <- par("usr")[2]
            y1 <- par("usr")[3]
            rect(x1 - x0 - xh, y1, x1, y1 + yh + y0, col = "white", 
                border = 0)
            text(x1 - xh/2 - x0/2, y1 + yh/2 + y0/2, cha, cex = cex0)
        }
    }
    rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[3] + 
        href)
    return(par("usr")[3] + href)
}
"score.acm" <- function (x, xax = 1, which.var = NULL, mfrow = NULL, sub = names(oritab),
    csub = 2, possub = "topleft", ...) 
{
    if (!inherits(x, "acm")) 
        stop("Object of class 'acm' expected")
    if (x$nf == 1) 
        xax <- yax <- 1
    if ((xax < 1) || (xax > x$nf)) 
        stop("non convenient axe number")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    nvar <- ncol(oritab)
    if (is.null(which.var)) 
        which.var <- (1:nvar)
    if (is.null(mfrow)) 
        par(mfrow = n2mfrow(length(which.var)))
    if (prod(par("mfrow")) < length(which.var)) 
        par(ask = TRUE)
    par(mar = c(2.6, 2.6, 1.1, 1.1))
    score <- x$l1[, xax]
    for (i in which.var) {
        y <- oritab[, i]
        moy <- unlist(tapply(score, y, mean))
        plot(score, score, type = "n")
        h <- (max(score) - min(score))/40
        abline(h = moy)
        segments(score, moy[y] - h, score, moy[y] + h)
        abline(0, 1)
        scatterutil.eti(moy, moy, label = as.character(levels(y)), 
            clab = 1.5)
        scatterutil.sub(sub[i], csub = csub, possub = possub)
    }
}
"score.coa" <- function (x, xax = 1, dotchart = FALSE, clab.r = 1, clab.c = 1,
    csub = 1, cpoi = 1.5, cet = 1.5, ...) 
{
    if (!inherits(x, "coa")) 
        stop("Object of class 'coa' expected")
    if (x$nf == 1) 
        xax <- 1
    if ((xax < 1) || (xax > x$nf)) 
        stop("non convenient axe number")
    "dudi.coa.dotchart" <- function(dudi, numfac, clab) {
        if (!inherits(dudi, "coa")) 
            stop("Object of class 'coa' expected")
        sli <- dudi$li[, numfac]
        sco <- dudi$co[, numfac]
        oli <- order(sli)
        oco <- order(sco)
        a <- c(sli[oli], sco[oco])
        gr <- as.factor(rep(c("Rows", "Columns"), c(length(sli), 
            length(sco))))
        lab <- c(row.names(dudi$li)[oli], row.names(dudi$co)[oco])
        if (clab > 0) 
            labels <- lab
        else labels <- NULL
        dotchart(a, labels = labels, groups = gr, pch = 20)
    }
    if (dotchart) {
        clab <- clab.r * clab.c
        dudi.coa.dotchart(x, xax, clab)
        return(invisible())
    }
    def.par <- par(mar = par("mar"))
    on.exit(par(def.par))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    sco.distri.class.2g <- function(score, fac1, fac2, weight, 
        labels1 = as.character(levels(fac1)), labels2 = as.character(levels(fac2)), 
        clab1, clab2, cpoi, cet) {
        n <- length(score)
        nvar1 <- nlevels(fac1)
        nvar2 <- nlevels(fac2)
        nvar <- nvar1 + nvar2
        ymin <- scoreutil.base(y = score, xlim = NULL, grid = TRUE, 
            cgrid = 0.75, include.origin = TRUE, origin = 0, 
            sub = NULL, csub = 0)
        ymax <- par("usr")[4]
        ylabel <- strheight("A", cex = par("cex") * max(1, clab1, 
            clab2)) * 1.4
        xmin <- par("usr")[1]
        xmax <- par("usr")[2]
        xaxp <- par("xaxp")
        nline <- xaxp[3] + 1
        v0 <- seq(xaxp[1], xaxp[2], le = nline)
        segments(v0, rep(ymin, nline), v0, rep(ymax, nline), 
            col = gray(0.5), lty = 1)
        rect(xmin, ymin, xmax, ymax)
        sum.col1 <- unlist(tapply(weight, fac1, sum))
        sum.col2 <- unlist(tapply(weight, fac2, sum))
        sum.col1[sum.col1 == 0] <- 1
        sum.col2[sum.col2 == 0] <- 1
        weight1 <- weight/sum.col1[fac1]
        weight2 <- weight/sum.col2[fac2]
        y.distri1 <- tapply(score * weight1, fac1, sum)
        y.distri1 <- rank(y.distri1)
        y.distri2 <- tapply(score * weight2, fac2, sum)
        y.distri2 <- rank(y.distri2) + nvar1 + 2
        y.distri <- c(y.distri1, y.distri2)
        ylabel <- strheight("A", cex = par("cex") * max(1, clab1, 
            clab2)) * 1.4
        y.distri1 <- (y.distri1 - min(y.distri))/(max(y.distri) - 
            min(y.distri))
        y.distri1 <- ymin + ylabel + (ymax - ymin - 2 * ylabel) * 
            y.distri1
        y.distri2 <- (y.distri2 - min(y.distri))/(max(y.distri) - 
            min(y.distri))
        y.distri2 <- ymin + ylabel + (ymax - ymin - 2 * ylabel) * 
            y.distri2
        for (i in 1:nvar1) {
            w <- weight1[fac1 == levels(fac1)[i]]
            y0 <- y.distri1[i]
            score0 <- score[fac1 == levels(fac1)[i]]
            x.moy <- sum(w * score0)
            x.et <- sqrt(sum(w * (score0 - x.moy)^2))
            x1 <- x.moy - cet * x.et
            x2 <- x.moy + cet * x.et
            etiagauche <- TRUE
            if ((x1 - xmin) < (xmax - x2)) 
                etiagauche <- FALSE
            segments(x1, y0, x2, y0)
            if (clab1 > 0) {
                cha <- labels1[i]
                cex0 <- par("cex") * clab1
                xh <- strwidth(cha, cex = cex0)
                xh <- xh + strwidth("x", cex = cex0)
                yh <- strheight(cha, cex = cex0) * 5/6
                if (etiagauche) 
                  x0 <- x1 - xh/2
                else x0 <- x2 + xh/2
                rect(x0 - xh/2, y0 - yh, x0 + xh/2, y0 + yh, 
                  col = "white", border = 1)
                text(x0, y0, cha, cex = cex0)
            }
            points(x.moy, y0, pch = 20, cex = par("cex") * cpoi)
        }
        for (i in 1:nvar2) {
            w <- weight2[fac2 == levels(fac2)[i]]
            y0 <- y.distri2[i]
            score0 <- score[fac2 == levels(fac2)[i]]
            x.moy <- sum(w * score0)
            x.et <- sqrt(sum(w * (score0 - x.moy)^2))
            x1 <- x.moy - cet * x.et
            x2 <- x.moy + cet * x.et
            etiagauche <- TRUE
            if ((x1 - xmin) < (xmax - x2)) 
                etiagauche <- FALSE
            segments(x1, y0, x2, y0)
            if (clab2 > 0) {
                cha <- labels2[i]
                cex0 <- par("cex") * clab2
                xh <- strwidth(cha, cex = cex0)
                xh <- xh + strwidth("x", cex = cex0)
                yh <- strheight(cha, cex = cex0) * 5/6
                if (etiagauche) 
                  x0 <- x1 - xh/2
                else x0 <- x2 + xh/2
                rect(x0 - xh/2, y0 - yh, x0 + xh/2, y0 + yh, 
                  col = "white", border = 1)
                text(x0, y0, cha, cex = cex0)
            }
            points(x.moy, y0, pch = 20, cex = par("cex") * cpoi)
        }
    }
    nl <- nrow(x$l1)
    nc <- nrow(x$c1)
    if (inherits(x, "witwit")) {
        y <- eval(as.list(x$call)[[2]], sys.frame(0))
        oritab <- eval(as.list(y$call)[[2]], sys.frame(0))
    }
    else oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    l.names <- row.names(oritab)
    c.names <- names(oritab)
    oritab <- as.matrix(oritab)
    a <- x$co[col(oritab), xax]
    a <- a + x$li[row(oritab), xax]
    a <- a/sqrt(2 * x$eig[xax] * (1 + sqrt(x$eig[xax])))
    a <- a[oritab > 0]
    aco <- col(oritab)[oritab > 0]
    aco <- factor(aco)
    levels(aco) <- c.names
    ali <- row(oritab)[oritab > 0]
    ali <- factor(ali)
    levels(ali) <- l.names
    aw <- oritab[oritab > 0]/sum(oritab)
    sco.distri.class.2g(a, aco, ali, aw, clab1 = clab.c, clab2 = clab.r, 
        cpoi = cpoi, cet = cet)
    scatterutil.sub("Rows", csub = csub, possub = "topleft")
    scatterutil.sub("Columns", csub = csub, possub = "bottomright")
}
"score.mix" <- function (x, xax = 1, csub = 2, mfrow = NULL, which.var = NULL, ...) {
    if (!inherits(x, "mix")) 
        stop("For 'mix' object")
    if (x$nf == 1) 
        xax <- yax <- 1
    lm.pcaiv <- function(x, df, weights, use) {
        if (!inherits(df, "data.frame")) 
            stop("data.frame expected")
        reponse.generic <- x
        begin <- "reponse.generic ~ "
        fmla <- as.formula(paste(begin, paste(names(df), collapse = "+")))
        df <- cbind.data.frame(reponse.generic, df)
        lm0 <- lm(fmla, data = df, weights = weights)
        if (use == 0) 
            return(predict(lm0))
        else if (use == 1) 
            return(residuals(lm0))
        else if (use == -1) 
            return(lm0)
        else stop("Non convenient use")
    }
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    nvar <- length(x$index)
    if (is.null(which.var)) 
        which.var <- (1:nvar)
    index <- as.character(x$index)
    if (is.null(mfrow)) 
        par(mfrow = n2mfrow(length(which.var)))
    if (prod(par("mfrow")) < length(which.var)) 
        par(ask = TRUE)
    sub <- names(oritab)
    par(mar = c(2.6, 2.6, 1.1, 1.1))
    score <- x$l1[, xax]
    for (i in which.var) {
        type.var <- index[i]
        col.var <- which(x$assign == i)
        if (type.var == "q") {
            if (length(col.var) == 1) {
                y <- x$tab[, col.var]
                plot(score, y, type = "n")
                points(score, y, pch = 20)
                abline(lm(y ~ score), lwd = 2)
            }
            else {
                y <- x$tab[, col.var]
                plot(score, y[, 1], type = "n")
                points(score, y[, 1], pch = 20)
                score.est <- lm.pcaiv(score, y, w = rep(1, nrow(y))/nrow(y), 
                  use = 0)
                ord0 <- order(y[, 1])
                lines(score.est[ord0], y[, 1][ord0], lwd = 2)
            }
        }
        else if (type.var == "f") {
            y <- oritab[, i]
            moy <- unlist(tapply(score, y, mean))
            plot(score, score, type = "n")
            h <- (max(score) - min(score))/40
            abline(h = moy)
            segments(score, moy[y] - h, score, moy[y] + h)
            abline(0, 1)
            scatterutil.eti(moy, moy, label = as.character(levels(y)), 
                clab = 1)
        }
        else if (type.var == "o") {
            y <- x$tab[, col.var]
            plot(score, y[, 1], type = "n")
            points(score, y[, 1], pch = 20)
            score.est <- lm.pcaiv(score, y, w = rep(1, nrow(y))/nrow(y), 
                use = 0)
            ord0 <- order(y[, 1])
            lines(score.est[ord0], y[, 1][ord0])
        }
        scatterutil.sub(sub[i], csub, "topleft")
    }
}
"score.pca" <- function (x, xax = 1, which.var = NULL, mfrow = NULL, csub = 2,
    sub = names(x$tab), abline = TRUE, ...) 
{
    if (!inherits(x, "pca")) 
        stop("Object of class 'pca' expected")
    if (x$nf == 1) 
        xax <- 1
    if ((xax < 1) || (xax > x$nf)) 
        stop("non convenient axe number")
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    oritab <- eval(as.list(x$call)[[2]], sys.frame(0))
    nvar <- ncol(oritab)
    if (is.null(which.var)) 
        which.var <- (1:nvar)
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(length(which.var))
    par(mfrow = mfrow)
    if (prod(par("mfrow")) < length(which.var)) 
        par(ask = TRUE)
    par(mar = c(2.6, 2.6, 1.1, 1.1))
    score <- x$l1[, xax]
    for (i in which.var) {
        y <- oritab[, i]
        plot(score, y, type = "n")
        points(score, y, pch = 20)
        if (abline) 
            abline(lm(y ~ score))
        scatterutil.sub(sub[i], csub = csub, "topleft")
    }
}
"sepan" <- function (X, nf = 2) {
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    complete.dudi <- function(dudi, nf1, nf2) {
        pcolzero <- nf2 - nf1 + 1
        w <- data.frame(matrix(0, nrow(dudi$li), pcolzero))
        names(w) <- paste("Axis", (nf1:nf2), sep = "")
        dudi$li <- cbind.data.frame(dudi$li, w)
        w <- data.frame(matrix(0, nrow(dudi$li), pcolzero))
        names(w) <- paste("RS", (nf1:nf2), sep = "")
        dudi$l1 <- cbind.data.frame(dudi$l1, w)
        w <- data.frame(matrix(0, nrow(dudi$co), pcolzero))
        names(w) <- paste("Comp", (nf1:nf2), sep = "")
        wco <- data.frame(matrix(0, nrow(dudi$co), pcolzero))
        dudi$co <- cbind.data.frame(dudi$co, w)
        w <- data.frame(matrix(0, nrow(dudi$co), pcolzero))
        names(w) <- paste("CS", (nf1:nf2), sep = "")
        dudi$c1 <- cbind.data.frame(dudi$c1, w)
        return(dudi)
    }
    lw <- X$lw
    cw <- X$cw
    blo <- X$blo
    ntab <- length(blo)
    auxinames <- ktab.util.names(X)
    tab <- as.data.frame(X[[1]])
    j1 <- 1
    j2 <- as.numeric(blo[1])
    auxi <- as.dudi(tab, col.w = cw[j1:j2], row.w = lw, nf = nf, 
        scannf = FALSE, call = match.call(), type = "sepan")
    if (auxi$nf < nf) 
        auxi <- complete.dudi(auxi, auxi$nf + 1, nf)
    Eig <- auxi$eig
    Co <- auxi$co
    Li <- auxi$li
    C1 <- auxi$c1
    L1 <- auxi$l1
    row.names(Li) <- paste(row.names(Li), j1, sep = ".")
    row.names(L1) <- paste(row.names(L1), j1, sep = ".")
    row.names(Co) <- paste(row.names(Co), j1, sep = ".")
    row.names(C1) <- paste(row.names(C1), j1, sep = ".")
    rank <- auxi$rank
    for (i in 2:ntab) {
        j1 <- j2 + 1
        j2 <- j2 + as.numeric(blo[i])
        tab <- as.data.frame(X[[i]])
        auxi <- as.dudi(tab, col.w = cw[j1:j2], row.w = lw, nf = nf, 
            scannf = FALSE, call = match.call(), type = "sepan")
        Eig <- c(Eig, auxi$eig)
        row.names(auxi$li) <- paste(row.names(auxi$li), i, sep = ".")
        row.names(auxi$l1) <- paste(row.names(auxi$l1), i, sep = ".")
        row.names(auxi$co) <- paste(row.names(auxi$co), i, sep = ".")
        row.names(auxi$c1) <- paste(row.names(auxi$c1), i, sep = ".")
        if (auxi$nf < nf) 
            auxi <- complete.dudi(auxi, auxi$nf + 1, nf)
        Co <- rbind.data.frame(Co, auxi$co)
        Li <- rbind.data.frame(Li, auxi$li)
        C1 <- rbind.data.frame(C1, auxi$c1)
        L1 <- rbind.data.frame(L1, auxi$l1)
        rank <- c(rank, auxi$rank)
    }
    res <- list()
    res$Li <- Li
    res$L1 <- L1
    res$Co <- Co
    res$C1 <- C1
    res$Eig <- Eig
    res$TL <- X$TL
    res$TC <- X$TC
    res$blo <- blo
    res$rank <- rank
    res$tab.names <- names(X)[1:ntab]
    res$call <- match.call()
    class(res) <- c("sepan", "list")
    return(res)
} 

"summary.sepan" <- function (object, ...) {
    if (!inherits(object, "sepan")) 
        stop("to be used with 'sepan' object")
    cat("Separate Analyses of a 'ktab' object\n")
    x1 <- object$tab.names
    ntab <- length(x1)
    nf <- min(max(object$rank), 4)
    indica <- factor(rep(1:length(object$blo), object$rank))
    nrow <- nlevels(object$TL[, 2])
    sumry <- array("", c(ntab, 9), list(1:ntab, c("names", "nrow", 
        "ncol", "rank", "lambda1", "lambda2", "lambda3", "lambda4", 
        "")))
    for (k in 1:ntab) {
        eig <- zapsmall(object$Eig[indica == k], dig = 4)
        l0 <- min(length(eig), 4)
        sumry[k, 4 + (1:l0)] <- round(eig[1:l0], dig = 3)
        if (length(eig) > 4) 
            sumry[k, 9] <- "..."
    }
    sumry[, 1] <- x1
    sumry[, 2] <- rep(nrow, ntab)
    sumry[, 3] <- object$blo
    sumry[, 4] <- object$rank
    class(sumry) <- "table"
    print(sumry)
}

"plot.sepan" <- function (x, mfrow = NULL, csub = 2, ...) {
    if (!inherits(x, "sepan")) 
        stop("Object of type 'sepan' expected")
    opar <- par(ask = par("ask"), mfrow = par("mfrow"), mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.6, 2.6, 0.6, 0.6))
    nbloc <- length(x$blo)
    if (is.null(mfrow)) 
        mfrow <- n2mfrow(nbloc)
    par(mfrow = mfrow)
    if (nbloc > prod(mfrow)) 
        par(ask = TRUE)
    rank.fac <- factor(rep(1:nbloc, x$rank))
    nf <- ncol(x$Li)
    neig <- max(x$rank)
    appel <- as.list(x$call)
    X <- eval(appel$X, sys.frame(0))
    maxeig <- max(x$Eig)
    for (ianal in 1:nbloc) {
        w <- x$Eig[rank.fac == ianal]
        scatterutil.eigen(w, xmax = neig, ymax = maxeig, wsel = 1:nf, 
            sub = x$tab.names[ianal], csub = csub, possub = "topright")
    }
}

"print.sepan" <- function (x, ...) {
    if (!inherits(x, "sepan")) 
        stop("to be used with 'sepan' object")
    cat("class:", class(x), "\n")
    cat("$call: ")
    print(x$call)
    sumry <- array("", c(4, 4), list(1:4, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$tab.names", length(x$tab.names), mode(x$tab.names), 
        "tab names")
    sumry[2, ] <- c("$blo", length(x$blo), mode(x$blo), "column number")
    sumry[3, ] <- c("$rank", length(x$rank), mode(x$rank), "tab rank")
    sumry[4, ] <- c("$Eig", length(x$Eig), mode(x$Eig), "All the eigen values")
    class(sumry) <- "table"
    print(sumry)
    sumry <- array("", c(6, 4), list(1:6, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$Li", nrow(x$Li), ncol(x$Li), "row coordinates")
    sumry[2, ] <- c("$L1", nrow(x$L1), ncol(x$L1), "row normed scores")
    sumry[3, ] <- c("$Co", nrow(x$Co), ncol(x$Co), "column coordinates")
    sumry[4, ] <- c("$C1", nrow(x$C1), ncol(x$C1), "column normed coordinates")
    sumry[5, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors for Li L1")
    sumry[6, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Co C1")
    class(sumry) <- "table"
    print(sumry)
}
"statis" <- function (X, scannf = TRUE, nf = 3, tol = 1e-07) {
    if (!inherits(X, "ktab")) 
        stop("object 'ktab' expected")
    lw <- X$lw
    nlig <- length(lw)
    cw <- X$cw
    ncol <- length(cw)
    blo <- X$blo
    ntab <- length(X$blo)
    indicablo <- X$TC[, 1]
    tab.names <- tab.names(X)
    auxinames <- ktab.util.names(X)
    statis <- list()
    sep <- list()
    lwsqrt <- sqrt(lw)
    for (k in 1:ntab) {
        ak <- sqrt(cw[indicablo == k])
        wk <- as.matrix(X[[k]]) * lwsqrt
        wk <- t(t(wk) * ak)
        wk <- wk %*% t(wk)
        sep[[k]] <- wk
    }
    ############## calcul des RV ###########
   sep <- matrix(unlist(sep), nlig * nlig, ntab)
    RV <- t(sep) %*% sep
    ak <- sqrt(diag(RV))
    RV <- sweep(RV, 1, ak, "/")
    RV <- sweep(RV, 2, ak, "/")
    dimnames(RV) <- list(tab.names, tab.names)
    statis$RV <- RV
    ############## diagonalisation de la matrice des RV ###########
   eig1 <- eigen(RV, sym = TRUE)
    statis$RV.eig <- eig1$values
    if (any(eig1$vectors[, 1] < 0)) 
        eig1$vectors[, 1] <- -eig1$vectors[, 1]
    tabw <- eig1$vectors[, 1]
    statis$RV.tabw <- tabw
    w <- t(t(eig1$vectors) * sqrt(eig1$values))
    w <- as.data.frame(w)
    row.names(w) <- tab.names
    names(w) <- paste("S", 1:ncol(w), sep = "")
    statis$RV.coo <- w[, 1:min(4, ncol(w))]
    ############## combinaison des oprateurs d'inertie norms ###########
    sep <- t(t(sep)/ak)
    C.ro <- apply(t(sep) * tabw, 2, sum)
    C.ro <- matrix(unlist(C.ro), nlig, nlig)
    ############## diagonalisation du compromis ###########
   eig1 <- eigen(C.ro, sym = TRUE)
    eig <- eig1$values
    rank <- sum((eig/eig[1]) > tol)
    if (scannf) {
        barplot(eig[1:rank])
        cat("Select the number of axes: ")
        nf <- as.integer(readLines(n = 1))
    }
    if (nf <= 0) 
        nf <- 2
    if (nf > rank) 
        nf <- rank
    statis$C.eig <- eig[1:rank]
    statis$C.nf <- nf
    statis$C.rank <- rank
    wref <- eig1$vectors[, 1:nf]
    wref <- wref/lwsqrt
    w <- data.frame(t(t(wref) * sqrt(eig[1:nf])))
    row.names(w) <- row.names(X)
    names(w) <- paste("C", 1:nf, sep = "")
    statis$C.li <- w
    w <- as.matrix(X[[1]])
    for (k in 2:ntab) {
        w <- cbind(w, as.matrix(X[[k]]))
    }
    w <- w * lw
    w <- t(w) %*% wref
    w <- data.frame(w, row.names = auxinames$col)
    names(w) <- paste("C", 1:nf, sep = "")
    statis$C.Co <- w
    sepanL1 <- sepan(X, nf = 4)$L1
    w <- matrix(0, ntab * 4, nf)
    i1 <- 0
    i2 <- 0
    for (k in 1:ntab) {
        i1 <- i2 + 1
        i2 <- i2 + 4
        tab <- as.matrix(sepanL1[X$TL[, 1] == k, ])
        tab <- t(tab * lw) %*% wref
        for (i in 1:min(nf, 4)) {
            if (tab[i, i] < 0) {
                for (j in 1:nf) tab[i, j] <- -tab[i, j]
            }
        }
        w[i1:i2, ] <- tab
    }
    w <- data.frame(w, row.names = auxinames$tab)
    names(w) <- paste("C", 1:nf, sep = "")
    statis$C.T4 <- w
    w <- as.matrix(statis$C.li) * lwsqrt
    w <- w %*% t(w)
    w <- w/sqrt(sum(w * w))
    w <- as.vector(unlist(w))
    sep <- sep * unlist(w)
    w <- apply(sep, 2, sum)
    statis$cos2 <- w
    statis$tab.names <- tab.names
    statis$TL <- X$TL
    statis$TC <- X$TC
    statis$T4 <- X$T4
    class(statis) <- "statis"
    return(statis)
}

"plot.statis" <- function (x, xax = 1, yax = 2, option = 1:4, ...) {
    if (!inherits(x, "statis")) 
        stop("Object of type 'statis' expected")
    nf <- x$C.nf
    if (xax > nf) 
        stop("Non convenient xax")
    if (yax > nf) 
        stop("Non convenient yax")
    opar <- par(mar = par("mar"), mfrow = par("mfrow"), xpd = par("xpd"))
    on.exit(par(opar))
    mfrow <- n2mfrow(length(option))
    par(mfrow = mfrow)
    for (j in option) {
        if (j == 1) {
            coolig <- x$RV.coo[, c(1, 2)]
            s.corcircle(coolig, label = x$tab.names, 
                cgrid = 0, sub = "Interstructure", csub = 1.5, 
                possub = "topleft", full = TRUE)
            l0 <- length(x$RV.eig)
            add.scatter.eig(x$RV.eig, l0, 1, 2, posi = "bottom", 
                ratio = 1/4)
        }
        if (j == 2) {
            coolig <- x$C.li[, c(xax, yax)]
            s.label(coolig, sub = "Compromise", csub = 1.5, 
                possub = "topleft", )
            add.scatter.eig(x$C.eig, x$C.nf, xax, yax, 
                posi = "bottom", ratio = 1/4)
        }
        if (j == 4) {
            cooax <- x$C.T4[x$T4[, 2] == 1, ]
            s.corcircle(cooax, xax, yax, full = TRUE, sub = "Component projection", 
                possub = "topright", csub = 1.5)
            add.scatter.eig(x$C.eig, x$C.nf, xax, yax, 
                posi = "bottom", ratio = 1/5)
        }
        if (j == 3) {
            plot(x$RV.tabw, x$cos2, xlab = "Tables weights", 
                ylab = "Cos 2")
            scatterutil.grid(0)
            title(main = "Typological value")
            par(xpd = TRUE)
            scatterutil.eti(x$RV.tabw, x$cos2, label = x$tab.names, 
                clabel = 1)
        }
    }
}

"print.statis" <- function (x, ...) {
    cat("STATIS Analysis\n")
    cat("class:")
    cat(class(x), "\n")
    cat("table number:", length(x$RV.tabw), "\n")
    cat("row number:", nrow(x$C.li), "  total column number:", 
        nrow(x$C.Co), "\n")
    cat("\n     **** Interstructure ****\n")
    cat("\neigen values: ")
    l0 <- length(x$RV.eig)
    cat(signif(x$RV.eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat(" $RV       matrix      ", nrow(x$RV), "    ", ncol(x$RV), "    RV coefficients\n")
    cat(" $RV.eig   vector      ", length(x$RV.eig), "      eigenvalues\n")
    cat(" $RV.coo   data.frame  ", nrow(x$RV.coo), "    ", ncol(x$RV.coo), 
        "   array scores\n")
    cat(" $tab.names    vector      ", length(x$tab.names), "       array names\n")
    cat(" $RV.tabw  vector      ", length(x$RV.tabw), "     array weigths\n")
    cat("\nRV coefficient\n")
    w <- x$RV
    w[row(w) < col(w)] <- NA
    print(w, na = "")
    cat("\n      **** Compromise ****\n")
    cat("\neigen values: ")
    l0 <- length(x$C.eig)
    cat(signif(x$C.eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("\n $nf:", x$C.nf, "axis-components saved")
    cat("\n $rank: ")
    cat(x$C.rank, "\n")
    sumry <- array("", c(6, 4), list(rep("", 6), c("data.frame", 
        "nrow", "ncol", "content")))
    sumry[1, ] <- c("$C.li", nrow(x$C.li), ncol(x$C.li), "row coordinates")
    sumry[2, ] <- c("$C.Co", nrow(x$C.Co), ncol(x$C.Co), "column coordinates")
    sumry[3, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "principal vectors (each table)")
    sumry[4, ] <- c("$TL", nrow(x$TL), ncol(x$TL), "factors (not used)")
    sumry[5, ] <- c("$TC", nrow(x$TC), ncol(x$TC), "factors for Co")
    sumry[6, ] <- c("$T4", nrow(x$T4), ncol(x$T4), "factors for T4")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"supcol" <- function (x, ...) UseMethod("supcol") 

"supcol.coa" <- function (x, Xsup, ...) {
    # modif pour Culhane, Aedin" <a.culhane@ucc.ie> 
    # supcol renvoie une liste  deux lments tabsup et cosup
    Xsup <- data.frame(Xsup)
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(x, "coa")) 
        stop("Object of class 'coa' expected")
    if (!inherits(Xsup, "data.frame")) 
        stop("Xsup is not a data.frame")
    if (nrow(Xsup) != nrow(x$tab)) 
        stop("non convenient row numbers")
    cwsup <- apply(Xsup, 2, sum)
    cwsup[cwsup == 0] <- 1
    Xsup <- sweep(Xsup, 2, cwsup, "/")
    coosup <- t(as.matrix(Xsup)) %*% as.matrix(x$l1)
    coosup <- data.frame(coosup, row.names = names(Xsup))
    names(coosup) <- names(x$co)
    return(list(tabsup=Xsup, cosup=coosup))
}

"supcol.default" <- function (x, Xsup, ...) {
    Xsup <- data.frame(Xsup)
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(Xsup, "data.frame")) 
        stop("Xsup is not a data.frame")
    if (nrow(Xsup) != nrow(x$tab)) 
        stop("non convenient row numbers")
    coosup <- t(as.matrix(Xsup)) %*% (as.matrix(x$l1) * x$lw)
    coosup <- data.frame(coosup, row.names = names(Xsup))
    names(coosup) <- names(x$co)
    return(list(tabsup=Xsup, cosup=coosup))
}
"suprow" <- function (x, ...) UseMethod("suprow")

"suprow.coa" <- function (x, Xsup, ...) {
    Xsup <- data.frame(Xsup)
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(x, "coa")) 
        stop("Object of class 'coa' expected")
    if (!inherits(Xsup, "data.frame")) 
        stop("Xsup is not a data.frame")
    if (ncol(Xsup) != ncol(x$tab)) 
        stop("non convenient col numbers")
    lwsup <- apply(Xsup, 1, sum)
    lwsup[lwsup == 0] <- 1
    Xsup <- sweep(Xsup, 1, lwsup, "/")
    coosup <- as.matrix(Xsup) %*% as.matrix(x$c1)
    coosup <- data.frame(coosup, row.names = row.names(Xsup))
    names(coosup) <- names(x$li)
    return(list(tabsup=Xsup, lisup=coosup))
}

"suprow.default" <- function (x, Xsup, ...) {
    # modif pour Culhane, Aedin" <a.culhane@ucc.ie> 
    # suprow renvoie une liste  deux lments tabsup et lisup
    Xsup <- data.frame(Xsup)
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(Xsup, "data.frame")) 
        stop("Xsup is not a data.frame")
    if (ncol(Xsup) != ncol(x$tab)) 
        stop("non convenient col numbers")
    coosup <- as.matrix(Xsup) %*% t(t(as.matrix(x$c1)) * x$cw)
    coosup <- data.frame(coosup, row.names = row.names(Xsup))
    names(coosup) <- names(x$li)
    return(list(tabsup=Xsup, lisup=coosup))
}

"suprow.pca" <- function (x, Xsup, ...) {
    Xsup <- data.frame(Xsup)
    if (!inherits(x, "dudi")) 
        stop("Object of class 'dudi' expected")
    if (!inherits(x, "pca")) 
        stop("Object of class 'pca' expected")
    if (!inherits(Xsup, "data.frame")) 
        stop("Xsup is not a data.frame")
    if (ncol(Xsup) != ncol(x$tab)) 
        stop("non convenient col numbers")
    f1 <- function(w) (w - x$cent)/x$norm
    Xsup <- t(apply(Xsup, 1, f1))
    coosup <- as.matrix(Xsup) %*% as.matrix(x$c1)
    coosup <- data.frame(coosup, row.names = row.names(Xsup))
    names(coosup) <- names(x$li)
    return(list(tabsup=Xsup, lisup=coosup))
}
"dotchart.phylog" <- function (phylog, values, ceti=1, cdot=1, ...) {
    if (!inherits(phylog, "phylog")) 
        stop("Non convenient data")
    if (! is.numeric (values)) stop ("'values' is not numeric")
    n <- length(values)
    if (length(phylog$leaves)!=n) stop ("Non convenient length")
    w <- plot.phylog (x=phylog, clabel.leaves=0, ...)
    mar.old <- par("mar")
    on.exit(par(mar=mar.old))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    par("usr"=c(0,1,-0.05,1))
    val.ref <- pretty(values,4)
    x1 <- w$xbase
    x2 <- 1 - (x1-max(w$xy$x))
    x1.use <- min(val.ref)
    x2.use <- max(val.ref)
    fun1 <- function (x) x1+(x2-x1)*(x-x1.use)/(x2.use-x1.use)
    xleg <- fun1(val.ref)
    miny <- 0 # min(w$xy$y)
    maxy <- max(w$xy$y)
    nleg <- length(xleg)
    segments(xleg,rep(miny,nleg),xleg,rep(maxy,nleg), col=grey(0.75))
    segments (w$xy$x,w$xy$y,rep(max(w$xy$x),n),w$xy$y, col=grey(0.75))
    segments (rep(xleg[1],n),w$xy$y,rep(max(xleg),n),w$xy$y, col=grey(0.5))
    if (cdot>0) points(fun1(values),w$xy$y,pch=21,cex=cdot,bg=1)
    if (ceti>0) text(xleg, rep((miny-0.05)/2,nleg),as.character(val.ref),cex=par("cex")*ceti) #(miny-0.05)/2
}


"symbols.phylog" <- function (phylog, circles, squares, csize = 1, clegend = 1, sub = "",
    csub = 1, possub = "topleft") 
{
    if (!inherits(phylog, "phylog")) 
        stop("Non convenient data")
    count <- 0
    if (!missing(circles)) {
        count <- count + 1
        data <- circles
        type <- 2
    }
    if (!missing(squares)) {
        count <- count + 1
        data <- squares
        type <- 1
    }
    if (count > 1) 
        stop("no more than one symbol type must be specified")
    if (csize <= 0) {
        data <- NULL
    }
    if (!is.null(data)) {
        if (is.null(names(data))) 
            names(data) <- names(phylog$leaves)
        if (length(data) != length(phylog$leaves)) data <- NULL
        if (!is.null(data)) {
            w1 <- sort(names(data))
            w2 <- sort(names(phylog$leaves))
            if (!all(w1 == w2)) {
                print(w1)
                print(w2)
                warning("names(data) non convenient for 'phylog' : we use the names of the leaves in 'phylog'")
                names(data) <- names(phylog$leaves)
            }
            data <- data[names(phylog$leaves)]
        }
    }
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", 
        yaxt = "n", ylim = c(-0.2, 1.05), xlim = c(0, 1), xaxs = "i", 
        yaxs = "i", frame.plot = TRUE)
    symbol.max <- csize/20
    if (symbol.max > 0.5) 
        symbol.max <- 0.5
    dis <- phylog$droot
    dis <- 1 - ((1 - symbol.max) * dis/max(dis))
    xinit <- dis[names(phylog$leaves)]
    dn <- dis[names(phylog$nodes)]
    n <- length(xinit)
    yinit <- (n:1)/(n + 1)
    names(yinit) <- names(phylog$leaves)
    x <- dis
    yn <- rep(0, length(dn))
    names(yn) <- names(dn)
    y <- c(yinit, yn)
    legender <- function(br0, sq0, sig0, clegend, type) {
        br0 <- round(br0, dig = 6)
        cha <- as.character(br0[1])
        for (i in (2:(length(br0)))) cha <- paste(cha, br0[i], 
            sep = " ")
        cex0 <- par("cex") * clegend
        yh <- max(c(strheight(cha, cex = cex0), sq0))
        h <- strheight(cha, cex = cex0)
        y0 <- par("usr")[3] + yh/2 + h
        ltot <- strwidth(cha, cex = cex0) + sum(sq0) + h
        x0 <- par("usr")[1] + h/2
        for (i in (1:(length(sq0)))) {
            cha <- br0[i]
            cha <- paste(" ", cha, sep = "")
            xh <- strwidth(cha, cex = cex0)
            text(x0 + xh/2, y0, cha, cex = cex0)
            z0 <- sq0[i]
            x0 <- x0 + xh + z0/2
            if (sig0[i] >= 0) {
                if (type == 1) 
                  symbols(x0, y0, squares = z0, bg = "black", 
                    fg = "white", add = TRUE, inch = FALSE)
                else if (type == 2) 
                  symbols(x0, y0, circles = z0/2, bg = "black", 
                    fg = "white", add = TRUE, inch = FALSE)
            }
            else {
                if (type == 1) 
                  symbols(x0, y0, squares = z0, bg = "white", 
                    fg = "black", add = TRUE, inch = FALSE)
                else if (type == 2) 
                  symbols(x0, y0, circles = z0/2, bg = "white", 
                    fg = "black", add = TRUE, inch = FALSE)
            }
            x0 <- x0 + z0/2
        }
        invisible()
    }
    for (i in 1:length(phylog$parts)) {
        w <- phylog$parts[[i]]
        but <- names(phylog$parts)[i]
        y[but] <- mean(y[w])
        b <- range(y[w])
        segments(b[1], x[but], b[2], x[but])
        x1 <- x[w]
        y1 <- y[w]
        x2 <- rep(x[but], length(w))
        segments(y1, x1, y1, x2)
    }
    if (!is.null(data)) {
        sq <- sqrt(abs(data))
        w1 <- max(sq)
        sq <- symbol.max * sq/w1
        if (type == 1) {
            for (i in 1:n) {
                if (sign(data[i]) >= 0) {
                  symbols(yinit[i], xinit[i], squares = sq[i], 
                    bg = "black", fg = "white", add = TRUE, inch = FALSE)
                }
                else {
                  symbols(yinit[i], xinit[i], squares = sq[i], 
                    bg = "white", fg = "black", add = TRUE, inch = FALSE)
                }
            }
        }
        else if (type == 2) {
            for (i in 1:n) {
                if (sign(data[i]) >= 0) {
                  symbols(yinit[i], xinit[i], circles = sq[i]/2, 
                    bg = "black", fg = "white", add = TRUE, inch = FALSE)
                }
                else {
                  symbols(yinit[i], xinit[i], circles = sq[i]/2, 
                    bg = "white", fg = "black", add = TRUE, inch = FALSE)
                }
            }
        }
        if (clegend > 0) {
            br0 <- pretty(data, 4)
            l0 <- length(br0)
            br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
            sq0 <- sqrt(abs(br0))
            sq0 <- symbol.max * sq0/w1
            sig0 <- sign(br0)
            legender(br0, sq0, sig0, clegend = clegend, type = type)
        }
    }
    if (csub > 0) 
        scatterutil.sub(sub, csub, possub)
}
"table.cont" <- function (df, x = 1:ncol(df), y = 1:nrow(df), row.labels = row.names(df),
    col.labels = names(df), clabel.row = 1, clabel.col = 1, abmean.x = FALSE, 
    abline.x = FALSE, abmean.y = FALSE, abline.y = FALSE, csize = 1, clegend = 0, 
    grid = TRUE) 
{
    opar <- par(mai = par("mai"), srt = par("srt"))
    on.exit(par(opar))
    if (any(df < 0)) 
        stop("Non negative values expected")
    N <- sum(df)
    df <- df/sum(df)
    table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels, 
        clabel.row = clabel.row, clabel.col = clabel.col, grid = grid, 
        pos = "leftbottom")
    xtot <- x[col(as.matrix(df))]
    ytot <- y[row(as.matrix(df))]
    coeff <- diff(range(x))/15
    z <- unlist(df)
    sq <- sqrt(abs(z))
    w1 <- max(sq)
    sq <- csize * coeff * sq/w1
    for (i in 1:length(z)) symbols(xtot[i], ytot[i], squares = sq[i], 
        bg = "white", fg = 1, add = TRUE, inch = FALSE)
    f1 <- function(x) {
        w1 <- weighted.mean(val, x)
        val <- (val - w1)^2
        w2 <- sqrt(weighted.mean(val, x))
        return(c(w1, w2))
    }
    if (abmean.x) {
        val <- y
        w <- t(apply(df, 2, f1))
        points(x, w[, 1], pch = 20, cex = 2)
        segments(x, w[, 1] - w[, 2], x, w[, 1] + w[, 2])
    }
    if (abmean.y) {
        val <- x
        w <- t(apply(df, 1, f1))
        points(w[, 1], y, pch = 20, cex = 2)
        segments(w[, 1] - w[, 2], y, w[, 1] + w[, 2], y)
    }
    df <- as.matrix(df)
    x <- x[col(df)]
    y <- y[row(df)]
    df <- as.vector(df)
    if (abline.x) {
        abline(lm(y ~ x, wei = df))
    }
    if (abline.y) {
        w <- coefficients(lm(x ~ y, wei = df))
        if (w[2] == 0) 
            abline(h = w[1])
        else abline(c(-w[1]/w[2], 1/w[2]))
    }
    br0 <- pretty(z, 4)
    l0 <- length(br0)
    br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
    sq0 <- sqrt(abs(br0))
    sq0 <- csize * coeff * sq0/w1
    sig0 <- sign(br0)
    if (clegend > 0) 
        scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
}
"table.dist" <- function (d, x = 1:(attr(d, "Size")), labels = as.character(x),
    clabel = 1, csize = 1, grid = TRUE) 
{
    opar <- par(mai = par("mai"), srt = par("srt"))
    on.exit(par(opar))
    if (!inherits(d, "dist")) 
        stop("object of class 'dist expected")
    table.prepare(x, x, labels, labels, clabel, clabel, grid, 
        "leftbottom")
    n <- attr(d, "Size")
    d <- dist2mat(d)
    xtot <- x[col(d)]
    ytot <- x[row(d)]
    coeff <- diff(range(x))/n
    z <- as.vector(d)
    sq <- sqrt(z * pi)
    w1 <- max(sq)
    sq <- csize * coeff * sq/w1
    symbols(xtot, ytot, circles = sq, fg = 1, bg = grey(0.8), 
        add = TRUE, inch = FALSE)
}
"table.paint" <- function (df, x = 1:ncol(df), y = nrow(df):1, row.labels = row.names(df),
    col.labels = names(df), clabel.row = 1, clabel.col = 1, csize = 1, 
    clegend = 1) 
{
    x <- rank(x)
    y <- rank(y)
    opar <- par(mai = par("mai"), srt = par("srt"))
    on.exit(par(opar))
    table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels, 
        clabel.row = clabel.row, clabel.col = clabel.col, grid = FALSE, 
        pos = "paint")
    xtot <- x[col(as.matrix(df))]
    ytot <- y[row(as.matrix(df))]
    xdelta <- (max(x) - min(x))/(length(x) - 1)/2
    ydelta <- (max(y) - min(y))/(length(y) - 1)/2
    coeff <- diff(range(xtot))/15
    z <- unlist(df)
    br0 <- pretty(z, 6)
    nborn <- length(br0)
    coeff <- diff(range(x))/15
    numclass <- cut.default(z, br0, include = TRUE, lab = FALSE)
    valgris <- seq(1, 0, le = (nborn - 1))
    h <- csize * coeff
    rect(xtot - xdelta, ytot - ydelta, xtot + xdelta, ytot + 
        ydelta, col = gray(valgris[numclass]))
    if (clegend > 0) 
        scatterutil.legend.square.grey(br0, valgris, h/2, clegend)
}
"table.phylog" <- function (df, phylog, x = 1:ncol(df), f.phylog = 0.5,
    labels.row = gsub("[_]"," ",row.names(df)), clabel.row = 1,
    labels.col = names(df), clabel.col = 1, 
    labels.nod = names(phylog$nodes), clabel.nod = 0, cleaves = 1,
    cnodes = 1, csize = 1, grid = TRUE, clegend=0.75)
{
    df <- as.data.frame(df)
    if (!inherits(df,"data.frame")) stop ("data.frame expected for 'df'")
    if (!inherits(phylog,"phylog")) stop ("class 'phylog' expected for 'phylog'")
    leave.names <- names(phylog$leaves)
    node.names <- names(phylog$nodes)
    n.leave <- length(leave.names)
    n.node <- length(node.names)
    if (f.phylog > 0.8) f.phylog <- 0.8
    if (f.phylog < 0.2) f.phylog <- 0.2
    opar <- par(mai = par("mai"), srt = par("srt"))
    on.exit(par(opar))
    w1 <- sort(row.names(df))
    w2 <- sort(names(phylog$leaves))
    if (!all(w1 == w2)) {
       print.noquote("names from 'df'")
       print(w1)
       print.noquote("names from 'phylog'")
       print(w2)
       stop ("non convenient matching information")
    }

    df <- df[names(phylog$leaves), ]
    # df donnes phylog structure
    frame()
    labels.row <- paste(" ", labels.row, " ", sep = "")
    labels.col <- paste(" ", labels.col, " ", sep = "")
    cexrow <- par("cex") * clabel.row
    strx <- 0.1
    if (cexrow > 0) {
        strx <- max( strwidth(labels.row,unit="inches",cex=cexrow))+0.1
    }
    cexcol <- par("cex") * clabel.col
    stry <- 0.1
    if (cexcol > 0) {
        stry <- max( strwidth(labels.col,unit="inches",cex=cexcol))+0.1
    }
    par(mai = c(0.1, 0.1, stry, strx))
    nc <- ncol(df)
    x <- 1/2/nc+(0:(nc-1))/nc
    x <- (1 - f.phylog) * x + f.phylog
    nl <- nrow(df)
    y <- 1/2/nl+((nl-1):0)/nl
    plot.default(0, 0, type = "n", xlab = "", ylab = "", 
        xaxt = "n", yaxt = "n", xlim = c(0,1), ylim = c(0,1), 
        xaxs = "i", yaxs = "i", frame.plot = FALSE)
    if (cexrow > 0) {
        for (i in 1:length(y)) {
            text(1.01, y[i], labels.row[i], adj = 0, 
              cex = cexrow, xpd = NA)
            segments(1, y[i], 1.01, y[i], xpd = NA)
        }
    }
    if (cexcol > 0) {
        par(srt = 90)
        for (i in 1:length(x)) {
            text(x[i], 1.01, labels.col[i], adj = 0, 
              cex = cexcol, xpd = NA)
            segments(x[i], 1.0, x[i], 1.01,, xpd = NA)
        }
        par(srt = 0)
    }
     if (grid) {
        col <- "lightgray"
        for (i in 1:length(y)) segments(1,y[i], 
            f.phylog, y[i], col = col)
        for (i in 1:length(x)) segments(x[i], 0, 
            x[i], 1, col = col)
    }
    rect(f.phylog, 0, 1, 1)
    xtot <- x[col(as.matrix(df))]
    ytot <- y[row(as.matrix(df))]
    coeff <- diff(range(xtot))/15
    z <- unlist(df)
    sq <- sqrt(abs(z))
    w1 <- max(sq)
    sq <- csize * coeff * sq/w1
    for (i in 1:length(z)) {
        if (sign(z[i]) >= 0) {
            symbols(xtot[i], ytot[i], squares = sq[i], bg = "black", 
                fg = "white", add = TRUE, inch = FALSE)
        }
        else {
            symbols(xtot[i], ytot[i], squares = sq[i], bg = "white", 
                fg = "black", add = TRUE, inch = FALSE)
        }
    }
    br0 <- pretty(z, 4)
    l0 <- length(br0)
    br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
    sq0 <- sqrt(abs(br0))
    sq0 <- csize * coeff * sq0/w1
    sig0 <- sign(br0)
    
    dis <- phylog$droot
    dl <- phylog$droot[leave.names]
    dn <- phylog$droot[node.names]
    names(y) <- leave.names
    x <- dis
    x <- (x/max(x)) * f.phylog
    for (i in 1:n.leave) {
        segments(f.phylog, y[i], x[i], y[i], col = grey(0.7))
        points(x[i], y[i], pch = 20, cex = par("cex") * cleaves)
    }
    newlab <- as.character(1:length(phylog$nodes))
    newx <- NULL
    newy <- NULL
    yn <- rep(0, length(dn))
    names(yn) <- names(dn)
    y <- c(y, yn)
    for (i in 1:n.node) {
        w <- phylog$parts[[i]]
        if (clabel.nod>0) newlab[i] <- labels.nod[i]
        but <- names(phylog$parts)[i]
        y[but] <- mean(y[w])
        newy[i] <- y[but]
        newx[i] <- x[but]
        b <- range(y[w])
        segments(x[but], b[1], x[but], b[2])
        x1 <- x[w]
        y1 <- y[w]
        x2 <- rep(x[but], length(w))
        segments(x1, y1, x2, y1)
     }
     if (cnodes > 0) points(newx, newy, pch = 21, bg="white", cex = par("cex") * cnodes, xpd=NA)
     if (clabel.nod>0) (scatterutil.eti(newx,newy,newlab,clabel.nod))
     if (clegend > 0) 
            scatterutil.legend.bw.square(br0, sq0, sig0, clegend)

}
"table.prepare" <- function (x, y, row.labels, col.labels, clabel.row, clabel.col,
    grid, pos) 
{
    cexrow <- par("cex") * clabel.row
    cexcol <- par("cex") * clabel.col
    wx <- range(x)
    wy <- range(y)
    maxx <- max(x)
    maxy <- max(y)
    minx <- min(x)
    miny <- min(y)
    dx <- diff(wx)/(length(x))
    dy <- diff(wy)/(length(y))
    if (cexrow > 0) {
        ncar <- max(nchar(paste(" ", row.labels, " ", sep = "")))
        strx <- par("cin")[1] * ncar * cexrow/2 + 0.1
    }
    else strx <- 0.1
    if (cexcol > 0) {
        ncar <- max(nchar(paste(" ", col.labels, " ", sep = "")))
        stry <- par("cin")[1] * ncar * cexcol/2 + 0.1
    }
    else stry <- 0.1
    if (pos == "righttop") {
        par(mai = c(0.1, 0.1, stry, strx))
        xlim <- wx + c(-dx, 2 * dx)
        ylim <- wy + c(-2 * dy, 2 * dy)
        plot.default(0, 0, type = "n", xlab = "", ylab = "", 
            xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
            xaxs = "i", yaxs = "i", frame.plot = FALSE)
        if (cexrow > 0) {
            for (i in 1:length(y)) {
                ynew <- seq(miny, maxy, le = length(y))
                ynew <- ynew[rank(y)]
                text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0, 
                  cex = cexrow, xpd = NA)
                segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
            }
        }
        if (cexcol > 0) {
            par(srt = 90)
            for (i in 1:length(x)) {
                xnew <- seq(minx, maxx, le = length(x))
                xnew <- xnew[rank(x)]
                text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0, 
                  cex = cexcol, xpd = NA)
                segments(xnew[i], maxy + 2 * dy, x[i], maxy + 
                  dy)
            }
            par(srt = 0)
        }
        if (grid) {
            col <- "lightgray"
            for (i in 1:length(y)) segments(maxx + dx, y[i], 
                minx - dx, y[i], col = col)
            for (i in 1:length(x)) segments(x[i], miny - dy, 
                x[i], maxy + dy, col = col)
        }
        rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
        return(invisible())
    }
    if (pos == "phylog") {
        par(mai = c(0.1, 0.1, stry, strx))
        xlim <- wx + c(-dx, 2 * dx)
        ylim <- wy + c(-dy, 2 * dy)
        plot.default(0, 0, type = "n", xlab = "", ylab = "", 
            xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
            xaxs = "i", yaxs = "i", frame.plot = FALSE)
        if (cexrow > 0) {
            for (i in 1:length(y)) {
                ynew <- seq(miny, maxy, le = length(y))
                ynew <- ynew[rank(y)]
                text(maxx + 2 * dx, ynew[i], row.labels[i], adj = 0, 
                  cex = cexrow, xpd = NA)
                segments(maxx + 2 * dx, ynew[i], maxx + dx, y[i])
            }
        }
        if (cexcol > 0) {
            par(srt = 90)
            xnew <- x[2:length(x)]
            x <- xnew
            for (i in 1:length(x)) {
                text(xnew[i], maxy + 2 * dy, col.labels[i], adj = 0, 
                  cex = cexcol, xpd = NA)
                segments(xnew[i], maxy + 2 * dy, x[i], maxy + 
                  dy)
            }
            par(srt = 0)
        }
        minx <- min(x)
        if (grid) {
            col <- "lightgray"
            for (i in 1:length(y)) segments(maxx + dx, y[i], 
                minx - dx, y[i], col = col)
            for (i in 1:length(x)) segments(x[i], miny - dy, 
                x[i], maxy + dy, col = col)
        }
        rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
        rect(-dx, miny - dy, minx - dx, maxy + dy)
        return(c(0, minx - dx))
    }
    if (pos == "leftbottom") {
        par(mai = c(stry, strx, 0.05, 0.05))
        xlim <- wx + c(-2 * dx, dx)
        ylim <- wy + c(-2 * dy, dy)
        plot.default(0, 0, type = "n", xlab = "", ylab = "", 
            xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
            xaxs = "i", yaxs = "i", frame.plot = FALSE)
        if (cexrow > 0) {
            for (i in 1:length(y)) {
                ynew <- seq(miny, maxy, le = length(y))
                ynew <- ynew[rank(y)]
                w9 <- strwidth(row.labels[i], cex = cexrow)
                text(minx - w9 - 2 * dx, ynew[i], row.labels[i], 
                  adj = 0, cex = cexrow, xpd = NA)
                segments(minx - 2 * dx, ynew[i], minx - dx, y[i])
            }
        }
        if (cexcol > 0) {
            par(srt = -90)
            for (i in 1:length(x)) {
                xnew <- seq(minx, maxx, le = length(x))
                xnew <- xnew[rank(x)]
                text(xnew[i], miny - 2 * dy, col.labels[i], adj = 0, 
                  cex = cexcol, xpd = NA)
                segments(xnew[i], miny - 2 * dy, x[i], miny - 
                  dy)
            }
            par(srt = 0)
        }
        if (grid) {
            col <- "lightgray"
            for (i in 1:length(y)) segments(maxx + 2 * dx, y[i], 
                minx - dx, y[i], col = col)
            for (i in 1:length(x)) segments(x[i], miny - 2 * 
                dy, x[i], maxy + dy, col = col)
        }
        rect(minx - dx, miny - dy, maxx + dx, maxy + dy)
        return(invisible())
    }
    if (pos == "paint") {
        par(mai = c(0.2, strx, stry, 0.1))
        xlim <- wx + c(-dx, dx)
        ylim <- wy + c(-dy, dy)
        plot.default(0, 0, type = "n", xlab = "", ylab = "", 
            xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, 
            xaxs = "i", yaxs = "i", frame.plot = FALSE)
        if (cexrow > 0) {
            ynew <- seq(miny, maxy, le = length(y))
            ynew <- ynew[rank(y)]
            w9 <- strwidth(row.labels, cex = cexrow)
            text(minx - w9 - 3 * dx/4, ynew, row.labels, adj = 0, 
                cex = cexrow, xpd = NA)
        }
        if (cexcol > 0) {
            xnew <- seq(minx, maxx, le = length(x))
            xnew <- xnew[rank(x)]
            par(srt = 90)
            text(xnew, maxy + 3 * dy/4, col.labels, adj = 0, 
                cex = cexcol, xpd = NA)
            par(srt = 0)
        }
        return(invisible())
    }
}


 "table.value" <- function (df, x = 1:ncol(df), y = nrow(df):1, row.labels = row.names(df),
    col.labels = names(df), clabel.row = 1, clabel.col = 1, csize = 1, 
    clegend = 1, grid = TRUE) 
{
    opar <- par(mai = par("mai"), srt = par("srt"))
    on.exit(par(opar))
    table.prepare(x = x, y = y, row.labels = row.labels, col.labels = col.labels, 
        clabel.row = clabel.row, clabel.col = clabel.col, grid = grid, 
        pos = "righttop")
    xtot <- x[col(as.matrix(df))]
    ytot <- y[row(as.matrix(df))]
    coeff <- diff(range(xtot))/15
    z <- unlist(df)
    sq <- sqrt(abs(z))
    w1 <- max(sq)
    sq <- csize * coeff * sq/w1
    for (i in 1:length(z)) {
        if (sign(z[i]) >= 0) {
            symbols(xtot[i], ytot[i], squares = sq[i], bg = 1, 
                fg = 0, add = TRUE, inch = FALSE)
        }
        else {
            symbols(xtot[i], ytot[i], squares = sq[i], bg = "white", 
                fg = 1, add = TRUE, inch = FALSE)
        }
    }
    br0 <- pretty(z, 4)
    l0 <- length(br0)
    br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2
    sq0 <- sqrt(abs(br0))
    sq0 <- csize * coeff * sq0/w1
    sig0 <- sign(br0)
    if (clegend > 0) 
        scatterutil.legend.bw.square(br0, sq0, sig0, clegend)
}
######################### triangle.plot ######################################
"triangle.plot" <- function (ta, label = as.character(1:nrow(ta)), clabel = 0, cpoint = 1,
    draw.line = TRUE, addaxes = FALSE, addmean = FALSE, labeltriangle = TRUE, 
    sub = "", csub = 0, possub = "topright", show.position = TRUE, 
    scale = TRUE, min3 = NULL, max3 = NULL) 
{
    seg <- function(a, b, col = par("col")) {
        segments(a[1], a[2], b[1], b[2], col = col)
    }
    nam <- names(ta)
    ta <- t(apply(ta, 1, function(x) x/sum(x)))
    d <- triangle.param(ta, scale = scale, min3 = min3, max3 = max3)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    A <- d$A
    B <- d$B
    C <- d$C
    xy <- d$xy
    mini <- d$mini
    maxi <- d$maxi
    plot(0, 0, type = "n", xlim = c(-0.8, 0.8), ylim = c(-0.6, 
        1), xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1, 
        frame.plot = FALSE)
    seg(A, B)
    seg(B, C)
    seg(C, A)
    text(C[1], C[2], labels = paste(mini[1]), pos = 2)
    text(C[1], C[2], labels = paste(maxi[3]), pos = 4)
    if (labeltriangle) 
        text((A + C)[1]/2, (A + C)[2]/2, labels = nam[1], cex = 1.5, 
            pos = 2)
    text(A[1], A[2], labels = paste(maxi[1]), pos = 2)
    text(A[1], A[2], labels = paste(mini[2]), pos = 1)
    if (labeltriangle) 
        text((A + B)[1]/2, (A + B)[2]/2, labels = nam[2], cex = 1.5, 
            pos = 1)
    text(B[1], B[2], labels = paste(maxi[2]), pos = 1)
    text(B[1], B[2], labels = paste(mini[3]), pos = 4)
    if (labeltriangle) 
        text((B + C)[1]/2, (B + C)[2]/2, labels = nam[3], cex = 1.5, 
            pos = 4)
    if (draw.line) {
        nlg <- 10 * (maxi[1] - mini[1])
        for (i in 1:(nlg - 1)) {
            x1 <- A + (i/nlg) * (B - A)
            x2 <- C + (i/nlg) * (B - C)
            seg(x1, x2, col = "lightgrey")
            x1 <- A + (i/nlg) * (B - A)
            x2 <- A + (i/nlg) * (C - A)
            seg(x1, x2, col = "lightgrey")
            x1 <- C + (i/nlg) * (A - C)
            x2 <- C + (i/nlg) * (B - C)
            seg(x1, x2, col = "lightgrey")
        }
    }
    if (cpoint > 0) 
        points(xy, pch = 20, cex = par("cex") * cpoint)
    if (clabel > 0) 
        scatterutil.eti(xy[, 1], xy[, 2], label, clabel)
    if (addaxes) {
        pr0 <- dudi.pca(ta, scale = FALSE, scann = FALSE)$c1
        w1 <- triangle.posipoint(apply(ta, 2, mean), mini, maxi)
        points(w1[1], w1[2], pch = 16, cex = 2)
        a1 <- pr0[, 1]
        x1 <- a1[1] * A + a1[2] * B + a1[3] * C
        seg(w1 - x1, w1 + x1)
        a1 <- pr0[, 2]
        x1 <- a1[1] * A + a1[2] * B + a1[3] * C
        seg(w1 - x1, w1 + x1)
    }
    if (addmean) {
        m <- apply(ta, 2, mean)
        w1 <- triangle.posipoint(m, mini, maxi)
        points(w1[1], w1[2], pch = 16, cex = 2)
        w2 <- triangle.posipoint(c(m[1], mini[2], 1 - m[1] - 
            mini[2]), mini, maxi)
        w3 <- triangle.posipoint(c(1 - m[2] - mini[3], m[2], 
            mini[3]), mini, maxi)
        w4 <- triangle.posipoint(c(mini[1], 1 - m[3] - mini[1], 
            m[3]), mini, maxi)
        points(w2[1], w2[2], pch = 20, cex = 2)
        points(w3[1], w3[2], pch = 20, cex = 2)
        points(w4[1], w4[2], pch = 20, cex = 2)
        seg(w1, w2)
        seg(w1, w3)
        seg(w1, w4)
        text(w2[1], w2[2], labels = as.character(round(m[1], 
            dig = 3)), cex = 1.5, pos = 2)
        text(w3[1], w3[2], labels = as.character(round(m[2], 
            dig = 3)), cex = 1.5, pos = 1)
        text(w4[1], w4[2], labels = as.character(round(m[3], 
            dig = 3)), cex = 1.5, pos = 4)
    }
    if (csub > 0) 
        scatterutil.sub(sub, csub, possub)
    if (show.position) 
        add.position.triangle(d)
} 

######################### triangle.posipoint ######################################
"triangle.posipoint" <- function (x, mini, maxi) {
    x <- (x - mini)/(maxi - mini)
    x <- x/sum(x)
    x1 <- (x[2] - x[1])/sqrt(2)
    y1 <- (2 * x[3] - x[2] - x[1])/sqrt(6)
    return(c(x1, y1))
} 

######################### add.position.triangle ######################################
"add.position.triangle" <- function (d) {
    opar <- par(new = par("new"), mar = par("mar"))
    on.exit(par(opar))
    par(new = TRUE)
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    w <- matrix(0, 3, 3)
    w[1, 1] <- d$mini[1]
    w[1, 2] <- d$mini[2]
    w[1, 3] <- d$maxi[3]
    w[2, 1] <- d$maxi[1]
    w[2, 2] <- d$mini[2]
    w[2, 3] <- d$mini[3]
    w[3, 1] <- d$mini[1]
    w[3, 2] <- d$maxi[2]
    w[3, 3] <- d$mini[3]
    A <- triangle.posipoint(c(0, 0, 1), c(0, 0, 0), c(1, 1, 1))
    B <- triangle.posipoint(c(1, 0, 0), c(0, 0, 0), c(1, 1, 1))
    C <- triangle.posipoint(c(0, 1, 0), c(0, 0, 0), c(1, 1, 1))
    a <- triangle.posipoint(w[1, ], c(0, 0, 0), c(1, 1, 1))
    b <- triangle.posipoint(w[2, ], c(0, 0, 0), c(1, 1, 1))
    c <- triangle.posipoint(w[3, ], c(0, 0, 0), c(1, 1, 1))
    plot(0, 0, type = "n", xlim = c(-0.71, 4 - 0.71), ylim = c(-4 + 
        0.85, 0.85), xlab = "", ylab = "", xaxt = "n", yaxt = "n", 
        asp = 1, frame.plot = FALSE)
    polygon(c(A[1], B[1], C[1]), c(A[2], B[2], C[2]))
    polygon(c(a[1], b[1], c[1]), c(a[2], b[2], c[2]), col = grey(0.75))
}

######################### triangle.biplot ######################################
"triangle.biplot" <- function (ta1, ta2, label = as.character(1:nrow(ta1)), draw.line = TRUE,
    show.position = TRUE, scale = TRUE) 
{
    seg <- function(a, b, col = 1) {
        segments(a[1], a[2], b[1], b[2], col = col)
    }
    nam <- names(ta1)
    ta1 <- t(apply(ta1, 1, function(x) x/sum(x)))
    ta2 <- t(apply(ta2, 1, function(x) x/sum(x)))
    d <- triangle.param(rbind(ta1, ta2), scale = scale)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    A <- d$A
    B <- d$B
    C <- d$C
    xy <- d$xy
    mini <- d$mini
    maxi <- d$maxi
    plot(0, 0, type = "n", xlim = c(-0.8, 0.8), ylim = c(-0.6, 
        1), xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1, 
        frame.plot = FALSE)
    seg(A, B)
    seg(B, C)
    seg(C, A)
    text(C[1], C[2], labels = paste(mini[1]), pos = 2)
    text(C[1], C[2], labels = paste(maxi[3]), pos = 4)
    text((A + C)[1]/2, (A + C)[2]/2, labels = nam[1], cex = 1.5, 
        pos = 2)
    text(A[1], A[2], labels = paste(maxi[1]), pos = 2)
    text(A[1], A[2], labels = paste(mini[2]), pos = 1)
    text((A + B)[1]/2, (A + B)[2]/2, labels = nam[2], cex = 1.5, 
        pos = 1)
    text(B[1], B[2], labels = paste(maxi[2]), pos = 1)
    text(B[1], B[2], labels = paste(mini[3]), pos = 4)
    text((B + C)[1]/2, (B + C)[2]/2, labels = nam[3], cex = 1.5, 
        pos = 4)
    if (draw.line) {
        nlg <- 10 * (maxi[1] - mini[1])
        for (i in (1:(nlg - 1))) {
            x1 <- A + (i/nlg) * (B - A)
            x2 <- C + (i/nlg) * (B - C)
            seg(x1, x2, col = "lightgrey")
            x1 <- A + (i/nlg) * (B - A)
            x2 <- A + (i/nlg) * (C - A)
            seg(x1, x2, col = "lightgrey")
            x1 <- C + (i/nlg) * (A - C)
            x2 <- C + (i/nlg) * (B - C)
            seg(x1, x2, col = "lightgrey")
        }
    }
    nl <- nrow(ta1)
    for (i in (1:nl)) {
        arrows(xy[i, 1], xy[i, 2], xy[i + nl, 1], xy[i + nl, 
            2], le = 0.1, ang = 15)
    }
    points(xy[1:nrow(ta1), ])
    text(xy[1:nrow(ta1), ], label, pos = 4)
    if (show.position) 
        add.position.triangle(d)
}

######################### triangle.param ######################################
"triangle.param" <- function (ta, scale = TRUE, min3 = NULL, max3 = NULL) {
    if (ncol(ta) != 3) 
        stop("Non convenient data")
    if (min(ta) < 0) 
        stop("Non convenient data")
    if ((!is.null(min3)) & (!is.null(max3))) 
        scale <- TRUE
    cal <- matrix(0, 9, 3)
    tb <- t(apply(ta, 1, function(x) x/sum(x)))
    mini <- apply(tb, 2, min)
    maxi <- apply(tb, 2, max)
    mini <- (floor(mini/0.1))/10
    maxi <- (floor(maxi/0.1) + 1)/10
    if (!is.null(min3)) 
        mini <- min3
    if (!is.null(max3)) 
        maxi <- min3
    ampli <- maxi - mini
    amplim <- max(ampli)
    for (j in 1:3) {
        k <- amplim - ampli[j]
        while (k > 0) {
            if ((k > 0) & (maxi[j] < 1)) {
                maxi[j] <- maxi[j] + 0.1
                k <- k - 1
            }
            if ((k > 0) & (mini[j] > 0)) {
                mini[j] <- mini[j] - 0.1
                k <- k - 1
            }
        }
    }
    cal[1, 1] <- mini[1]
    cal[1, 2] <- mini[2]
    cal[1, 3] <- 1 - cal[1, 1] - cal[1, 2]
    cal[2, 1] <- mini[1]
    cal[2, 2] <- maxi[2]
    cal[2, 3] <- 1 - cal[2, 1] - cal[2, 2]
    cal[3, 1] <- maxi[1]
    cal[3, 2] <- mini[2]
    cal[3, 3] <- 1 - cal[3, 1] - cal[3, 2]
    cal[4, 1] <- mini[1]
    cal[4, 3] <- mini[3]
    cal[4, 2] <- 1 - cal[4, 1] - cal[4, 3]
    cal[5, 1] <- mini[1]
    cal[5, 3] <- maxi[3]
    cal[5, 2] <- 1 - cal[5, 1] - cal[5, 3]
    cal[6, 1] <- maxi[1]
    cal[6, 3] <- mini[3]
    cal[6, 2] <- 1 - cal[6, 1] - cal[6, 3]
    cal[7, 2] <- mini[2]
    cal[7, 3] <- mini[3]
    cal[7, 1] <- 1 - cal[7, 2] - cal[7, 3]
    cal[8, 2] <- mini[2]
    cal[8, 3] <- maxi[3]
    cal[8, 1] <- 1 - cal[8, 2] - cal[8, 3]
    cal[9, 2] <- maxi[2]
    cal[9, 3] <- mini[3]
    cal[9, 1] <- 1 - cal[9, 2] - cal[9, 3]
    mini <- apply(cal, 2, min)
    mini <- round(mini, dig = 4)
    maxi <- apply(cal, 2, max)
    maxi <- round(maxi, dig = 4)
    ampli <- maxi - mini
    if (!scale) {
        mini <- c(0, 0, 0)
        maxi <- c(1, 1, 1)
    }
    A <- c(-1/sqrt(2), -1/sqrt(6))
    B <- c(1/sqrt(2), -1/sqrt(6))
    C <- c(0, 2/sqrt(6))
    xy <- t(apply(tb, 1, FUN = triangle.posipoint, mini = mini, 
        maxi = maxi))
    return(list(A = A, B = B, C = C, xy = xy, mini = mini, maxi = maxi))
} 
"uniquewt.df" <- function (x) {
    x <- data.frame(x)
    lig <- nrow(x)
    col <- ncol(x)
    w <- unlist(x[1])
    for (j in 2:col) {
        w <- paste(w, x[, j], sep = "")
    }
    w <- factor(w, unique(w))
    levels(w) <- 1:length(unique(w))
    select <- match(1:length(w), w)[1:nlevels(w)]
    x <- x[select, ]
    attr(x, "factor") <- w
    attr(x, "len.class") <- as.vector(table(w))
    return(x)
}
"variance.phylog" <- function (phylog, z, bynames = TRUE, na.action = c("fail", "mean")) {
    if (!is.numeric(z)) 
        stop("z is not numeric")
    n <- length(z)
    if (!inherits(phylog, "phylog")) 
        stop("Object of class 'phylog' expected")
    if (n != length(phylog$leaves)) 
        stop("Non convenient dimension")
    if (bynames) {
        if (is.null(names(z))) 
            stop("names(z) is NULL & bynames = TRUE")
        w1 <- sort(names(z))
        w2 <- sort(names(phylog$leaves))
        if (!all(w1 == w2) & bynames) {
            stop("names(z) non convenient for 'phylog' : bynames = FALSE ?")
        }
        z <- z[names(phylog$leaves)]
    }
    if (any(is.na(z))) {
        if (na.action == "fail") 
            stop(" missing values in 'z'")
        else if (na.action == "mean") 
            z[is.na(z)] <- mean(na.omit(z))
        else stop("unknown method for 'na.action'")
    }
    labels <- names(phylog$leaves)
    res <- list()
    z <- (z - mean(z))/sqrt(var(z))
    w1 <- sort(names(z))
    w2 <- sort(names(phylog$leaves))
    if (!all(w1 == w2)) {
        warning("names(z) non convenient for 'phylog' : we use the names of the leaves in 'phylog'")
        names(z) <- names(phylog$leaves)
    }
    z <- z[names(phylog$leaves)]
    vecpro <- phylog$Ascores
    npro <- ncol(vecpro)
    df <- cbind.data.frame(z, phylog$Ascores[, 1:phylog$Adim])
    begin <- paste(names(df)[1], "~", sep = "")
    fmla <- as.formula(paste(begin, paste(names(df)[-1], collapse = "+")))
    lmnull <- lm(z ~ 1, data = df)
    lm0 <- lm(fmla, data = df)
    res$lm <- lm0
    res$anova <- anova(lm0)
    a1 <- sum(res$anova$"Sum Sq"[1:phylog$Adim])
    df1 <- phylog$Adim
    r1 <- a1/df1
    a2 <- res$anova$"Sum Sq"[1 + phylog$Adim]
    df2 <- res$anova$Df[1 + phylog$Adim]
    r2 <- a2/df2
    Fvalue <- r1/r2
    proba <- 1 - pf(Fvalue, df1, df2)
    dig1 <- max(getOption("digits") - 2, 3)
    sumry <- array("", c(2, 5), list(c("Phylogenetic", "Residuals"), 
        c("Df", "Sum Sq", "Mean Sq", "F value", "Pr(>F)")))
    sumry[1, ] <- round(c(df1, a1, r1, Fvalue, proba), digits = dig1)
    sumry[2, 1:3] <- round(c(df2, a2, r2), digits = dig1)
    class(sumry) <- "table"
    res$sumry <- sumry
    return(res)
}
"within" <- function (dudi, fac, scannf = TRUE, nf = 2) {
    if (!inherits(dudi, "dudi")) 
        stop("Object of class dudi expected")
    if (!is.factor(fac)) 
        stop("factor expected")
    lig <- nrow(dudi$tab)
    col <- ncol(dudi$tab)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    cla.w <- tapply(dudi$lw, fac, sum)
    mean.w <- function(x, w, fac, cla.w) {
        z <- x * w
        z <- tapply(z, fac, sum)/cla.w
        return(z)
    }
    tabmoy <- apply(dudi$tab, 2, mean.w, w = dudi$lw, fac = fac, 
        cla.w = cla.w)
    tabw <- unlist(tapply(dudi$lw, fac, sum))
    tabw <- tabw/sum(tabw)
    tabwit <- dudi$tab - tabmoy[fac, ]
    X <- as.dudi(tabwit, dudi$cw, dudi$lw, scannf = scannf, nf = nf, 
        call = match.call(), type = "wit")
    X$ratio <- sum(X$eig)/sum(dudi$eig)
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(as.matrix(dudi$tab) %*% U)
    row.names(U) <- row.names(dudi$tab)
    names(U) <- names(X$li)
    X$ls <- U
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
    row.names(U) <- names(dudi$li)
    names(U) <- names(X$li)
    X$as <- U
    X$tabw <- tabw
    X$fac <- fac
    class(X) <- c("within", "dudi")
    return(X)
} 

"plot.within" <- function (x, xax = 1, yax = 2, ...) {
    if (!inherits(x, "within")) 
        stop("Use only with 'within' objects")
    if ((x$nf == 1) || (xax == yax)) {
        return(invisible())
    }
    if (xax > x$nf) 
        stop("Non convenient xax")
    if (yax > x$nf) 
        stop("Non convenient yax")
    fac <- x$fac
    def.par <- par(no.readonly = TRUE)
    on.exit(par(def.par))
    nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
        respect = TRUE)
    par(mar = c(0.2, 0.2, 0.2, 0.2))
    s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights", 
        csub = 2, clab = 1.25)
    s.arrow(x$co, xax = xax, yax = yax, sub = "Variables", 
        csub = 2, clab = 1.25)
    scatterutil.eigen(x$eig, wsel = c(xax, yax))
    s.class(x$ls, fac, xax = xax, yax = yax, sub = "Scores and classes", 
        csub = 2, clab = 1.5, cpoi = 2)
    s.corcircle(x$as, xax = xax, yax = yax, sub = "Inertia axes", 
        csub = 2, cgrid = 0, clab = 1.25)
    s.class(x$li, fac, xax = xax, yax = yax, axesell = FALSE, 
        clab = 0, cstar = 0, sub = "Common centring", csub = 2)
}

"print.within" <- function (x, ...) {
    if (!inherits(x, "within")) 
        stop("to be used with 'within' object")
    cat("Within analysis\n")
    cat("call: ")
    print(x$call)
    cat("class: ")
    cat(class(x), "\n")
    cat("\n$nf (axis saved) :", x$nf)
    cat("\n$rank: ", x$rank)
    cat("\n$ratio: ", x$ratio)
    cat("\n\neigen values: ")
    l0 <- length(x$eig)
    cat(signif(x$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n\n")
    else cat("\n\n")
    sumry <- array("", c(5, 4), list(1:5, c("vector", "length", 
        "mode", "content")))
    sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
    sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
    sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
    sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "table weigths")
    sumry[5, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", 
        "ncol", "content")))
    sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
    sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
    sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
    sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
    sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
    sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "supplementary row coordinates")
    sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto within axis")
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
"within.pca" <- function (df, fac, scaling = c("partial", "total"), scannf = TRUE,
    nf = 2) 
{
    if (!inherits(df, "data.frame")) 
        stop("Object of class 'data.frame' expected")
    if (!is.factor(fac)) 
        stop("factor expected")
    lig <- nrow(df)
    col <- ncol(df)
    if (length(fac) != lig) 
        stop("Non convenient dimension")
    cla.w <- tapply(rep(1, length(fac)), fac, sum)
    df <- data.frame(scalewt(df))
    mean.w <- function(x) tapply(x, fac, sum)/cla.w
    tabmoy <- apply(df, 2, mean.w)
    tabw <- cla.w
    tabw <- tabw/sum(tabw)
    tabwit <- df
    tabwit <- tabwit - tabmoy[fac, ]
    scaling <- scaling[1]
    if (scaling == "total") {
        tabwit <- scalewt(tabwit, center = FALSE, scale = TRUE)
    }
    else if (scaling == "partial") {
        for (j in levels(fac)) {
            w <- tabwit[fac == j, ]
            w <- scalewt(w)
            tabwit[fac == j, ] <- w
        }
    }
    else stop("unknown scaling value")
    tabwit <- data.frame(tabwit)
    for (i in 1:nrow(df)) {
        df[i, ] <- tabwit[i, ] + tabmoy[fac[i], ]
    }
    dudi <- as.dudi(df, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1, 
        ncol(df)), scannf = FALSE, nf = 4, call = match.call(), 
        type = "tmp")
    X <- as.dudi(tabwit, row.w = rep(1, nrow(df))/nrow(df), col.w = rep(1, 
        ncol(df)), scannf = scannf, nf = nf, call = match.call(), 
        type = "wit")
    X$ratio <- sum(X$eig)/sum(dudi$eig)
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(as.matrix(dudi$tab) %*% U)
    row.names(U) <- row.names(dudi$tab)
    names(U) <- names(X$c1)
    X$ls <- U
    U <- as.matrix(X$c1) * unlist(X$cw)
    U <- data.frame(t(as.matrix(dudi$c1)) %*% U)
    row.names(U) <- names(dudi$li)
    names(U) <- names(X$li)
    X$as <- U
    X$tabw <- tabw
    X$fac <- fac
    class(X) <- c("within", "dudi")
    return(X)
}
"witwit.coa" <- function (dudi, row.blocks, col.blocks, scannf = TRUE, nf = 2) {
    if (!inherits(dudi, "coa")) 
        stop("Object of class coa expected")
    lig <- nrow(dudi$tab)
    col <- ncol(dudi$tab)
    row.fac <- rep(1:length(row.blocks),row.blocks)
    col.fac <- rep(1:length(col.blocks),col.blocks)
    if (length(col.fac)!=col) stop ("Non convenient col.fac")
    if (length(row.fac)!=lig) stop ("Non convenient row.fac")
    tabinit <- as.matrix(eval(as.list(dudi$call)$df, sys.frame(0)))
    
    tabinit <- tabinit/sum(tabinit)
    # tabinit contient les pij
    wrmat <- rowsum(tabinit,row.fac, reorder = FALSE)[row.fac,]
    wrvec <- tapply(dudi$lw,row.fac,sum)[row.fac]
    wrvec <- as.numeric(wrvec)
    wrvec <- dudi$lw/wrvec
    wrmat <- wrmat*wrvec
    # wrmat contient les pi.*pd(i)j/pd(i)+
    
    wcmat <- rowsum(t(tabinit),col.fac, reorder = FALSE)[col.fac,]
    wcvec <- tapply(dudi$cw,col.fac,sum)[col.fac]
    wcvec <- as.numeric(wcvec)
    wcvec <- dudi$cw/wcvec
    wcmat <- t(wcmat*wcvec)
    # wcmat contient les pj.*pim(j)/p+m(j)
    wcmat <- wrmat+wcmat
    
    wrmat <- rowsum(tabinit,row.fac, reorder = FALSE)
    wrmat <- t(rowsum(t(wrmat),col.fac, reorder = FALSE))
    wrmat <- wrmat[row.fac,col.fac]
    wrmat <- wrmat*wrvec
    wrmat <- t(t(wrmat)*wcvec)
    # wrmat contient les pi.*p.j*pd(i)m(j)/pd(i)+/p+m(j)
    
    tabinit <- tabinit-wcmat+wrmat
    # le tableau est doublement centr par classe de lignes et de colonnes
    tabinit <- tabinit/dudi$lw
    tabinit <- t(t(tabinit)/dudi$cw)
    tabinit <- data.frame(tabinit+wrmat)
    ww <- as.dudi(tabinit, dudi$cw, dudi$lw, scannf = scannf, nf = nf, 
        call = match.call(), type = "witwit")
   class(ww) <- c("witwit", "coa", "dudi")
 
    wr <- ww$li*ww$li*wrvec
    wr <- rowsum(as.matrix(wr),row.fac, reorder = FALSE)
    cha <- names(row.blocks)
    if (is.null(cha)) cha <- as.character(1:length(row.blocks))
    wr <- data.frame(wr)
    names(wr) <- names(ww$li)
    row.names(wr) <- cha
    ww$lbvar <- wr
    ww$lbw <- tapply(dudi$lw,row.fac,sum)

    wr <- ww$co*ww$co*wcvec
    wr <- rowsum(as.matrix(wr),col.fac, reorder = FALSE)
    cha <- names(col.blocks)
    if (is.null(cha)) cha <- as.character(1:length(col.blocks))
    wr <- data.frame(wr)
    names(wr) <- names(ww$co)
    row.names(wr) <- cha
    ww$cbvar <- wr
    ww$cbw <- tapply(dudi$cw,col.fac,sum)
    
    
   return(ww)
}

"summary.witwit" <- function (object, ...) {
    if (!inherits(object, "witwit")) 
        stop("For 'witwit' object")
    cat("Internal correspondence analysis\n")
    cat("class: ")
    cat(class(object))
    cat("\n$call: ")
    print(object$call)
    cat(object$nf, "axis-components saved")
    cat("\neigen values: ")
    l0 <- length(object$eig)
    cat(signif(object$eig, 4)[1:(min(5, l0))])
    if (l0 > 5) 
        cat(" ...\n")
    else cat("\n")
    cat("\n")
    cat("Eigen value decomposition among row blocks\n")
    nf <- object$nf
    nrb <- nrow(object$lbvar)
    aa <- as.matrix(object$lbvar)
    sumry <- array("", c(nrb + 1, nf + 1), list(c(row.names(object$lbvar), 
        "mean"), c(names(object$lbvar), "weights")))
    sumry[(1:nrb), (1:nf)] <- round(aa, dig = 4)
    sumry[(1:nrb), (nf + 1)] <- round(object$lbw, dig = 4)
    sumry[(nrb + 1), (1:nf)] <- round(object$eig[1:nf], dig = 4)
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(nrb + 1, nf), list(c(row.names(object$lbvar), 
        "sum"), names(object$lbvar)))
    aa <- object$lbvar * object$lbw
    aa <- 1000 * t(t(aa)/object$eig[1:nf])
    sumry[(1:nrb), (1:nf)] <- round(aa, dig = 0)
    sumry[(nrb + 1), (1:nf)] <- rep(1000, nf)
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    cat("Eigen value decomposition among column blocks\n")
    nrb <- nrow(object$cbvar)
    aa <- as.matrix(object$cbvar)
    sumry <- array("", c(nrb + 1, nf + 1), list(c(row.names(object$cbvar), 
        "mean"), c(names(object$cbvar), "weights")))
    sumry[(1:nrb), (1:nf)] <- round(aa, dig = 4)
    sumry[(1:nrb), (nf + 1)] <- round(object$cbw, dig = 4)
    sumry[(nrb + 1), (1:nf)] <- round(object$eig[1:nf], dig = 4)
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
    sumry <- array("", c(nrb + 1, nf), list(c(row.names(object$cbvar), 
        "sum"), names(object$cbvar)))
    aa <- object$cbvar * object$cbw
    aa <- 1000 * t(t(aa)/object$eig[1:nf])
    sumry[(1:nrb), (1:nf)] <- round(aa, dig = 0)
    sumry[(nrb + 1), (1:nf)] <- rep(1000, nf)
    class(sumry) <- "table"
    print(sumry)
    cat("\n")
}
